+++ /dev/null
-/* Copyright (C) 1990 Free Software Foundation, Inc.
-This file is part of the GNU C Library.
-
-$Id: ansidecl.h,v 1.9 2007/01/05 15:33:06 cph Exp $
-
-The GNU C Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
-any later version.
-
-The GNU C Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* ANSI and traditional C compatibility macros
-
- ANSI C is assumed if STDC_HEADERS is #defined.
-
- Macros
- PTR - Generic pointer type
- LONG_DOUBLE - `long double' type
- CONST - `const' keyword
- VOLATILE - `volatile' keyword
- SIGNED - `signed' keyword
- PTRCONST - Generic const pointer (void *const)
-
- EXFUN(name, prototype) - declare external function NAME
- with prototype PROTOTYPE
- DEFUN(name, arglist, args) - define function NAME with
- args ARGLIST of types in ARGS
- DEFUN_VOID(name) - define function NAME with no args
- AND - argument separator for ARGS
- NOARGS - null arglist
- DOTS - `...' in args
-
- For example:
- extern int EXFUN(printf, (CONST char *format DOTS));
- int DEFUN(fprintf, (stream, format),
- FILE *stream AND CONST char *format DOTS) { ... }
- void DEFUN_VOID(abort) { ... }
-*/
-
-#ifndef _ANSIDECL_H
-#define _ANSIDECL_H 1
-
-
-/* Every source file includes this file,
- so they will all get the switch for lint. */
-/* LINTLIBRARY */
-
-#if defined(__STDC__) || defined(STDC_HEADERS)
-#define HAVE_STDC
-
-#define PTR void *
-#define PTRCONST void *CONST
-#define LONG_DOUBLE long double
-
-#define AND ,
-#define NOARGS void
-#define VOLATILE volatile
-#define SIGNED signed
-#define DOTS , ...
-
-/* Some systems don't declare their libraries correctly, making CONST
- impossible to have. */
-#ifdef CONST
-#undef CONST
-#endif
-
-#ifdef NO_CONST
-#define CONST
-#else
-#define CONST const
-#endif
-
-#define EXFUN(name, proto) name proto
-#define DEFUN(name, arglist, args) name(args)
-#define DEFUN_VOID(name) name(NOARGS)
-
-#else /* not (__STDC__ || STDC_HEADERS) */
-
-#define PTR char *
-#define PTRCONST PTR
-#define LONG_DOUBLE double
-
-#define AND ;
-#define NOARGS
-#define CONST
-#define VOLATILE
-#define SIGNED
-#define DOTS
-
-#define EXFUN(name, proto) name()
-#define DEFUN(name, arglist, args) name arglist args;
-#define DEFUN_VOID(name) name()
-
-#endif /* not (__STDC__ || STDC_HEADERS) */
-
-#endif /* _ANSIDECL_H */
+++ /dev/null
-/* -*-C-*-
-
-$Id: array.c,v 9.50 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "scheme.h"
-#include "prims.h"
-#include "array.h"
-#include <math.h>
-#include <values.h>
-/* <values.h> contains some math constants */
-
-/* ARRAY (as a scheme object)
- is a usual array (in C) containing REAL numbers (float/double)
- and tagged as a non-marked vector.
-
- Basic contents:
- constructors, selectors, arithmetic operations,
- conversion routines between C_Array, and Scheme_Vector
-
- see array.h for macros, NM_VECTOR, and extern */
-
-/* mathematical constants */
-#ifdef PI
-#undef PI
-#endif
-#define PI 3.141592653589793238462643
-#define PI_OVER_2 1.570796326794896619231322
-#define TWOPI 6.283185307179586476925287
-#define SQRT_2 1.4142135623730950488
-#define ONE_OVER_SQRT_2 .7071067811865475244
-/* Abramowitz and Stegun p.3 */
-\f
-REAL
-flonum_to_real (argument, arg_number)
- fast SCHEME_OBJECT argument;
- int arg_number;
-{
- switch (OBJECT_TYPE (argument))
- {
- case TC_FIXNUM:
- return ((REAL) (FIXNUM_TO_DOUBLE (argument)));
-
- case TC_BIG_FIXNUM:
- if (! (BIGNUM_TO_DOUBLE_P (argument)))
- error_bad_range_arg (arg_number);
- return ((REAL) (bignum_to_double (argument)));
-
- case TC_BIG_FLONUM:
- return ((REAL) (FLONUM_TO_DOUBLE (argument)));
-
- default:
- error_wrong_type_arg (arg_number);
- /* NOTREACHED */
- }
-}
-\f
-SCHEME_OBJECT
-allocate_array (length)
- long length;
-{
-#if (REAL_IS_DEFINED_DOUBLE == 0)
-
- fast SCHEME_OBJECT result =
- (allocate_non_marked_vector
- (TC_NON_MARKED_VECTOR, ((length * REAL_SIZE) + 1), true));
- FAST_MEMORY_SET (result, 1, length);
- return (result);
-
-#else /* (REAL_IS_DEFINED_DOUBLE != 0) */
-
- long n_words = (length * DOUBLE_SIZE);
- ALIGN_FLOAT (Free);
- Primitive_GC_If_Needed (n_words + 1);
- {
- SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (Free)));
- (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, n_words));
- Free += n_words;
- return (result);
- }
-
-#endif /* (REAL_IS_DEFINED_DOUBLE != 0) */
-}
-
-DEFINE_PRIMITIVE ("VECTOR->ARRAY", Prim_vector_to_array, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, VECTOR_P);
- {
- SCHEME_OBJECT vector = (ARG_REF (1));
- long length = (VECTOR_LENGTH (vector));
- SCHEME_OBJECT result = (allocate_array (length));
- fast SCHEME_OBJECT * scan_source = (& (VECTOR_REF (vector, 0)));
- fast SCHEME_OBJECT * end_source = (scan_source + length);
- fast REAL * scan_target = (ARRAY_CONTENTS (result));
- while (scan_source < end_source)
- (*scan_target++) = (flonum_to_real ((*scan_source++), 1));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("ARRAY->VECTOR", Prim_array_to_vector, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P);
- {
- SCHEME_OBJECT array = (ARG_REF (1));
- long length = (ARRAY_LENGTH (array));
- fast REAL * scan_source = (ARRAY_CONTENTS (array));
- fast REAL * end_source = (scan_source + length);
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, length, true));
- fast SCHEME_OBJECT * scan_result = (MEMORY_LOC (result, 1));
- while (scan_source < end_source)
- (*scan_result++) = (double_to_flonum ((double) (*scan_source++)));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("ARRAY-ALLOCATE", Prim_array_allocate, 1,1, 0)
-{
- fast REAL * scan;
- long length;
- SCHEME_OBJECT result;
- PRIMITIVE_HEADER (1);
-
- length = (arg_nonnegative_integer (1));
- result = (allocate_array (length));
- for (scan = (ARRAY_CONTENTS (result)); --length >= 0; )
- *scan++ = ((REAL) 0.0);
- PRIMITIVE_RETURN (result);
-}
-
-DEFINE_PRIMITIVE ("ARRAY-CONS-REALS", Prim_array_cons_reals, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- fast double from = (arg_real_number (1));
- fast double dt = (arg_real_number (2));
- long length = (arg_nonnegative_integer (3));
- SCHEME_OBJECT result = (allocate_array (length));
- fast REAL * scan_result = (ARRAY_CONTENTS (result));
- fast int i;
- for (i = 0; (i < length); i += 1)
- {
- (*scan_result++) = ((REAL) from);
- from += dt;
- }
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("ARRAY-LENGTH", Prim_array_length, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (ARRAY_LENGTH (ARG_REF (1))));
-}
-
-DEFINE_PRIMITIVE ("ARRAY-REF", Prim_array_ref, 2, 2, 0)
-{
- SCHEME_OBJECT array;
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- array = (ARG_REF (1));
- PRIMITIVE_RETURN
- (double_to_flonum
- ((double)
- ((ARRAY_CONTENTS (array))
- [arg_index_integer (2, (ARRAY_LENGTH (array)))])));
-}
-
-DEFINE_PRIMITIVE ("ARRAY-SET!", Prim_array_set, 3, 3, 0)
-{
- SCHEME_OBJECT array;
- REAL * array_ptr;
- double old_value, new_value;
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, ARRAY_P);
- array = (ARG_REF (1));
- array_ptr =
- (& ((ARRAY_CONTENTS (array))
- [arg_index_integer (2, (ARRAY_LENGTH (array)))]));
- old_value = (*array_ptr);
- new_value = (arg_real_number (3));
-#if (REAL_IS_DEFINED_DOUBLE == 0)
- if ((new_value >= 0.0)
- ? (new_value < ((double) FLT_MIN))
- : (new_value > (0.0 - ((double) FLT_MIN))))
- new_value = ((REAL) 0.0);
-#endif
- (*array_ptr) = ((REAL) new_value);
- PRIMITIVE_RETURN (double_to_flonum (old_value));
-}
-\f
-/*____________________ file readers ___________
- ascii and 2bint formats
- ______________________________________________*/
-
-/* Reading data from files
- To read REAL numbers, use "lf" for double, "%f" for float
- */
-#if (REAL_IS_DEFINED_DOUBLE == 1)
-#define REALREAD "%lf"
-#define REALREAD2 "%lf %lf"
-#else
-#define REALREAD "%f"
-#define REALREAD2 "%f %f"
-#endif
-
-static void
-C_Array_Read_Ascii_File (a, N, fp) /* 16 ascii decimal digits */
- REAL * a;
- long N;
- FILE * fp;
-{
- fast long i;
- for (i = 0; (i < N); i += 1)
- {
- if ((fscanf (fp, REALREAD, (&(a[i])))) != 1)
- { printf("Not enough values read ---\n last value a[%d] = % .16e \n", (i-1), a[i-1]);
- error_external_return (); }
- }
- return;
-}
-
-/* 2BINT FORMAT = integer stored in 2 consecutive bytes.
- On many machines, "putw" and "getw" use 4 byte integers (C int)
- so use "putc" "getc" as shown below.
- */
-
-static void
-C_Array_Read_2bint_File (a, N, fp)
- REAL * a;
- long N;
- FILE * fp;
-{
- fast long i;
- fast int msd;
- for (i = 0; (i < N); i += 1)
- {
- if (feof (fp))
- error_external_return ();
- msd = (getc (fp));
- (a [i]) = ((REAL) ((msd << 8) | (getc (fp))));
- }
- return;
-}
-
-DEFINE_PRIMITIVE ("ARRAY-READ-FROM-FILE", Prim_array_read_from_file, 3,3, 0)
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, STRING_P); /* 1 = filename */
- /* 2 = length of data */
- CHECK_ARG (3, FIXNUM_P); /* 3 = format of data 0=ascii 1=2bint */
- {
- fast long length = (arg_nonnegative_integer (2));
- fast SCHEME_OBJECT result = (allocate_array (length));
- int format;
- fast FILE * fp;
- if ( (fp = fopen((STRING_ARG (1)), "r")) == NULL)
- error_bad_range_arg (1);
-
- format = arg_nonnegative_integer(3);
- if (format==0)
- C_Array_Read_Ascii_File ((ARRAY_CONTENTS (result)), length, fp);
- else if (format==1)
- C_Array_Read_2bint_File ((ARRAY_CONTENTS (result)), length, fp);
- else
- error_bad_range_arg(3); /* illegal format code */
-
- if ((fclose (fp)) != 0)
- error_external_return ();
- PRIMITIVE_RETURN (result);
- }
-}
-
-static void
-C_Array_Write_Ascii_File (a, N, fp) /* 16 ascii decimal digits */
- REAL * a;
- long N;
- FILE * fp;
-{
- fast long i;
- for (i = 0; (i < N); i += 1)
- {
- if (feof (fp))
- error_external_return ();
- fprintf (fp, "% .16e \n", a[i]);
- }
- return;
-}
-
-DEFINE_PRIMITIVE ("ARRAY-WRITE-ASCII-FILE", Prim_array_write_ascii_file, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, STRING_P);
- {
- fast SCHEME_OBJECT array = (ARG_REF (1));
- fast FILE * fp = (fopen((STRING_ARG (2)), "w"));
- if (fp == ((FILE *) 0))
- error_bad_range_arg (2);
- C_Array_Write_Ascii_File
- ((ARRAY_CONTENTS (array)),
- (ARRAY_LENGTH (array)),
- fp);
- if ((fclose (fp)) != 0)
- error_external_return ();
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-
-
-\f
-DEFINE_PRIMITIVE ("SUBARRAY-COPY!", Prim_subarray_copy, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- CHECK_ARG (1, ARRAY_P); /* source array */
- CHECK_ARG (2, ARRAY_P); /* destination array */
- {
- REAL * source = (ARRAY_CONTENTS (ARG_REF (1)));
- REAL * target = (ARRAY_CONTENTS (ARG_REF (2)));
- long start_source = (arg_nonnegative_integer (3));
- long start_target = (arg_nonnegative_integer (4));
- long n_elements = (arg_nonnegative_integer (5));
- if ((start_source + n_elements) > (ARRAY_LENGTH (ARG_REF (1))))
- error_bad_range_arg (3);
- if ((start_target + n_elements) > (ARRAY_LENGTH (ARG_REF (2))))
- error_bad_range_arg (4);
- {
- fast REAL * scan_source = (source + start_source);
- fast REAL * end_source = (scan_source + n_elements);
- fast REAL * scan_target = (target + start_target);
- while (scan_source < end_source)
- (*scan_target++) = (*scan_source++);
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("ARRAY-REVERSE!", Prim_array_reverse, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P);
- {
- SCHEME_OBJECT array = (ARG_REF (1));
- long length = (ARRAY_LENGTH (array));
- long half_length = (length / 2);
- fast REAL * array_ptr = (ARRAY_CONTENTS (array));
- fast long i;
- fast long j;
- for (i = 0, j = (length - 1); (i < half_length); i += 1, j -= 1)
- {
- fast REAL Temp = (array_ptr [j]);
- (array_ptr [j]) = (array_ptr [i]);
- (array_ptr [i]) = Temp;
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("ARRAY-TIME-REVERSE!", Prim_array_time_reverse, 1, 1, 0)
-{
- void C_Array_Time_Reverse ();
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P);
- C_Array_Time_Reverse
- ((ARRAY_CONTENTS (ARG_REF (1))), (ARRAY_LENGTH (ARG_REF (1))));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* time-reverse
- x[0] remains fixed. (time=0)
- x[i] swapped with x[n-i]. (mirror image around x[0]) */
-
-void
-C_Array_Time_Reverse (x,n)
- REAL *x;
- long n;
-{ long i, ni, n2;
- REAL xt;
- if ((n % 2) == 0) /* even length */
- { n2 = (n/2);
- for (i=1; i<n2; i++) /* i=1,2,..,n/2-1 */
- { ni = n-i;
- xt = x[i];
- x[i] = x[ni];
- x[ni] = xt; }}
- else /* odd length */
- { n2 = (n+1)/2; /* (n+1)/2 = (n-1)/2 + 1 */
- for (i=1; i<n2; i++) /* i=1,2,..,(n-1)/2 */
- { ni = n-i;
- xt = x[i];
- x[i] = x[ni];
- x[ni] = xt; }}
-}
-
-/* The following is smart
- and avoids computation when offset or scale are degenerate 0,1 */
-
-DEFINE_PRIMITIVE ("SUBARRAY-OFFSET-SCALE!", Prim_subarray_offset_scale, 5, 5, 0)
-{
- long i, at, m,mplus;
- REAL *a, offset,scale;
- PRIMITIVE_HEADER (5);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, FIXNUM_P);
- CHECK_ARG (3, FIXNUM_P);
- a = ARRAY_CONTENTS(ARG_REF(1));
- at = arg_nonnegative_integer(2); /* at = starting index */
- m = arg_nonnegative_integer(3); /* m = number of points to change */
- mplus = at + m;
- if (mplus > (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(3);
- offset = (arg_real (4));
- scale = (arg_real (5));
- if ((offset == 0.0) && (scale == 1.0))
- ; /* be smart */
- else if (scale == 0.0)
- for (i=at; i<mplus; i++) a[i] = offset;
- else if (offset == 0.0)
- for (i=at; i<mplus; i++) a[i] = scale * a[i];
- else if (scale == 1.0)
- for (i=at; i<mplus; i++) a[i] = offset + a[i];
- else
- for (i=at; i<mplus; i++) a[i] = offset + scale * a[i];
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("COMPLEX-SUBARRAY-COMPLEX-SCALE!", Prim_complex_subarray_complex_scale, 6,6, 0)
-{ long i, at,m,mplus;
- REAL *a,*b; /* (a,b) = (real,imag) arrays */
- double temp, minus_y, x, y; /* (x,y) = (real,imag) scale */
- PRIMITIVE_HEADER (6);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- at = (arg_nonnegative_integer (3)); /* starting index */
- m = (arg_nonnegative_integer (4)); /* number of points to change */
- mplus = at + m;
- if (mplus > (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(4);
- x = (arg_real_number (5));
- y = (arg_real_number (6));
- a = ARRAY_CONTENTS(ARG_REF(1));
- b = ARRAY_CONTENTS(ARG_REF(2));
- if ((ARRAY_LENGTH(ARG_REF(1))) != (ARRAY_LENGTH(ARG_REF(2))))
- error_bad_range_arg(2);
- if (x==0.0) /* imaginary only */
- if (y==0.0)
- for (i=at; i<mplus; i++)
- { a[i] = 0.0;
- b[i] = 0.0; }
- else if (y==1.0)
- for (i=at; i<mplus; i++)
- { temp = b[i];
- b[i] = a[i];
- a[i] = (-temp); }
- else if (y==-1.0)
- for (i=at; i<mplus; i++)
- { temp = b[i];
- b[i] = (-a[i]);
- a[i] = temp; }
- else
- { minus_y = (-y);
- for (i=at; i<mplus; i++)
- { temp = y * ((double) a[i]);
- a[i] = (REAL) (minus_y * ((double) b[i]));
- b[i] = (REAL) temp; }}
- else if (y==0.0) /* real only */
- if (x==1.0) ;
- else for (i=at; i<mplus; i++)
- { a[i] = (REAL) (x * ((double) a[i]));
- b[i] = (REAL) (x * ((double) b[i])); }
- else /* full complex scale */
- for (i=at; i<mplus; i++)
- { temp = ((double) a[i])*x - ((double) b[i])*y;
- b[i] = (REAL) (((double) b[i])*x + ((double) a[i])*y);
- a[i] = (REAL) temp; }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* Accumulate
- using combinators *
- corresponding type codes 1 */
-
-DEFINE_PRIMITIVE ("COMPLEX-SUBARRAY-ACCUMULATE!", Prim_complex_subarray_accumulate, 6,6, 0)
-{ long at,m,mplus, tc, i;
- REAL *a,*b; /* (a,b) = (real,imag) input arrays */
- REAL *c; /* result = output array of length 2, holds a complex number */
- double x, y, temp;
- PRIMITIVE_HEADER (6);
- CHECK_ARG (1, ARRAY_P); /* a = input array (real) */
- CHECK_ARG (2, ARRAY_P); /* b = input array (imag) */
- a = ARRAY_CONTENTS(ARG_REF(1));
- b = ARRAY_CONTENTS(ARG_REF(2));
- if ((ARRAY_LENGTH(ARG_REF(1))) != (ARRAY_LENGTH(ARG_REF(2))))
- error_bad_range_arg(2);
- tc = arg_nonnegative_integer(3); /* tc = type code 0 or 1 */
- at = arg_nonnegative_integer(4); /* at = starting index */
- m = arg_nonnegative_integer(5); /* m = number of points to process */
- CHECK_ARG (6, ARRAY_P); /* c = output array of length 2 */
- c = ARRAY_CONTENTS(ARG_REF(6));
- if ((ARRAY_LENGTH(ARG_REF(6))) != 2) error_bad_range_arg(6);
- mplus = at + m;
- if (mplus > (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(5);
- if (tc==1)
- { x = 1.0; /* real part of accumulator */
- y = 0.0; /* imag part of accumulator */
- for (i=at;i<mplus;i++)
- { temp = ((double) a[i])*x - ((double) b[i])*y;
- y = ((double) b[i])*x + ((double) a[i])*y;
- x = temp; }
- }
- else
- error_bad_range_arg(3);
- c[0] = ((REAL) x); /* mechanism for returning complex number */
- c[1] = ((REAL) y); /* do not use lists, avoid heap pointer */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("CS-ARRAY-TO-COMPLEX-ARRAY!", Prim_cs_array_to_complex_array, 3, 3, 0)
-{ long n,n2,n2_1, i;
- REAL *a, *b,*c;
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- CHECK_ARG (3, ARRAY_P);
- a = ARRAY_CONTENTS(ARG_REF(1));
- n = ARRAY_LENGTH(ARG_REF(1));
- b = ARRAY_CONTENTS(ARG_REF(2));
- c = ARRAY_CONTENTS(ARG_REF(3));
- if (n!=(ARRAY_LENGTH(ARG_REF(2)))) error_bad_range_arg(2);
- if (n!=(ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(3);
- b[0] = a[0];
- c[0] = 0.0;
- n2 = n/2; /* integer division truncates down */
- n2_1 = n2+1;
- if (2*n2 == n) /* even length, n2 is only real */
- { b[n2] = a[n2]; c[n2] = 0.0; }
- else /* odd length, make the loop include the n2 index */
- { n2 = n2+1;
- n2_1 = n2; }
- for (i=1; i<n2; i++) { b[i] = a[i];
- c[i] = a[n-i]; }
- for (i=n2_1; i<n; i++) { b[i] = a[n-i];
- c[i] = (-a[i]); }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("CS-ARRAY-MULTIPLY-INTO-SECOND-ONE!", Prim_cs_array_multiply_into_second_one, 2, 2, 0)
-{ long n,n2;
- REAL *a, *b;
- void cs_array_multiply_into_second_one();
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- a = ARRAY_CONTENTS(ARG_REF(1));
- n = ARRAY_LENGTH(ARG_REF(1));
- b = ARRAY_CONTENTS(ARG_REF(2));
- if (n!=(ARRAY_LENGTH(ARG_REF(2)))) error_bad_range_arg(2);
- n2 = n/2; /* integer division truncates down */
- cs_array_multiply_into_second_one(a,b, n,n2);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-cs_array_multiply_into_second_one (a,b, n,n2)
- REAL *a, *b;
- long n,n2;
-{
- REAL temp;
- long i,ni;
- b[0] = a[0] * b[0];
- if (2*n2 == n) /* even length, n2 is only real */
- b[n2] = a[n2] * b[n2];
- else
- n2 = n2+1; /* odd length, make the loop include the n2 index */
- for (i=1; i<n2; i++)
- {
- ni = n-i;
- temp = a[i]*b[i] - a[ni]*b[ni]; /* real part */
- b[ni] = a[i]*b[ni] + a[ni]*b[i]; /* imag part */
- b[i] = temp;
- }
-}
-
-DEFINE_PRIMITIVE ("CS-ARRAY-DIVIDE-INTO-XXX!", Prim_cs_array_divide_into_xxx, 4, 4, 0)
-{
- long n,n2, one_or_two;
- REAL *a, *b, inf;
- void cs_array_divide_into_z();
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- inf = (arg_real (3));
- /* where to store result of division */
- one_or_two = (arg_nonnegative_integer (4));
- a = ARRAY_CONTENTS(ARG_REF(1));
- b = ARRAY_CONTENTS(ARG_REF(2));
- n = ARRAY_LENGTH(ARG_REF(1));
- if (n!=(ARRAY_LENGTH(ARG_REF(2)))) error_bad_range_arg(2);
- n2 = n/2; /* integer division truncates down */
- if (one_or_two == 1)
- cs_array_divide_into_z(a,b, a, n,n2, inf);
- else if (one_or_two == 2)
- cs_array_divide_into_z(a,b, b, n,n2, inf);
- else
- error_bad_range_arg(4);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-cs_array_divide_into_second_one (a,b, n,n2,inf) /* used in image.c */
- REAL *a,*b, inf;
- long n,n2;
-{
- void cs_array_divide_into_z ();
- cs_array_divide_into_z (a,b, b, n,n2,inf);
-}
-\f
-void
-cs_array_divide_into_z (a,b, z, n,n2, inf) /* z can be either a or b */
- REAL *a,*b,*z, inf;
- long n,n2;
-{ long i,ni;
- REAL temp, radius;
-
- if (b[0] == 0.0)
- if (a[0] == 0.0) z[0] = 1.0;
- else z[0] = a[0] * inf;
- else z[0] = a[0] / b[0];
-
- if (2*n2 == n) /* even length, n2 is only real */
- if (b[n2] == 0.0)
- if (a[n2] == 0.0) z[n2] = 1.0;
- else z[n2] = a[n2] * inf;
- else z[n2] = a[n2] / b[n2];
- else
- n2 = n2+1; /* odd length, make the loop include the n2 index */
-
- for (i=1; i<n2; i++)
- { ni = n-i;
- radius = b[i]*b[i] + b[ni]*b[ni]; /* b^2 denominator = real^2 + imag^2 */
-
- if (radius == 0.0) {
- if (a[i] == 0.0) z[i] = 1.0;
- else z[i] = a[i] * inf;
- if (a[ni] == 0.0) z[ni] = 1.0;
- else z[ni] = a[ni] * inf; }
- else {
- temp = a[i]*b[i] + a[ni]*b[ni];
- z[ni] = (a[ni]*b[i] - a[i]*b[ni]) / radius; /* imag part */
- z[i] = temp / radius; /* real part */
- }}
-}
-\f
-/* ARRAY-UNARY-FUNCTION!
- apply unary-function elementwise on array
- Available functions : */
-
-void
-REALabs (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) fabs( (double) (*a)) );
-}
-
-void
-REALexp (a,b)
- REAL *a,*b;
-{
- fast double y;
- if ((y = exp((double) (*a))) == HUGE)
- error_bad_range_arg (1); /* OVERFLOW */
- (*b) = ((REAL) y);
-}
-
-void
-REALlog (a,b)
- REAL *a,*b;
-{
- if ((*a) < 0.0)
- error_bad_range_arg(1); /* log(negative) */
- (*b) = ( (REAL) log( (double) (*a)) );
-}
-
-void
-REALtruncate (a,b)
- REAL *a,*b; /* towards zero */
-{
- double integral_part, modf();
- modf( ((double) (*a)), &integral_part);
- (*b) = ( (REAL) integral_part);
-}
-
-void
-REALround (a,b)
- REAL *a,*b; /* towards nearest integer */
-{
- double integral_part, modf();
- if ((*a) >= 0.0) /* It may be faster to look at the sign
- of mantissa, and dispatch */
- modf( ((double) ((*a)+0.5)), &integral_part);
- else
- modf( ((double) ((*a)-0.5)), &integral_part);
- (*b) = ( (REAL) integral_part);
-}
-
-void
-REALsquare (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) ((*a) * (*a)) );
-}
-
-void
-REALsqrt (a,b)
- REAL *a,*b;
-{
- if ((*a) < 0.0)
- error_bad_range_arg(1); /* sqrt(negative) */
- (*b) = ( (REAL) sqrt( (double) (*a)) );
-}
-\f
-void
-REALsin (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) sin( (double) (*a)) );
-}
-
-void
-REALcos (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) cos( (double) (*a)) );
-}
-
-void
-REALtan (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) tan( (double) (*a)) );
-}
-
-void
-REALasin (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) asin( (double) (*a)) );
-}
-
-void
-REALacos (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) acos( (double) (*a)) );
-}
-
-void
-REALatan (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) atan( (double) (*a)) );
-}
-
-void
-REALgamma (a,b)
- REAL *a,*b;
-{
- fast double y;
- if ((y = gamma(((double) (*a)))) > LN_MAXDOUBLE)
- error_bad_range_arg(1); /* gamma( non-positive integer ) */
- (*b) = ((REAL) (signgam * exp(y))); /* see HPUX Section 3 */
-}
-
-void
-REALerf (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) erf((double) (*a)) );
-}
-
-void
-REALerfc (a,b)
- REAL *a,*b;
-{
- (*b) = ( (REAL) erfc((double) (*a)) );
-}
-\f
-void
-REALbessel1 (order,a,b) /* Bessel of first kind */
- long order;
- REAL *a,*b;
-{
- if (order == 0)
- (*b) = ( (REAL) j0((double) (*a)) );
- if (order == 1)
- (*b) = ( (REAL) j1((double) (*a)) );
- else
- (*b) = ( (REAL) jn(((int) order), ((double) (*a))) );
-}
-
-void
-REALbessel2 (order,a,b) /* Bessel of second kind */
- long order;
- REAL *a,*b;
-{
- if ((*a) <= 0.0)
- error_bad_range_arg(1); /* Blows Up */
- if (order == 0)
- (*b) = ( (REAL) y0((double) (*a)) );
- if (order == 1)
- (*b) = ( (REAL) y1((double) (*a)) );
- else
- (*b) = ( (REAL) yn(((int) order), ((double) (*a))) );
-}
-
-/* Table to store the available unary-functions.
- Also some binary functions at the end -- not available right now.
- The (1 and 2)s denote the numofargs (1 for unary 2 for binary) */
-
-struct array_func_table
-{
- long numofargs;
- void (*func)();
-}
-Array_Function_Table [] =
-{
- 1, REALabs, /*0*/
- 1, REALexp, /*1*/
- 1, REALlog, /*2*/
- 1, REALtruncate, /*3*/
- 1, REALround, /*4*/
- 1, REALsquare, /*5*/
- 1, REALsqrt, /*6*/
- 1, REALsin, /*7*/
- 1, REALcos, /*8*/
- 1, REALtan, /*9*/
- 1, REALasin, /*10*/
- 1, REALacos, /*11*/
- 1, REALatan, /*12*/
- 1, REALgamma, /*13*/
- 1, REALerf, /*14*/
- 1, REALerfc, /*15*/
- 2, REALbessel1, /*16*/
- 2, REALbessel2 /*17*/
- };
-
-#define MAX_ARRAY_FUNCTC 17
-\f
-/* array-unary-function! could be called array-operation-1!
- following the naming convention for other similar procedures
- but it is specialized to mappings only, so we have special name. */
-
-DEFINE_PRIMITIVE ("ARRAY-UNARY-FUNCTION!", Prim_array_unary_function, 2,2, 0)
-{
- long n, i;
- REAL *a,*b;
- long tc;
- void (*f)();
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P); /* a = input (and output) array */
- CHECK_ARG (2, FIXNUM_P); /* tc = type code */
- tc = arg_nonnegative_integer(2);
- if (tc > MAX_ARRAY_FUNCTC) error_bad_range_arg(2);
- f = ((Array_Function_Table[tc]).func);
- if (1 != (Array_Function_Table[tc]).numofargs) error_wrong_type_arg(2);
- /* check it is a unary function */
- a = ARRAY_CONTENTS(ARG_REF(1));
- b = a;
- n = ARRAY_LENGTH(ARG_REF(1));
- for (i=0; i<n; i++)
- (*f) ( &(a[i]), &(b[i]) ); /* a into b */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* Accumulate
- using combinators + or *
- corresponding type codes 0 1 */
-
-DEFINE_PRIMITIVE ("SUBARRAY-ACCUMULATE", Prim_subarray_accumulate, 4,4, 0)
-{
- long at,m,mplus, tc, i;
- REAL *a;
- double result;
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, ARRAY_P); /* a = input array */
- a = ARRAY_CONTENTS(ARG_REF(1));
- tc = arg_nonnegative_integer(2); /* tc = type code 0 or 1 */
- at = arg_nonnegative_integer(3); /* at = starting index */
- m = arg_nonnegative_integer(4); /* m = number of points to process */
- mplus = at + m;
- if (mplus > (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(4);
- if (tc == 0)
- {
- result = 0.0;
- for (i=at;i<mplus;i++)
- result = result + ((double) a[i]);
- }
- else if (tc == 1)
- {
- result = 1.0;
- for (i=at;i<mplus;i++)
- result = result * ((double) a[i]);
- }
- else
- error_bad_range_arg (2);
- PRIMITIVE_RETURN (double_to_flonum (result));
-}
-\f
-/* The following searches for value within tolerance
- starting from index=from in array.
- Returns first index where match occurs (useful for finding zeros). */
-
-DEFINE_PRIMITIVE ("ARRAY-SEARCH-VALUE-TOLERANCE-FROM", Prim_array_search_value_tolerance_from, 4, 4, 0)
-{
- SCHEME_OBJECT array;
- fast long length;
- fast REAL * a;
- fast REAL value; /* value to search for */
- fast double tolerance; /* tolerance allowed */
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, ARRAY_P);
- array = (ARG_REF (1));
- length = (ARRAY_LENGTH (array));
- a = (ARRAY_CONTENTS (array));
- value = (arg_real (2));
- tolerance = (arg_real (3));
- {
- fast long i;
- for (i = (arg_index_integer (4, length)); i<length; i+=1)
- if (tolerance >= (fabs ((double) ((a [i]) - value))))
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (i));
- }
- PRIMITIVE_RETURN (SHARP_F);
-}
-
-DEFINE_PRIMITIVE ("SUBARRAY-MIN-MAX-INDEX", Prim_subarray_min_max_index, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, ARRAY_P);
- {
- REAL * a = (ARRAY_CONTENTS (ARG_REF (1)));
- long at = (arg_nonnegative_integer (2)); /* starting index */
- long m = (arg_nonnegative_integer (3)); /* number of points to process */
- long mplus = (at + m);
- long nmin;
- long nmax;
- if (mplus > (ARRAY_LENGTH (ARG_REF (1))))
- error_bad_range_arg (3);
-
- C_Array_Find_Min_Max ((& (a [at])), m, (&nmin), (&nmax));
- nmin = nmin + at; /* offset appropriately */
- nmax = nmax + at;
-
- PRIMITIVE_RETURN
- (cons ((LONG_TO_FIXNUM (nmin)),
- (cons ((LONG_TO_FIXNUM (nmax)),
- EMPTY_LIST))));
- }
-}
-
-void
-C_Array_Find_Min_Max (x, n, nmin, nmax)
- fast REAL * x;
- fast long n;
- long * nmin;
- long * nmax;
-{ REAL *xold = x;
- register REAL xmin, xmax;
- register long nnmin, nnmax;
- register long count;
-
- nnmin = nnmax = 0;
- xmin = xmax = *x++;
- n--;
- count = 1;
- if(n>0)
- {
- do {
- if(*x < xmin) {
- nnmin = count++ ;
- xmin = *x++ ;
- } else if(*x > xmax) {
- nnmax = count++ ;
- xmax = *x++ ;
- } else {
- count++ ;
- x++ ;
- }
- } while( --n > 0 ) ;
- }
- *nmin = nnmin ;
- *nmax = nnmax ;
-}
-
-\f
-/* array-average
- can be done with (array-reduce +) and division by array-length.
- But there is also this C primitive.
- Keep it around, may be useful someday. */
-
-/* Computes the average in pieces, so as to reduce
- roundoff smearing in cumulative sum.
- example= first huge positive numbers, then small nums,
- then huge negative numbers. */
-
-static void
-C_Array_Find_Average (Array, Length, pAverage)
- long Length;
- REAL * Array;
- REAL * pAverage;
-{
- long i;
- long array_index;
- REAL average_n, sum;
-
- average_n = 0.0;
- array_index = 0;
- while (array_index < Length)
- {
- sum = 0.0;
- for (i=0;((array_index<Length) && (i<2000));i++) {
- sum += Array[array_index];
- array_index++;
- }
- average_n += (sum / ((REAL) Length));
- }
- (*pAverage) = average_n;
- return;
-}
-
-DEFINE_PRIMITIVE ("ARRAY-AVERAGE", Prim_array_find_average, 1, 1, 0)
-{
- SCHEME_OBJECT array;
- REAL average;
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P);
- array = (ARG_REF (1));
- C_Array_Find_Average
- ((ARRAY_CONTENTS (array)),
- (ARRAY_LENGTH (array)),
- (&average));
- PRIMITIVE_RETURN (double_to_flonum ((double) average));
-}
-\f
-void
-C_Array_Make_Histogram (Array, Length, Histogram, npoints)
- REAL Array[], Histogram[];
- long Length, npoints;
-{
- REAL Max, Min, Offset, Scale;
- long i, nmin, nmax, index;
- C_Array_Find_Min_Max (Array, Length, (&nmin), (&nmax));
- Min = (Array [nmin]);
- Max = (Array [nmax]);
- Find_Offset_Scale_For_Linear_Map
- (Min, Max, 0.0, ((REAL) npoints), (&Offset), (&Scale));
- for (i = 0; (i < npoints); i += 1)
- (Histogram [i]) = 0.0;
- for (i = 0; (i < Length); i += 1)
- {
- /* Everything from 0 to 1 maps to bin 0, and so on */
- index = ((long) (floor ((double) ((Scale * (Array [i])) + Offset))));
- /* max that won't floor to legal array index */
- if (index == npoints)
- index = (index - 1);
- (Histogram [index]) += 1.0;
- }
- return;
-}
-
-DEFINE_PRIMITIVE ("ARRAY-MAKE-HISTOGRAM", Prim_array_make_histogram, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- {
- fast SCHEME_OBJECT array = (ARG_REF (1));
- long length = (ARRAY_LENGTH (array));
- long npoints = (arg_integer_in_range (2, 1, ((2 * length) + 1)));
- SCHEME_OBJECT result = (allocate_array (npoints));
- C_Array_Make_Histogram
- ((ARRAY_CONTENTS (array)),
- length,
- (ARRAY_CONTENTS (result)),
- npoints);
- PRIMITIVE_RETURN (result);
- }
-}
-
-/* The following geometrical map is slightly tricky. */
-void
-Find_Offset_Scale_For_Linear_Map (Min, Max, New_Min, New_Max, Offset, Scale)
- REAL Min, Max, New_Min, New_Max, *Offset, *Scale;
-{
- if (Min != Max)
- {
- (*Scale) = ((New_Max - New_Min) / (Max - Min));
- (*Offset) = (New_Min - ((*Scale) * Min));
- }
- else
- {
- (*Scale) =
- ((Max == 0.0)
- ? 0.0
- : (0.25 * (mabs ((New_Max - New_Min) / Max))));
- (*Offset) = ((New_Max + New_Min) / 2.0);
- }
- return;
-}
-
-
-DEFINE_PRIMITIVE ("ARRAY-CLIP-MIN-MAX!", Prim_array_clip_min_max, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, ARRAY_P);
- {
- SCHEME_OBJECT array = (ARG_REF (1));
- REAL xmin = (arg_real (2));
- REAL xmax = (arg_real (3));
- long Length = (ARRAY_LENGTH (array));
- REAL * From_Here = (ARRAY_CONTENTS (array));
- REAL * To_Here = From_Here;
- long i;
- if (xmin > xmax)
- error_bad_range_arg (3);
- for (i = 0; (i < Length); i += 1)
- {
- if ((*From_Here) < xmin)
- (*To_Here++) = xmin;
- else if ((*From_Here) > xmax)
- (*To_Here++) = xmax;
- else
- (*To_Here++) = (*From_Here);
- From_Here += 1;
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* complex-array-operation-1!
- groups together procedures that use 1 complex-array
- and store the result in place */
-
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1!", Prim_complex_array_operation_1, 3,3, 0)
-{ long n, i, opcode;
- REAL *a, *b;
- void complex_array_to_polar(), complex_array_exp(), complex_array_sqrt();
- void complex_array_sin(), complex_array_cos();
- void complex_array_asin(), complex_array_acos(), complex_array_atan();
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, ARRAY_P); /* input array -- n real part */
- CHECK_ARG (3, ARRAY_P); /* input array -- n imag part */
- n = ARRAY_LENGTH(ARG_REF(2));
- if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- a = ARRAY_CONTENTS(ARG_REF(2)); /* real part */
- b = ARRAY_CONTENTS(ARG_REF(3)); /* imag part */
- opcode = arg_nonnegative_integer(1);
- if (opcode==1)
- complex_array_to_polar(a,b,n);
- else if (opcode==2)
- complex_array_exp(a,b,n);
- else if (opcode==3)
- complex_array_sqrt(a,b,n);
-
- else if (opcode==4)
- complex_array_sin(a,b,n);
- else if (opcode==5)
- complex_array_cos(a,b,n);
- /* for tan(z) use sin(z)/cos(z) */
-
- else if (opcode==6)
- complex_array_asin(a,b,n);
- else if (opcode==7)
- complex_array_acos(a,b,n);
- else if (opcode==8)
- complex_array_atan(a,b,n);
-
- else
- error_bad_range_arg(1); /* illegal opcode */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-void
-complex_array_to_polar (a,b,n)
- REAL *a,*b;
- long n;
-{
- long i;
- double x,y, temp;
- for (i=0; i<n; i++)
- {
- x = (double) a[i];
- y = (double) b[i];
- temp = sqrt(x*x + y*y);
- if (temp == 0.0)
- b[i] = 0.0; /* choose angle = 0 for x,y=0,0 */
- else
- b[i] = (REAL) atan2(y,x);
- a[i] = (REAL) temp;
- }
-}
-
-void
-complex_array_exp (a,b,n)
- REAL *a,*b;
- long n;
-{
- long i;
- double x,y, temp;
-
- for (i=0; i<n; i++)
- {
- x = (double) a[i];
- y = (double) b[i];
- if ((temp = exp(x)) == HUGE) error_bad_range_arg(2); /* overflow */
- a[i] = (REAL) (temp*cos(y));
- b[i] = (REAL) (temp*sin(y));
- }
-}
-
-void
-complex_array_sqrt (a,b,n)
- REAL *a,*b;
- long n;
-{
- long i;
- double x,y, r;
-
- for (i=0; i<n; i++)
- {
- x = (double) a[i];
- y = (double) b[i];
- r = sqrt( x*x + y*y);
- a[i] = sqrt((r+x)/2.0);
- if (y>=0.0)
- b[i] = sqrt((r-x)/2.0); /* choose principal root */
- else /* see Abramowitz (p.17 3.7.27) */
- b[i] = -sqrt((r-x)/2.0);
- }
-}
-\f
-void
-complex_array_sin (a,b,n)
- REAL *a,*b;
- long n;
-{
- long i;
- double x, ey,fy;
- REAL temp;
-
- for (i=0; i<n; i++)
- {
- x = (double) a[i];
- ey = exp((double) b[i]); /* radius should be small to avoid overflow */
- fy = 1.0/ey; /* exp(-y) */
- /* expanded (e(iz)-e(-iz))*(-.5i) formula */
- temp = (REAL) (sin(x) * (ey + fy) * 0.5);
- /* see my notes in Abram.p.71 */
- b[i] = (REAL) (cos(x) * (ey - fy) * 0.5);
- a[i] = temp;
- }
-}
-
-void
-complex_array_cos (a,b,n)
- REAL *a,*b;
- long n;
-{
- long i;
- double x, ey,fy;
- REAL temp;
-
- for (i=0; i<n; i++)
- {
- x = (double) a[i];
- ey = exp((double) b[i]); /* radius should be small to avoid overflow */
- fy = 1.0/ey; /* exp(-y) */
- /* expanded (e(iz)+e(-iz))*.5 formula */
- temp = (REAL) (cos(x) * (ey + fy) * 0.5);
- b[i] = (REAL) (sin(x) * (fy - ey) * 0.5); /* see my notes in Abram.p.71*/
- a[i] = temp;
- }
-}
-
-
-void
-complex_array_asin (a,b,n)
- REAL *a,*b;
- long n;
-{ /* logarithmic formula as in R3.99, about 21ops plus log,atan - see my notes */
- long i;
- double oldx,oldy, x,y, real,imag, r;
-
- for (i=0; i<n; i++)
- {
- oldx = (double) a[i];
- oldy = (double) b[i];
-
- x = 1.0 - oldx*oldx + oldy*oldy; /* 1 - z*z */
- y = -2.0 * oldx * oldy;
-
- r = sqrt(x*x + y*y); /* sqrt(1-z*z) */
- real = sqrt((r+x)/2.0);
- if (y>=0.0)
- imag = sqrt((r-x)/2.0); /* choose principal root */
- else /* see Abramowitz (p.17 3.7.27) */
- imag = -sqrt((r-x)/2.0);
-
- real = real - oldy; /* i*z + sqrt(...) */
- imag = imag + oldx;
-
- b[i] = (REAL) (- log (sqrt (real*real + imag*imag))); /* -i*log(...) */
- a[i] = (REAL) atan2( imag, real); /* chosen angle is okay
- Also 0/0 doesnot occur */
- }
-}
-
-void
-complex_array_acos (a,b,n)
- REAL *a,*b;
- long n;
-{
- long i;
-
- complex_array_asin (a,b,n);
-
- for (i=0; i<n; i++)
- {
- a[i] = PI_OVER_2 - a[i];
- b[i] = - b[i];
- }
-}
-
-
-void
-complex_array_atan (a,b,n)
- REAL *a,*b;
- long n;
-{ /* logarithmic formula, expanded, simplified - see my notes */
- long i;
- double x,y, xx, real,imag, d;
-
- for (i=0; i<n; i++)
- {
- x = (double) a[i];
- y = (double) b[i];
-
- xx = x*x;
- imag = 1.0 + y; /* temp var */
- d = xx + imag*imag;
-
- real = (1 - y*y - xx) / d;
- imag = (2.0 * x) / d;
-
- b[i] = (REAL) ((log (sqrt (real*real + imag*imag))) / -2.0);
- a[i] = (atan2 (imag,real)) / 2.0;
- }
-}
-
-
-/* complex-array-operation-1b!
- groups together procedures that use 1 complex-array & 1 number
- and store the result in place (e.g. invert 1/x) */
-
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1B!", Prim_complex_array_operation_1b, 4,4, 0)
-{
- long n, i, opcode;
- REAL *a, *b, inf;
- void complex_array_invert ();
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, ARRAY_P); /* input array -- n real part */
- CHECK_ARG (3, ARRAY_P); /* input array -- n imag part */
- inf = (arg_real (4)); /* User-Provided Infinity */
- n = ARRAY_LENGTH(ARG_REF(2));
- if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- a = ARRAY_CONTENTS(ARG_REF(2)); /* real part */
- b = ARRAY_CONTENTS(ARG_REF(3)); /* imag part */
- opcode = arg_nonnegative_integer(1);
- if (opcode==1)
- complex_array_invert(a,b, n, inf); /* performs 1/x */
- else if (opcode==2)
- error_bad_range_arg(1); /* illegal opcode */
- else
- error_bad_range_arg(1); /* illegal opcode */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-complex_array_invert (a,b, n, inf)
- REAL *a,*b, inf;
- long n;
-{
- long i;
- double x,y, r;
- for (i=0; i<n; i++)
- {
- x = (double) a[i];
- y = (double) b[i];
- r = (x*x + y*y);
- if (r==0.0)
- {
- a[i] = inf;
- b[i] = inf;
- }
- else
- {
- a[i] = (REAL) x/r;
- b[i] = (REAL) -y/r;
- }
- }
-}
-\f
-/* complex-array-operation-1a
- groups together procedures that use 1 complex-array
- and store result in a 3rd real array. */
-
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1A", Prim_complex_array_operation_1a, 4,4, 0)
-{
- long n, i, opcode;
- REAL *a, *b, *c;
- void complex_array_magnitude(), complex_array_angle();
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, ARRAY_P); /* input array -- n real part */
- CHECK_ARG (3, ARRAY_P); /* input array -- n imag part */
- CHECK_ARG (4, ARRAY_P); /* output array -- n */
- n = ARRAY_LENGTH(ARG_REF(2));
- if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
- a = ARRAY_CONTENTS(ARG_REF(2)); /* real part */
- b = ARRAY_CONTENTS(ARG_REF(3)); /* imag part */
- c = ARRAY_CONTENTS(ARG_REF(4)); /* output */
- opcode = arg_nonnegative_integer(1);
- if (opcode==1)
- complex_array_magnitude(a,b,c,n);
- else if (opcode==2)
- complex_array_angle(a,b,c,n);
- else
- error_bad_range_arg(1); /* illegal opcode */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-complex_array_magnitude (a,b,c,n)
- REAL *a,*b,*c;
- long n;
-{
- long i;
- for (i=0; i<n; i++)
- c[i] = (REAL) sqrt( (double) a[i]*a[i] + b[i]*b[i] );
-}
-
-void
-complex_array_angle (a,b,c,n)
- REAL *a,*b,*c;
- long n;
-{
- long i;
- for (i=0; i<n; i++)
- {
- if ((a[i] == 0.0) && (b[i]==0.0))
- c[i] = 0.0; /* choose angle=0 for point (0,0) */
- else
- c[i] = (REAL) atan2( (double) b[i], (double) a[i]);
- /* angle == -pi (exclusive) to +pi (inclusive) */
- }
-}
-\f
-DEFINE_PRIMITIVE ("CS-ARRAY-MAGNITUDE!", Prim_cs_array_magnitude, 1, 1, 0)
-{
- long n, i;
- REAL *a;
- void cs_array_magnitude();
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P);
- a = ARRAY_CONTENTS(ARG_REF(1)); /* input cs-array */
- n = ARRAY_LENGTH(ARG_REF(1)); /* becomes a standard array on return */
- cs_array_magnitude(a,n);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* result is a standard array (even signal, real data) */
-void
-cs_array_magnitude (a,n)
- REAL *a;
- long n;
-{
- long i, n2, ni;
- n2 = n/2; /* integer division truncates down */
- a[0] = (REAL) fabs((double) a[0]); /* imag=0 */
- if (2*n2 == n) /* even length, n2 is only real */
- a[n2] = (REAL) fabs((double) a[n2]); /* imag=0 */
- else
- /* odd length, make the loop include the n2 index */
- n2 = n2+1;
- for (i=1; i<n2; i++)
- {
- ni = n-i;
- a[i] = (REAL) sqrt( (double) a[i]*a[i] + (double) a[ni]*a[ni] );
- a[ni] = a[i]; /* even signal */
- }
-}
-\f
-/* Rectangular and Polar
- A cs-array has even magnitude and odd angle (almost)
- hence a polar cs-array stores magnitude in the first half (real part)
- and angle in the second half (imag part)
- except for a[0] real-only and a[n2] (n even)
- The angle of a[0] is either 0 (pos. sign) or pi (neg. sign),
- but there is no place in an n-point cs-array to store this, so
- a[0] and a[n2] when n even are left unchanged when going polar.
- as opposed to taking their absolute values, for magnitude. */
-
-DEFINE_PRIMITIVE ("CS-ARRAY-TO-POLAR!", Prim_cs_array_to_polar, 1,1, 0)
-{
- long n, i;
- REAL *a;
- void cs_array_to_polar();
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P);
- a = ARRAY_CONTENTS(ARG_REF(1));
- n = ARRAY_LENGTH(ARG_REF(1));
- cs_array_to_polar(a,n);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-cs_array_to_polar (a,n)
- REAL *a;
- long n;
-{
- long i, n2;
- double real, imag; /* temporary variables */
- n2 = n/2; /* integer division truncates down */
- /* a[0] stores both magnitude and angle
- (pos. sign angle=0 , neg. sign angle=pi) */
- if (2*n2 == n) /* even length, n2 is only real */
- ; /* a[n2] stores sign information like a[0] */
- else
- /* odd length, make the loop include the n2 index */
- n2 = n2+1;
- for (i=1; i<n2; i++)
- {
- real = (double) a[i];
- imag = (double) a[n-i];
- a[i] = (REAL) sqrt( real*real + imag*imag );
- if (a[i] == 0.0)
- a[n-i] = 0.0;
- else
- a[n-i] = (REAL) atan2( imag, real );
- }
-}
-\f
-DEFINE_PRIMITIVE ("CS-ARRAY-TO-RECTANGULAR!", Prim_cs_array_to_rectangular, 1,1, 0)
-{
- long n,n2, i;
- double magn,angl; /* temporary variables */
- REAL *a;
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P);
- a = ARRAY_CONTENTS(ARG_REF(1));
- n = ARRAY_LENGTH(ARG_REF(1));
- n2 = n/2; /* integer division truncates down */
- ; /* a[0] is okay */
- if (2*n2 == n) /* even length, n2 is real only */
- ; /* a[n2] is okay */
- else
- n2 = n2+1; /* odd length, make the loop include the n2 index */
- for (i=1; i<n2; i++)
- { magn = (double) a[i];
- angl = (double) a[n-i];
- a[i] = (REAL) magn * cos(angl);
- a[n-i] = (REAL) magn * sin(angl); }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* Convolution in the Time-Domain */
-/* In the following macro
- To1 and To2 should be (Length1-1) and (Length2-1) respectively. */
-
-#define C_Convolution_Point_Macro(X, Y, To1, To2, N, Result) \
-{ \
- long Min_of_N_To1 = (min ((N), (To1))); \
- long mi, N_minus_mi; \
- REAL Sum = 0.0; \
- for (mi = (max (0, ((N) - (To2)))), N_minus_mi = ((N) - mi); \
- (mi <= Min_of_N_To1); \
- mi += 1, N_minus_mi -= 1) \
- Sum += ((X [mi]) * (Y [N_minus_mi])); \
- (Result) = Sum; \
-}
-
-DEFINE_PRIMITIVE ("CONVOLUTION-POINT", Prim_convolution_point, 3, 3, 0)
-{
- long Length1, Length2, N;
- REAL *Array1, *Array2;
- REAL C_Result;
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- Length1 = ARRAY_LENGTH (ARG_REF (1));
- Length2 = ARRAY_LENGTH (ARG_REF (2));
- N = (arg_nonnegative_integer (3));
- Array1 = ARRAY_CONTENTS (ARG_REF (1));
- Array2 = ARRAY_CONTENTS (ARG_REF (2));
- C_Convolution_Point_Macro(Array1, Array2, Length1-1, Length2-1, N, C_Result);
- PRIMITIVE_RETURN (double_to_flonum ((double) C_Result));
-}
-\f
-DEFINE_PRIMITIVE ("ARRAY-CONVOLUTION-IN-TIME!", Prim_array_convolution_in_time, 3, 3, 0)
-{
- long n,m,l, n_1,m_1, i;
- REAL *a,*b,*c;
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- CHECK_ARG (3, ARRAY_P);
- a = ARRAY_CONTENTS(ARG_REF(1));
- b = ARRAY_CONTENTS(ARG_REF(2));
- c = ARRAY_CONTENTS(ARG_REF(3));
- n = ARRAY_LENGTH(ARG_REF(1));
- m = ARRAY_LENGTH(ARG_REF(2));
- l = n+m-1; /* resulting length */
- if (l != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- n_1 = n-1; m_1 = m-1;
- for (i=0; i<l; i++)
- { C_Convolution_Point_Macro(a, b, n_1, m_1, i, c[i]); }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("ARRAY-MULTIPLY-INTO-SECOND-ONE!", Prim_array_multiply_into_second_one, 2, 2, 0)
-{
- long Length, i;
- REAL *To_Here;
- REAL *From_Here_1, *From_Here_2;
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- Length = ARRAY_LENGTH (ARG_REF (1));
- if (Length != ARRAY_LENGTH (ARG_REF (2))) error_bad_range_arg (2);
- From_Here_1 = ARRAY_CONTENTS (ARG_REF (1));
- From_Here_2 = ARRAY_CONTENTS (ARG_REF (2));
- To_Here = From_Here_2;
- for (i=0; i < Length; i++)
- {
- *To_Here++ = (*From_Here_1) * (*From_Here_2);
- From_Here_1++ ;
- From_Here_2++ ;
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* complex-array-operation-2!
- groups together procedures that use 2 complex-arrays
- and store result in either 1st or 2nd */
-
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-2!", Prim_complex_array_operation_2, 5,5, 0)
-{
- long n, opcode;
- REAL *ax,*ay, *bx,*by;
- void complex_array_multiply_into_second_one();
- PRIMITIVE_HEADER (5);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, ARRAY_P); /* ax array -- n real */
- CHECK_ARG (3, ARRAY_P); /* ay array -- n imag */
- CHECK_ARG (4, ARRAY_P); /* bx array -- n real */
- CHECK_ARG (5, ARRAY_P); /* by array -- n imag */
- n = ARRAY_LENGTH(ARG_REF(2));
- if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
- if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(5);
- ax = ARRAY_CONTENTS(ARG_REF(2)); /* real */
- ay = ARRAY_CONTENTS(ARG_REF(3)); /* imag */
- bx = ARRAY_CONTENTS(ARG_REF(4)); /* real */
- by = ARRAY_CONTENTS(ARG_REF(5)); /* imag */
- opcode = arg_nonnegative_integer(1);
- if (opcode==1)
- complex_array_multiply_into_second_one(ax,ay,bx,by, n);
- else if (opcode==2)
- error_bad_range_arg(1); /* illegal opcode */
- else
- error_bad_range_arg(1); /* illegal opcode */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-complex_array_multiply_into_second_one (ax,ay,bx,by, n)
- REAL *ax,*ay,*bx,*by;
- long n;
-{
- long i;
- REAL temp;
- for (i=0;i<n;i++)
- {
- temp = ax[i]*bx[i] - ay[i]*by[i]; /* real part */
- by[i] = ax[i]*by[i] + ay[i]*bx[i]; /* imag part */
- bx[i] = temp;
- }
-}
-
-void
-C_Array_Complex_Multiply_Into_First_One (a,b,c,d, length) /* used in fft.c */
- REAL *a,*b,*c,*d;
- long length;
-{
- long i;
- REAL temp;
- for (i=0;i<length;i++)
- {
- temp = a[i]*c[i] - b[i]*d[i];
- b[i] = a[i]*d[i] + b[i]*c[i];
- a[i] = temp;
- }
-}
-\f
-DEFINE_PRIMITIVE ("ARRAY-DIVIDE-INTO-XXX!", Prim_array_divide_into_xxx, 4,4, 0)
-{
- long n, i, one_or_two;
- REAL *x,*y,*z, inf;
- void array_divide_into_z();
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- inf = (arg_real (3));
- /* where to store result of division */
- one_or_two = (arg_nonnegative_integer (4));
- x = ARRAY_CONTENTS(ARG_REF(1));
- y = ARRAY_CONTENTS(ARG_REF(2));
- n = ARRAY_LENGTH(ARG_REF(1));
- if (n!=(ARRAY_LENGTH(ARG_REF(2)))) error_bad_range_arg(2);
- if (one_or_two == 1)
- array_divide_into_z( x,y, x, n, inf);
- else if (one_or_two == 2)
- array_divide_into_z( x,y, y, n, inf);
- else
- error_bad_range_arg(4);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-array_divide_into_z (x,y, z, n, inf) /* z can either x or y */
- REAL *x,*y,*z, inf;
- long n;
-{
- long i;
- for (i=0; i<n; i++)
- {
- if (y[i] == 0.0)
- {
- if (x[i] == 0.0)
- z[i] = 1.0;
- else
- z[i] = inf * x[i];
- }
- else
- z[i] = x[i] / y[i];
- }
-}
-\f
-/* complex-array-operation-2b!
- groups together procedures that use 2 complex-arrays
- & 1 additional real number
- and store result in either 1st or 2nd (e.g. division) */
-
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-2B!", Prim_complex_array_operation_2b, 6,6, 0)
-{ long n, opcode;
- REAL *ax,*ay, *bx,*by, inf;
- void complex_array_divide_into_z();
- PRIMITIVE_HEADER (6);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, ARRAY_P); /* ax array -- n real */
- CHECK_ARG (3, ARRAY_P); /* ay array -- n imag */
- CHECK_ARG (4, ARRAY_P); /* bx array -- n real */
- CHECK_ARG (5, ARRAY_P); /* by array -- n imag */
- inf = (arg_real (6)); /* User-Provided Infinity */
- n = ARRAY_LENGTH(ARG_REF(2));
- if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
- if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(5);
- ax = ARRAY_CONTENTS(ARG_REF(2)); /* real */
- ay = ARRAY_CONTENTS(ARG_REF(3)); /* imag */
- bx = ARRAY_CONTENTS(ARG_REF(4)); /* real */
- by = ARRAY_CONTENTS(ARG_REF(5)); /* imag */
- opcode = arg_nonnegative_integer(1);
- if (opcode==1)
- complex_array_divide_into_z (ax,ay,bx,by, ax,ay, n, inf);
- else if (opcode==2)
- complex_array_divide_into_z (ax,ay,bx,by, bx,by, n, inf);
- else
- error_bad_range_arg(1); /* illegal opcode */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-complex_array_divide_into_z (xr,xi, yr,yi, zr,zi, n, inf)
- REAL *xr,*xi, *yr,*yi, *zr,*zi, inf;
- long n;
-{
- long i;
- fast double temp, radius;
- for (i=0; i<n; i++)
- {
- radius = (double) (yr[i] * yr[i]) + (yi[i] * yi[i]); /* denominator */
- if (radius == 0.0)
- {
- if (xr[i] == 0.0)
- zr[i] = 1.0;
- else
- zr[i] = inf * xr[i];
- if (xi[i] == 0.0)
- zi[i] = 1.0;
- else
- zi[i] = inf * xi[i];
- }
- else
- {
- temp = (double) (xr[i] * yr[i] + xi[i] * yi[i]);
- zi[i] = (REAL) (xi[i] * yr[i] - xr[i] * yi[i]) / radius;
- zr[i] = (REAL) temp / radius;
- }
- }
-}
-\f
-DEFINE_PRIMITIVE ("ARRAY-LINEAR-SUPERPOSITION-INTO-SECOND-ONE!", Prim_array_linear_superposition_into_second_one, 4, 4, 0)
-{
- long n, i;
- REAL *To_Here, Coeff1, Coeff2;
- REAL *From_Here_1, *From_Here_2;
- PRIMITIVE_HEADER (4);
- Coeff1 = (arg_real (1));
- CHECK_ARG (2, ARRAY_P);
- Coeff2 = (arg_real (3));
- CHECK_ARG (4, ARRAY_P);
- n = (ARRAY_LENGTH (ARG_REF (2)));
- if (n != (ARRAY_LENGTH (ARG_REF (4))))
- error_bad_range_arg (4);
- From_Here_1 = (ARRAY_CONTENTS (ARG_REF (2)));
- From_Here_2 = (ARRAY_CONTENTS (ARG_REF (4)));
- To_Here = From_Here_2;
- for (i=0; i < n; i++)
- {
- *To_Here++ = (Coeff1 * (*From_Here_1)) + (Coeff2 * (*From_Here_2));
- From_Here_1++ ;
- From_Here_2++ ;
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* m_pi = 3.14159265358979323846264338327950288419716939937510; */
-
-DEFINE_PRIMITIVE ("SAMPLE-PERIODIC-FUNCTION", Prim_sample_periodic_function, 4, 4, 0)
-{
- long N, i, Function_Number;
- double Signal_Frequency, Sampling_Frequency, DT, DTi;
- double twopi = 6.28318530717958;
- SCHEME_OBJECT Result, Pfunction_number, Psignal_frequency;
- SCHEME_OBJECT Pfunction_Number;
- REAL *To_Here;
- double unit_square_wave(), unit_triangle_wave();
- PRIMITIVE_HEADER (4);
- Function_Number = (arg_index_integer (1, 11));
- Signal_Frequency = (arg_real_number (2));
- if (Signal_Frequency == 0)
- error_bad_range_arg (2);
- Sampling_Frequency = (arg_real_number (3));
- if (Sampling_Frequency == 0)
- error_bad_range_arg (3);
- N = (arg_nonnegative_integer (4));
- Result = (allocate_array (N));
- To_Here = ARRAY_CONTENTS(Result);
- DT = (double) (twopi * Signal_Frequency * (1 / Sampling_Frequency));
- if (Function_Number == 0)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) cos(DTi);
- else if (Function_Number == 1)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) sin(DTi);
- else if (Function_Number == 2)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) unit_square_wave(DTi);
- else if (Function_Number == 3)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) unit_triangle_wave(DTi);
- else
- error_bad_range_arg (1);
- PRIMITIVE_RETURN (Result);
-}
-\f
-double
-hamming (t, length)
- double t, length;
-{
- double twopi = 6.28318530717958;
- double pi = twopi/2.;
- double t_bar = cos(twopi * (t / length));
- if ((t<length) && (t>0.0)) return(.08 + .46 * (1 - t_bar));
- else return (0);
-}
-
-double
-unit_square_wave (t)
- double t;
-{
- double twopi = 6.28318530717958;
- double fmod(), fabs();
- double pi = twopi/2.;
- double t_bar = ((REAL) fabs(fmod( ((double) t), twopi)));
- if (t_bar < pi) return(1);
- else return(-1);
-}
-
-double
-unit_triangle_wave (t)
- double t;
-{
- double twopi = 6.28318530717958;
- double pi = twopi/2.;
- double pi_half = pi/2.;
- double three_pi_half = pi+pi_half;
- double t_bar = ((double) fabs(fmod( ((double) t), twopi)));
- if (t_bar<pi_half)
- return (-(t_bar/pi));
- else if (t_bar<pi)
- return (t_bar/pi);
- else if (t_bar<three_pi_half)
- return ((twopi-t_bar)/pi);
- else
- return (-((twopi-t_bar)/pi));
-}
-\f
-DEFINE_PRIMITIVE ("ARRAY-HANNING!", Prim_array_hanning, 2,2, 0)
-{
- long n, hanning_power;
- REAL *a;
- void C_Array_Make_Hanning();
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P); /* input array -- n */
- CHECK_ARG (2, FIXNUM_P); /* hanning power */
- a = ARRAY_CONTENTS(ARG_REF(1));
- n = ARRAY_LENGTH(ARG_REF(1));
- hanning_power = arg_nonnegative_integer(2);
- C_Array_Make_Hanning (a, n, hanning_power);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-C_Array_Make_Hanning (f1, length, power)
- REAL f1[];
- long length, power;
-{
- double window_length;
- long i;
- double integer_power(), hanning();
- window_length = ((double) length);
- for (i=0;i<length;i++)
- {
- f1[i] = ((REAL) hanning(((double) i), window_length));
- f1[i] = (REAL) integer_power(((double) f1[i]), power);
- }
-}
-
-double
-hanning (t, length)
- double t, length;
-{
- double twopi = 6.283185307179586476925287;
- double t_bar;
- t_bar = cos(twopi * (t / length));
- if ((t<length) && (t>0.0))
- return(.5 * (1 - t_bar));
- else
- return (0.0);
-}
-
-double
-integer_power (a, n)
- double a;
- long n;
-{
- double b;
- double integer_power();
-
- if (n<0) exit(-1);
- else if (n==0) return(1.0);
- else if (n==1) return(a);
- else if ((n%2) == 0)
- {
- b = integer_power(a, n/2);
- return(b*b);
- }
- else
- return(a * integer_power(a, (n-1)));
-}
-\f
-/* array-operation-1!
- groups together procedures that use 1 array
- and store the result in place (e.g. random) */
-
-DEFINE_PRIMITIVE ("ARRAY-OPERATION-1!", Prim_array_operation_1, 2,2, 0)
-{
- long n, opcode;
- REAL *a;
- void array_random();
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, ARRAY_P); /* input array -- n */
- n = ARRAY_LENGTH(ARG_REF(2));
- a = ARRAY_CONTENTS(ARG_REF(2));
- opcode = arg_nonnegative_integer(1);
- if (opcode==1)
- array_random(a,n);
- else if (opcode==2)
- error_bad_range_arg(1); /* illegal opcode */
- else
- error_bad_range_arg(1); /* illegal opcode */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-array_random (a,n)
- REAL *a;
- long n;
-{
- long i;
- /* HPUX 3: Rand uses a multiplicative congruential random-number generator
- with period 2^32 that returns successive pseudo-random numbers in the
- range from 0 to 2^15-1 */
- for (i=0;i<n;i++)
- a[i] = ((REAL) rand()) * (3.0517578125e-5);
- /* 3.051xxx = 2^(-15) makes the range from 0 to 1 */
-}
-\f
-/* The following should go away.
- superceded by ARRAY-CONS-INTEGERS, ARRAY-UNARY-FUNCTION and array-random */
-DEFINE_PRIMITIVE ("SAMPLE-APERIODIC-FUNCTION", Prim_sample_aperiodic_function, 3, 3, 0)
-{
- long N, i, Function_Number;
- double Sampling_Frequency, DT, DTi;
- double twopi = 6.28318530717958;
- SCHEME_OBJECT Result;
- REAL *To_Here, twopi_dt;
- PRIMITIVE_HEADER (3);
- Function_Number = (arg_index_integer (1, 7));
- Sampling_Frequency = (arg_real_number (2));
- if (Sampling_Frequency == 0)
- error_bad_range_arg (2);
- N = (arg_nonnegative_integer (3));
- Result = (allocate_array (N));
- To_Here = ARRAY_CONTENTS(Result);
- DT = (twopi * (1 / Sampling_Frequency));
- if (Function_Number == 0)
- /* HPUX 3: Rand uses a multiplicative congruential random-number generator
- with period 2^32 that returns successive pseudo-random numbers in the
- range from 0 to 2^15-1 */
- for (i=0; i<N; i++)
- /* 2^(-15) makes range from 0 to 1 */
- *To_Here++ = 3.0517578125e-5 * ((REAL) rand());
- else if (Function_Number == 1)
- { double length=DT*N;
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) hanning(DTi, length);
- }
- else if (Function_Number == 2)
- { double length=DT*N;
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) hamming(DTi, length);
- }
- else if (Function_Number == 3)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) sqrt(DTi);
- else if (Function_Number == 4)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) log(DTi);
- else if (Function_Number == 5)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) exp(DTi);
- else
- error_bad_range_arg (1);
- PRIMITIVE_RETURN (Result);
-}
-\f
-DEFINE_PRIMITIVE ("ARRAY-PERIODIC-DOWNSAMPLE", Prim_array_periodic_downsample, 2, 2, 0)
-{
- long Length, Pseudo_Length, Sampling_Ratio;
- REAL *Array, *To_Here;
- SCHEME_OBJECT Result;
- long i, array_index;
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- Length = ARRAY_LENGTH(ARG_REF (1));
- Sampling_Ratio = ((arg_integer (2)) % Length);
- if (Sampling_Ratio < 1)
- error_bad_range_arg (2);
- Array = ARRAY_CONTENTS(ARG_REF (1));
- Result = (allocate_array (Length));
- To_Here = ARRAY_CONTENTS(Result);
- Pseudo_Length = Length * Sampling_Ratio;
- /* new Array has the same Length by assuming periodicity */
- for (i=0; i<Pseudo_Length; i += Sampling_Ratio)
- { array_index = i % Length;
- *To_Here++ = Array[array_index]; }
- PRIMITIVE_RETURN (Result);
-}
-
-/* Shift is not done in place (no side-effects). */
-DEFINE_PRIMITIVE ("ARRAY-PERIODIC-SHIFT", Prim_array_periodic_shift, 2, 2, 0)
-{
- long Length, Shift;
- REAL *Array, *To_Here;
- SCHEME_OBJECT Result;
- long i, array_index;
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- Length = ARRAY_LENGTH(ARG_REF (1));
- /* periodic waveform, same sign as dividend */
- Shift = ((arg_integer (2)) % Length);
- Array = ARRAY_CONTENTS(ARG_REF (1));
- Result = (allocate_array (Length));
- To_Here = ARRAY_CONTENTS(Result);
- /* new Array has the same Length by assuming periodicity */
- for (i=0; i<Length; i++) {
- array_index = (i+Shift) % Length;
- if (array_index<0) array_index = Length + array_index; /* wrap around */
- *To_Here++ = Array[array_index]; }
- PRIMITIVE_RETURN (Result);
-}
-
-/* This is done here because array-map is very slow */
-DEFINE_PRIMITIVE ("ARRAY-APERIODIC-DOWNSAMPLE", Prim_array_aperiodic_downsample, 2, 2, 0)
-{
- long Length, New_Length, Sampling_Ratio;
- REAL *Array, *To_Here;
- SCHEME_OBJECT Result;
- long i, array_index;
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- Array = ARRAY_CONTENTS(ARG_REF (1));
- Length = ARRAY_LENGTH(ARG_REF (1));
- Sampling_Ratio = (arg_integer_in_range (2, 1, (Length + 1)));
- if (Length < 1) error_bad_range_arg (1);
- /* 1 for first one and then the rest --- integer division chops */
- New_Length = 1 + ((Length-1)/Sampling_Ratio);
- Result = (allocate_array (New_Length));
- To_Here = ARRAY_CONTENTS(Result);
- for (i=0; i<Length; i += Sampling_Ratio)
- *To_Here++ = Array[i];
- PRIMITIVE_RETURN (Result);
-}
-\f
-/* one more hack for speed */
-
-/* (SOLVE-SYSTEM A B N)
- Solves the system of equations Ax = b. A and B are
- arrays and b is the order of the system. Returns x.
- From the Fortran procedure in Strang. */
-
-DEFINE_PRIMITIVE ("SOLVE-SYSTEM", Prim_gaussian_elimination, 2, 2, 0)
-{
- REAL *A, *B, *X;
- long Length;
- SCHEME_OBJECT Result;
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, ARRAY_P);
- Length = ARRAY_LENGTH(ARG_REF (2));
- if ((Length*Length) != ARRAY_LENGTH(ARG_REF (1))) error_bad_range_arg (2);
- A = ARRAY_CONTENTS(ARG_REF (1));
- B = ARRAY_CONTENTS(ARG_REF (2));
- Result = (allocate_array (Length));
- X = ARRAY_CONTENTS(Result);
- C_Array_Copy(B, X, Length);
- C_Gaussian_Elimination(A, X, Length);
- PRIMITIVE_RETURN (Result);
-}
-
-/* C routine side-effects b. */
-C_Gaussian_Elimination (a, b, n)
- REAL *a, *b;
- long n;
-{
- long *pvt;
- REAL p, t;
- long i, j, k, m;
- Primitive_GC_If_Needed (n);
- pvt = ((long *) Free);
- *(pvt+n-1) = 1;
- if (n != 1) {
- for (k=1; k<n; k++) {
- m = k;
- for (i=k+1; i<=n; i++)
- if (fabs(*(a+i+(k-1)*n-1)) > fabs(*(a+m+(k-1)*n-1)))
- m = i;
- *(pvt+k-1) = m;
- if (m != k)
- *(pvt+n-1) = - *(pvt+n-1);
- p = *(a+m+(k-1)*n-1);
- *(a+m+(k-1)*n-1) = *(a+k+(k-1)*n-1);
- *(a+k+(k-1)*n-1) = p;
- if (p != 0.0) {
- for (i=k+1; i<=n; i++)
- *(a+i+(k-1)*n-1) = - *(a+i+(k-1)*n-1) / p;
- for (j=k+1; j<=n; j++) {
- t = *(a+m+(j-1)*n-1);
- *(a+m+(j-1)*n-1) = *(a+k+(j-1)*n-1);
- *(a+k+(j-1)*n-1) = t;
- if (t != 0.0)
- for (i=k+1; i<=n; i++)
- *(a+i+(j-1)*n-1) = *(a+i+(j-1)*n-1) + *(a+i+(k-1)*n-1) * t;
- }
- }
- }
- for (k=1; k<n; k++) {
- m = *(pvt+k-1);
- t = *(b+m-1);
- *(b+m-1) = *(b+k-1);
- *(b+k-1) = t;
- for (i=k+1; i<=n; i++)
- *(b+i-1) = *(b+i-1) + *(a+i+(k-1)*n-1) * t;
- }
- for (j=1; j<n; j++) {
- k = n - j + 1;
- *(b+k-1) = *(b+k-1) / *(a+k+(k-1)*n-1);
- t = - *(b+k-1);
- for (i=1; i <= n-j; i++)
- *(b+i-1) = *(b+i-1) + *(a+i+(k-1)*n-1) * t;
- }
- }
- *b = *b / *a;
- return;
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: array.h,v 9.40 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-\f
-#ifndef REAL_IS_DEFINED_DOUBLE
-#define REAL_IS_DEFINED_DOUBLE 0
-#endif
-
-#if (REAL_IS_DEFINED_DOUBLE == 0)
-#define REAL float
-#else
-#define REAL double
-#endif
-
-#define arg_real(arg_number) ((REAL) (arg_real_number (arg_number)))
-#define REAL_SIZE (BYTES_TO_WORDS (sizeof (REAL)))
-
-#define FLOAT_SIZE (BYTES_TO_WORDS (sizeof (float)))
-#define DOUBLE_SIZE (BYTES_TO_WORDS (sizeof (double)))
-
-#if (REAL_IS_DEFINED_DOUBLE == 0)
-
-/* Scheme_Arrays are implemented as NON_MARKED_VECTOR. */
-
-#define ARRAY_P NON_MARKED_VECTOR_P
-#define ARRAY_LENGTH(array) ((long) (FAST_MEMORY_REF ((array), 1)))
-#define ARRAY_CONTENTS(array) ((REAL *) (MEMORY_LOC (array, 2)))
-
-#else /* (REAL_IS_DEFINED_DOUBLE != 0) */
-
-/* Scheme_Arrays are implemented as flonum vectors.
- This is required to get alignment to work right on RISC machines. */
-
-#define ARRAY_P FLONUM_P
-#define ARRAY_LENGTH(array) ((VECTOR_LENGTH (array)) / DOUBLE_SIZE)
-#define ARRAY_CONTENTS(array) ((REAL *) (MEMORY_LOC (array, 1)))
-
-#endif /* (REAL_IS_DEFINED_DOUBLE != 0) */
-
-extern SCHEME_OBJECT allocate_array ();
-
-extern void C_Array_Find_Min_Max ();
-extern void C_Array_Complex_Multiply_Into_First_One ();
-
-extern void C_Array_Make_Histogram ();
-/* REAL * Array;
- REAL * Histogram;
- long Length;
- long npoints; */
-
-extern void Find_Offset_Scale_For_Linear_Map();
-/* REAL Min;
- REAL Max;
- REAL New_Min;
- REAL New_Max;
- REAL * Offset;
- REAL * Scale; */
-\f
-/* The following macros implement commonly used array procs. */
-
-/* In the following macros we assign the arguments to local variables
- so as to do any computation (referencing, etc.) only once outside the loop.
- Otherwise it would be done again and again inside the loop.
- The names, like "MCRINDX", have been chosen to avoid shadowing the
- variables that are substituted in. WARNING: Do not use any names
- starting with the prefix "mcr", when calling these macros */
-
-#define C_Array_Scale(array, scale, n) \
-{ \
- fast REAL * mcr_scan = (array); \
- fast REAL * mcr_end = (mcr_scan + (n)); \
- fast REAL mcrd0 = (scale); \
- while (mcr_scan < mcr_end) \
- (*mcr_scan++) *= mcrd0; \
-}
-
-#define Array_Scale(array, scale) \
-{ \
- C_Array_Scale \
- ((ARRAY_CONTENTS (array)), \
- (scale), \
- (ARRAY_LENGTH (array))); \
-}
-
-#define C_Array_Copy(from, to, n) \
-{ \
- fast REAL * mcr_scan_source = (from); \
- fast REAL * mcr_end_source = (mcr_scan_source + (n)); \
- fast REAL * mcr_scan_target = (to); \
- while (mcr_scan_source < mcr_end_source) \
- (*mcr_scan_target++) = (*mcr_scan_source++); \
-}
-
-#define Array_Copy(from, to) \
-{ \
- C_Array_Copy \
- ((ARRAY_CONTENTS (from)), \
- (ARRAY_CONTENTS (to)), \
- (ARRAY_LENGTH (from))); \
-}
-
-#define C_Array_Add_Into_Second_One(from, to, n) \
-{ \
- fast REAL * mcr_scan_source = (from); \
- fast REAL * mcr_end_source = (mcr_scan_source + (n)); \
- fast REAL * mcr_scan_target = (to); \
- while (mcr_scan_source < mcr_end_source) \
- (*mcr_scan_target++) += (*mcr_scan_source++); \
-}
-
-#define Array_Add_Into_Second_One(from,to) \
-{ \
- C_Array_Add_Into_Second_One \
- ((ARRAY_CONTENTS (from)), \
- (ARRAY_CONTENTS (to)), \
- (ARRAY_LENGTH (from))); \
-}
-
-#define mabs(x) (((x) < 0) ? (- (x)) : (x))
-#define max(x,y) (((x) < (y)) ? (y) : (x))
-#define min(x,y) (((x) < (y)) ? (x) : (y))
/* -*-C-*-
-$Id: artutl.c,v 1.20 2007/01/05 21:19:25 cph Exp $
+$Id: artutl.c,v 1.21 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Arithmetic Utilities */
#include "scheme.h"
-#include <math.h>
-#include "limits.h"
\f
/* Conversions between Scheme types and C types. */
long
-DEFUN (fixnum_to_long, (fixnum), SCHEME_OBJECT fixnum)
+fixnum_to_long (SCHEME_OBJECT fixnum)
{
return (FIXNUM_TO_LONG (fixnum));
}
SCHEME_OBJECT
-DEFUN (double_to_fixnum, (value), double value)
+double_to_fixnum (double value)
{
#ifdef HAVE_DOUBLE_TO_LONG_BUG
- fast long temp = ((long) value);
+ long temp = ((long) value);
return (LONG_TO_FIXNUM (temp));
#else
return (LONG_TO_FIXNUM ((long) value));
#endif
}
\f
-Boolean
-DEFUN (integer_to_long_p, (n), fast SCHEME_OBJECT n)
+bool
+integer_to_long_p (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n)) || (BIGNUM_TO_LONG_P (n)));
}
long
-DEFUN (integer_to_long,
- (n),
- fast SCHEME_OBJECT n)
+integer_to_long (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n)) ? (FIXNUM_TO_LONG (n)) : (bignum_to_long (n)));
}
SCHEME_OBJECT
-DEFUN (long_to_integer, (number), long number)
+long_to_integer (long number)
{
return
((LONG_TO_FIXNUM_P (number))
: (long_to_bignum (number)));
}
-Boolean
-DEFUN (integer_to_ulong_p, (n), fast SCHEME_OBJECT n)
+bool
+integer_to_ulong_p (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n)) || (BIGNUM_TO_ULONG_P (n)));
}
unsigned long
-DEFUN (integer_to_ulong,
- (n),
- fast SCHEME_OBJECT n)
+integer_to_ulong (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n))
? ((unsigned long) (FIXNUM_TO_LONG (n)))
}
SCHEME_OBJECT
-DEFUN (ulong_to_integer, (number), unsigned long number)
+ulong_to_integer (unsigned long number)
{
long s_number = ((long) number);
if (s_number >= 0)
return (ulong_to_bignum (number));
}
-Boolean
-DEFUN (integer_to_double_p, (n), fast SCHEME_OBJECT n)
+bool
+integer_to_double_p (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n)) || (BIGNUM_TO_DOUBLE_P (n)));
}
double
-DEFUN (integer_to_double, (n), fast SCHEME_OBJECT n)
+integer_to_double (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n)) ? (FIXNUM_TO_DOUBLE (n)) : (bignum_to_double (n)));
}
SCHEME_OBJECT
-DEFUN (double_to_integer, (x), fast double x)
+double_to_integer (double x)
{
return
((DOUBLE_TO_FIXNUM_P (x))
}
double
-DEFUN (double_truncate, (x), fast double x)
+double_truncate (double x)
{
double iptr;
(void) modf (x, (&iptr));
return (iptr);
}
+
+double
+double_round (double x)
+{
+ return (double_truncate ((x < 0) ? (x - 0.5) : (x + 0.5)));
+}
\f
/* Conversions between Scheme types and Scheme types. */
SCHEME_OBJECT
-DEFUN (bignum_to_fixnum, (bignum), fast SCHEME_OBJECT bignum)
+bignum_to_fixnum (SCHEME_OBJECT bignum)
{
return
((BIGNUM_TO_FIXNUM_P (bignum))
}
SCHEME_OBJECT
-DEFUN (bignum_to_integer, (bignum), fast SCHEME_OBJECT bignum)
+bignum_to_integer (SCHEME_OBJECT bignum)
{
return
((BIGNUM_TO_FIXNUM_P (bignum))
}
SCHEME_OBJECT
-DEFUN (bignum_to_flonum, (bignum), fast SCHEME_OBJECT bignum)
+bignum_to_flonum (SCHEME_OBJECT bignum)
{
return
((BIGNUM_TO_FLONUM_P (bignum))
: SHARP_F);
}
\f
-Boolean
-DEFUN (flonum_integer_p, (x), SCHEME_OBJECT x)
+bool
+flonum_integer_p (SCHEME_OBJECT x)
{
- extern double EXFUN (modf, (double, double *));
double iptr;
return ((modf ((FLONUM_TO_DOUBLE (x)), (&iptr))) == 0);
}
SCHEME_OBJECT
-DEFUN (flonum_floor, (x), SCHEME_OBJECT x)
+flonum_floor (SCHEME_OBJECT x)
{
- extern double EXFUN (floor, (double));
return (double_to_flonum (floor (FLONUM_TO_DOUBLE (x))));
}
SCHEME_OBJECT
-DEFUN (flonum_ceiling, (x), SCHEME_OBJECT x)
+flonum_ceiling (SCHEME_OBJECT x)
{
- extern double EXFUN (ceil, (double));
return (double_to_flonum (ceil (FLONUM_TO_DOUBLE (x))));
}
SCHEME_OBJECT
-DEFUN (flonum_round,
- (x),
- SCHEME_OBJECT x)
+flonum_round (SCHEME_OBJECT x)
{
- fast double dx = (FLONUM_TO_DOUBLE (x));
- return
- (double_to_flonum (double_truncate ((dx < 0) ? (dx - 0.5) : (dx + 0.5))));
+ return (double_to_flonum (double_round (FLONUM_TO_DOUBLE (x))));
}
SCHEME_OBJECT
-DEFUN (flonum_normalize, (x), SCHEME_OBJECT x)
+flonum_normalize (SCHEME_OBJECT x)
{
- extern double EXFUN (frexp, (double, int *));
int exponent;
double significand = (frexp ((FLONUM_TO_DOUBLE (x)), (&exponent)));
return (cons ((double_to_flonum (significand)),
}
SCHEME_OBJECT
-DEFUN (flonum_denormalize, (x, e), SCHEME_OBJECT x AND SCHEME_OBJECT e)
+flonum_denormalize (SCHEME_OBJECT x, SCHEME_OBJECT e)
{
- extern double EXFUN (ldexp, (double, int));
return (double_to_flonum (ldexp ((FLONUM_TO_DOUBLE (x)),
((int) (integer_to_long (e))))));
}
\f
/* Generic Integer Operations */
-Boolean
-DEFUN (integer_zero_p, (n), SCHEME_OBJECT n)
+bool
+integer_zero_p (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n)) ? (FIXNUM_ZERO_P (n)) : (BIGNUM_ZERO_P (n)));
}
-Boolean
-DEFUN (integer_negative_p, (n), SCHEME_OBJECT n)
+bool
+integer_negative_p (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n)) ? (FIXNUM_NEGATIVE_P (n)) : (BIGNUM_NEGATIVE_P (n)));
}
-Boolean
-DEFUN (integer_positive_p, (n), SCHEME_OBJECT n)
+bool
+integer_positive_p (SCHEME_OBJECT n)
{
return ((FIXNUM_P (n)) ? (FIXNUM_POSITIVE_P (n)) : (BIGNUM_POSITIVE_P (n)));
}
-Boolean
-DEFUN (integer_equal_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
+bool
+integer_equal_p (SCHEME_OBJECT n, SCHEME_OBJECT m)
{
return
((FIXNUM_P (n))
: (bignum_equal_p (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
}
-Boolean
-DEFUN (integer_less_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
+bool
+integer_less_p (SCHEME_OBJECT n, SCHEME_OBJECT m)
{
return
((FIXNUM_P (n))
}
SCHEME_OBJECT
-DEFUN (integer_negate, (n), SCHEME_OBJECT n)
+integer_negate (SCHEME_OBJECT n)
{
return
((FIXNUM_P (n))
}
\f
SCHEME_OBJECT
-DEFUN (integer_add, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
+integer_add (SCHEME_OBJECT n, SCHEME_OBJECT m)
{
return
((FIXNUM_P (n))
}
SCHEME_OBJECT
-DEFUN (integer_add_1, (n), SCHEME_OBJECT n)
+integer_add_1 (SCHEME_OBJECT n)
{
return
((FIXNUM_P (n))
}
SCHEME_OBJECT
-DEFUN (integer_subtract, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
+integer_subtract (SCHEME_OBJECT n, SCHEME_OBJECT m)
{
return
((FIXNUM_P (n))
}
SCHEME_OBJECT
-DEFUN (integer_subtract_1, (n), SCHEME_OBJECT n)
+integer_subtract_1 (SCHEME_OBJECT n)
{
return
((FIXNUM_P (n))
}
SCHEME_OBJECT
-DEFUN (integer_multiply, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
+integer_multiply (SCHEME_OBJECT n, SCHEME_OBJECT m)
{
- extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT));
- fast SCHEME_OBJECT result;
+ SCHEME_OBJECT result;
return
((FIXNUM_P (n))
? ((FIXNUM_P (m))
(bignum_multiply (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
}
\f
-Boolean
-DEFUN (integer_divide, (n, d, q, r),
- SCHEME_OBJECT n AND SCHEME_OBJECT d
- AND SCHEME_OBJECT * q AND SCHEME_OBJECT * r)
+bool
+integer_divide (SCHEME_OBJECT n, SCHEME_OBJECT d,
+ SCHEME_OBJECT * q, SCHEME_OBJECT * r)
{
if (FIXNUM_P (n))
{
/* Now, unbelievable hair because C doesn't fully specify
/ and % when their arguments are negative. We must get
consistent answers for all valid arguments. */
- fast long lx = (FIXNUM_TO_LONG (n));
- fast long ly = (FIXNUM_TO_LONG (d));
- fast long quotient;
- fast long remainder;
+ long lx = (FIXNUM_TO_LONG (n));
+ long ly = (FIXNUM_TO_LONG (d));
+ long quotient;
+ long remainder;
if (ly == 0)
return (true);
if (lx < 0)
}
\f
SCHEME_OBJECT
-DEFUN (integer_quotient, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d)
+integer_quotient (SCHEME_OBJECT n, SCHEME_OBJECT d)
{
if (FIXNUM_P (n))
{
if (FIXNUM_P (d))
{
- fast long lx = (FIXNUM_TO_LONG (n));
- fast long ly = (FIXNUM_TO_LONG (d));
+ long lx = (FIXNUM_TO_LONG (n));
+ long ly = (FIXNUM_TO_LONG (d));
return
((ly == 0)
? SHARP_F
}
SCHEME_OBJECT
-DEFUN (integer_remainder, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d)
+integer_remainder (SCHEME_OBJECT n, SCHEME_OBJECT d)
{
if (FIXNUM_P (n))
{
if (FIXNUM_P (d))
{
- fast long lx = (FIXNUM_TO_LONG (n));
- fast long ly = (FIXNUM_TO_LONG (d));
+ long lx = (FIXNUM_TO_LONG (n));
+ long ly = (FIXNUM_TO_LONG (d));
return
((ly == 0)
? SHARP_F
}
\f
static unsigned long
-DEFUN (unsigned_long_length_in_bits, (n), unsigned long n)
+unsigned_long_length_in_bits (unsigned long n)
{
unsigned long result = 0;
while (n > 0)
}
SCHEME_OBJECT
-DEFUN (integer_length_in_bits, (n), SCHEME_OBJECT n)
+integer_length_in_bits (SCHEME_OBJECT n)
{
if (FIXNUM_P (n))
{
}
SCHEME_OBJECT
-DEFUN (integer_shift_left, (n, m), SCHEME_OBJECT n AND unsigned long m)
+integer_shift_left (SCHEME_OBJECT n, unsigned long m)
{
if ((m == 0) || (!integer_positive_p (n)))
return (n);
/* -*-C-*-
-$Id: avltree.c,v 1.10 2007/01/05 21:19:25 cph Exp $
+$Id: avltree.c,v 1.11 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* This file contains the code for a simple AVL tree library.
It is used by the MIT/GNU Scheme microcode to quickly map
- names to indices into various tables.
- */
+ names to indices into various tables. */
#include "avltree.h"
-extern int EXFUN (strcmp_ci, (CONST char * s1, CONST char * s2));
-extern PTR EXFUN (malloc, (unsigned long));
-extern void EXFUN (free, (PTR));
+extern int strcmp_ci (const char *, const char *);
-CONST char * tree_error_message = 0;
-CONST char * tree_error_noise = 0;
+const char * tree_error_message = 0;
+const char * tree_error_noise = 0;
static void
-DEFUN (tree_error, (message, noise),
- CONST char * message AND
- CONST char * noise)
+tree_error (const char * message, const char * noise)
{
tree_error_message = message;
tree_error_noise = noise;
With random insertion (or when created as below),
they are better, approaching log base 2.
- This version does not allow duplicate entries. */
+ This version does not allow duplicate entries. */
-#define BRANCH_HEIGHT(tree) (((tree) == 0) ? 0 : (tree)->height)
+#define BRANCH_HEIGHT(tree) (((tree) == 0) ? 0 : ((tree) -> height))
#ifndef MAX
# define MAX(a,b) (((a) >= (b)) ? (a) : (b))
#endif
static void
-DEFUN (update_height, (tree), tree_node tree)
+update_height (tree_node tree)
{
- tree->height = (1 + (MAX ((BRANCH_HEIGHT (tree->left)),
+ (tree->height) = (1 + (MAX ((BRANCH_HEIGHT (tree->left)),
(BRANCH_HEIGHT (tree->rite)))));
}
static tree_node
-DEFUN (leaf_make, (name, value),
- CONST char * name AND
- unsigned long value)
+leaf_make (const char * name, unsigned long value)
{
tree_node leaf = ((tree_node) (malloc (sizeof (struct tree_node_s))));
if (leaf == 0)
tree_error ("leaf_make: malloc failed.\n", 0);
return (leaf);
}
- leaf->name = name;
- leaf->value = value;
- leaf->height = 1;
- leaf->left = 0;
- leaf->rite = 0;
+ (leaf->name) = name;
+ (leaf->value) = value;
+ (leaf->height) = 1;
+ (leaf->left) = 0;
+ (leaf->rite) = 0;
return (leaf);
}
\f
static tree_node
-DEFUN (rotate_left, (tree), tree_node tree)
+rotate_left (tree_node tree)
{
- tree_node rite = tree->rite;
- tree_node beta = rite->left;
- tree->rite = beta;
- rite->left = tree;
+ tree_node rite = (tree->rite);
+ tree_node beta = (rite->left);
+ (tree->rite) = beta;
+ (rite->left) = tree;
update_height (tree);
update_height (rite);
return (rite);
}
static tree_node
-DEFUN (rotate_rite, (tree), tree_node tree)
+rotate_rite (tree_node tree)
{
- tree_node left = tree->left;
- tree_node beta = left->rite;
- tree->left = beta;
- left->rite = tree;
+ tree_node left = (tree->left);
+ tree_node beta = (left->rite);
+ (tree->left) = beta;
+ (left->rite) = tree;
update_height (tree);
update_height (left);
return (left);
}
static tree_node
-DEFUN (rebalance_left, (tree), tree_node tree)
+rebalance_left (tree_node tree)
{
if ((1 + (BRANCH_HEIGHT (tree->rite))) >= (BRANCH_HEIGHT (tree->left)))
{
}
else
{
- tree_node q = tree->left;
+ tree_node q = (tree->left);
if ((BRANCH_HEIGHT (q->rite)) > (BRANCH_HEIGHT (q->left)))
- tree->left = (rotate_left (q));
+ (tree->left) = (rotate_left (q));
return (rotate_rite (tree));
}
}
static tree_node
-DEFUN (rebalance_rite, (tree), tree_node tree)
+rebalance_rite (tree_node tree)
{
if ((1 + (BRANCH_HEIGHT (tree->left))) >= (BRANCH_HEIGHT (tree->rite)))
{
}
else
{
- tree_node q = tree->rite;
+ tree_node q = (tree->rite);
if ((BRANCH_HEIGHT (q->left)) > (BRANCH_HEIGHT (q->rite)))
- tree->rite = (rotate_rite (q));
+ (tree->rite) = (rotate_rite (q));
return (rotate_left (tree));
}
}
\f
tree_node
-DEFUN (tree_insert, (tree, name, value),
- tree_node tree AND
- CONST char * name AND
- unsigned long value)
+tree_insert (tree_node tree, const char * name, unsigned long value)
{
if (tree == 0)
return (leaf_make (name, value));
- switch (strcmp_ci (name, tree->name))
+ switch (strcmp_ci (name, (tree->name)))
{
case 0:
tree_error ("tree_insert: Duplicate entry %s.\n", name);
return (tree);
-
- case -1:
+
+ case (-1):
{
- /* To the left */
- tree->left = (tree_insert (tree->left, name, value));
+ (tree->left) = (tree_insert ((tree->left), name, value));
return (rebalance_left (tree));
}
case 1:
{
- /* To the right */
- tree->rite = (tree_insert (tree->rite, name, value));
+ (tree->rite) = (tree_insert ((tree->rite), name, value));
return (rebalance_rite (tree));
}
}
}
tree_node
-DEFUN (tree_lookup, (tree, name), tree_node tree AND CONST char * name)
+tree_lookup (tree_node tree, const char * name)
{
while (tree != 0)
- switch (strcmp_ci (name, tree->name))
+ switch (strcmp_ci (name, (tree->name)))
{
case 0:
return (tree);
- case -1:
- tree = tree->left;
+ case (-1):
+ tree = (tree->left);
break;
case 1:
- tree = tree->rite;
+ tree = (tree->rite);
break;
}
return (tree);
}
\f
tree_node
-DEFUN (tree_build, (high, names, value),
- unsigned long high AND
- CONST char ** names AND
- unsigned long value)
+tree_build (unsigned long high, const char ** names, unsigned long value)
{
static long bias = 0;
if (high > 1)
bias = (1 - bias);
}
next = (middle + 1);
- tree = (leaf_make (names[middle], (value + middle)));
- tree->left = (tree_build (middle, names, value));
- tree->rite = (tree_build ((high - next), &names[next], (value + next)));
+ tree = (leaf_make ((names[middle]), (value + middle)));
+ (tree->left) = (tree_build (middle, names, value));
+ (tree->rite)
+ = (tree_build ((high - next), (& (names[next])), (value + next)));
update_height (tree);
return (tree);
}
- else if (high == 1)
- return (leaf_make (* names, value));
- else
- return (0);
+ return ((high == 1) ? (leaf_make ((*names), value)) : 0);
}
void
-DEFUN (tree_free, (tree), tree_node tree)
+tree_free (tree_node tree)
{
if (tree != 0)
{
/* -*-C-*-
-$Id: avltree.h,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: avltree.h,v 1.10 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "config.h"
-extern CONST char * tree_error_message;
-extern CONST char * tree_error_noise;
+extern const char * tree_error_message;
+extern const char * tree_error_noise;
typedef struct tree_node_s * tree_node;
int height;
tree_node left;
tree_node rite;
- CONST char * name;
+ const char * name;
unsigned long value;
};
-extern tree_node EXFUN
- (tree_build, (unsigned long, CONST char **, unsigned long));
-extern tree_node EXFUN (tree_lookup, (tree_node, CONST char *));
-extern tree_node EXFUN (tree_insert, (tree_node, CONST char *, unsigned long));
-extern void EXFUN (tree_free, (tree_node));
+extern tree_node tree_build (unsigned long, const char **, unsigned long);
+extern tree_node tree_lookup (tree_node, const char *);
+extern tree_node tree_insert (tree_node, const char *, unsigned long);
+extern void tree_free (tree_node);
#endif /* AVLTREE_H */
+++ /dev/null
-/* -*-C-*-
-
-$Id: bchdmp.c,v 9.94 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
- purify, and fasdump, respectively, to provide garbage collection
- and related utilities to disk. */
-
-#include "scheme.h"
-#include "prims.h"
-#include "osfile.h"
-#include "osfs.h"
-#include "trap.h"
-#include "lookup.h" /* UNCOMPILED_VARIABLE */
-#define In_Fasdump
-#include "fasl.h"
-#include "bchgcc.h"
-
-extern int EXFUN (OS_channel_copy, (off_t, Tchannel, Tchannel));
-
-extern SCHEME_OBJECT EXFUN
- (dump_renumber_primitive, (SCHEME_OBJECT));
-extern SCHEME_OBJECT * EXFUN
- (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *));
-extern SCHEME_OBJECT * EXFUN
- (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
-extern SCHEME_OBJECT * EXFUN
- (cons_whole_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
-
-extern SCHEME_OBJECT compiler_utilities;
-extern SCHEME_OBJECT * EXFUN
- (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
-\f
-#ifdef __unix__
-# include "ux.h"
-# include "uxio.h"
- static char FASDUMP_FILENAME[] = "fasdumpXXXXXX";
-#endif
-
-#ifdef __WIN32__
-# include "nt.h"
-# include "ntio.h"
- static char FASDUMP_FILENAME[] = "faXXXXXX";
-#endif
-
-#ifdef __OS2__
-# include "os2.h"
- static char FASDUMP_FILENAME[] = "faXXXXXX";
-# ifdef __EMX__
-# include <io.h>
-# endif
-# if defined(__IBMC__) || defined(__WATCOMC__)
-# include <io.h>
-# include <sys\stat.h>
-# include <fcntl.h>
-# ifndef F_OK
-# define F_OK 0
-# define X_OK 1
-# define W_OK 2
-# define R_OK 4
-# endif
-# endif
-#endif
-\f
-static Tchannel dump_channel;
-static CONST char * dump_file_name;
-static int real_gc_file;
-static int dump_file;
-static SCHEME_OBJECT * saved_free;
-static SCHEME_OBJECT * fixup_buffer = 0;
-static SCHEME_OBJECT * fixup_buffer_end;
-static SCHEME_OBJECT * fixup;
-static int fixup_count = 0;
-static Boolean compiled_code_present_p;
-
-#define Write_Data(size, buffer) \
- ((OS_channel_write_dump_file \
- (dump_channel, \
- ((char *) (buffer)), \
- ((size) * (sizeof (SCHEME_OBJECT))))) \
- / (sizeof (SCHEME_OBJECT)))
-
-#include "dump.c"
-
-static SCHEME_OBJECT EXFUN (dump_to_file, (SCHEME_OBJECT, CONST char *));
-static int EXFUN (fasdump_exit, (long length));
-static int EXFUN (reset_fixes, (void));
-static ssize_t EXFUN (eta_read, (int, char *, int));
-static ssize_t EXFUN (eta_write, (int, char *, int));
-static long EXFUN
- (dump_loop, (SCHEME_OBJECT *, SCHEME_OBJECT **, SCHEME_OBJECT **));
-\f
-/* (PRIMITIVE-FASDUMP object-to-dump filename-or-channel flag)
-
- 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 or channel. The third argument, 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). It should signal an error rather than return false,
- but ... some other time.
-
- This version of fasdump can only handle files (actually lseek-able
- streams), since the header is written at the beginning of the
- output but its contents are only know after the rest of the output
- has been written.
-
- Thus, for arbitrary channels, a temporary file is allocated, and on
- completion, the file is copied to the channel. */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- SCHEME_OBJECT root = (ARG_REF (1));
- if (STRING_P (ARG_REF (2)))
- PRIMITIVE_RETURN (dump_to_file (root, (STRING_ARG (2))));
- {
- Tchannel channel = (arg_channel (2));
- char * temp_name = (make_gc_file_name (FASDUMP_FILENAME));
- transaction_begin ();
- protect_gc_file_name (temp_name);
- if (!allocate_gc_file (temp_name))
- signal_error_from_primitive (ERR_EXTERNAL_RETURN);
- {
- SCHEME_OBJECT fasdump_result = (dump_to_file (root, temp_name));
- if (fasdump_result == SHARP_T)
- {
- Tchannel temp_channel = (OS_open_input_file (temp_name));
- int copy_result
- = (OS_channel_copy ((OS_file_length (temp_channel)),
- temp_channel,
- channel));
- OS_channel_close (temp_channel);
- OS_file_remove (temp_name);
- transaction_commit ();
- if (copy_result < 0)
- signal_error_from_primitive (ERR_IO_ERROR);
- }
- PRIMITIVE_RETURN (fasdump_result);
- }
- }
- }
-}
-\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 #F. */
-
-DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
-{
- SCHEME_OBJECT * saved_free;
- SCHEME_OBJECT * prim_table_start;
- SCHEME_OBJECT * prim_table_end;
- SCHEME_OBJECT * c_table_start;
- SCHEME_OBJECT * c_table_end;
- long prim_table_length;
- long c_table_length;
- int result = 0;
- PRIMITIVE_HEADER (2);
-
- Band_Dump_Permitted ();
- CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
- CHECK_ARG (2, STRING_P);
- if (Unused_Heap_Bottom < Heap_Bottom)
- /* Cause the image to be in the low heap, to increase
- the probability that no relocation is needed on reload. */
- Primitive_GC (0);
- Primitive_GC_If_Needed (5);
-
- saved_free = Free;
-
- {
- SCHEME_OBJECT Combination;
- Combination = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free));
- (Free[COMB_1_FN]) = (ARG_REF (1));
- (Free[COMB_1_ARG_1]) = SHARP_F;
- Free += 2;
- {
- SCHEME_OBJECT p = (MAKE_POINTER_OBJECT (TC_LIST, Free));
- (*Free++) = Combination;
- (*Free++) = compiler_utilities;
- (*Free++) = p;
- }
- }
-
- prim_table_start = Free;
- prim_table_end
- = (cons_whole_primitive_table (prim_table_start, Heap_Top,
- (&prim_table_length)));
- if (prim_table_end >= Heap_Top)
- goto done;
-
- c_table_start = prim_table_end;
- c_table_end
- = (cons_c_code_table (c_table_start, Heap_Top,
- (&c_table_length)));
- if (c_table_end >= Heap_Top)
- goto done;
-
- {
- CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0)));
- SCHEME_OBJECT * faligned_heap = Heap_Bottom;
- SCHEME_OBJECT * faligned_constant = Constant_Space;
-
- BCH_ALIGN_FLOAT_ADDRESS (faligned_heap);
- BCH_ALIGN_FLOAT_ADDRESS (faligned_constant);
-
- OS_file_remove_link (filename);
- dump_channel = (OS_open_dump_file (filename));
- if (dump_channel == NO_CHANNEL)
- error_bad_range_arg (2);
-
- result
- = (Write_File ((Free - 1),
- ((long) (Free - faligned_heap)),
- faligned_heap,
- ((long) (Free_Constant - faligned_constant)),
- faligned_constant,
- prim_table_start,
- prim_table_length,
- ((long) (prim_table_end - prim_table_start)),
- c_table_start,
- c_table_length,
- ((long) (c_table_end - c_table_start)),
- (compiler_utilities != SHARP_F),
- 1));
-
- OS_channel_close_noerror (dump_channel);
- if (!result)
- OS_file_remove (filename);
- }
-
- done:
- Band_Dump_Exit_Hook ();
- Free = saved_free;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
-}
-\f
-static SCHEME_OBJECT
-DEFUN (dump_to_file, (root, fname),
- SCHEME_OBJECT root AND
- CONST char * fname)
-{
- Boolean success = 1;
- long value;
- long length;
- long hlength;
- long tlength;
- long tsize;
- SCHEME_OBJECT * dumped_object;
- SCHEME_OBJECT * free_buffer;
- SCHEME_OBJECT * dummy;
- SCHEME_OBJECT * table_start;
- SCHEME_OBJECT * table_end;
- SCHEME_OBJECT * table_top;
- SCHEME_OBJECT header [FASL_HEADER_LENGTH];
-
- if (fixup_buffer == 0)
- {
- fixup_buffer = ((SCHEME_OBJECT *) (malloc (gc_buffer_bytes)));
- if (fixup_buffer == 0)
- error_system_call (errno, syscall_malloc);
- fixup_buffer_end = (fixup_buffer + gc_buffer_size);
- }
-
- dump_file_name = fname;
- dump_file = (open (dump_file_name, GC_FILE_FLAGS, 0666));
- if (dump_file < 0)
- error_bad_range_arg (2);
-
- compiled_code_present_p = 0;
- real_gc_file = (swap_gc_file (dump_file));
- saved_free = Free;
- fixup = fixup_buffer_end;
- fixup_count = -1;
-
- table_top = (& (saved_free [Space_Before_GC ()]));
- table_start = (initialize_primitive_table (saved_free, table_top));
- if (table_start >= table_top)
- {
- fasdump_exit (0);
- Primitive_GC (table_start - saved_free);
- }
-
- free_buffer = (initialize_free_buffer ());
- Free = 0;
- free_buffer += FASL_HEADER_LENGTH;
-
- dummy = free_buffer;
- BCH_ALIGN_FLOAT (Free, dummy);
-
- (*free_buffer++) = root;
- dumped_object = (Free++);
-
- value
- = dump_loop (((initialize_scan_buffer (0)) + FASL_HEADER_LENGTH),
- (&free_buffer), (&Free));
- if (value != PRIM_DONE)
- {
- fasdump_exit (0);
- if (value == PRIM_INTERRUPT)
- return (SHARP_F);
- else
- signal_error_from_primitive (value);
- }
- end_transport (&success);
- if (!success)
- {
- fasdump_exit (0);
- return (SHARP_F);
- }
-
- length = (Free - dumped_object);
-
- table_end = (cons_primitive_table (table_start, table_top, &tlength));
- if (table_end >= table_top)
- {
- fasdump_exit (0);
- Primitive_GC (table_end - saved_free);
- }
-
-#ifdef NATIVE_CODE_IS_C
- /* Cannot dump C compiled code. */
- if (compiled_code_present_p)
- {
- fasdump_exit (0);
- signal_error_from_primitive (ERR_COMPILED_CODE_ERROR);
- }
-#endif
-
- tsize = (table_end - table_start);
- hlength = ((sizeof (SCHEME_OBJECT)) * tsize);
- if (((lseek (dump_file,
- ((sizeof (SCHEME_OBJECT)) * (length + FASL_HEADER_LENGTH)),
- 0))
- == -1)
- || ((write (dump_file, ((char *) (&table_start[0])), hlength))
- != hlength))
- {
- fasdump_exit (0);
- return (SHARP_F);
- }
-
- hlength = ((sizeof (SCHEME_OBJECT)) * FASL_HEADER_LENGTH);
- prepare_dump_header
- (header, dumped_object, length, dumped_object,
- 0, Constant_Space, tlength, tsize, 0, 0,
- compiled_code_present_p, 0);
- if (((lseek (dump_file, 0, 0)) == -1)
- || ((write (dump_file, ((char *) &header[0]), hlength)) != hlength))
- {
- fasdump_exit (0);
- return (SHARP_F);
- }
- return
- (BOOLEAN_TO_OBJECT
- (fasdump_exit (((sizeof (SCHEME_OBJECT)) * (length + tsize)) + hlength)));
-}
-\f
-static int
-DEFUN (fasdump_exit, (length), long length)
-{
- SCHEME_OBJECT * fixes, * fix_address;
- int result;
-
- Free = saved_free;
- restore_gc_file ();
-
-#ifdef HAVE_FTRUNCATE
- ftruncate (dump_file, length);
-#endif
- result = ((close (dump_file)) == 0);
-#if defined(HAVE_TRUNCATE) && !defined(HAVE_FTRUNCATE)
- truncate (dump_file_name, length);
-#endif
-
- if (length == 0)
- unlink (dump_file_name);
- dump_file_name = 0;
-
- fixes = fixup;
-
- next_buffer:
-
- while (fixes != fixup_buffer_end)
- {
- fix_address = ((SCHEME_OBJECT *) (*fixes++));
- (*fix_address) = (*fixes++);
- }
-
- if (fixup_count >= 0)
- {
- if ((retrying_file_operation
- (eta_read,
- real_gc_file,
- ((char *) fixup_buffer),
- (gc_file_start_position + (fixup_count << gc_buffer_byte_shift)),
- gc_buffer_bytes,
- "read",
- "the fixup buffer",
- (&gc_file_current_position),
- io_error_retry_p))
- != ((long) gc_buffer_bytes))
- {
- gc_death
- (TERM_EXIT,
- "fasdump: Could not read back the fasdump fixup information",
- 0, 0);
- /*NOTREACHED*/
- }
- fixup_count -= 1;
- fixes = fixup_buffer;
- goto next_buffer;
- }
-
- fixup = fixes;
- Fasdump_Exit_Hook ();
- return (result);
-}
-\f
-static int
-DEFUN_VOID (reset_fixes)
-{
- long start;
-
- fixup_count += 1;
- start = (gc_file_start_position + (fixup_count << gc_buffer_byte_shift));
-
- if (((start + ((long) gc_buffer_bytes)) > gc_file_end_position)
- || ((retrying_file_operation
- (eta_write,
- real_gc_file,
- ((char *) fixup_buffer),
- start,
- gc_buffer_bytes,
- "write",
- "the fixup buffer",
- (&gc_file_current_position),
- io_error_always_abort))
- != ((long) gc_buffer_bytes)))
- return (0);
- fixup = fixup_buffer_end;
- return (1);
-}
-
-static ssize_t
-DEFUN (eta_read, (fid, buffer, size),
- int fid AND
- char * buffer AND
- int size)
-{
- return (read (fid, buffer, size));
-}
-
-static ssize_t
-DEFUN (eta_write, (fid, buffer, size),
- int fid AND
- char * buffer AND
- int size)
-{
- return (write (fid, buffer, size));
-}
-\f
-#define MAYBE_DUMP_FREE(free) \
-{ \
- if (free >= free_buffer_top) \
- DUMP_FREE (free); \
-}
-
-#define DUMP_FREE(free) do \
-{ \
- Boolean _s = 1; \
- free = (dump_and_reset_free_buffer (free, (&_s))); \
- if (!_s) \
- return (PRIM_INTERRUPT); \
-} while (0)
-
-#define MAYBE_DUMP_SCAN(scan) \
-{ \
- if (scan >= scan_buffer_top) \
- DUMP_SCAN (scan); \
-}
-
-#define DUMP_SCAN(scan) do \
-{ \
- Boolean _s = 1; \
- scan = (dump_and_reload_scan_buffer (scan, (&_s))); \
- if (!_s) \
- return (PRIM_INTERRUPT); \
-} while (0)
-
-#define PUSH_FIXUP_DATA(ptr) \
-{ \
- if ((fixup == fixup_buffer) && (!reset_fixes ())) \
- return (PRIM_INTERRUPT); \
- (*--fixup) = (* (ptr)); \
- (*--fixup) = ((SCHEME_OBJECT) ptr); \
-}
-
-#define TRANSPORT_VECTOR(new_address, free, old_start, n_words) \
-{ \
- SCHEME_OBJECT * old_ptr = old_start; \
- SCHEME_OBJECT * free_end = (free + n_words); \
- if (free_end < free_buffer_top) \
- while (free < free_end) \
- (*free++) = (*old_ptr++); \
- else \
- { \
- while (free < free_buffer_top) \
- (*free++) = (*old_ptr++); \
- free = (transport_vector_tail (free, free_end, old_ptr)); \
- if (free == 0) \
- return (PRIM_INTERRUPT); \
- } \
-}
-
-static SCHEME_OBJECT *
-DEFUN (transport_vector_tail, (free, free_end, tail),
- SCHEME_OBJECT * free AND
- SCHEME_OBJECT * free_end AND
- SCHEME_OBJECT * tail)
-{
- unsigned long n_words = (free_end - free);
- {
- Boolean success = 1;
- free = (dump_and_reset_free_buffer (free, (&success)));
- if (!success)
- return (0);
- }
- {
- unsigned long n_blocks = (n_words >> gc_buffer_shift);
- if (n_blocks > 0)
- {
- Boolean success = 1;
- free = (dump_free_directly (tail, n_blocks, (&success)));
- if (!success)
- return (0);
- tail += (n_blocks << gc_buffer_shift);
- }
- }
- {
- SCHEME_OBJECT * free_end = (free + (n_words & gc_buffer_mask));
- while (free < free_end)
- (*free++) = (*tail++);
- }
- return (free);
-}
-\f
-/* A copy of gc_loop, with minor modifications. */
-
-static long
-DEFUN (dump_loop, (scan, free_ptr, new_address_ptr),
- SCHEME_OBJECT * scan AND
- SCHEME_OBJECT ** free_ptr AND
- SCHEME_OBJECT ** new_address_ptr)
-{
- SCHEME_OBJECT * free = (*free_ptr);
- SCHEME_OBJECT * new_address = (*new_address_ptr);
- while (scan != free)
- {
- SCHEME_OBJECT object;
- if (scan >= scan_buffer_top)
- {
- if (scan == scan_buffer_top)
- DUMP_SCAN (scan);
- else
- {
- sprintf
- (gc_death_message_buffer,
- "dump_loop: scan (0x%lx) > scan_buffer_top (0x%lx)",
- ((unsigned long) scan),
- ((unsigned long) scan_buffer_top));
- gc_death (TERM_EXIT, gc_death_message_buffer, scan, free);
- /*NOTREACHED*/
- }
- }
- object = (*scan);
- switch (OBJECT_TYPE (object))
- {
- case TC_BROKEN_HEART:
- if ((OBJECT_DATUM (object)) == 0)
- {
- scan += 1;
- break;
- }
- if (object == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan)))
- /* Does this ever happen? */
- goto end_dump_loop;
- sprintf (gc_death_message_buffer,
- "dump_loop: broken heart (0x%lx) in scan",
- object);
- gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, scan, free);
- /*NOTREACHED*/
- break;
-
- case TC_CHARACTER:
- case TC_CONSTANT:
- case TC_FIXNUM:
- case TC_NULL:
- case TC_RETURN_CODE:
- case TC_STACK_ENVIRONMENT:
- case TC_THE_ENVIRONMENT:
- scan += 1;
- break;
-
- case TC_PCOMB0:
- case TC_PRIMITIVE:
- (*scan++) = (dump_renumber_primitive (object));
- break;
-
- case TC_CELL:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- PUSH_FIXUP_DATA (old_start);
- (*free++) = (old_start[0]);
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 1;
- }
- }
- break;
-
- case TC_ACCESS:
- case TC_ASSIGNMENT:
- case TC_COMBINATION_1:
- case TC_COMMENT:
- case TC_COMPLEX:
- case TC_DEFINITION:
- case TC_DELAY:
- case TC_DELAYED:
- case TC_DISJUNCTION:
- case TC_ENTITY:
- case TC_EXTENDED_PROCEDURE:
- case TC_INTERNED_SYMBOL:
- case TC_IN_PACKAGE:
- case TC_LAMBDA:
- case TC_LEXPR:
- case TC_LIST:
- case TC_PCOMB1:
- case TC_PROCEDURE:
- case TC_RATNUM:
- case TC_SCODE_QUOTE:
- case TC_SEQUENCE_2:
- case TC_UNINTERNED_SYMBOL:
- case TC_WEAK_CONS:
- transport_pair:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- PUSH_FIXUP_DATA (old_start);
- (*free++) = (old_start[0]);
- switch (OBJECT_TYPE (object))
- {
- case TC_INTERNED_SYMBOL:
- (*free++) = BROKEN_HEART_ZERO;
- break;
- case TC_UNINTERNED_SYMBOL:
- (*free++) = UNBOUND_OBJECT;
- break;
- default:
- (*free++) = (old_start[1]);
- break;
- }
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 2;
- }
- }
- break;
-
- case TC_COMBINATION_2:
- case TC_CONDITIONAL:
- case TC_EXTENDED_LAMBDA:
- case TC_HUNK3_A:
- case TC_HUNK3_B:
- case TC_PCOMB2:
- case TC_SEQUENCE_3:
- case TC_VARIABLE:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- PUSH_FIXUP_DATA (old_start);
- (*free++) = (old_start[0]);
- switch (OBJECT_TYPE (object))
- {
- case TC_VARIABLE:
- (*free++) = UNCOMPILED_VARIABLE;
- (*free++) = SHARP_F;
- break;
- default:
- (*free++) = (old_start[1]);
- (*free++) = (old_start[2]);
- break;
- }
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 3;
- }
- }
- break;
-
- case TC_QUAD:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- PUSH_FIXUP_DATA (old_start);
- (*free++) = (old_start[0]);
- (*free++) = (old_start[1]);
- (*free++) = (old_start[2]);
- (*free++) = (old_start[3]);
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 4;
- }
- }
- break;
-
- case TC_BIG_FIXNUM:
- case TC_CHARACTER_STRING:
- case TC_COMBINATION:
- case TC_CONTROL_POINT:
- case TC_NON_MARKED_VECTOR:
- case TC_PCOMB3:
- case TC_RECORD:
- case TC_VECTOR:
- case TC_VECTOR_16B:
- case TC_VECTOR_1B:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- PUSH_FIXUP_DATA (old_start);
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- }
- break;
-
- case TC_BIG_FLONUM:
- case TC_COMPILED_CODE_BLOCK:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- PUSH_FIXUP_DATA (old_start);
- BCH_ALIGN_FLOAT (new_address, free);
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- }
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- scan += (1 + (OBJECT_DATUM (object)));
- MAYBE_DUMP_SCAN (scan);
- break;
-
- case TC_REFERENCE_TRAP:
- if ((OBJECT_DATUM (object)) > TRAP_MAX_IMMEDIATE)
- goto transport_pair;
- /* Otherwise it's a non-pointer. */
- scan += 1;
- break;
-
- case TC_COMPILED_ENTRY:
- compiled_code_present_p = true;
- {
- SCHEME_OBJECT * old_start;
- Get_Compiled_Block (old_start, (OBJECT_ADDRESS (object)));
- if (BROKEN_HEART_P (*old_start))
- (*scan++)
- = (RELOCATE_COMPILED (object,
- (OBJECT_ADDRESS (*old_start)),
- old_start));
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- PUSH_FIXUP_DATA (old_start);
- BCH_ALIGN_FLOAT (new_address, free);
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++)
- = (RELOCATE_COMPILED (object, new_address, old_start));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- }
- break;
-
- case TC_LINKAGE_SECTION:
- switch (READ_LINKAGE_KIND (object))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- /* `count' typeless pointers to hunk3s follow. */
- unsigned long count = (READ_CACHE_LINKAGE_COUNT (object));
- scan += 1;
- while (count > 0)
- {
- SCHEME_OBJECT * old_start;
- MAYBE_DUMP_SCAN (scan);
- old_start = (SCHEME_ADDR_TO_ADDR (*scan));
- if (BROKEN_HEART_P (*old_start))
- (*scan++)
- = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (*old_start)));
- else
- {
- PUSH_FIXUP_DATA (old_start);
- (*free++) = (old_start[0]);
- (*free++) = (old_start[1]);
- (*free++) = (old_start[2]);
- MAYBE_DUMP_FREE (free);
- (*scan++) = (ADDR_TO_SCHEME_ADDR (new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 3;
- }
- count -= 1;
- }
- }
- break;
-
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- {
- unsigned long count = (READ_OPERATOR_LINKAGE_COUNT (object));
- char * entry = (FIRST_OPERATOR_LINKAGE_ENTRY (scan));
- long delta;
-
- if (count > 0)
- compiled_code_present_p = true;
-
- {
- int extend_p = (entry >= ((char *) scan_buffer_top));
- long delta1 = (((char *) scan) - entry);
- if (extend_p)
- extend_scan_buffer (entry, free);
- BCH_START_OPERATOR_RELOCATION (scan);
- if (extend_p)
- {
- entry = (end_scan_buffer_extension (entry));
- scan = ((SCHEME_OBJECT *) (entry + delta1));
- }
- }
-
- /* END_OPERATOR_LINKAGE_AREA assumes that we will add
- one to the result, so do that now. */
- delta
- = (((END_OPERATOR_LINKAGE_AREA (scan, count)) + 1)
- - scan_buffer_top);
-
- /* The operator entries are copied sequentially, but
- extra hair is required because the entry addresses
- are encoded. */
- while (count > 0)
- {
- char * next_entry = (NEXT_LINKAGE_OPERATOR_ENTRY (entry));
- int extend_p = (next_entry >= ((char *) scan_buffer_top));
- SCHEME_OBJECT esaddr;
- SCHEME_OBJECT * old_start;
-
- /* Guarantee that the scan buffer is large enough
- to hold the entry. */
- if (extend_p)
- extend_scan_buffer (next_entry, free);
-
- /* Get the entry address. */
- BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS (esaddr, entry);
-
- /* Get the code-block pointer for this entry. */
- Get_Compiled_Block
- (old_start, (SCHEME_ADDR_TO_ADDR (esaddr)));
-
- /* Copy the block. */
- if (BROKEN_HEART_P (*old_start))
- {
- BCH_STORE_OPERATOR_LINKAGE_ADDRESS
- ((RELOCATE_COMPILED_RAW_ADDRESS
- (esaddr,
- (OBJECT_ADDRESS (*old_start)),
- old_start)),
- entry);
- }
- else
- {
- unsigned long n_words
- = (1 + (OBJECT_DATUM (*old_start)));
- PUSH_FIXUP_DATA (old_start);
- BCH_ALIGN_FLOAT (new_address, free);
- TRANSPORT_VECTOR
- (new_address, free, old_start, n_words);
- BCH_STORE_OPERATOR_LINKAGE_ADDRESS
- ((RELOCATE_COMPILED_RAW_ADDRESS
- (esaddr, new_address, old_start)),
- entry);
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
-
- if (extend_p)
- {
- entry = (end_scan_buffer_extension (next_entry));
- delta -= gc_buffer_size;
- }
- else
- entry = next_entry;
-
- count -= 1;
- }
- scan = (scan_buffer_top + delta);
- MAYBE_DUMP_SCAN (scan);
- BCH_END_OPERATOR_RELOCATION (scan);
- }
- break;
-
- case CLOSURE_PATTERN_LINKAGE_KIND:
- scan += (1 + (READ_CACHE_LINKAGE_COUNT (object)));
- MAYBE_DUMP_SCAN (scan);
- break;
-
- default:
- gc_death (TERM_EXIT, "dump_loop: Unknown compiler linkage kind.",
- scan, free);
- /*NOTREACHED*/
- scan += 1;
- break;
- }
- break;
-
- case TC_MANIFEST_CLOSURE:
- {
- unsigned long count;
- char * entry;
- char * closure_end;
-
- {
- unsigned long delta = (2 * (sizeof (format_word)));
- char * count_end = (((char *) (scan + 1)) + delta);
- int extend_p = (count_end >= ((char *) scan_buffer_top));
-
- /* Guarantee that the scan buffer is large enough to
- hold the count field. */
- if (extend_p)
- extend_scan_buffer (count_end, free);
-
- BCH_START_CLOSURE_RELOCATION (scan);
- count = (MANIFEST_CLOSURE_COUNT (scan + 1));
- entry = (FIRST_MANIFEST_CLOSURE_ENTRY (scan + 1));
-
- if (extend_p)
- {
- long dw = (entry - count_end);
- count_end = (end_scan_buffer_extension (count_end));
- entry = (count_end + dw);
- }
- scan = ((SCHEME_OBJECT *) (count_end - delta));
- }
-
- if (count > 0)
- compiled_code_present_p = true;
-
- closure_end = ((char *) (MANIFEST_CLOSURE_END (scan, count)));
-
- /* The closures are copied sequentially, but extra hair is
- required because the code-entry pointers are encoded as
- machine instructions. */
- while (count > 0)
- {
- char * entry_end = (CLOSURE_ENTRY_END (entry));
- int extend_p = (entry_end >= ((char *) scan_buffer_top));
- SCHEME_OBJECT esaddr;
- SCHEME_OBJECT * old_start;
- long delta1 = (entry - entry_end);
- long delta2 = (closure_end - entry_end);
-
- /* If the closure overflows the scan buffer, extend
- the buffer to the end of the closure. */
- if (extend_p)
- extend_scan_buffer (entry_end, free);
-
- /* Extract the code-entry pointer and convert it to a
- C pointer. */
- BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS (esaddr, entry);
- Get_Compiled_Block (old_start, (SCHEME_ADDR_TO_ADDR (esaddr)));
-
- /* Copy the code entry. Use machine-specific macro to
- update the pointer. */
- if (BROKEN_HEART_P (*old_start))
- BCH_STORE_CLOSURE_ENTRY_ADDRESS
- ((RELOCATE_COMPILED_RAW_ADDRESS
- (esaddr, (OBJECT_ADDRESS (*old_start)), old_start)),
- entry);
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- PUSH_FIXUP_DATA (old_start);
- BCH_ALIGN_FLOAT (new_address, free);
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- BCH_STORE_CLOSURE_ENTRY_ADDRESS
- ((RELOCATE_COMPILED_RAW_ADDRESS
- (esaddr, new_address, old_start)),
- entry);
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
-
- if (extend_p)
- {
- entry_end = (end_scan_buffer_extension (entry_end));
- entry = (entry_end + delta1);
- closure_end = (entry_end + delta2);
- }
-
- entry = (NEXT_MANIFEST_CLOSURE_ENTRY (entry));
- count -= 1;
- }
- scan = ((SCHEME_OBJECT *) closure_end);
- MAYBE_DUMP_SCAN (scan);
- BCH_END_CLOSURE_RELOCATION (scan);
- }
- break;
-
- case TC_ENVIRONMENT:
- /* Make fasdump fail */
- return (ERR_FASDUMP_ENVIRONMENT);
-
- case TC_FUTURE:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else if (Future_Spliceable (object))
- (*scan) = (Future_Value (object));
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- PUSH_FIXUP_DATA (old_start);
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- }
- break;
-
- default:
- GC_BAD_TYPE ("dump_loop", object);
- scan += 1;
- break;
- }
- }
-
- end_dump_loop:
- (*free_ptr) = free;
- (*new_address_ptr) = new_address;
- return (PRIM_DONE);
-}
+++ /dev/null
-/* -*- C -*-
-
-$Id: bchdrn.c,v 1.14 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Drone program for overlapped I/O in bchscheme. */
-
-#include "ux.h"
-#include "bchdrn.h"
-#if 0
-/* ux.h includes <setjmp.h> indirectly */
-# include <setjmp.h>
-#endif
-
-#define DEBUG
-/* #define DEBUG_1 */
-/* #define DEBUG_2 */
-
-extern char * EXFUN (error_name, (int));
-extern int EXFUN (retrying_file_operation,
- (ssize_t EXFUN ((*), (int, char *, int)),
- int, char *, long, long, char *, char *, long *,
- int EXFUN ((*), (char *, char *))));
-\f
-#ifdef USE_SYSV_SHARED_MEMORY
-
-static struct
-{
- char * program_name;
- char * file_name; /* gc file name */
- int shmid; /* shared memory descriptor */
- int tdron; /* total number of drones */
- int nbuf; /* total number of buffers */
- long bufsiz; /* size of each buffer in bytes */
- int sdron; /* index of first drone to start */
- int ndron; /* number of drones to start */
- int keep_p; /* keep the gc file if Scheme dies? */
-} arguments;
-
-struct argdesc
-{
- char * name;
- char * format;
- PTR location;
-};
-
-static char string_a[] = "%s";
-#define STRING_FMT &string_a[0]
-
-static char decimal_int_a[] = "%d";
-#define DECIMAL_INT_FMT &decimal_int_a[0]
-
-static char decimal_long_a[] = "%ld";
-#define DECIMAL_LONG_FMT &decimal_long_a[0]
-
-static struct argdesc command_line[] =
-{
- { "program_name", STRING_FMT, &arguments.program_name },
- { "file_name", STRING_FMT, &arguments.file_name },
- { "shmid", DECIMAL_INT_FMT, &arguments.shmid },
- { "tdron", DECIMAL_INT_FMT, &arguments.tdron },
- { "nbuf", DECIMAL_INT_FMT, &arguments.nbuf },
- { "bufsiz", DECIMAL_LONG_FMT, &arguments.bufsiz },
- { "sdron", DECIMAL_INT_FMT, &arguments.sdron },
- { "ndron", DECIMAL_INT_FMT, &arguments.ndron },
- { "keep_gc_file", DECIMAL_INT_FMT, &arguments.keep_p }
-};
-
-static int gc_fid = -1;
-static char * shared_memory;
-static struct buffer_info * gc_buffers;
-static struct drone_info * myself;
-static unsigned long * drone_version, * wait_mask;
-static jmp_buf abort_point;
-static pid_t boss_pid;
-\f
-static void EXFUN (kill_program, (int sig));
-
-static void
-DEFUN (posix_signal, (signum, handler),
- int signum AND void EXFUN ((*handler), ()))
-{
- struct sigaction new;
-
- new.sa_handler = handler;
- UX_sigemptyset (&new.sa_mask);
- UX_sigaddset ((&new.sa_mask), SIGCONT);
- UX_sigaddset ((&new.sa_mask), SIGQUIT);
- new.sa_flags = SA_NOCLDSTOP;
-
- if ((UX_sigaction (signum, &new, 0)) == -1)
- {
- fprintf (stderr, "%s (%d, posix_signal): sigaction failed. errno = %s.\n",
- arguments.program_name, myself->index, (error_name (errno)));
- fflush (stderr);
- kill_program (0);
- /*NOTREACHED*/
- }
- return;
-}
-
-static void
-DEFUN (kill_program, (sig), int sig)
-{
- myself->state = drone_dead;
- if (gc_fid != -1)
- close (gc_fid);
- shmdt (shared_memory);
- if (sig == -1)
- {
- shmctl (arguments.shmid, IPC_RMID, ((struct shmid_ds *) 0));
- if (!arguments.keep_p)
- unlink (arguments.file_name);
- }
- exit (0);
- /*NOTREACHED*/
-}
-
-static void
-DEFUN (abort_operation, (sig), int sig)
-{
- RE_INSTALL_HANDLER (SIGQUIT, abort_operation);
- myself->state = drone_aborting;
- longjmp (abort_point, 1);
- /*NOTREACHED*/
-}
-
-static void
-DEFUN (continue_running, (sig), int sig)
-{
- RE_INSTALL_HANDLER (SIGCONT, continue_running);
- longjmp (abort_point, 1);
- /*NOTREACHED*/
-}
-
-static int
-DEFUN (always_one, (operation_name, noise),
- char * operation_name AND char * noise)
-{
- return (1);
-}
-\f
-static void
-DEFUN (process_requests, (drone), struct drone_info * drone)
-{
- sigset_t non_blocking_signal_mask, blocking_signal_mask;
- int result, count, buffer_index, flags;
- long current_position = -1;
- struct timeval timeout;
- struct stat file_info;
- unsigned long read_mask, my_mask;
-
- myself = drone;
- my_mask = (((unsigned long) 1) << drone->index);
- drone->DRONE_PID = (getpid ());
- gc_fid = (open (arguments.file_name, O_RDWR, 0644));
- if (gc_fid == -1)
- {
- fprintf (stderr,
- "%s (%d, process_requests): open failed. errno = %s.\n",
- arguments.program_name, drone->index, (error_name (errno)));
- fflush (stderr);
- if (drone->DRONE_PPID == boss_pid)
- (void) (kill (boss_pid, SIGCONT));
- kill_program (0);
- /*NOTREACHED*/
- }
-#ifdef DEBUG_1
- printf ("%s (%d, process_requests): Starting (pid = %d, ppid = %d).\n",
- arguments.program_name, drone->index,
- drone->DRONE_PID, drone->DRONE_PPID);
- fflush (stdout);
-#endif
- if ((result = (fstat (gc_fid, &file_info))) == -1)
- {
- fprintf (stderr,
- "%s (%d, process_requests): fstat failed. errno = %s.\n",
- arguments.program_name, drone->index, (error_name (errno)));
- fflush (stderr);
- }
- /* Force O_SYNC only if we are dealing with a raw device. */
-
- if ((result == -1) || ((file_info.st_mode & S_IFMT) == S_IFCHR))
- {
- if ((flags = (fcntl (gc_fid, F_GETFL, 0))) == -1)
- {
- fprintf
- (stderr,
- "%s (%d, process_requests): fcntl (F_GETFL) failed. errno = %s.\n",
- arguments.program_name, drone->index, (error_name (errno)));
- fflush (stderr);
- }
- else
- {
- flags |= O_SYNC;
- if ((fcntl (gc_fid, F_SETFL, flags)) == -1)
- {
- fprintf
- (stderr,
- "%s (%d, process_requests): fcntl (F_SETFL) failed. errno = %s.\n",
- arguments.program_name, drone->index, (error_name (errno)));
- fflush (stderr);
- }
- }
- }
-\f
- UX_sigemptyset (&non_blocking_signal_mask);
- UX_sigemptyset (&blocking_signal_mask);
- UX_sigaddset ((&blocking_signal_mask), SIGCONT);
- UX_sigaddset ((&blocking_signal_mask), SIGQUIT);
- UX_sigprocmask (SIG_SETMASK, (&blocking_signal_mask), 0);
- posix_signal (SIGQUIT, abort_operation);
- posix_signal (SIGCONT, continue_running);
-
- if ((setjmp (abort_point)) == 0)
- {
- count = drone->index;
- drone->state = drone_idle;
- if (drone->DRONE_PPID == boss_pid)
- (void) (kill (boss_pid, SIGCONT));
- }
- else
- goto redo_dispatch;
-
- for (; 1; count++)
- {
- timeout.tv_sec = 6;
- timeout.tv_usec = 0;
-
- UX_sigprocmask (SIG_SETMASK, (&non_blocking_signal_mask), 0);
- result = (select (0, 0, 0, 0, &timeout));
- UX_sigprocmask (SIG_SETMASK, (&blocking_signal_mask), 0);
-
- if ((drone->state != drone_idle)
- || ((result == -1) && (errno == EINTR)))
- {
- if (result != -1)
- {
- fprintf (stderr,
- "\n%s (%d, process_requests): request after timeout %d.\n",
- arguments.program_name, drone->index, drone->state);
- fflush (stderr);
- }
-redo_dispatch:
- switch (drone->state)
- {
- default:
- fprintf (stderr,
- "\n%s (%d, process_requests): Unknown/bad operation %d.\n",
- arguments.program_name, drone->index, drone->state);
- fflush (stderr);
- kill_program (0);
- /*NOTREACHED*/
-
- case drone_idle:
- break;
-
- case drone_aborting:
-#ifdef DEBUG_1
- printf ("\n%s (%d, process_requests): Aborting.",
- arguments.program_name, drone->index);
- fflush (stdout);
-#endif
- drone->buffer_index = -1;
- current_position = -1;
- break;
-\f
- case drone_reading:
- case drone_writing:
- {
- /* Can't use buffer->bottom because the shared memory may be
- attached at a different address!
- */
-
- int saved_errno;
- enum drone_state operation;
- char * operation_name, * buffer_address;
- struct buffer_info * buffer;
- struct gc_queue_entry * entry;
-
- operation = drone->state;
- buffer_index = (drone->buffer_index);
- buffer = (gc_buffers + buffer_index);
-
- entry = ((struct gc_queue_entry *)
- (((char *) drone) + (drone->entry_offset)));
- entry->error_code = 0;
-
- operation_name = ((operation == drone_reading) ? "read" : "write");
- buffer_address = (shared_memory + (arguments.bufsiz * buffer_index));
-#ifdef DEBUG_1
- printf ("\n%s (%d, process_requests %s): Buffer index = %d.\n",
- arguments.program_name, drone->index, operation_name,
- buffer_index);
- printf ("\tBuffer address = 0x%lx; Position = 0x%lx; Size = 0x%lx.",
- buffer_address, buffer->position, buffer->size);
- fflush (stdout);
-#endif
-
- UX_sigprocmask (SIG_SETMASK, (&non_blocking_signal_mask), 0);
- result = (retrying_file_operation
- (((operation == drone_reading) ? read : write),
- gc_fid, buffer_address,
- buffer->position, buffer->size, operation_name, NULL,
- ¤t_position, always_one));
- saved_errno = errno;
- UX_sigprocmask (SIG_SETMASK, (&blocking_signal_mask), 0);
-
- if (result == -1)
- {
- buffer->state = ((operation == drone_reading)
- ? buffer_read_error
- : buffer_write_error);
- drone->buffer_index = -1;
- entry->drone_index = -1;
- entry->error_code = saved_errno;
- entry->state = entry_error;
- current_position = -1;
-#ifdef DEBUG
- printf ("\n%s (%d, process_requests): %s error (errno = %s).\n",
- arguments.program_name, drone->index, operation_name,
- (error_name (saved_errno)));
- fflush (stdout);
-#endif
- }
-\f
- else
- {
- buffer->state = ((operation == drone_reading)
- ? buffer_ready
- : buffer_idle);
- drone->buffer_index = -1;
- entry->drone_index = -1;
- if (operation == drone_writing)
- {
- entry->retry_count = 0;
- entry->state = entry_idle;
- }
-
-#ifdef DEBUG_1
- printf ("\n%s (%d, process_requests %s): Done.",
- arguments.program_name, drone->index, operation_name);
- fflush (stdout);
-#endif
- }
- }
- }
-
- count = 0;
- drone->state = drone_idle;
- read_mask = (* wait_mask);
- if ((read_mask & my_mask) == my_mask)
- (void) (kill (boss_pid, SIGCONT));
- }
- else if (result == 0)
- {
- if (count == arguments.tdron)
- {
- count = 0;
- if ((kill (boss_pid, 0)) == -1)
- kill_program (-1);
- }
- read_mask = (* wait_mask);
- if ((read_mask & my_mask) == my_mask)
- {
- fprintf (stderr,
- "\n%s (%d, process_requests): signal deadlock (%s)!\n",
- arguments.program_name, drone->index,
- ((read_mask == ((unsigned long) -1)) ? "any" : "me"));
- fflush (stderr);
- drone->state = drone_idle; /* !! */
- (void) (kill (boss_pid, SIGCONT));
- }
- }
- }
-}
-
-static void
-DEFUN_VOID (start_drones)
-{
- pid_t my_pid;
- int counter, cpid;
- struct drone_info *gc_drones, *drone;
-
- my_pid = (getpid ());
-\f
- shared_memory = (shmat (arguments.shmid, ((char *) 0), 0));
- if (shared_memory == ((char *) -1))
- {
- fprintf (stderr,
- "\
-%s (start_drones): Unable to attach shared memory segment %d (errno = %s).\n",
- arguments.program_name, arguments.shmid, (error_name (errno)));
- fflush (stderr);
- sleep (10);
- kill (boss_pid, SIGCONT);
- exit (1);
- }
-#ifdef DEBUG_1
- printf ("%s (start_drones): Attached shared memory at address = 0x%lx.\n",
- arguments.program_name, ((long) shared_memory));
- fflush (stdout);
-#endif
- posix_signal (SIGINT, SIG_IGN);
- posix_signal (SIGQUIT, SIG_IGN);
- posix_signal (SIGHUP, kill_program);
- posix_signal (SIGTERM, kill_program);
-
- gc_buffers = ((struct buffer_info *)
- (shared_memory + (arguments.nbuf * arguments.bufsiz)));
- gc_drones = ((struct drone_info *) (gc_buffers + arguments.nbuf));
- drone_version = ((unsigned long *) (gc_drones + arguments.tdron));
- wait_mask = (drone_version + 1);
- if ((* drone_version) != ((unsigned long) DRONE_VERSION_NUMBER))
- {
- fprintf (stderr,
- "%s (start_drones): stored drone version != drone version.\n",
- arguments.program_name);
- fprintf (stderr, "\t*drone_version = %ld; DRONE_VERSION_NUMBER = %ld.\n",
- (* drone_version), ((unsigned long) DRONE_VERSION_NUMBER));
- fflush (stderr);
- kill (boss_pid, SIGCONT);
- exit (1);
- }
-
- for (counter = 1, drone = (gc_drones + (arguments.sdron + 1));
- counter < arguments.ndron;
- counter++, drone ++)
- {
- if ((cpid = (fork ())) == 0)
- {
- drone->DRONE_PPID = my_pid;
- process_requests (drone);
- /*NOTREACHED*/
- }
- else if (cpid == -1)
- {
- fprintf (stderr,
- "%s (start_drones): fork failed; errno = %s.\n",
- arguments.program_name, (error_name (errno)));
- fflush (stderr);
- }
- }
- drone = (gc_drones + arguments.sdron);
- drone->DRONE_PPID = boss_pid;
- /* This is non-portable behavior to prevent zombies from being created. */
- if (arguments.ndron != 1)
- posix_signal (SIGCHLD, SIG_IGN);
- process_requests (drone);
- /*NOTREACHED*/
-}
-\f
-int
-DEFUN (main, (argc, argv), int argc AND char ** argv)
-{
- int count, nargs;
- static char err_buf[1024];
-#if defined(DEBUG) || defined(DEBUG_1) || defined(DEBUG_2)
- static char out_buf[1024];
-
- setvbuf (stdout, &out_buf[0], _IOFBF, (sizeof (out_buf)));
-#endif
- setvbuf (stderr, &err_buf[0], _IOFBF, (sizeof (err_buf)));
-
-#ifdef DEBUG_2
- printf ("%s (main): Arguments =\n", argv[0]);
- for (count = 1; count < argc; count++)
- printf ("\t%s\n", argv[count]);
- fflush (stdout);
-#endif
-
- nargs = ((sizeof (command_line)) / (sizeof (struct argdesc)));
- boss_pid = (getppid ());
- if (argc != nargs)
- {
- fprintf (stderr,
- "%s (main): Wrong number of arguments (got %d, expected %d).\n",
- argv[0], (argc - 1), (nargs - 1));
- fflush (stderr);
- kill (boss_pid, SIGCONT);
- exit (1);
- }
- for (count = 0; count < nargs; count++)
- {
- if (command_line[count].format == STRING_FMT)
- (* ((char **) command_line[count].location)) = argv[count];
- else
- sscanf (argv[count],
- command_line[count].format,
- command_line[count].location);
- }
-
-#ifdef DEBUG_2
- printf ("%s (main): Parsed arguments =\n", argv[0]);
- for (count = 0; count < nargs; count++)
- {
- if (command_line[count].format == STRING_FMT)
- printf ("\t%s\t= %s\n",
- command_line[count].name,
- (* ((char **) (command_line[count].location))));
- else
- printf ("\t%s\t= %d\n",
- command_line[count].name,
- (* ((int *) (command_line[count].location))));
- }
- fflush (stdout);
-#endif
-
- start_drones ();
- /*NOTREACHED*/
- return (0);
-}
-
-#define MAIN main
-
-#endif /* USE_SYSV_SHARED_MEMORY */
-\f
-#ifndef MAIN
-
-int
-DEFUN (main, (argc, argv), int argc AND char ** argv)
-{
- fprintf (stderr, "%s: Not implemented.\n", (argv[0]));
- fflush (stderr);
- exit (1);
- return (1);
-}
-
-#endif /* MAIN */
+++ /dev/null
-/* -*-C-*-
-
-$Id: bchdrn.h,v 1.14 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Header file for overlapped I/O in bchscheme. */
-
-#ifndef _BCHDRN_H_INCLUDED
-#define _BCHDRN_H_INCLUDED
-
-#include "config.h"
-#include <errno.h>
-#include <signal.h>
-
-#ifdef HAVE_UNISTD_H
-# include <unistd.h>
-#else
-# ifdef __unix__
- extern ssize_t EXFUN (read, (int, PTR, size_t));
- extern ssize_t EXFUN (write, (int, PTR, size_t));
-# endif
-#endif
-
-#ifdef HAVE_POSIX_SIGNALS
-# define RE_INSTALL_HANDLER(signum,handler) do { } while (0)
-#else
-# define RE_INSTALL_HANDLER(signum,handler) signal (signum, handler)
-#endif
-
-/* Doesn't work on GNU/Linux or on FreeBSD. Disable until we can
- figure out what is going on. */
-#define AVOID_SYSV_SHARED_MEMORY
-
-#if !defined(AVOID_SYSV_SHARED_MEMORY) && defined(HAVE_SHMAT)
-# define USE_SYSV_SHARED_MEMORY
-#endif
-\f
-#if defined(__HPUX__)
-
-# define HAVE_PREALLOC
-
-# include <magic.h>
-# if defined(SHL_MAGIC)
-# define hpux8 1
-# endif
-
-/* Page tables can have no gaps in HP-UX < 8.0, leave a gap for malloc. */
-
-# if defined(hp9000s300) || defined(__hp9000s300)
-# ifdef hpux8
-# define ATTACH_POINT 0x60000000
-# else /* not hpux8 */
-# define MALLOC_SPACE (2 << 20) /* 2 Meg */
-# endif /* hpux8 */
-# endif /* hp9000s300 */
-
-#endif /* __HPUX__ */
-
-#ifdef USE_SYSV_SHARED_MEMORY
-
-#define DRONE_VERSION_NUMBER ((1 << 8) | 2)
-
-#include <sys/time.h>
-#include <sys/ipc.h>
-#include <sys/shm.h>
-#include <sys/signal.h>
-#include <sys/types.h>
-#include <sys/wait.h>
-
-#ifndef MALLOC_SPACE
-# define MALLOC_SPACE 0
-#endif
-
-#ifndef ATTACH_POINT
-# define ATTACH_POINT 0
-#endif
-
-#define DRONE_EXTRA_T
-
-struct drone_extra_s
-{
- pid_t my_pid;
- pid_t my_ppid;
-};
-
-typedef struct drone_extra_s drone_extra_t;
-
-#define DRONE_PID drone_extra.my_pid
-#define DRONE_PPID drone_extra.my_ppid
-
-#endif /* USE_SYSV_SHARED_MEMORY */
-\f
-/* Shared definitions for all versions */
-
-enum buffer_state
-{
- buffer_idle, /* 0 */
- buffer_busy, /* 1, used for scan or free */
- buffer_ready, /* 2, after being read */
- buffer_queued, /* 3, never written, use as if read */
- buffer_being_read, /* 4 */
- buffer_read_error, /* 5 */
- buffer_being_written, /* 6 */
- buffer_write_error /* 7 */
-};
-
-struct buffer_info
-{
- int index;
- enum buffer_state state;
- long position;
- long size;
- PTR bottom;
- PTR top;
- PTR end;
-};
-
-enum drone_state
-{
- drone_dead, /* 0 */
- drone_not_ready, /* 1 */
- drone_idle, /* 2 */
- drone_reading, /* 3 */
- drone_writing, /* 4 */
- drone_aborting /* 5 */
-};
-
-struct drone_info
-{
- int index;
-#ifdef DRONE_EXTRA_T
- drone_extra_t drone_extra;
-#endif
- enum drone_state state;
- int buffer_index;
- long entry_offset;
-};
-
-enum queue_entry_state
-{
- entry_idle, /* 0 */
- entry_busy, /* 1 */
- entry_error /* 2 */
-};
-
-struct gc_queue_entry
-{
- int index;
- enum queue_entry_state state;
- struct buffer_info * buffer;
- int drone_index;
- int error_code;
- int retry_count;
-};
-
-#endif /* _BCHDRN_H_INCLUDED */
+++ /dev/null
-/* -*-C-*-
-
-$Id: bchgcc.h,v 9.67 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_BCHGCC_H
-#define SCM_BCHGCC_H
-
-#include "config.h"
-#include "gccode.h"
-
-#ifdef HAVE_SYS_FILE_H
-# include <sys/file.h>
-#endif
-#ifdef HAVE_FCNTL_H
-# include <fcntl.h>
-#endif
-
-#ifdef __WIN32__
-# define IO_PAGE_SIZE 4096
-#endif
-#ifdef __OS2__
-# define IO_PAGE_SIZE 4096
-#endif
-#ifndef IO_PAGE_SIZE
-# include <sys/param.h>
-#endif
-\f
-#ifndef BCH_START_CLOSURE_RELOCATION
-# define BCH_START_CLOSURE_RELOCATION(scan) do { } while (0)
-#endif
-
-#ifndef BCH_END_CLOSURE_RELOCATION
-# define BCH_END_CLOSURE_RELOCATION(scan) do { } while (0)
-#endif
-
-#ifndef BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS
-# define BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS EXTRACT_CLOSURE_ENTRY_ADDRESS
-#endif
-
-#ifndef BCH_STORE_CLOSURE_ENTRY_ADDRESS
-# define BCH_STORE_CLOSURE_ENTRY_ADDRESS STORE_CLOSURE_ENTRY_ADDRESS
-#endif
-
-
-#ifndef BCH_START_OPERATOR_RELOCATION
-# define BCH_START_OPERATOR_RELOCATION(scan) do { } while (0)
-#endif
-
-#ifndef BCH_END_OPERATOR_RELOCATION
-# define BCH_END_OPERATOR_RELOCATION(scan) do { } while (0)
-#endif
-
-#ifndef BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS
-# define BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS EXTRACT_OPERATOR_LINKAGE_ADDRESS
-#endif
-
-#ifndef BCH_STORE_OPERATOR_LINKAGE_ADDRESS
-# define BCH_STORE_OPERATOR_LINKAGE_ADDRESS STORE_OPERATOR_LINKAGE_ADDRESS
-#endif
-
-extern char * EXFUN (error_name, (int));
-
-typedef ssize_t EXFUN (file_operation_t, (int, char *, int));
-
-extern int EXFUN (retrying_file_operation,
- (file_operation_t *,
- int, char *, long, long, char *, char *, long *,
- int EXFUN ((*), (char *, char *))));
-
-extern int EXFUN (io_error_retry_p, (char *, char *));
-extern int EXFUN (io_error_always_abort, (char *, char *));
-
-extern char * EXFUN (make_gc_file_name, (CONST char *));
-extern int EXFUN (allocate_gc_file, (char *));
-extern void EXFUN (protect_gc_file_name, (CONST char *));
-
-struct saved_scan_state
-{
- SCHEME_OBJECT * virtual_scan_pointer;
- unsigned long scan_position;
- unsigned long scan_offset;
-};
-
-extern void EXFUN
- (save_scan_state, (struct saved_scan_state * state, SCHEME_OBJECT * scan));
-extern SCHEME_OBJECT * EXFUN
- (restore_scan_state, (struct saved_scan_state * state));
-extern void EXFUN
- (set_fixed_scan_area, (SCHEME_OBJECT * bottom, SCHEME_OBJECT * top));
-\f
-#ifndef O_BINARY
-# define O_BINARY 0
-#endif
-
-#define GC_FILE_FLAGS (O_RDWR | O_CREAT | O_BINARY) /* O_SYNCIO removed */
-#define GC_FILE_MASK 0644 /* Everyone reads, owner writes */
-
-/* IO_PAGE_SIZE must be a power of 2! */
-
-#ifndef IO_PAGE_SIZE
-# ifdef DEV_BSIZE
-# define IO_PAGE_SIZE DEV_BSIZE
-# else
-# define IO_PAGE_SIZE 8192
-# endif
-#endif
-
-#define ALIGN_DOWN_TO_IO_PAGE(addr) \
- (((unsigned long) (addr)) & (~(IO_PAGE_SIZE - 1)))
-
-#define ALIGN_UP_TO_IO_PAGE(addr) \
- (ALIGN_DOWN_TO_IO_PAGE (((unsigned long) (addr)) + (IO_PAGE_SIZE - 1)))
-
-#define ALIGNED_TO_IO_PAGE_P(addr) \
- (((unsigned long) (addr)) == (ALIGN_DOWN_TO_IO_PAGE (addr)))
-
-extern long
- gc_file_end_position,
- gc_file_current_position,
- gc_file_start_position;
-
-extern unsigned long
- gc_buffer_size,
- gc_buffer_bytes,
- gc_buffer_shift,
- gc_buffer_mask,
- gc_buffer_byte_shift;
-
-extern char
- gc_death_message_buffer[];
-
-extern SCHEME_OBJECT
- * scan_buffer_top,
- * scan_buffer_bottom,
- * free_buffer_top,
- * free_buffer_bottom,
- * weak_pair_stack_ptr,
- * weak_pair_stack_limit,
- * virtual_scan_pointer;
-\f
-typedef enum { NORMAL_GC, PURE_COPY, CONSTANT_COPY } gc_mode_t;
-
-extern SCHEME_OBJECT * EXFUN
- (gc_loop, (SCHEME_OBJECT *, SCHEME_OBJECT **, SCHEME_OBJECT **,
- SCHEME_OBJECT *, gc_mode_t, int));
-
-extern SCHEME_OBJECT
- * EXFUN (dump_and_reload_scan_buffer, (SCHEME_OBJECT *, Boolean *)),
- * EXFUN (dump_and_reset_free_buffer, (SCHEME_OBJECT *, Boolean *)),
- * EXFUN (dump_free_directly, (SCHEME_OBJECT *, long, Boolean *)),
- * EXFUN (initialize_free_buffer, (void)),
- * EXFUN (initialize_scan_buffer, (SCHEME_OBJECT *)),
- EXFUN (read_newspace_address, (SCHEME_OBJECT *));
-
-extern void
- EXFUN (GC, (int)),
- EXFUN (end_transport, (Boolean *)),
- EXFUN (final_reload, (SCHEME_OBJECT *, unsigned long, char *)),
- EXFUN (extend_scan_buffer, (char *, SCHEME_OBJECT *)),
- EXFUN (gc_death, (long, char *, SCHEME_OBJECT *, SCHEME_OBJECT *)),
- EXFUN (restore_gc_file, (void)),
- EXFUN (initialize_weak_pair_transport, (SCHEME_OBJECT *)),
- EXFUN (fix_weak_chain_1, (SCHEME_OBJECT *)),
- EXFUN (fix_weak_chain_2, (void)),
- EXFUN (GC_end_root_relocation, (SCHEME_OBJECT *, SCHEME_OBJECT *));
-
-extern long
- EXFUN (GC_relocate_root, (SCHEME_OBJECT **));
-
-extern char
- * EXFUN (end_scan_buffer_extension, (char *));
-
-extern int
- EXFUN (swap_gc_file, (int));
-
-extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *));
-extern void EXFUN (reset_allocator_parameters, (void));
-\f
-/* Some utility macros */
-
-/* These work even when scan/addr point to constant space
- because initialize_free_buffer (in bchmmg.c) cleverly initializes
- scan_buffer_bottom, scan_buffer_top, and virtual_scan_pointer
- so that the operations below do the right thing.
-
- These depend on (scan) and (addr) always pointing past the current
- Scan pointer!
- */
-
-#define SCAN_POINTER_TO_NEWSPACE_ADDRESS(scan) \
- (((char *) virtual_scan_pointer) \
- + (((char *) (scan)) - ((char *) scan_buffer_bottom)))
-
-#define READ_NEWSPACE_ADDRESS(loc, addr) do \
-{ \
- SCHEME_OBJECT * _addr, * _scaddr; \
- \
- _addr = (addr); \
- _scaddr = (scan_buffer_bottom + ((_addr) - virtual_scan_pointer)); \
- \
- if ((_scaddr >= scan_buffer_bottom) && (_scaddr < scan_buffer_top)) \
- (loc) = (* _scaddr); \
- else if ((_addr >= Constant_Space) && (_addr < Free_Constant)) \
- (loc) = (* _addr); \
- else \
- (loc) = (read_newspace_address (_addr)); \
-} while (0)
-
-#ifdef FLOATING_ALIGNMENT
-
-#define BCH_ALIGN_FLOAT(address, pointer) \
-{ \
- while (!FLOATING_ALIGNED_P (address)) \
- { \
- (address) += 1; \
- (* ((pointer)++)) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); \
- } \
-}
-
-#define BCH_ALIGN_FLOAT_ADDRESS(address) \
-{ \
- while (!FLOATING_ALIGNED_P (address)) \
- (address) += 1; \
-}
-
-#else
-#define BCH_ALIGN_FLOAT(address, pointer)
-#define BCH_ALIGN_FLOAT_ADDRESS(address)
-#endif
-
-#endif /* SCM_BCHGCC_H */
+++ /dev/null
-/* -*-C-*-
-
-$Id: bchgcl.c,v 9.58 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This is the main GC loop for bchscheme. */
-
-#include "scheme.h"
-#include "bchgcc.h"
-\f
-#define MAYBE_DUMP_FREE(free) \
-{ \
- if (free >= free_buffer_top) \
- DUMP_FREE (free); \
-}
-
-#define DUMP_FREE(free) \
- free = (dump_and_reset_free_buffer (free, 0))
-
-#define MAYBE_DUMP_SCAN(scan) \
-{ \
- if (scan >= scan_buffer_top) \
- DUMP_SCAN (scan); \
-}
-
-#define DUMP_SCAN(scan) \
- scan = (dump_and_reload_scan_buffer (scan, 0))
-
-#define TRANSPORT_VECTOR(new_address, free, old_start, n_words) \
-{ \
- SCHEME_OBJECT * old_ptr = old_start; \
- SCHEME_OBJECT * free_end = (free + n_words); \
- if (free_end < free_buffer_top) \
- while (free < free_end) \
- (*free++) = (*old_ptr++); \
- else \
- { \
- while (free < free_buffer_top) \
- (*free++) = (*old_ptr++); \
- free = (transport_vector_tail (free, free_end, old_ptr)); \
- } \
-}
-
-static SCHEME_OBJECT *
-DEFUN (transport_vector_tail, (free, free_end, tail),
- SCHEME_OBJECT * free AND
- SCHEME_OBJECT * free_end AND
- SCHEME_OBJECT * tail)
-{
- unsigned long n_words = (free_end - free);
- DUMP_FREE (free);
- {
- unsigned long n_blocks = (n_words >> gc_buffer_shift);
- if (n_blocks > 0)
- {
- free = (dump_free_directly (tail, n_blocks, 0));
- tail += (n_blocks << gc_buffer_shift);
- }
- }
- {
- SCHEME_OBJECT * free_end = (free + (n_words & gc_buffer_mask));
- while (free < free_end)
- (*free++) = (*tail++);
- }
- return (free);
-}
-\f
-SCHEME_OBJECT *
-DEFUN (gc_loop,
- (scan, free_ptr, new_address_ptr, low_heap, gc_mode,
- require_normal_end),
- SCHEME_OBJECT * scan AND
- SCHEME_OBJECT ** free_ptr AND
- SCHEME_OBJECT ** new_address_ptr AND
- SCHEME_OBJECT * low_heap AND
- gc_mode_t gc_mode AND
- int require_normal_end)
-{
- SCHEME_OBJECT * free = (*free_ptr);
- SCHEME_OBJECT * new_address = (*new_address_ptr);
- while (scan != free)
- {
- SCHEME_OBJECT object;
- if (scan >= scan_buffer_top)
- {
- if (scan == scan_buffer_top)
- DUMP_SCAN (scan);
- else
- {
- sprintf
- (gc_death_message_buffer,
- "gc_loop: scan (0x%lx) > scan_buffer_top (0x%lx)",
- ((unsigned long) scan),
- ((unsigned long) scan_buffer_top));
- gc_death (TERM_EXIT, gc_death_message_buffer, scan, free);
- /*NOTREACHED*/
- }
- }
- object = (*scan);
- switch (OBJECT_TYPE (object))
- {
- case TC_BROKEN_HEART:
- if (gc_mode != NORMAL_GC)
- goto end_gc_loop;
- if (object == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan)))
- /* Does this ever happen? */
- goto end_gc_loop;
- sprintf (gc_death_message_buffer,
- "gc_loop: broken heart (0x%lx) in scan",
- object);
- gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, scan, free);
- /*NOTREACHED*/
- break;
-
- case TC_CHARACTER:
- case TC_CONSTANT:
- case TC_FIXNUM:
- case TC_NULL:
- case TC_PCOMB0:
- case TC_PRIMITIVE:
- case TC_RETURN_CODE:
- case TC_STACK_ENVIRONMENT:
- case TC_THE_ENVIRONMENT:
- scan += 1;
- break;
-
- case TC_CELL:
- if (gc_mode == CONSTANT_COPY)
- {
- scan += 1;
- break;
- }
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- (*free++) = (old_start[0]);
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 1;
- }
- }
- break;
-
- case TC_ACCESS:
- case TC_ASSIGNMENT:
- case TC_COMBINATION_1:
- case TC_COMMENT:
- case TC_COMPLEX:
- case TC_DEFINITION:
- case TC_DELAY:
- case TC_DELAYED:
- case TC_DISJUNCTION:
- case TC_ENTITY:
- case TC_EXTENDED_PROCEDURE:
- case TC_IN_PACKAGE:
- case TC_LAMBDA:
- case TC_LEXPR:
- case TC_LIST:
- case TC_PCOMB1:
- case TC_PROCEDURE:
- case TC_RATNUM:
- case TC_SCODE_QUOTE:
- case TC_SEQUENCE_2:
- transport_pair:
- if (gc_mode == CONSTANT_COPY)
- {
- scan += 1;
- break;
- }
- goto really_transport_pair;
-
- case TC_INTERNED_SYMBOL:
- case TC_UNINTERNED_SYMBOL:
- if (gc_mode == PURE_COPY)
- {
- SCHEME_OBJECT name = (MEMORY_REF (object, SYMBOL_NAME));
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (name));
- if ((old_start < low_heap)
- || (BROKEN_HEART_P (*old_start)))
- scan += 1;
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++) = (OBJECT_NEW_ADDRESS (name, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- break;
- }
- really_transport_pair:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- (*free++) = (old_start[0]);
- (*free++) = (old_start[1]);
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 2;
- }
- }
- break;
-
- case TC_COMBINATION_2:
- case TC_CONDITIONAL:
- case TC_EXTENDED_LAMBDA:
- case TC_HUNK3_A:
- case TC_HUNK3_B:
- case TC_PCOMB2:
- case TC_SEQUENCE_3:
- case TC_VARIABLE:
- if (gc_mode == CONSTANT_COPY)
- {
- scan += 1;
- break;
- }
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- (*free++) = (old_start[0]);
- (*free++) = (old_start[1]);
- (*free++) = (old_start[2]);
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 3;
- }
- }
- break;
-
- case TC_QUAD:
- if (gc_mode == CONSTANT_COPY)
- {
- scan += 1;
- break;
- }
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- (*free++) = (old_start[0]);
- (*free++) = (old_start[1]);
- (*free++) = (old_start[2]);
- (*free++) = (old_start[3]);
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 4;
- }
- }
- break;
-
- case TC_BIG_FIXNUM:
- case TC_CHARACTER_STRING:
- case TC_COMBINATION:
- case TC_CONTROL_POINT:
- case TC_NON_MARKED_VECTOR:
- case TC_PCOMB3:
- case TC_RECORD:
- case TC_VECTOR:
- case TC_VECTOR_16B:
- case TC_VECTOR_1B:
- if (gc_mode == CONSTANT_COPY)
- {
- scan += 1;
- break;
- }
- goto transport_vector;
-
- case TC_ENVIRONMENT:
- if (gc_mode == PURE_COPY)
- {
- scan += 1;
- break;
- }
- transport_vector:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- }
- break;
-
- case TC_BIG_FLONUM:
- if (gc_mode == CONSTANT_COPY)
- {
- scan += 1;
- break;
- }
- goto transport_aligned_vector;
-
- case TC_COMPILED_CODE_BLOCK:
- if (gc_mode == PURE_COPY)
- {
- scan += 1;
- break;
- }
- transport_aligned_vector:
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- BCH_ALIGN_FLOAT (new_address, free);
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- }
- break;
-
- case TC_WEAK_CONS:
- if (gc_mode == PURE_COPY)
- {
- scan += 1;
- break;
- }
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else
- {
- SCHEME_OBJECT weak_car = (old_start[0]);
- if (((OBJECT_TYPE (weak_car)) == TC_NULL)
- || ((OBJECT_ADDRESS (weak_car)) < low_heap))
- {
- (*free++) = weak_car;
- (*free++) = (old_start[1]);
- }
- else if (weak_pair_stack_ptr > weak_pair_stack_limit)
- {
- (*--weak_pair_stack_ptr) = ((SCHEME_OBJECT) new_address);
- (*--weak_pair_stack_ptr) = weak_car;
- (*free++) = SHARP_F;
- (*free++) = (old_start[1]);
- }
- else
- {
- (*free++) = (OBJECT_NEW_TYPE (TC_NULL, weak_car));
- (*free++) = (old_start[1]);
- (old_start[1])
- = (MAKE_OBJECT_FROM_OBJECTS (weak_car, Weak_Chain));
- Weak_Chain = object;
- }
- MAYBE_DUMP_FREE (free);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 2;
- }
- }
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- scan += (1 + (OBJECT_DATUM (object)));
- MAYBE_DUMP_SCAN (scan);
- break;
-
- case TC_REFERENCE_TRAP:
- if ((OBJECT_DATUM (object)) > TRAP_MAX_IMMEDIATE)
- goto transport_pair;
- /* Otherwise it's a non-pointer. */
- scan += 1;
- break;
-
- case TC_COMPILED_ENTRY:
- if (gc_mode == PURE_COPY)
- {
- scan += 1;
- break;
- }
- {
- SCHEME_OBJECT * old_start;
- Get_Compiled_Block (old_start, (OBJECT_ADDRESS (object)));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++)
- = (RELOCATE_COMPILED (object,
- (OBJECT_ADDRESS (*old_start)),
- old_start));
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- BCH_ALIGN_FLOAT (new_address, free);
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++)
- = (RELOCATE_COMPILED (object, new_address, old_start));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- }
- break;
-
- case TC_LINKAGE_SECTION:
- if (gc_mode == PURE_COPY)
- {
- gc_death (TERM_COMPILER_DEATH,
- "gc_loop: linkage section in pure area",
- scan, free);
- /*NOTREACHED*/
- }
- switch (READ_LINKAGE_KIND (object))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- /* `count' typeless pointers to hunk3s follow. */
- unsigned long count = (READ_CACHE_LINKAGE_COUNT (object));
- scan += 1;
- while (count > 0)
- {
- SCHEME_OBJECT * old_start;
- MAYBE_DUMP_SCAN (scan);
- old_start = (SCHEME_ADDR_TO_ADDR (*scan));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++)
- = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (*old_start)));
- else
- {
- (*free++) = (old_start[0]);
- (*free++) = (old_start[1]);
- (*free++) = (old_start[2]);
- MAYBE_DUMP_FREE (free);
- (*scan++) = (ADDR_TO_SCHEME_ADDR (new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += 3;
- }
- count -= 1;
- }
- }
- break;
-
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- {
- unsigned long count = (READ_OPERATOR_LINKAGE_COUNT (object));
- char * entry = (FIRST_OPERATOR_LINKAGE_ENTRY (scan));
- long delta;
-
- {
- int extend_p = (entry >= ((char *) scan_buffer_top));
- long delta1 = (((char *) scan) - entry);
- if (extend_p)
- extend_scan_buffer (entry, free);
- BCH_START_OPERATOR_RELOCATION (scan);
- if (extend_p)
- {
- entry = (end_scan_buffer_extension (entry));
- scan = ((SCHEME_OBJECT *) (entry + delta1));
- }
- }
-
- /* END_OPERATOR_LINKAGE_AREA assumes that we will add
- one to the result, so do that now. */
- delta
- = (((END_OPERATOR_LINKAGE_AREA (scan, count)) + 1)
- - scan_buffer_top);
-
- /* The operator entries are copied sequentially, but
- extra hair is required because the entry addresses
- are encoded. */
- while (count > 0)
- {
- char * next_entry = (NEXT_LINKAGE_OPERATOR_ENTRY (entry));
- int extend_p = (next_entry >= ((char *) scan_buffer_top));
- SCHEME_OBJECT esaddr;
- SCHEME_OBJECT * old_start;
-
- /* Guarantee that the scan buffer is large enough
- to hold the entry. */
- if (extend_p)
- extend_scan_buffer (next_entry, free);
-
- /* Get the entry address. */
- BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS (esaddr, entry);
-
- /* Get the code-block pointer for this entry. */
- Get_Compiled_Block
- (old_start, (SCHEME_ADDR_TO_ADDR (esaddr)));
-
- /* Copy the block. */
- if (old_start < low_heap)
- ;
- else if (BROKEN_HEART_P (*old_start))
- {
- BCH_STORE_OPERATOR_LINKAGE_ADDRESS
- ((RELOCATE_COMPILED_RAW_ADDRESS
- (esaddr,
- (OBJECT_ADDRESS (*old_start)),
- old_start)),
- entry);
- }
- else
- {
- unsigned long n_words
- = (1 + (OBJECT_DATUM (*old_start)));
- BCH_ALIGN_FLOAT (new_address, free);
- TRANSPORT_VECTOR
- (new_address, free, old_start, n_words);
- BCH_STORE_OPERATOR_LINKAGE_ADDRESS
- ((RELOCATE_COMPILED_RAW_ADDRESS
- (esaddr, new_address, old_start)),
- entry);
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
-
- if (extend_p)
- {
- entry = (end_scan_buffer_extension (next_entry));
- delta -= gc_buffer_size;
- }
- else
- entry = next_entry;
-
- count -= 1;
- }
- scan = (scan_buffer_top + delta);
- MAYBE_DUMP_SCAN (scan);
- BCH_END_OPERATOR_RELOCATION (scan);
- }
- break;
-
- case CLOSURE_PATTERN_LINKAGE_KIND:
- scan += (1 + (READ_CACHE_LINKAGE_COUNT (object)));
- MAYBE_DUMP_SCAN (scan);
- break;
-
- default:
- gc_death (TERM_EXIT, "gc_loop: Unknown compiler linkage kind.",
- scan, free);
- /*NOTREACHED*/
- break;
- }
- break;
-
- case TC_MANIFEST_CLOSURE:
- if (gc_mode == PURE_COPY)
- {
- gc_death (TERM_COMPILER_DEATH,
- "gc_loop: manifest closure in pure area",
- scan, free);
- /*NOTREACHED*/
- }
- {
- unsigned long count;
- char * entry;
- char * closure_end;
-
- {
- unsigned long delta = (2 * (sizeof (format_word)));
- char * count_end = (((char *) (scan + 1)) + delta);
- int extend_p = (count_end >= ((char *) scan_buffer_top));
-
- /* Guarantee that the scan buffer is large enough to
- hold the count field. */
- if (extend_p)
- extend_scan_buffer (count_end, free);
-
- BCH_START_CLOSURE_RELOCATION (scan);
- count = (MANIFEST_CLOSURE_COUNT (scan + 1));
- entry = (FIRST_MANIFEST_CLOSURE_ENTRY (scan + 1));
-
- if (extend_p)
- {
- long dw = (entry - count_end);
- count_end = (end_scan_buffer_extension (count_end));
- entry = (count_end + dw);
- }
- scan = ((SCHEME_OBJECT *) (count_end - delta));
- }
-
- closure_end = ((char *) (MANIFEST_CLOSURE_END (scan, count)));
-
- /* The closures are copied sequentially, but extra hair is
- required because the code-entry pointers are encoded as
- machine instructions. */
- while (count > 0)
- {
- char * entry_end = (CLOSURE_ENTRY_END (entry));
- int extend_p = (entry_end >= ((char *) scan_buffer_top));
- SCHEME_OBJECT esaddr;
- SCHEME_OBJECT * old_start;
- long delta1 = (entry - entry_end);
- long delta2 = (closure_end - entry_end);
-
- /* If the closure overflows the scan buffer, extend
- the buffer to the end of the closure. */
- if (extend_p)
- extend_scan_buffer (entry_end, free);
-
- /* Extract the code-entry pointer and convert it to a
- C pointer. */
- BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS (esaddr, entry);
- Get_Compiled_Block (old_start, (SCHEME_ADDR_TO_ADDR (esaddr)));
-
- /* Copy the code entry. Use machine-specific macro to
- update the pointer. */
- if (old_start < low_heap)
- ;
- else if (BROKEN_HEART_P (*old_start))
- BCH_STORE_CLOSURE_ENTRY_ADDRESS
- ((RELOCATE_COMPILED_RAW_ADDRESS
- (esaddr, (OBJECT_ADDRESS (*old_start)), old_start)),
- entry);
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- BCH_ALIGN_FLOAT (new_address, free);
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- BCH_STORE_CLOSURE_ENTRY_ADDRESS
- ((RELOCATE_COMPILED_RAW_ADDRESS
- (esaddr, new_address, old_start)),
- entry);
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
-
- if (extend_p)
- {
- entry_end = (end_scan_buffer_extension (entry_end));
- entry = (entry_end + delta1);
- closure_end = (entry_end + delta2);
- }
-
- entry = (NEXT_MANIFEST_CLOSURE_ENTRY (entry));
- count -= 1;
- }
- scan = ((SCHEME_OBJECT *) closure_end);
- MAYBE_DUMP_SCAN (scan);
- BCH_END_CLOSURE_RELOCATION (scan);
- }
- break;
-
- case TC_FUTURE:
- if (gc_mode == CONSTANT_COPY)
- {
- scan += 1;
- break;
- }
- {
- SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
- if (old_start < low_heap)
- scan += 1;
- else if (BROKEN_HEART_P (*old_start))
- (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
- else if (Future_Spliceable (object))
- (*scan) = (Future_Value (object));
- else
- {
- unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
- TRANSPORT_VECTOR (new_address, free, old_start, n_words);
- (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
- (*old_start) = (MAKE_BROKEN_HEART (new_address));
- new_address += n_words;
- }
- }
- break;
-
- default:
- GC_BAD_TYPE ("gc_loop", object);
- scan += 1;
- break;
- }
- }
- end_gc_loop:
- (*free_ptr) = free;
- (*new_address_ptr) = new_address;
- if (require_normal_end && (scan != free))
- {
- gc_death (TERM_BROKEN_HEART, "gc_loop ended too early", scan, free);
- /*NOTREACHED*/
- }
- return (scan);
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: bchmmg.c,v 9.109 2007/02/10 19:22:13 riastradh Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Memory management top level. Garbage collection to disk. */
-
-#include "scheme.h"
-#include "prims.h"
-#include "memmag.h"
-#include "option.h"
-#include "osenv.h"
-#include "osfs.h"
-
-#ifdef __unix__
-# include "ux.h"
-# define SUB_DIRECTORY_DELIMITER '/'
-/* This makes for surprising behavior: */
-/* # define UNLINK_BEFORE_CLOSE */
-#endif
-
-#ifdef __WIN32__
-# include "nt.h"
-# define SUB_DIRECTORY_DELIMITER '\\'
-#endif
-
-#ifdef __OS2__
-# include "os2.h"
-# define SUB_DIRECTORY_DELIMITER '\\'
-# if defined(__IBMC__) || defined(__WATCOMC__) || defined(__EMX__)
-# include <io.h>
-# include <sys\stat.h>
-# endif
-# ifndef F_OK
-# define F_OK 0
-# define X_OK 1
-# define W_OK 2
-# define R_OK 4
-# endif
-#endif
-
-#include "bchgcc.h"
-#include "bchdrn.h"
-
-#ifndef SEEK_SET
-# define SEEK_SET 0
-#endif
-
-#ifdef USE_SYSV_SHARED_MEMORY
-# define RECORD_GC_STATISTICS
-#endif
-#define MILLISEC * 1000
-
-#define FLOOR(value,quant) ((quant) * ((value) / (quant)))
-#define CEILING(value,quant) (FLOOR (((value) + ((quant) - 1)), (quant)))
-\f
-/* Memory management top level. Garbage collection to disk.
-
- The algorithm is basically the same as for the 2 space collector,
- except that new space is on the disk, and there are two windows to
- it (the scan and free buffers). The two windows are physically the
- same whent they correspond to the same section of the address space.
- There may be additional windows used to overlap I/O.
-
- For information on the 2 space collector, read the comments in the
- replaced files.
-
- The memory management code is spread over the following files:
- - bchgcc.h: shared header file for bchscheme.
- - bchmmg.c: top level, initialization and I/O. Replaces memmag.c
- - bchgcl.c: main garbage collector loop. Replaces gcloop.c
- - bchpur.c: constant/pure space hacking. Replaces purify.c
- - bchdmp.c: object & world image dumping. Replaces fasdump.c
- - bchdrn.h: header file for bchmmg.c and the bchdrn.c.
- - bchdrn.c: stand-alone program used as an overlapped I/O drone.
- - bchutl.c: utilities common to bchmmg.c and bchdrn.c.
-
- Problems with this implementation right now:
- - It only works on Unix (or systems which support Unix I/O calls).
- - Dumpworld does not work because the file is not closed at dump time or
- reopened at restart time.
- - Command-line specified gc files are only locked on versions of Unix
- that have lockf(2). If your system does not have lockf, two
- processes can try to share the file and get very confused.
-
-oo
- ------------------------------------------
- | GC Buffer Space | (not always contiguous)
- | |
- ------------------------------------------ <- fixed boundary (currently)
- | Heap Space |
- | |
- ------------------------------------------ <- boundary moved by purify
- | Constant + Pure Space /\ |
- | || |
- ------------------------------------------ <- fixed boundary (currently)
- | Control Stack || |
- | \/ |
- ------------------------------------------ <- fixed boundary (currently)
-0
-
- Each area has a pointer to its starting address and a pointer to
- the next free cell (for the stack, it is a pointer to the last cell
- in use). The GC buffer space contains two (or more) buffers used
- during the garbage collection process. One is the scan buffer and
- the other is the free buffer, and they are dumped and loaded from
- disk as necessary. At the beginning and at the end a single buffer
- is used, since transporting will occur into the area being scanned.
-*/
-\f
-/* Exports */
-
-extern void EXFUN (Clear_Memory, (int, int, int));
-extern void EXFUN (Setup_Memory, (int, int, int));
-extern void EXFUN (Reset_Memory, (void));
-
-long
- absolute_gc_file_end_position,
- gc_file_end_position,
- gc_file_current_position,
- gc_file_start_position;
-
-unsigned long
- gc_buffer_size,
- gc_buffer_bytes,
- gc_buffer_shift,
- gc_buffer_mask,
- gc_buffer_byte_shift;
-
-static unsigned long
- gc_extra_buffer_size,
- gc_buffer_overlap_bytes,
- gc_buffer_remainder_bytes,
- gc_total_buffer_size;
-
-SCHEME_OBJECT
- * scan_buffer_top, * scan_buffer_bottom,
- * free_buffer_top, * free_buffer_bottom,
- * virtual_scan_pointer;
-
-static SCHEME_OBJECT
- * virtual_scan_base;
-
-static char
- * gc_file_name = 0;
-
-CONST char
- * drone_file_name = 0;
-
-static int
- keep_gc_file_p = 0,
- gc_file = -1,
- read_overlap = 0,
- write_overlap = 0;
-
-static SCHEME_OBJECT
- * aligned_heap;
-
-static Boolean
- can_dump_directly_p,
- extension_overlap_p,
- scan_buffer_extended_p;
-
-static long
- scan_position,
- free_position,
- pre_read_position,
- extension_overlap_length;
-
-static long
- saved_heap_size,
- saved_constant_size,
- saved_stack_size;
-
-static unsigned long
- read_queue_bitmask; /* Change MAX_READ_OVERLAP if you change this. */
-
-static struct buffer_info
- * free_buffer,
- * scan_buffer,
- * next_scan_buffer;
-\f
-int
-DEFUN (io_error_always_abort, (operation_name, noise),
- char * operation_name AND char * noise)
-{
- return (1);
-}
-
-#ifdef __WIN32__
-#include <windows.h>
-
-int
-DEFUN (io_error_retry_p, (operation_name, noise),
- char * operation_name AND char * noise)
-{
- char buf[512];
- extern HANDLE master_tty_window;
-
- sprintf (&buf[0],
- "%s: GC file error (code = %d) when manipulating %s.\n"
- "Choose an option (Cancel = Exit Scheme)",
- operation_name, (GetLastError ()), noise);
- switch (MessageBox (master_tty_window,
- &buf[0],
- "MIT/GNU Scheme garbage-collection problem description",
- (MB_ICONSTOP | MB_ABORTRETRYIGNORE | MB_APPLMODAL)))
- {
- case IDABORT:
- return (1);
-
- case IDRETRY:
- return (0);
-
- case IDIGNORE:
- Microcode_Termination (TERM_EXIT);
- }
- /*NOTREACHED*/
- return (0);
-}
-
-#else /* not __WIN32__ */
-#ifdef __OS2__
-
-int
-io_error_retry_p (char * operation_name, char * noise)
-{
- char buf [512];
- sprintf ((&buf[0]),
- "%s: GC file error (code = %d) when manipulating %s.\n"
- "Choose an option (Cancel = Exit Scheme)",
- operation_name, errno, noise);
- switch
- (WinMessageBox (HWND_DESKTOP,
- NULLHANDLE,
- (&buf[0]),
- "MIT/GNU Scheme garbage-collection problem description",
- 0,
- (MB_ICONHAND | MB_ABORTRETRYIGNORE | MB_APPLMODAL)))
- {
- case MBID_ABORT: return (1);
- case MBID_RETRY: return (0);
- case MBID_IGNORE: Microcode_Termination (TERM_EXIT);
- }
-}
-
-#else /* not __OS2__ */
-
-extern char EXFUN (userio_choose_option,
- (CONST char *, CONST char *, CONST char **));
-extern int EXFUN (userio_confirm, (CONST char *));
-
-int
-DEFUN (io_error_retry_p, (operation_name, noise),
- char * operation_name AND char * noise)
-{
- static CONST char * retry_choices [] =
- {
- "A = abort the operation",
- "E = exit scheme",
- "K = kill scheme",
- "Q = quit scheme",
- "R = retry the operation",
- "S = sleep for 1 minute and retry the operation",
- "X = exit scheme",
- 0};
-
- outf_error ("\n%s (%s): GC file error (errno = %s) when manipulating %s.\n",
- scheme_program_name, operation_name, (error_name (errno)),
- noise);
-
- while (1)
- {
- switch (userio_choose_option
- ("Choose one of the following actions:",
- "Action -> ", retry_choices))
- {
- case 'A':
- return (1);
-
- case '\0':
- /* IO problems, assume everything is scrod. */
- outf_fatal
- ("%s (io_error_retry_p): Problems reading the keyboard; Exitting.\n",
- scheme_program_name);
- termination_eof ();
- /*NOTREACHED*/
-
- case 'E': case 'K': case 'Q': case 'X':
- if (!(userio_confirm ("Kill Scheme (Y/N)? ")))
- continue;
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
-
- case 'S':
- sleep (60);
- /* fall through */
-
- case 'R':
- default:
- return (0);
- }
- }
-}
-
-#endif /* not __OS2__ */
-#endif /* not __WIN32__ */
-\f
-static int
-DEFUN (verify_write, (position, size, success),
- long position AND long size AND Boolean * success)
-{
- if ((position >= gc_file_start_position)
- && ((position + size) <= gc_file_end_position))
- return (0);
- outf_error (
- "\n%s (verify_write): attempting to write outside allowed area.\n",
- scheme_program_name);
- outf_error("\tlow position = 0x%lx; high position = 0x%lx.\n",
- gc_file_start_position, gc_file_end_position);
- outf_error("\twrite position = 0x%lx; size = 0x%lx = %d bytes.\n",
- position, size, size);
- outf_flush_error();
- if (success == ((Boolean *) NULL))
- {
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- }
- *success = ((Boolean) false);
- return (-1);
-}
-
-static void
-DEFUN (write_data, (from, position, nbytes, noise, success),
- char * from AND long position AND long nbytes
- AND char * noise AND Boolean * success)
-{
- if (((verify_write (position, nbytes, success)) != -1)
- && ((retrying_file_operation (((file_operation_t *) write),
- gc_file,
- from,
- position,
- nbytes,
- "write",
- noise,
- &gc_file_current_position,
- ((success == ((Boolean *) NULL))
- ? io_error_retry_p
- : io_error_always_abort)))
- == -1)
- && (success != ((Boolean *) NULL)))
- *success = false;
- return;
-}
-
-static void
-DEFUN (load_data, (position, to, nbytes, noise, success),
- long position AND char * to AND long nbytes
- AND char * noise AND Boolean * success)
-{
- (void) (retrying_file_operation (((file_operation_t *) read),
- gc_file,
- to,
- position,
- nbytes,
- "read",
- noise,
- &gc_file_current_position,
- ((success == ((Boolean *) NULL))
- ? io_error_retry_p
- : io_error_always_abort)));
-}
-\f
-static int
-DEFUN (parameterization_termination, (kill_p, init_p),
- int kill_p AND int init_p)
-{
- fflush (stderr);
- if (init_p)
- termination_init_error (); /*NOTREACHED*/
- if (kill_p)
- Microcode_Termination (TERM_EXIT); /*NOTREACHED*/
- return (-1);
-}
-
-struct bch_GC_statistic
-{
- char * name;
- long * counter;
-};
-
-#ifdef RECORD_GC_STATISTICS
-
-static void EXFUN (statistics_clear, (void));
-static void EXFUN (statistics_print, (int, char *));
-
-# define STATISTICS_INCR(name) name += 1
-# define STATISTICS_CLEAR() statistics_clear ()
-# define STATISTICS_PRINT(level, noise) statistics_print (level, noise)
-
-#else
-
-static struct bch_GC_statistic all_gc_statistics[] =
-{ { "invalid last statistic", ((long *) NULL) } };
-
-# define STATISTICS_INCR(name) do { } while (0)
-# define STATISTICS_CLEAR() do { } while (0)
-# define STATISTICS_PRINT(level, noise) do { } while (0)
-
-#endif
-\f
-#ifdef USE_SYSV_SHARED_MEMORY
-
-#ifdef RECORD_GC_STATISTICS
-
-static long
- reads_not_overlapped,
- reads_overlapped,
- reads_ready,
- reads_queued,
- reads_pending,
- reads_overlapped_aborted,
- reads_found_in_write_queue,
- reads_found_ready,
- read_wait_cycles,
- writes_not_overlapped,
- writes_overlapped,
- writes_not_deferred,
- writes_restarted,
- writes_retried,
- writes_pending,
- write_wait_cycles,
- pre_reads_aborted,
- pre_reads_ignored,
- pre_reads_found_in_write_queue,
- pre_reads_found_ready,
- pre_reads_not_started,
- pre_reads_started,
- pre_reads_deferred,
- pre_reads_restarted,
- pre_reads_retried,
- pre_reads_not_retried,
- pre_reads_requeued_as_writes,
- ready_buffers_enqueued,
- ready_buffers_not_enqueued,
- drone_wait_cycles,
- drone_request_failures,
- drones_found_dead,
- sleeps_interrupted,
- await_io_cycles,
- gc_start_time,
- gc_end_transport_time,
- gc_end_weak_update_time,
- gc_start_reload_time,
- gc_end_time;
-
-#define START_TRANSPORT_HOOK() \
- gc_start_time = ((long) (OS_real_time_clock ()))
-
-#define END_TRANSPORT_HOOK() \
- gc_end_transport_time = ((long) (OS_real_time_clock ()))
-
-#define END_WEAK_UPDATE_HOOK() \
- gc_end_weak_update_time = ((long) (OS_real_time_clock ()))
-
-#define START_RELOAD_HOOK() \
- gc_start_reload_time = ((long) (OS_real_time_clock ()))
-
-#define END_GC_HOOK() \
- gc_end_time = ((long) (OS_real_time_clock ()))
-\f
-static struct bch_GC_statistic all_gc_statistics[] =
-{
- { "reads not overlapped", &reads_not_overlapped },
- { "reads overlapped", &reads_overlapped },
- { "reads ready", &reads_ready },
- { "reads queued", &reads_queued },
- { "reads pending", &reads_pending },
- { "reads overlapped aborted", &reads_overlapped_aborted },
- { "reads found in write queue", &reads_found_in_write_queue },
- { "reads found ready", &reads_found_ready },
- { "read wait cycles", &read_wait_cycles },
- { "writes not overlapped", &writes_not_overlapped },
- { "writes overlapped", &writes_overlapped },
- { "writes retried", &writes_retried },
- { "writes not deferred", &writes_not_deferred },
- { "writes restarted", &writes_restarted },
- { "writes retried", &writes_retried },
- { "writes pending", &writes_pending },
- { "write wait cycles", &write_wait_cycles },
- { "pre-reads aborted", &pre_reads_aborted },
- { "pre-reads ignored", &pre_reads_ignored },
- { "pre-reads found in write queue", &pre_reads_found_in_write_queue },
- { "pre-reads found ready", &pre_reads_found_ready },
- { "pre-reads not started", &pre_reads_not_started },
- { "pre-reads started", &pre_reads_started },
- { "pre-reads deferred", &pre_reads_deferred },
- { "pre-reads restarted", &pre_reads_restarted },
- { "pre-reads retried", &pre_reads_retried },
- { "pre-reads not retried", &pre_reads_not_retried },
- { "pre-reads requeued as writes", &pre_reads_requeued_as_writes },
- { "ready buffers enqueued", &ready_buffers_enqueued },
- { "ready buffers not enqueued", &ready_buffers_not_enqueued },
- { "drone wait cycles", &drone_wait_cycles },
- { "drone request failures", &drone_request_failures },
- { "drones found dead", &drones_found_dead },
- { "sleeps interrupted", &sleeps_interrupted },
- { "cycles awaiting I/O completion", &await_io_cycles },
- { "time at gc start", &gc_start_time },
- { "time at end of transport", &gc_end_transport_time },
- { "time at end of weak update", &gc_end_weak_update_time },
- { "time at start of reload", &gc_start_reload_time },
- { "time at gc end", &gc_end_time },
- { "invalid last statistic", ((long *) NULL) }
-};
-
-#endif /* RECORD_GC_STATISTICS */
-\f
-/* The limit on MAX_READ_OVERLAP is the number of bits in read_queue_bitmask.
- The limit on MAX_GC_DRONES is the number of bits in (* wait_mask).
- There is no direct limit on MAX_WRITE_OVERLAP.
- On the other hand, the explicit searches through the queues
- will become slower as the numbers are increased.
- */
-
-#define MAX_READ_OVERLAP ((sizeof (long)) * CHAR_BIT)
-#define MAX_WRITE_OVERLAP MAX_READ_OVERLAP
-#define MAX_GC_DRONES ((sizeof (long)) * CHAR_BIT)
-#define MAX_OVERLAPPED_RETRIES 2
-
-static char * shared_memory = ((char *) -1);
-static char * malloc_memory = ((char *) NULL);
-static int drones_initialized_p = 0;
-static int shmid = -1;
-static int n_gc_buffers, n_gc_drones, gc_next_buffer, gc_next_drone;
-static struct gc_queue_entry * gc_read_queue, * gc_write_queue;
-static struct drone_info * gc_drones;
-static struct buffer_info * gc_buffers;
-static unsigned long * wait_mask, * drone_version;
-
-static long default_sleep_period = 20 MILLISEC;
-
-#define GET_SLEEP_DELTA() default_sleep_period
-#define SET_SLEEP_DELTA(value) default_sleep_period = (value)
-
-static void
-DEFUN (sleep_awaiting_drones, (microsec, mask),
- unsigned int microsec AND unsigned long mask)
-{
- int saved_errno;
- int retval;
-
- *wait_mask = mask;
-#ifdef HAVE_POLL
- retval = (poll (0, 0, (microsec / 1000)));
-#else
- {
- int dummy = 0;
- struct timeval timeout;
- timeout.tv_sec = 0;
- timeout.tv_usec = microsec;
- retval
- = (select (0,
- ((SELECT_TYPE *) &dummy),
- ((SELECT_TYPE *) &dummy),
- ((SELECT_TYPE *) &dummy),
- &timeout));
- }
-#endif
- *wait_mask = ((unsigned long) 0);
- saved_errno = errno;
-
- if ((retval == -1) && (saved_errno == EINTR))
- STATISTICS_INCR (sleeps_interrupted);
-}
-
-#ifndef _SUNOS4
-# define SYSV_SPRINTF sprintf
-#else
-/* Losing SunOS sprintf */
-
-# define SYSV_SPRINTF sysV_sprintf
-
-static int
-DEFUN (sysV_sprintf, (string, format, value),
- char * string AND char * format AND long value)
-{
- sprintf (string, format, value);
- return (strlen (string));
-}
-
-#endif /* _SUNOS4 */
-
-#ifdef SIGCONT
-static void
-DEFUN (continue_running, (sig), int sig)
-{
- RE_INSTALL_HANDLER (SIGCONT, continue_running);
-}
-#endif
-\f
-static void
-DEFUN (start_gc_drones, (first_drone, how_many, restarting),
- int first_drone AND int how_many AND int restarting)
-{
- pid_t pid;
- char arguments[512];
- struct drone_info *drone;
- char
- * shmid_string, /* shared memory handle */
- * tdron_string, /* total number of drones */
- * nbuf_string, /* total number of buffers */
- * bufsiz_string, /* size of each buffer in bytes */
- * sdron_string, /* index of first drone to start */
- * ndron_string; /* number of drones to start */
-
- shmid_string = &arguments[0];
- tdron_string =
- (shmid_string + (1 + (SYSV_SPRINTF (shmid_string, "%d", shmid))));
- nbuf_string =
- (tdron_string + (1 + (SYSV_SPRINTF (tdron_string, "%d", n_gc_drones))));
- bufsiz_string =
- (nbuf_string + (1 + (SYSV_SPRINTF (nbuf_string, "%d", n_gc_buffers))));
- sdron_string =
- (bufsiz_string
- + (1 + (SYSV_SPRINTF (bufsiz_string, "%ld",
- (gc_total_buffer_size
- * (sizeof (SCHEME_OBJECT)))))));
- ndron_string =
- (sdron_string + (1 + (SYSV_SPRINTF (sdron_string, "%d", first_drone))));
- (void) (SYSV_SPRINTF (ndron_string, "%d", how_many));
-
- drone = (gc_drones + first_drone);
- if (restarting && (drone->state != drone_dead))
- (void) (kill (drone->DRONE_PID, SIGTERM));
- drone->state = drone_not_ready;
- (* drone_version) = ((unsigned long) DRONE_VERSION_NUMBER);
-
- if ((pid = (vfork ())) == 0)
- {
- execlp (drone_file_name, drone_file_name, gc_file_name, shmid_string,
- tdron_string, nbuf_string, bufsiz_string,
- sdron_string, ndron_string, (keep_gc_file_p ? "1" : "0"),
- ((char *) 0));
- outf_error ("\n%s (start_gc_drones): execlp (%s) failed (errno = %s).\n",
- scheme_program_name, drone_file_name, (error_name (errno)));
- drone->state = drone_dead;
- (void) (kill ((getppid ()), SIGCONT));
- _exit (1);
- }
- else if (pid == -1)
- {
- outf_error ("\n%s (start_gc_drones): vfork failed (errno = %s).\n",
- scheme_program_name, (error_name (errno)));
- drone->state = drone_dead;
- }
- else
- {
- sigset_t old_mask, new_mask;
-
- UX_sigemptyset (&new_mask);
- UX_sigaddset ((&new_mask), SIGCONT);
- UX_sigprocmask (SIG_BLOCK, (&new_mask), (&old_mask));
- if (drone->state == drone_not_ready)
- UX_sigsuspend (&old_mask);
- UX_sigprocmask (SIG_SETMASK, (&old_mask), 0);
-
- if ((drone->state != drone_idle) && !restarting)
- {
- /* Do the wait only at startup since Scheme handles SIGCHLD
- for all children. */
- ((void) (waitpid (pid, ((int *) 0), WNOHANG)));
- drone->state = drone_dead;
- }
- }
- return;
-}
-
-static int
-DEFUN (invoke_gc_drone,
- (entry, operation, buffer, position, size),
- struct gc_queue_entry * entry
- AND enum drone_state operation
- AND struct buffer_info * buffer
- AND long position
- AND long size)
-{
- int result, drone_index;
- struct drone_info * drone;
- enum buffer_state old_state;
-
- drone_index = (entry->drone_index);
- drone = (gc_drones + drone_index);
- drone->buffer_index = buffer->index;
- drone->entry_offset = (((char *) entry) - ((char *) drone));
-
- old_state = buffer->state;
- buffer->state = ((operation == drone_reading)
- ? buffer_being_read
- : buffer_being_written);
- buffer->position = position;
- buffer->size = size;
- entry->buffer = buffer;
- entry->state = entry_busy;
-
- drone->state = operation; /* Previously drone_idle */
- if ((result = (kill (drone->DRONE_PID, SIGCONT))) == -1)
- {
- entry->state = entry_idle;
- buffer->state = old_state;
- drone->state = drone_dead;
- if (errno != ESRCH)
- outf_error
- ("\n%s (invoke_gc_drone): kill (%d, SIGCONT) failed; errno = %s.\n",
- scheme_program_name, drone->DRONE_PID, (error_name (errno)));
- start_gc_drones (drone_index, 1, 1);
- }
- return (result != -1);
-}
-\f
-/* The following don't do a wait/waitpid because Scheme handles SIGCHLD. */
-
-static void
-DEFUN_VOID (kill_all_gc_drones)
-{
- int count;
- struct drone_info * drone;
-
- for (count = 0, drone = gc_drones; count < n_gc_drones; count++, drone++)
- (void) (kill (drone->DRONE_PID, SIGTERM));
- return;
-}
-
-static int
-DEFUN (probe_gc_drone, (drone), struct drone_info * drone)
-{
- int result;
-
- if ((result = (kill ((drone->DRONE_PID), 0))) == -1)
- {
- if (errno != ESRCH)
- (void) (kill ((drone->DRONE_PID), SIGTERM));
- drone->state = drone_dead;
- }
- return (result == 0);
-}
-
-static void EXFUN (handle_drone_death, (struct drone_info *));
-
-static void
-DEFUN (probe_all_gc_drones, (wait_p), int wait_p)
-{
- int count;
- unsigned long running;
- struct drone_info * drone;
-
- do {
- for (count = 0, drone = gc_drones, running = ((unsigned long) 0);
- count < n_gc_drones;
- count++, drone++)
- {
- if (drone->state != drone_idle)
- {
- running |= (((unsigned long) 1) << drone->index);
- if ((kill (drone->DRONE_PID, 0)) == -1)
- {
- if (errno != ESRCH)
- (void) (kill (drone->DRONE_PID, SIGTERM));
- drone->state = drone_dead;
- start_gc_drones (drone->index, 1, 1);
- handle_drone_death (drone);
- }
- }
- }
- if (wait_p && (running != ((unsigned long) 0)))
- {
- sleep_awaiting_drones (default_sleep_period, running);
- STATISTICS_INCR (await_io_cycles);
- }
- } while (wait_p && (running != ((unsigned long) 0)));
- return;
-}
-\f
-static void EXFUN (open_gc_file, (long, int));
-
-static int
-DEFUN (sysV_initialize, (first_time_p, size, r_overlap, w_overlap, drfnam),
- int first_time_p
- AND long size AND int r_overlap AND int w_overlap
- AND CONST char * drfnam)
-{
- SCHEME_OBJECT * bufptr;
- int cntr;
- long buffer_space, shared_size, malloc_size;
- struct buffer_info * buffer;
-
- if (r_overlap < 0)
- r_overlap = 0;
- else if (r_overlap > MAX_READ_OVERLAP)
- r_overlap = MAX_READ_OVERLAP;
- read_overlap = r_overlap;
-
- if (w_overlap < 0)
- w_overlap = 0;
- else if (w_overlap > MAX_WRITE_OVERLAP)
- w_overlap = MAX_WRITE_OVERLAP;
- write_overlap = w_overlap;
-
- if ((n_gc_drones = (read_overlap + write_overlap)) > MAX_GC_DRONES)
- {
- read_overlap = ((read_overlap * MAX_GC_DRONES) / n_gc_drones);
- write_overlap = ((write_overlap * MAX_GC_DRONES) / n_gc_drones);
- n_gc_drones = (read_overlap + write_overlap);
- }
- n_gc_buffers = (2 + n_gc_drones);
-
- /* The second argument to open_gc_file should be (n_gc_drones == 0),
- but we can't do this since we can change the number of drones.
- */
-
- if (first_time_p)
- {
- open_gc_file (size, 0);
-#ifdef F_SETFD
- /* Set the close on exec flag, the drones re-open it to get a
- different file pointer so that all the processes can independently
- lseek without clobbering each other.
- */
- (void) (fcntl (gc_file, F_SETFD, 1));
-#endif
- }
-
- buffer_space = (n_gc_buffers
- * (gc_total_buffer_size * (sizeof (SCHEME_OBJECT))));
- shared_size =
- (ALIGN_UP_TO_IO_PAGE (buffer_space
- + (n_gc_buffers * (sizeof (struct buffer_info)))
- + (n_gc_drones * (sizeof (struct drone_info)))
- + (sizeof (long))
- + (sizeof (long))
- + (r_overlap * (sizeof (struct gc_queue_entry)))
- + (w_overlap * (sizeof (struct gc_queue_entry)))
- + IO_PAGE_SIZE));
-
- malloc_size = ((n_gc_drones == 0)
- ? shared_size
- : (first_time_p ? MALLOC_SPACE : 0));
-
- if (malloc_size > 0)
- {
- malloc_memory = ((char *) (malloc (malloc_size)));
- if (malloc_memory == ((char *) NULL))
- {
- outf_error
- ("%s (sysV_initialize): Unable to allocate %d bytes (errno = %s).\n",
- scheme_program_name, malloc_size, (error_name (errno)));
- return (parameterization_termination (1, first_time_p));
- }
- }
-
- if (n_gc_drones == 0)
- shared_memory = ((char *) (ALIGN_UP_TO_IO_PAGE (malloc_memory)));
- else
- {
- if ((shmid = (shmget (IPC_PRIVATE, shared_size, 0600))) == -1)
- {
- outf_error
- ("%s (sysV_initialize): shmget (-, %d, -) failed (errno = %s).\n\
- \tUnable to allocate shared memory for drone processes.\n",
- scheme_program_name, shared_size, (error_name (errno)));
- return (parameterization_termination (0, first_time_p));
- }
- shared_memory = (shmat (shmid, ATTACH_POINT, 0));
- if (shared_memory == ((char *) -1))
- {
- int saved_errno = errno;
-
- (void) (shmctl (shmid, IPC_RMID, 0));
- shmid = -1;
- outf_error
- ("%s (sysV_initialize): shmat (%d, 0x%lx, 0) failed. (errno = %s).\n\
- \tUnable to attach shared memory for drone processes.\n",
- scheme_program_name, shmid, shared_size, (error_name (saved_errno)));
- return (parameterization_termination (0, first_time_p));
- }
- signal (SIGCONT, continue_running);
- }
-
- if (!(ALIGNED_TO_IO_PAGE_P (shared_memory)))
- {
- outf_error
- ("%s (sysV_initialize): buffer space is not aligned properly.\n\
- \taddress = 0x%lx; IO_PAGE_SIZE = 0x%lx.\n",
- ((long) shared_memory), ((long) IO_PAGE_SIZE));
- return (parameterization_termination (0, first_time_p));
- }
-
- if ((n_gc_drones != 0) && (malloc_size > 0)
- && (malloc_memory != ((char *) NULL)))
- {
- free (malloc_memory);
- malloc_memory = ((char *) NULL);
- }
-
- gc_buffers = ((struct buffer_info *) (shared_memory + buffer_space));
- gc_drones = ((struct drone_info *) (gc_buffers + n_gc_buffers));
- drone_version = ((unsigned long *) (gc_drones + n_gc_drones));
- wait_mask = (drone_version + 1);
- gc_read_queue = ((struct gc_queue_entry *) (drone_version + 2));
- gc_write_queue = (gc_read_queue + r_overlap);
-
- /* Initialize structures. */
-
- *wait_mask = ((unsigned long) 0);
- gc_next_drone = 0;
- gc_next_buffer = 0;
-
- drone_file_name = ((char *) drfnam);
- if ((drfnam != ((char *) NULL)) && (drfnam[0] != SUB_DIRECTORY_DELIMITER))
- {
- CONST char * temp = (search_for_library_file (drfnam));
-
- if (temp != ((char *) NULL))
- {
- drone_file_name = temp;
- if (drfnam != option_gc_drone)
- free ((PTR) drfnam);
- }
- }
-
- for (bufptr = ((SCHEME_OBJECT *) shared_memory), cntr = 0,
- buffer = gc_buffers;
- (cntr < n_gc_buffers);
- bufptr = buffer->end, cntr++, buffer++)
- {
- buffer->index = cntr;
- buffer->state = buffer_idle;
- buffer->position = -1;
- buffer->bottom = ((PTR) bufptr);
- buffer->top = ((PTR) (bufptr + gc_buffer_size));
- buffer->end = ((PTR) (bufptr + gc_total_buffer_size));
- }
-
- if (n_gc_drones == 0)
- shared_memory = ((char *) -1);
- else
- {
- struct gc_queue_entry * entry;
- struct drone_info * drone;
-
- /* Make sure that SIGCONT is enabled. */
- {
- sigset_t mask;
-
- UX_sigemptyset (&mask);
- UX_sigaddset ((&mask), SIGCONT);
- UX_sigprocmask (SIG_UNBLOCK, (&mask), 0);
- }
-
- for (cntr = 0, entry = gc_read_queue;
- cntr < read_overlap;
- cntr++, entry++)
- {
- entry->index = cntr;
- entry->state = entry_idle;
- entry->retry_count = 0;
- }
-
- for (cntr = 0, entry = gc_write_queue;
- cntr < write_overlap;
- cntr++, entry++)
- {
- entry->index = cntr;
- entry->state = entry_idle;
- entry->retry_count = 0;
- }
-
- for (cntr = 0, drone = gc_drones;
- cntr < n_gc_drones;
- cntr++, drone++)
- {
- drone->index = cntr;
- drone->state = drone_not_ready;
- }
-
- start_gc_drones (0, n_gc_drones, 0);
- if (gc_drones->state != drone_idle)
- {
- outf_error
- ("%s (sysV_initialize): Problems starting up the GC drones%s.\n",
- scheme_program_name,
- (((* drone_version) != ((unsigned long) DRONE_VERSION_NUMBER))
- ? " (wrong drone version)"
- : ""));
- return (parameterization_termination (0, first_time_p));
- }
- drones_initialized_p = 1;
- }
- return (0);
-}
-\f
-static void EXFUN (close_gc_file, (int));
-
-static void
-DEFUN (sysV_shutdown, (final_time_p), int final_time_p)
-{
- /* arg should be (n_gc_drones > 0), see sysV_initialize */
- if (final_time_p)
- close_gc_file (1);
-
- if (malloc_memory != ((char *) NULL))
- {
- free (malloc_memory);
- malloc_memory = ((char *) NULL);
- }
-
- if ((n_gc_drones != 0) && (drones_initialized_p))
- {
- kill_all_gc_drones ();
- drones_initialized_p = 0;
- }
-
- if ((shared_memory != ((char *) -1)) && ((shmdt (shared_memory)) == -1))
- outf_error ("\n%s (sysV_shutdown): shmdt failed. errno = %s.\n",
- scheme_program_name, (error_name (errno)));
- shared_memory = ((char *) -1);
-
- if ((shmid != -1)
- && (shmctl (shmid, IPC_RMID, ((struct shmid_ds *) 0))) == -1)
- outf_error ("\n%s (sysV_shutdown): shmctl failed. errno = %s.\n",
- scheme_program_name, (error_name (errno)));
- shmid = -1;
-
- return;
-}
-\f
-static int
-DEFUN (find_idle_drone, (wait_p), int wait_p)
-{
- int drone_index, next_drone_index, count = 0;
- struct drone_info * drone;
-
- drone_index = gc_next_drone;
- while (1)
- {
- count += 1;
- do
- {
- next_drone_index = (drone_index + 1);
- if (next_drone_index >= n_gc_drones)
- next_drone_index = 0;
-
- drone = (gc_drones + drone_index);
- switch (drone->state)
- {
- case drone_idle:
- gc_next_drone = next_drone_index;
- return (drone_index);
-
- case drone_dead:
- start_gc_drones (drone_index, 1, 1);
- /* fall through, look at it on next pass. */
-
- default:
- break;
- }
- drone_index = next_drone_index;
- } while (drone_index != gc_next_drone);
-
- /* All the drones are busy... */
-
- if (!wait_p)
- {
- STATISTICS_INCR (drone_request_failures);
- return (-1);
- }
-
- if (count == 10)
- {
- probe_all_gc_drones (0);
- count = 0;
- }
- else
- {
- /* Use -1 as the mask to awaken when any drone becomes idle. */
-
- sleep_awaiting_drones (default_sleep_period, ((unsigned long) -1));
- STATISTICS_INCR (drone_wait_cycles);
- }
- }
-}
-\f
-static void
-DEFUN (abort_gc_drone, (drone), struct drone_info * drone)
-{
- int restart_p = 0;
- sigset_t block_mask, signal_mask;
-
- UX_sigemptyset (&block_mask);
- UX_sigaddset ((&block_mask), SIGCONT);
- UX_sigprocmask (SIG_BLOCK, (&block_mask), (&signal_mask));
-
- *wait_mask = (((unsigned long) 1) << drone->index);
- if (drone->state != drone_idle)
- {
- if ((kill (drone->DRONE_PID, SIGQUIT)) == -1)
- restart_p = 1;
- else if (drone->state != drone_idle)
- UX_sigsuspend (&signal_mask);
- }
- *wait_mask = ((unsigned long) 0);
- UX_sigprocmask (SIG_SETMASK, (&signal_mask), 0);
- if (restart_p)
- start_gc_drones (drone->index, 1, 1);
- return;
-}
-
-static struct gc_queue_entry *
-DEFUN (find_queue_entry, (queue, queue_size, position, drone_index),
- struct gc_queue_entry * queue AND int queue_size
- AND long position AND int drone_index)
-{
- struct gc_queue_entry * entry;
- int cntr;
-
- for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++)
- {
- if ((entry->state != entry_idle)
- && (((entry->buffer)->position == position)
- || (entry->drone_index == drone_index)))
- return (entry);
- }
- return ((struct gc_queue_entry *) NULL);
-}
-
-enum allocate_request
-{
- request_read,
- request_write,
- request_ready
-};
-
-static struct gc_queue_entry *
-DEFUN (allocate_queue_entry, (queue, queue_size, position, request, mask),
- struct gc_queue_entry * queue AND int queue_size AND long position
- AND enum allocate_request request AND unsigned long * mask)
-{
- struct gc_queue_entry * entry;
- int cntr, queue_index, drone_index;
- unsigned long drone_mask;
-
- /* Examine all entries for duplicates, ergo no `break' */
-
- queue_index = -1;
- drone_mask = ((unsigned long) 0);
- for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++)
- {
- if (entry->state == entry_idle)
- queue_index = cntr;
- else if ((entry->buffer)->position == position)
- return (entry);
- else if (entry->state == entry_error)
- {
- struct buffer_info * buffer = entry->buffer;
-
- entry->retry_count += 1;
- if (entry->retry_count <= MAX_OVERLAPPED_RETRIES)
- {
- if (request == request_write)
- {
- /* This was done when originally queued, but we are paranoid. */
- (void) (verify_write (buffer->position, buffer->size,
- ((Boolean *) NULL)));
- do
- entry->drone_index = (find_idle_drone (1));
- while (!(invoke_gc_drone (entry, drone_writing, entry->buffer,
- buffer->position, buffer->size)));
- STATISTICS_INCR (writes_retried);
- }
- else
- {
- entry->drone_index = (find_idle_drone (0));
- if ((entry->drone_index != -1)
- && (invoke_gc_drone (entry, drone_reading, entry->buffer,
- buffer->position, buffer->size)))
- STATISTICS_INCR (pre_reads_retried);
- else
- STATISTICS_INCR (pre_reads_not_retried);
- }
- }
- else if (request == request_write)
- {
- STATISTICS_INCR (writes_not_deferred);
- write_data (((char *) (buffer->bottom)),
- buffer->position, buffer->size,
- "a queued buffer", ((Boolean *) NULL));
- buffer->state = buffer_idle;
- entry->state = entry_idle;
- entry->retry_count = 0;
- queue_index = cntr;
- }
- else
- /* If pre-reading, it will be taken care of later. */
- STATISTICS_INCR (pre_reads_deferred);
- }
- else if ((drone_index = (entry->drone_index)) != -1)
- drone_mask |= (((unsigned long) 1) << drone_index);
- }
-
- if (queue_index == -1)
- {
- probe_all_gc_drones (0);
- if (mask != ((unsigned long *) NULL))
- (* mask) = drone_mask;
- return ((struct gc_queue_entry *) NULL);
- }
-
- entry = (queue + queue_index);
- entry->buffer = ((struct buffer_info *) NULL);
- return (entry);
-}
-\f
-static struct buffer_info *
-DEFUN_VOID (find_idle_buffer)
-{
- int next_buffer, new_next_buffer;
- struct buffer_info *buffer;
-
- next_buffer = gc_next_buffer;
- do
- {
- new_next_buffer = (next_buffer + 1);
- if (new_next_buffer >= n_gc_buffers)
- new_next_buffer = 0;
- buffer = (gc_buffers + next_buffer);
- if (buffer->state == buffer_idle)
- {
- gc_next_buffer = new_next_buffer;
- return (buffer);
- }
- next_buffer = new_next_buffer;
- } while (next_buffer != gc_next_buffer);
-
- outf_fatal ("\n%s (find_idle_buffer): All buffers are in use!\n",
- scheme_program_name);
- Microcode_Termination (TERM_GC_OUT_OF_SPACE);
- /*NOTREACHED*/
- return (0);
-}
-
-static struct buffer_info *
-DEFUN (find_ready_buffer, (position, size), long position AND long size)
-{
- int next_buffer, new_next_buffer;
- struct buffer_info *buffer;
-
- next_buffer = gc_next_buffer;
- do
- {
- new_next_buffer = (next_buffer + 1);
- if (new_next_buffer >= n_gc_buffers)
- new_next_buffer = 0;
- buffer = (gc_buffers + next_buffer);
- if ((buffer->state == buffer_idle) /* && (buffer->size == size) */
- && (buffer->position == position))
- {
- gc_next_buffer = new_next_buffer;
- return (buffer);
- }
- next_buffer = new_next_buffer;
- } while (next_buffer != gc_next_buffer);
- return ((struct buffer_info *) NULL);
-}
-
-static struct buffer_info *
-DEFUN_VOID (get_gc_buffer)
-{
- struct buffer_info * buffer;
-
- buffer = (find_idle_buffer ());
- buffer->state = buffer_busy;
- return (buffer);
-}
-\f
-static struct buffer_info *
-DEFUN (read_buffer, (posn, size, noise),
- long posn AND long size AND char * noise)
-{
- struct gc_queue_entry * entry;
- struct buffer_info * buffer;
-
- if ((read_overlap > 0)
- && ((entry = (find_queue_entry (gc_read_queue, read_overlap, posn, -2)))
- != ((struct gc_queue_entry *) NULL))
- && ((buffer = entry->buffer) != ((struct buffer_info *) NULL)))
- {
- switch (buffer->state)
- {
- default:
- outf_error
- ("\n%s (read_buffer %s): invalid state.\n\
- \tindex = %d; state = %d; position = 0x%lx.\n",
- scheme_program_name, noise, buffer->index, buffer->state, posn);
- /* fall through */
-
- case buffer_read_error:
- /* Try synchronously, and complain then if the condition persists. */
- break;
-
- case buffer_being_read:
- {
- int count;
- struct drone_info * drone = (gc_drones + entry->drone_index);
-
- for (count = 1; (buffer->state == buffer_being_read) ; count++)
- {
- if (count == 10)
- {
- if (probe_gc_drone (drone))
- count = 0;
- else
- {
- start_gc_drones (drone->index, 1, 1);
- goto buffer_failed;
- }
- }
- else
- sleep_awaiting_drones (default_sleep_period,
- (((unsigned long) 1) << drone->index));
- STATISTICS_INCR (read_wait_cycles);
- }
-
- if (buffer->state != buffer_ready)
- {
-buffer_failed:
- entry->state = entry_idle;
- entry->retry_count = 0;
- buffer->state = buffer_idle;
- buffer->position = -1;
- STATISTICS_INCR (reads_overlapped_aborted);
- break;
- }
- STATISTICS_INCR (reads_pending);
- goto buffer_available;
- }
-
- case buffer_queued:
- STATISTICS_INCR (reads_queued);
- goto buffer_available;
-
- case buffer_ready:
- STATISTICS_INCR (reads_ready);
-
-buffer_available:
- /* This should check size, but they are all the same. */
- entry->state = entry_idle;
- entry->retry_count = 0;
- buffer->state = buffer_busy;
- STATISTICS_INCR (reads_overlapped);
- return (buffer);
- }
- }
- else if ((write_overlap > 0)
- && ((entry = (find_queue_entry (gc_write_queue, write_overlap,
- posn, -2)))
- != ((struct gc_queue_entry *) NULL)))
- {
- int index;
-
- /* This should check size, but they are all the same. */
-
- entry->state = entry_idle;
- entry->retry_count = 0;
- buffer = entry->buffer;
- index = entry->drone_index;
- if (index != -1)
- abort_gc_drone (gc_drones + index);
- buffer->state = buffer_busy;
- STATISTICS_INCR (reads_found_in_write_queue);
- return (buffer);
- }
- else if ((buffer = (find_ready_buffer (posn, size)))
- != ((struct buffer_info *) NULL))
- {
- /* This should check size, but they are all the same. */
-
- buffer->state = buffer_busy;
- STATISTICS_INCR (reads_found_ready);
- return (buffer);
- }
-
- /* (read_overlap == 0) or not pre-read. */
- {
- buffer = (find_idle_buffer ());
-
- load_data (posn, ((char *) buffer->bottom), size,
- noise, ((Boolean *) NULL));
- buffer->state = buffer_busy;
- STATISTICS_INCR (reads_not_overlapped);
- return (buffer);
- }
-}
-\f
-static void
-DEFUN (write_buffer, (buffer, position, size, success, noise),
- struct buffer_info * buffer AND long position
- AND long size AND Boolean * success AND char * noise)
-{
- if ((write_overlap > 0) && ((verify_write (position, size, success)) != -1))
- {
- unsigned long drone_mask;
- struct gc_queue_entry * entry =
- (allocate_queue_entry (gc_write_queue, write_overlap,
- position, request_write, (& drone_mask)));
-
- if (entry == ((struct gc_queue_entry *) NULL))
- {
- STATISTICS_INCR (writes_pending);
- do
- {
- sleep_awaiting_drones (default_sleep_period, drone_mask);
- entry =
- (allocate_queue_entry (gc_write_queue, write_overlap,
- position, request_write, (& drone_mask)));
- STATISTICS_INCR (write_wait_cycles);
- } while (entry == ((struct gc_queue_entry *) NULL));
- }
- else if (entry->buffer != NULL)
- {
- int index = entry->drone_index;
- struct buffer_info * old_buffer;
-
- if (index != -1)
- abort_gc_drone (gc_drones + index);
- old_buffer = entry->buffer;
- old_buffer->state = buffer_idle;
- entry->buffer = buffer;
- outf_error ("\n%s (write_buffer %s): duplicate write at 0x%lx.\n",
- scheme_program_name, noise, position);
- }
- do
- entry->drone_index = (find_idle_drone (1));
- while (!(invoke_gc_drone (entry, drone_writing, buffer, position, size)));
- STATISTICS_INCR (writes_overlapped);
- return;
- }
-
- STATISTICS_INCR (writes_not_overlapped);
- write_data (((char *) buffer->bottom), position, size, noise, success);
- buffer->state = buffer_idle;
- return;
-}
-
-static void
-DEFUN (enqueue_buffer, (entry, buffer, position, size, state),
- struct gc_queue_entry * entry AND struct buffer_info * buffer
- AND long position AND long size AND enum buffer_state state)
-{
- buffer->state = state;
- buffer->position = position;
- buffer->size = size;
- entry->buffer = buffer;
- entry->drone_index = -1;
- entry->state = entry_busy;
- return;
-}
-\f
-static void
-DEFUN (enqueue_ready_buffer, (buffer, position, size),
- struct buffer_info * buffer AND long position AND long size)
-{
- struct gc_queue_entry * entry;
-
- if ((read_overlap == 0)
- || ((entry = (allocate_queue_entry (gc_read_queue, read_overlap,
- position, request_ready,
- ((unsigned long *) NULL))))
- == ((struct gc_queue_entry *) NULL)))
- {
- write_buffer (buffer, position, size, ((char *) NULL), "a ready buffer");
- STATISTICS_INCR (ready_buffers_not_enqueued);
- return;
- }
- if (entry->buffer != NULL)
- {
- int index = entry->drone_index;
- struct buffer_info * old_buffer = entry->buffer;
-
- if (index != -1)
- abort_gc_drone (gc_drones + index);
- old_buffer->state = buffer_idle;
- outf_error ("\n%s (enqueue_ready_buffer): Duplicate pre-read at 0x%lx.\n",
- scheme_program_name, old_buffer->position);
- }
- enqueue_buffer (entry, buffer, position, size, buffer_queued);
- STATISTICS_INCR (ready_buffers_enqueued);
- return;
-}
-
-static void
-DEFUN (abort_pre_read, (position), long position)
-{
- int index;
- struct gc_queue_entry * entry;
- struct buffer_info * buffer;
-
- entry = (find_queue_entry (gc_read_queue, read_overlap, position, -2));
- if (entry == ((struct gc_queue_entry *) NULL))
- return;
- buffer = entry->buffer;
- if (buffer->state == buffer_queued)
- {
- entry->state = entry_idle;
- entry->retry_count = 0;
- write_buffer (buffer, buffer->position, buffer->size,
- ((Boolean *) NULL), "a queued buffer");
- STATISTICS_INCR (pre_reads_requeued_as_writes);
- return;
- }
- index = entry->drone_index;
- if (index != -1)
- abort_gc_drone (gc_drones + index);
- buffer->state = buffer_idle;
- buffer->position = -1;
- entry->state = entry_idle;
- entry->retry_count = 0;
- STATISTICS_INCR (pre_reads_aborted);
- return;
-}
-\f
-static int
-DEFUN (pre_read_buffer, (position, size), long position AND long size)
-{
- struct gc_queue_entry * rentry, * wentry;
- struct buffer_info * buffer;
-
- if (read_overlap <= 0)
- return (0);
-
- /* Do this first, to guarantee that we can insert it in the queue.
- Otherwise there is no point in aborting a write, etc.
- It is not really allocated until enqueue_buffer or invoke_gc_drone.
- */
-
- rentry = (allocate_queue_entry (gc_read_queue, read_overlap,
- position, request_read,
- ((unsigned long *) NULL)));
- if (rentry == ((struct gc_queue_entry *) NULL))
- {
- STATISTICS_INCR (pre_reads_ignored);
- return (0);
- }
- else if (rentry->buffer != NULL)
- /* Already being pre-read */
- return (1);
-
- if ((write_overlap > 0)
- && ((wentry = (find_queue_entry (gc_write_queue, write_overlap,
- position, -2)))
- != ((struct gc_queue_entry *) NULL)))
- {
- int index = wentry->drone_index;
-
- buffer = wentry->buffer;
- if (index != -1)
- abort_gc_drone (gc_drones + index);
- wentry->state = entry_idle;
- wentry->retry_count = 0;
- enqueue_buffer (rentry, buffer, position, size, buffer_queued);
- STATISTICS_INCR (pre_reads_found_in_write_queue);
- return (1);
- }
- else if ((buffer = (find_ready_buffer (position, size)))
- != ((struct buffer_info *) NULL))
- {
- enqueue_buffer (rentry, buffer, position, size, buffer_ready);
- STATISTICS_INCR (pre_reads_found_ready);
- return (1);
- }
-
- if (((rentry->drone_index = (find_idle_drone (0))) == -1)
- || (!(invoke_gc_drone (rentry, drone_reading, (find_idle_buffer ()),
- position, size))))
- {
- STATISTICS_INCR (pre_reads_not_started);
- return (0);
- }
- STATISTICS_INCR (pre_reads_started);
- return (1);
-}
-\f
-static void
-DEFUN (handle_drone_death, (drone), struct drone_info * drone)
-{
- struct buffer_info * buffer;
- struct gc_queue_entry * entry;
-
- STATISTICS_INCR (drones_found_dead);
- if ((entry = (find_queue_entry (gc_write_queue, write_overlap,
- -1, drone->index)))
- != ((struct gc_queue_entry *) NULL))
- {
- buffer = entry->buffer;
- entry->state = entry_idle;
- entry->retry_count = 0;
- if (buffer->state != buffer_idle)
- {
- write_buffer (buffer, buffer->position, buffer->size,
- ((Boolean *) NULL), "a queued buffer whose drone died");
- STATISTICS_INCR (writes_restarted);
- }
- }
- else if ((entry = (find_queue_entry (gc_read_queue, read_overlap,
- -1, drone->index)))
- != ((struct gc_queue_entry *) NULL))
- {
- buffer = entry->buffer;
- if (buffer->state != buffer_ready)
- {
- entry->state = entry_idle;
- entry->retry_count = 0;
- buffer->state = buffer_idle;
- STATISTICS_INCR (pre_reads_restarted);
- (void) (pre_read_buffer (buffer->position, buffer->size));
- }
- }
- return;
-}
-
-static void
-DEFUN (await_io_completion, (start_p), int start_p)
-{
- int cntr;
- struct buffer_info * buffer;
- struct gc_queue_entry * entry;
-
- if (n_gc_drones != 0)
- probe_all_gc_drones (1);
- if (start_p)
- {
- for (cntr = 0, buffer = gc_buffers; cntr < n_gc_buffers; cntr++, buffer++)
- {
- buffer->state = buffer_idle;
- buffer->position = -1;
- }
- for (cntr = 0, entry = gc_read_queue; cntr < read_overlap; cntr++, entry++)
- entry->state = entry_idle;
- for (cntr = 0, entry = gc_write_queue; cntr < write_overlap;
- cntr++, entry++)
- entry->state = entry_idle;
- }
- return;
-}
-\f
-#define CAN_RECONFIGURE_GC_BUFFERS 1
-
-#define GC_BUFFER_ALLOCATION(space) 0
-
-#define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd) \
- sysV_initialize (ft, size, ro, wo, gcd)
-
-#define RE_INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd) \
- sysV_initialize (ft, size, ro, wo, gcd)
-
-#define BUFFER_SHUTDOWN(lt) sysV_shutdown (lt)
-
-#define INITIALIZE_IO() await_io_completion (1)
-#define AWAIT_IO_COMPLETION() await_io_completion (0)
-
-#define INITIAL_SCAN_BUFFER() free_buffer /* NOP */
-#define INITIAL_FREE_BUFFER() get_gc_buffer ()
-#define OTHER_BUFFER(buffer) get_gc_buffer ()
-
-#define GC_BUFFER_BOTTOM(buffer) ((SCHEME_OBJECT *) buffer->bottom)
-#define GC_BUFFER_TOP(buffer) ((SCHEME_OBJECT *) buffer->top)
-
-#define READ_BUFFER read_buffer
-#define DUMP_BUFFER write_buffer
-#define PRE_READ_BUFFER pre_read_buffer
-#define ABORT_PRE_READ abort_pre_read
-#define ENQUEUE_READY_BUFFER enqueue_ready_buffer
-
-#define LOAD_BUFFER(buffer, position, size, noise) \
- buffer = (read_buffer (position, size, noise))
-\f
-#else /* not USE_SYSV_SHARED_MEMORY */
-
-static struct buffer_info
- * gc_disk_buffer_1,
- * gc_disk_buffer_2;
-
-#define CAN_RECONFIGURE_GC_BUFFERS 0
-
-#define GC_BUFFER_ALLOCATION(space) space
-
-#define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd) \
-do { \
- SCHEME_OBJECT * ptr = (start); \
- \
- gc_disk_buffer_1 = ((struct buffer_info *) ptr); \
- gc_disk_buffer_2 = ((struct buffer_info *) \
- (ptr + gc_total_buffer_size)); \
- open_gc_file (size, 1); \
-} while (0)
-
-#define BUFFER_SHUTDOWN(lt) close_gc_file (lt)
-
-#define INITIALIZE_IO() do { } while (0)
-#define AWAIT_IO_COMPLETION() do { } while (0)
-
-#define INITIAL_FREE_BUFFER() gc_disk_buffer_1
-#define INITIAL_SCAN_BUFFER() OTHER_BUFFER(free_buffer)
-
-/* (gc_disk_buffer_1 - (gc_disk_buffer_2 - (buffer))) does not work
- because scan_buffer is not initialized until after scanning
- constant space. */
-
-#define OTHER_BUFFER(buffer) (((buffer) == gc_disk_buffer_1) \
- ? gc_disk_buffer_2 \
- : gc_disk_buffer_1)
-
-#define GC_BUFFER_BOTTOM(buffer) ((SCHEME_OBJECT *) (buffer))
-#define GC_BUFFER_TOP(buffer) (((SCHEME_OBJECT *) (buffer)) + gc_buffer_size)
-
-static int
-DEFUN (catastrophic_failure, (name), char * name)
-{
- outf_fatal ("\n%s: Procedure %s should never be called!\n",
- scheme_program_name, name);
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- return (0);
-}
-
-#define GCDIE(m) catastrophic_failure (m)
-
-#define RE_INITIALIZE_GC_BUFFERS(f,s,z,r,w,g) \
- GCDIE ("RE_INITIALIZE_GC_BUFFERS")
-#define READ_BUFFER(p,s,n) GCDIE ("read_buffer")
-#define PRE_READ_BUFFER(p,s) GCDIE ("pre_read_buffer")
-#define ABORT_PRE_READ(p) GCDIE ("abort_pre_read")
-#define ENQUEUE_READY_BUFFER(b,p,s) GCDIE ("enqueue_ready_buffer")
-
-#define LOAD_BUFFER(buffer, position, size, noise) \
- load_data (position, ((char *) buffer), size, noise, ((Boolean *) NULL))
-
-#define DUMP_BUFFER(buffer, position, size, successp, noise) \
- write_data (((char *) buffer), position, size, noise, successp)
-
-#endif /* not USE_SYSV_SHARED_MEMORY */
-\f
-#define DUMP_SCAN_BUFFER(success) \
- DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes, \
- success, "the scan buffer")
-
-#define DUMP_FREE_BUFFER(success) \
- DUMP_BUFFER (free_buffer, free_position, gc_buffer_bytes, \
- success, "the free buffer")
-
-#define LOAD_SCAN_BUFFER() \
- LOAD_BUFFER (scan_buffer, scan_position, gc_buffer_bytes, \
- "the scan buffer")
-
-#define LOAD_FREE_BUFFER() \
- LOAD_BUFFER (free_buffer, free_position, gc_buffer_bytes, \
- "the free buffer")
-
-static int
-DEFUN (next_exponent_of_two, (value), int value)
-{
- unsigned int power;
- int exponent;
-
- if (value < 0)
- return (0);
-
- for (power = 1, exponent = 0;
- power < ((unsigned int) value);
- power = (power << 1), exponent += 1)
- ;
- return (exponent);
-}
-\f
-/* Hacking the gc file */
-
-static int
- saved_gc_file = -1,
- saved_read_overlap,
- saved_write_overlap;
-
-static long
- saved_start_position,
- saved_end_position;
-
-int
-DEFUN (swap_gc_file, (fid), int fid)
-{
- /* Do not use overlapped I/O for fasdump because the drone processes
- will continue writing to the same old file!
- */
- saved_gc_file = gc_file;
- saved_read_overlap = read_overlap;
- saved_write_overlap = write_overlap;
- saved_start_position = gc_file_start_position;
- saved_end_position = gc_file_end_position;
- gc_file = fid;
- read_overlap = 0;
- write_overlap = 0;
- gc_file_end_position
- = (absolute_gc_file_end_position - gc_file_start_position);
- gc_file_start_position = 0L;
- return (saved_gc_file);
-}
-
-void
-DEFUN_VOID (restore_gc_file)
-{
- gc_file = saved_gc_file;
- read_overlap = saved_read_overlap;
- write_overlap = saved_write_overlap;
- gc_file_start_position = saved_start_position;
- gc_file_end_position = saved_end_position;
- saved_gc_file = -1;
- return;
-}
-
-static void
-DEFUN (close_gc_file, (unlink_p), int unlink_p)
-{
-#ifdef HAVE_LOCKF
- if (gc_file != -1)
- {
- if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) < 0)
- perror ("lseek");
- if ((lockf (gc_file, F_ULOCK,
- (gc_file_end_position - gc_file_start_position)))
- < 0)
- perror ("lockf");
- }
-#endif
- if ((gc_file != -1) && ((close (gc_file)) == -1))
- outf_error ("\n%s (close_gc_file): error: GC file = \"%s\"; errno = %s.\n",
- scheme_program_name, gc_file_name, (error_name (errno)));
- gc_file = -1;
- if (!keep_gc_file_p && unlink_p)
- unlink (gc_file_name);
- OS_free (gc_file_name);
- gc_file_name = 0;
- keep_gc_file_p = 0;
-}
-\f
-#define EMPTY_STRING_P(string) \
- (((string) == ((char *) NULL)) || ((*(string)) == '\0'))
-
-static void
-DEFUN (termination_open_gc_file, (operation, extra),
- CONST char * operation AND CONST char * extra)
-{
- if ((! (EMPTY_STRING_P (operation))) && (! (EMPTY_STRING_P (extra))))
- outf_fatal
- ("%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n\t%s.\n",
- scheme_program_name, operation, gc_file_name, (error_name (errno)),
- extra);
- else if (! (EMPTY_STRING_P (operation)))
- outf_fatal
- ("%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n",
- scheme_program_name, operation, gc_file_name, (error_name (errno)));
- else if (! (EMPTY_STRING_P (extra)))
- outf_fatal ("\t%s.\n", extra);
- termination_init_error ();
- /*NOTREACHED*/
-}
-
-char *
-DEFUN (make_gc_file_name, (suffix), CONST char * suffix)
-{
- unsigned int s = (strlen (suffix));
- if ((option_gc_file[0]) == SUB_DIRECTORY_DELIMITER)
- {
- unsigned int n
- = (((strrchr (option_gc_file, SUB_DIRECTORY_DELIMITER))
- - option_gc_file)
- + 1);
- char * result = (OS_malloc (n + s + 1));
- strncpy (result, option_gc_file, n);
- (result[n]) = '\0';
- strcat (result, suffix);
- return (result);
- }
- {
- unsigned int l = (strlen (option_gc_directory));
- if ((option_gc_directory [l - 1]) == SUB_DIRECTORY_DELIMITER)
- {
- unsigned int n = l;
- char * result = (OS_malloc (n + s + 1));
- sprintf (result, "%s%s", option_gc_directory, suffix);
- return (result);
- }
- else
- {
- unsigned int n = (l + 1);
- char * result = (OS_malloc (n + s + 1));
- sprintf (result, "%s%c%s",
- option_gc_directory, SUB_DIRECTORY_DELIMITER, suffix);
- return (result);
- }
- }
-}
-
-int
-DEFUN (allocate_gc_file, (name), char * name)
-{
- /* `name' must end in 6 `X' characters. */
- char * exxes = (name + ((strlen (name)) - 6));
- unsigned int n = 0;
-
- while (n < 1000000)
- {
- sprintf (exxes, "%06d", n);
- if (OS_file_touch (name))
- return (1);
- n += 1;
- }
- return (0);
-}
-
-void
-DEFUN (protect_gc_file_name, (name), CONST char * name)
-{
- CONST char ** p = (dstack_alloc (sizeof (char *)));
- (*p) = name;
- transaction_record_action (tat_always, OS_free, p);
-}
-
-#ifndef _POSIX_VERSION
-extern off_t EXFUN (lseek, (int, off_t, int));
-#endif
-
-static void
-DEFUN (open_gc_file, (size, unlink_p),
- long size AND
- int unlink_p)
-{
- struct stat file_info;
- int flags;
- Boolean temp_p, exists_p;
-
- gc_file_name
- = (make_gc_file_name
- (((option_gc_file[0]) == SUB_DIRECTORY_DELIMITER)
- ? ((strrchr (option_gc_file, SUB_DIRECTORY_DELIMITER)) + 1)
- : option_gc_file));
-
- {
- unsigned int n = (strlen (option_gc_file));
- if ((n >= 6) && ((strcmp ((option_gc_file + (n - 6)), "XXXXXX")) == 0))
- {
- if (!allocate_gc_file (gc_file_name))
- {
- outf_fatal
- ("%s: Unable to allocate a temporary file for the spare heap.\n",
- scheme_program_name);
- termination_open_gc_file (0, 0);
- /*NOTREACHED*/
- }
- temp_p = true;
- }
- else
- temp_p = false;
- }
-
- flags = GC_FILE_FLAGS;
- gc_file_start_position = (ALIGN_UP_TO_IO_PAGE (option_gc_start_position));
- gc_file_end_position = option_gc_end_position;
- if (gc_file_end_position == -1)
- gc_file_end_position = (gc_file_start_position + size);
- gc_file_end_position = (ALIGN_DOWN_TO_IO_PAGE (gc_file_end_position));
- if (gc_file_end_position < gc_file_start_position)
- {
- outf_fatal
- ("%s (open_gc_file): file bounds are inconsistent.\n\
- \trequested start = 0x%lx;\taligned start = 0x%lx.\n\
- \trequested end = 0x%lx;\taligned end = 0x%lx.\n",
- scheme_program_name,
- option_gc_start_position, gc_file_start_position,
- option_gc_end_position, gc_file_end_position);
- termination_open_gc_file (0, 0);
- }
-
- absolute_gc_file_end_position = gc_file_end_position;
-
- if ((stat (gc_file_name, &file_info)) == -1)
- {
- exists_p = false;
- can_dump_directly_p = true;
- flags |= O_EXCL;
- }
- else
- {
-#ifdef __unix__
- /* If it is S_IFCHR, it should determine the IO block
- size and make sure that it will work.
- I don't know how to do that.
- ustat(2) will do that for a mounted file system,
- but obviously, if a raw device file is used,
- there better not be a file system on the device or partition.
- Does st_blksize give the correct value? -- Apparently not.
- */
-
- exists_p = true;
- if ((file_info.st_mode & S_IFMT) == S_IFCHR)
- can_dump_directly_p = false;
-
- else if (((file_info.st_mode & S_IFMT) != S_IFREG)
- && ((file_info.st_mode & S_IFMT) != S_IFBLK))
- {
- outf_fatal
- ("%s (open_gc_file): file \"%s\" has unknown/bad type 0x%x.\n\
- \tKnown types: S_IFREG (0x%x), S_IFBLK (0x%x), S_IFCHR (0x%x).\n",
- scheme_program_name, gc_file_name,
- ((int) (file_info.st_mode & S_IFMT)),
- S_IFREG, S_IFBLK, S_IFCHR);
- termination_open_gc_file (((char *) NULL), ((char *) NULL));
- }
- else
- can_dump_directly_p = true;
-#else
- /* Assume that it will be a normal file. */
- exists_p = true;
- can_dump_directly_p = true;
-#endif
- }
-
- gc_file = (open (gc_file_name, flags, GC_FILE_MASK));
- if (gc_file == -1)
- {
-#ifndef __unix__
- /* errno does not give sufficient information except under unix. */
-
- int saved_errno = errno;
- char
- directory_buffer[FILE_NAME_LENGTH],
- * directory, * directory_end;
-
- directory = &directory_buffer[0];
- strcpy (directory, gc_file_name);
- directory_end = (strrchr (directory, SUB_DIRECTORY_DELIMITER));
- if (directory_end != ((char *) NULL))
- * directory_end = '\0';
- if ((access (directory, F_OK)) != 0)
- {
- outf_fatal
- ("\n%s (open_gc_file): GC directory \"%s\" does not exist.\n",
- scheme_program_name, directory);
- termination_open_gc_file (((char *) NULL), ((char *) NULL));
- }
- else if ((access (directory, W_OK)) != 0)
- {
- outf_fatal
- ("\n%s (open_gc_file): GC directory \"%s\" is read protected.\n",
- scheme_program_name, directory);
- termination_open_gc_file (((char *) NULL), ((char *) NULL));
- }
- else
- errno = saved_errno;
-#endif /* not __unix__ */
- termination_open_gc_file ("open", ((char *) NULL));
- }
-
- keep_gc_file_p = (option_gc_keep || (exists_p && (!temp_p)));
-
-#ifdef UNLINK_BEFORE_CLOSE
- if (!keep_gc_file_p && unlink_p)
- unlink (gc_file_name);
-#endif
-
-#ifdef HAVE_PREALLOC
- if (!exists_p)
- prealloc (gc_file, ((unsigned int) gc_file_end_position));
-#endif
-
-#ifdef HAVE_LOCKF
- if (exists_p)
- {
- if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) < 0)
- termination_open_gc_file ("lseek", ((char *) NULL));
-
- if ((lockf (gc_file, F_TLOCK, size)) < 0)
- termination_open_gc_file
- ("lockf",
- "The GC file is probably being used by another process");
- }
-#endif
-
- gc_file_current_position = -1; /* Unknown position */
-
-#ifdef __unix__
- /* Determine whether it is a seekable file. */
- if (exists_p && ((file_info.st_mode & S_IFMT) == S_IFCHR))
- {
-#ifdef HAVE_FCNTL
- int fcntl_flags;
-#endif
- Boolean ignore;
- static char message[] = "This is a test message to the GC file.\n";
- char * buffer;
-
- buffer = ((char *) aligned_heap);
- strcpy (buffer, &message[0]);
- strncpy ((buffer + ((sizeof (message)) - 1)),
- buffer,
- (IO_PAGE_SIZE - (sizeof (message))));
- (* (buffer + (IO_PAGE_SIZE - 1))) = '\n';
-
-#ifdef HAVE_FCNTL
- fcntl_flags = (fcntl (gc_file, F_GETFL, 0));
- if (fcntl_flags != (-1))
- fcntl (gc_file, F_SETFL, (fcntl_flags | O_NONBLOCK));
-#endif
-
- write_data (buffer,
- (gc_file_start_position + ((long) IO_PAGE_SIZE)),
- ((long) IO_PAGE_SIZE),
- "a test buffer (1)",
- &ignore);
- load_data (gc_file_start_position,
- (buffer + IO_PAGE_SIZE),
- ((long) (2 * IO_PAGE_SIZE)),
- "a test buffer (2)",
- &ignore);
- if ((strncmp (buffer, (buffer + (2 * IO_PAGE_SIZE)), IO_PAGE_SIZE)) != 0)
- {
- outf_fatal ("\n%s (open_gc_file): \"%s\" is not a seek-able device.\n",
- scheme_program_name, gc_file_name);
- termination_open_gc_file (((char *) NULL), ((char *) NULL));
- }
-#ifdef HAVE_FCNTL
- if (fcntl_flags != (-1))
- fcntl (gc_file, F_SETFL, fcntl_flags);
-#endif
- }
-#endif /* __unix__ */
-}
-\f
-#define CONSTANT_SPACE_FUDGE 128
-
-Boolean
-DEFUN (update_allocator_parameters, (ctop), SCHEME_OBJECT * ctop)
-{
- SCHEME_OBJECT * htop;
- long new_end;
-
- /* buffer for impurify, etc. */
- ctop = ((SCHEME_OBJECT *)
- (ALIGN_UP_TO_IO_PAGE (ctop + CONSTANT_SPACE_FUDGE)));
- htop = ((SCHEME_OBJECT *)
- (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address)));
- if (ctop >= htop)
- return (FALSE);
-
- new_end = (((char *) htop) - ((char *) ctop));
- new_end = (CEILING (new_end, gc_buffer_bytes));
- new_end += gc_file_start_position;
- if ((new_end > absolute_gc_file_end_position)
- && (! option_gc_end_position))
- return (FALSE);
-
- gc_file_end_position = new_end;
- Constant_Top = ctop;
- Heap_Bottom = Constant_Top;
- Heap_Top = htop;
- aligned_heap = Heap_Bottom;
- Local_Heap_Base = Heap_Bottom;
- Unused_Heap_Bottom = Heap_Top;
- Unused_Heap_Top = Highest_Allocated_Address;
- Free = Heap_Bottom;
- SET_MEMTOP (Heap_Top - GC_Reserve);
- return (TRUE);
-}
-
-Boolean
-DEFUN_VOID (recompute_gc_end_position)
-{
- SCHEME_OBJECT * htop;
- long new_end, delta;
-
- if ((((gc_file_end_position - gc_file_start_position) % gc_buffer_bytes)
- == 0)
- || option_gc_end_position)
- return (TRUE);
-
- htop = ((SCHEME_OBJECT *)
- (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address)));
- new_end = (CEILING ((((char *) htop) - ((char *) Constant_Top)),
- gc_buffer_bytes));
- new_end += gc_file_start_position;
- if (new_end <= absolute_gc_file_end_position)
- {
- gc_file_end_position = new_end;
- return (TRUE);
- }
- delta = (FLOOR ((absolute_gc_file_end_position - gc_file_start_position),
- gc_buffer_bytes));
- if ((((char *) Constant_Top) + delta) <= (((char *) Free) + GC_Reserve))
- /* This should really GC and retry, but ... */
- return (FALSE);
- Heap_Top = ((SCHEME_OBJECT *) (((char *) Constant_Top) + delta));
- SET_MEMTOP (Heap_Top - GC_Reserve);
- return (TRUE);
-}
-\f
-void
-DEFUN_VOID (reset_allocator_parameters)
-{
- GC_Reserve = 4500;
- GC_Space_Needed = 0;
- Stack_Bottom = ((SCHEME_OBJECT *)
- (ALIGN_UP_TO_IO_PAGE (Lowest_Allocated_Address)));
- Stack_Top = ((SCHEME_OBJECT *)
- (ALIGN_DOWN_TO_IO_PAGE
- (Stack_Bottom + (STACK_ALLOCATION_SIZE (saved_stack_size)))));
- Constant_Space = Stack_Top;
- Free_Constant = Constant_Space;
- (void) update_allocator_parameters (Free_Constant);
- SET_CONSTANT_TOP ();
- ALIGN_FLOAT (Free);
- INITIALIZE_STACK ();
- STACK_RESET ();
- return;
-}
-
-void
-DEFUN (Clear_Memory, (heap_size, stack_size, constant_space_size),
- int heap_size
- AND int stack_size
- AND int constant_space_size)
-{
- saved_heap_size = heap_size;
- saved_constant_size = constant_space_size;
- saved_stack_size = stack_size;
- reset_allocator_parameters ();
-}
-
-void
-DEFUN_VOID (Reset_Memory)
-{
- BUFFER_SHUTDOWN (1);
- HEAP_FREE (Lowest_Allocated_Address);
- DEALLOCATE_REGISTERS ();
- return;
-}
-\f
-#define BLOCK_TO_IO_SIZE(size) \
- ((ALIGN_UP_TO_IO_PAGE ((size) * (sizeof (SCHEME_OBJECT)))) \
- / (sizeof (SCHEME_OBJECT)))
-
-static int
-DEFUN (set_gc_buffer_sizes, (new_buffer_shift), unsigned long new_buffer_shift)
-{
- unsigned long
- new_buffer_size, new_buffer_bytes, new_buffer_byte_shift,
- new_buffer_overlap_bytes, new_extra_buffer_size;
-
- new_buffer_size = (1L << new_buffer_shift);
- new_buffer_bytes = (new_buffer_size * (sizeof (SCHEME_OBJECT)));
- if (! (ALIGNED_TO_IO_PAGE_P (new_buffer_bytes)))
- {
- outf_error
- ("%s (Setup_Memory): improper new_buffer_size.\n\
- \tIO_PAGE_SIZE = 0x%lx bytes.\n\
- \tgc_buffer_size = 0x%lx bytes = 0x%lx objects.\n\
- \tIO_PAGE_SIZE should divide gc_buffer_size.\n",
- scheme_program_name,
- ((long) IO_PAGE_SIZE),
- new_buffer_bytes, new_buffer_size);
- return (-1);
- }
-
- new_buffer_byte_shift = (next_exponent_of_two (new_buffer_bytes));
- if ((((unsigned long) 1L) << new_buffer_byte_shift) != new_buffer_bytes)
- {
- outf_error
- ("%s (Setup_Memory): gc_buffer_bytes (0x%lx) is not a power of 2.\n",
- scheme_program_name, new_buffer_bytes);
- return (-1);
- }
-
- new_buffer_overlap_bytes = IO_PAGE_SIZE;
- new_extra_buffer_size
- = (new_buffer_overlap_bytes / (sizeof (SCHEME_OBJECT)));
- if ((new_extra_buffer_size * (sizeof (SCHEME_OBJECT)))
- != new_buffer_overlap_bytes)
- {
- outf_error
- (" %s (Setup_Memory): improper IO_PAGE_SIZE.\n\
- \tIO_PAGE_SIZE = 0x%lx; (sizeof (SCHEME_OBJECT)) = 0x%lx.\n\
- \t(sizeof (SCHEME_OBJECT)) should divide IO_PAGE_SIZE.\n",
- scheme_program_name,
- ((long) IO_PAGE_SIZE), ((long) (sizeof (SCHEME_OBJECT))));
- return (-1);
- }
-
- gc_buffer_shift = new_buffer_shift;
- gc_buffer_size = new_buffer_size;
- gc_buffer_bytes = new_buffer_bytes;
- gc_buffer_mask = (gc_buffer_size - 1);
- gc_buffer_byte_shift = new_buffer_byte_shift;
- gc_buffer_overlap_bytes = new_buffer_overlap_bytes;
- gc_extra_buffer_size = new_extra_buffer_size;
- gc_buffer_remainder_bytes = (gc_buffer_bytes - gc_buffer_overlap_bytes);
- gc_total_buffer_size = (gc_buffer_size + gc_extra_buffer_size);
- return (0);
-}
-\f
-void
-DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size),
- int heap_size
- AND int stack_size
- AND int constant_space_size)
-{
- SCHEME_OBJECT test_value;
- int real_stack_size;
- long gc_buffer_allocation;
-
- ALLOCATE_REGISTERS ();
-
- /* Consistency check 1 */
- if (heap_size == 0)
- {
- outf_fatal ("%s (Setup_Memory): Configuration won't hold initial data.\n",
- scheme_program_name);
- termination_init_error ();
- /*NOTREACHED*/
- }
-
- real_stack_size = (STACK_ALLOCATION_SIZE (stack_size));
-
- /* add log(1024)/log(2) to exponent */
- if ((set_gc_buffer_sizes (10
- + (next_exponent_of_two (option_gc_window_size))))
- != 0)
- parameterization_termination (1, 1);
-
- /* Use multiples of IO_PAGE_SIZE. */
-
- heap_size = (BLOCK_TO_IO_SIZE (heap_size));
- constant_space_size = (BLOCK_TO_IO_SIZE (constant_space_size));
- real_stack_size = (BLOCK_TO_IO_SIZE (real_stack_size));
- gc_buffer_allocation = (GC_BUFFER_ALLOCATION (2 * gc_total_buffer_size));
-
- /* Allocate. */
-
- ALLOCATE_HEAP_SPACE ((heap_size
- + constant_space_size + real_stack_size
- + gc_buffer_allocation
- + (IO_PAGE_SIZE / (sizeof (SCHEME_OBJECT)))),
- Lowest_Allocated_Address,
- Highest_Allocated_Address);
-
- /* Consistency check 2 */
- if (Lowest_Allocated_Address == NULL)
- {
- outf_fatal
- ("%s (Setup_Memory): Not enough memory for this configuration.\n",
- scheme_program_name);
- termination_init_error ();
- /*NOTREACHED*/
- }
-
- Highest_Allocated_Address -= gc_buffer_allocation;
-
- /* Consistency check 3 */
- test_value =
- (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address));
-
- if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
- ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
- {
- outf_fatal
- ("%s (Setup_Memory): \
- Largest address does not fit in datum field of object.\n\
- \tAllocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n",
- scheme_program_name);
- Reset_Memory ();
- termination_init_error ();
- /*NOTREACHED*/
- }
-
- Clear_Memory (heap_size, stack_size, constant_space_size);
- INITIALIZE_GC_BUFFERS (1,
- Highest_Allocated_Address,
- ((sizeof (SCHEME_OBJECT))
- * (CEILING ((heap_size + constant_space_size),
- gc_buffer_size))),
- option_gc_read_overlap,
- option_gc_write_overlap,
- option_gc_drone);
- return;
-}
-\f
-/* Utilities for the GC proper. */
-
-static void
-DEFUN (enqueue_free_buffer, (success), Boolean * success)
-{
- int diff;
-
- diff = ((free_position - pre_read_position) >> gc_buffer_byte_shift);
- if (diff >= read_overlap)
- DUMP_FREE_BUFFER (success);
- else
- {
- ENQUEUE_READY_BUFFER (free_buffer, free_position, gc_buffer_bytes);
- read_queue_bitmask |= (1L << diff);
- }
- return;
-}
-
-static void
-DEFUN_VOID (schedule_pre_reads)
-{
- int cntr;
- long position;
- unsigned long bit;
-
- if (pre_read_position == scan_position)
- {
- read_queue_bitmask = (read_queue_bitmask >> 1);
- pre_read_position += gc_buffer_bytes;
- }
- for (cntr = 0, bit = 1L, position = pre_read_position;
- ((cntr < read_overlap) && (position < free_position));
- cntr++, bit = (bit << 1), position += gc_buffer_bytes)
- {
- if ((read_queue_bitmask & bit) != bit)
- if (PRE_READ_BUFFER (position, gc_buffer_bytes))
- read_queue_bitmask |= bit;
- }
- return;
-}
-
-static void
-DEFUN_VOID (abort_pre_reads)
-{
- while (scan_position > pre_read_position)
- {
- ABORT_PRE_READ (pre_read_position);
- pre_read_position += gc_buffer_bytes;
- read_queue_bitmask = (read_queue_bitmask >> 1);
- }
- schedule_pre_reads ();
- return;
-}
-\f
-static void
-DEFUN (reload_scan_buffer, (skip), unsigned long skip)
-{
- scan_position += (skip << gc_buffer_byte_shift);
- virtual_scan_pointer += (skip << gc_buffer_shift);
-
- if ((read_overlap > 0) && (scan_position > pre_read_position))
- abort_pre_reads ();
-
- if (scan_position == free_position)
- {
- pre_read_position = (free_position + gc_buffer_bytes);
- read_queue_bitmask = 0L;
- scan_buffer = free_buffer;
- scan_buffer_bottom = free_buffer_bottom;
- scan_buffer_top = free_buffer_top;
- return;
- }
- LOAD_SCAN_BUFFER ();
- scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
- scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
- *scan_buffer_top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
-
- if (read_overlap > 0)
- schedule_pre_reads ();
-}
-
-SCHEME_OBJECT *
-DEFUN (dump_and_reload_scan_buffer, (end, success),
- SCHEME_OBJECT * end AND
- Boolean * success)
-{
- unsigned long number_to_skip = (end - scan_buffer_top);
- DUMP_SCAN_BUFFER (success);
- reload_scan_buffer (1 + (number_to_skip >> gc_buffer_shift));
- return (scan_buffer_bottom + (number_to_skip & gc_buffer_mask));
-}
-\f
-SCHEME_OBJECT *
-DEFUN (dump_and_reset_free_buffer, (current_free, success),
- SCHEME_OBJECT * current_free AND
- Boolean * success)
-{
- unsigned long overflow = (current_free - free_buffer_top);
- SCHEME_OBJECT * from = free_buffer_top;
- Boolean buffer_overlap_p = extension_overlap_p;
- Boolean same_buffer_p = (scan_buffer == free_buffer);
-
- if (read_overlap > 0)
- {
- if (buffer_overlap_p)
- {
- extension_overlap_p = false;
- next_scan_buffer = free_buffer;
- }
- else if (!same_buffer_p)
- enqueue_free_buffer (success);
- }
- else if (!same_buffer_p)
- DUMP_FREE_BUFFER (success);
-
- /* Otherwise there is no need to dump now, it will be dumped
- when scan is dumped. Note that the next buffer may be dumped
- before this one, but there should be no problem lseeking past the
- end of file. */
- free_position += gc_buffer_bytes;
- free_buffer = (OTHER_BUFFER (scan_buffer));
- free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer));
- free_buffer_top = (GC_BUFFER_TOP (free_buffer));
- {
- SCHEME_OBJECT * into = free_buffer_bottom;
- SCHEME_OBJECT * end = (into + overflow);
- while (into < end)
- (*into++) = (*from++);
- if (same_buffer_p && (!buffer_overlap_p))
- (*scan_buffer_top)
- = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
- return (into);
- }
-}
-\f
-/* These utilities are needed when pointers fall accross window boundaries.
-
- Between both they effectively do a dump_and_reload_scan_buffer, in two
- stages.
-*/
-
-void
-DEFUN (extend_scan_buffer, (to_where, current_free),
- char * to_where AND
- SCHEME_OBJECT * current_free)
-{
- fast char * source, * dest;
- long new_scan_position = (scan_position + gc_buffer_bytes);
-
- /* Is there buffer overlap?, i.e. is the next bufferful the one cached
- in the free pointer window?
- */
-
- scan_buffer_extended_p = true;
- dest = ((char *) scan_buffer_top);
- extension_overlap_length = (to_where - dest);
- extension_overlap_p = (new_scan_position == free_position);
-
- if (extension_overlap_p)
- {
- long temp;
-
- source = ((char *) free_buffer_bottom);
- temp = (((char *) current_free) - source);
- if (temp < extension_overlap_length)
- {
- /* This should only happen when Scan and Free are very close. */
- extension_overlap_length = temp;
- }
- }
- else if (read_overlap == 0)
- {
- load_data (new_scan_position, dest, gc_buffer_overlap_bytes,
- "the next scan buffer", ((Boolean *) NULL));
- return;
- }
- else
- {
- LOAD_BUFFER (next_scan_buffer, new_scan_position,
- gc_buffer_bytes, "the next scan buffer");
- source = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer)));
- }
-
- while (dest < to_where)
- *dest++ = *source++;
- return;
-}
-
-char *
-DEFUN (end_scan_buffer_extension, (to_relocate), char * to_relocate)
-{
- char * result;
- if (extension_overlap_p)
- {
- /* There was overlap between the scan buffer and the free buffer,
- there may no longer be, but dump_and_reload_scan_buffer will
- get us the correct next buffer.
- The old scan buffer may be written, but the while loop below
- will read storage contiguous to it (in the buffer extension).
- */
- SCHEME_OBJECT old, new;
- fast char * source, * dest, * limit;
-
- extension_overlap_p = false;
- source = ((char *) scan_buffer_top);
- old = (* ((SCHEME_OBJECT *) source));
- limit = (source + extension_overlap_length);
- dest = ((char *) (dump_and_reload_scan_buffer (scan_buffer_top, 0)));
- /* The following is only necesary if we are reusing the scan buffer. */
- new = (* scan_buffer_top);
- (* ((SCHEME_OBJECT *) source)) = old;
- result = (dest + (to_relocate - source));
- while (source < limit)
- *dest++ = *source++;
- (* scan_buffer_top) = new;
- }
- else if (next_scan_buffer == ((struct buffer_info *) NULL))
- {
- /* There was no buffer overlap and no read overlap */
-
- fast SCHEME_OBJECT * source, * dest, * limit;
-
- source = scan_buffer_top;
- limit = (source + gc_extra_buffer_size);
-
- DUMP_SCAN_BUFFER (0);
- scan_position += gc_buffer_bytes;
- virtual_scan_pointer += gc_buffer_size;
-
- scan_buffer = (OTHER_BUFFER (free_buffer));
- scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
- scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
-
- dest = scan_buffer_bottom;
- result = (((char *) dest) + (to_relocate - ((char *) source)));
-
- while (source < limit)
- *dest++ = *source++;
-
- if (gc_buffer_remainder_bytes != 0)
- load_data ((scan_position + gc_buffer_overlap_bytes),
- ((char *) dest), gc_buffer_remainder_bytes,
- "the scan buffer", ((Boolean *) NULL));
-
- (* scan_buffer_top) =
- (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
- }
- else
- {
- /* There is overlap with the next bufferful (not the free bufferful). */
-
- fast char * source, * dest, * limit;
-
- source = ((char *) scan_buffer_top);
- limit = (source + extension_overlap_length);
- dest = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer)));
- result = (dest + (to_relocate - source));
-
- while (source < limit)
- *dest++ = *source++;
-
- DUMP_SCAN_BUFFER (0);
- scan_position += gc_buffer_bytes;
- virtual_scan_pointer += gc_buffer_size;
-
- scan_buffer = next_scan_buffer;
- next_scan_buffer = NULL;
- scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
- scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
- (* scan_buffer_top) =
- (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
- schedule_pre_reads ();
- }
- scan_buffer_extended_p = false;
- return (result);
-}
-
-/* This is used to avoid unnecessary copying when copying a large
- non-marked area.
- */
-
-SCHEME_OBJECT *
-DEFUN (dump_free_directly, (from, nbuffers, success),
- fast SCHEME_OBJECT * from
- AND fast long nbuffers
- AND Boolean * success)
-{
- if (((read_overlap + write_overlap) == 0)
- && (can_dump_directly_p || (ALIGNED_TO_IO_PAGE_P (from))))
- {
- long byte_length = (nbuffers << gc_buffer_byte_shift);
-
- write_data (((char *) from), free_position, byte_length,
- "free buffers", success);
- free_position += byte_length;
- }
- else
- {
- /* This assumes that the free buffer has no valid data, so it can be
- used as scratch.
- This code is executed when there is I/O overlap, or when the
- data is not aligned to be written to a raw (character) device.
- */
-
- while ((--nbuffers) >= 0)
- {
- fast SCHEME_OBJECT * to, * bufend;
-
- for (to = free_buffer_bottom, bufend = free_buffer_top; to != bufend; )
- *to++ = *from++;
-
- (void) (dump_and_reset_free_buffer (to, success));
- }
- }
- return (free_buffer_bottom);
-}
-\f
-/* This code is needed by purify. After the purified object is
- copied, the next step is to scan constant space. In order to do
- this, it's necessary to save the current scan position, reset the
- scan limit pointers to scan constant space, then restore the saved
- scan position and finish scanning the heap. These procedures
- provide the necessary functionality to do this. */
-
-static void
-DEFUN_VOID (reset_scan_buffer)
-{
- virtual_scan_pointer = 0;
- scan_position = (-1L);
- scan_buffer = 0;
- scan_buffer_bottom = 0;
- scan_buffer_top = Highest_Allocated_Address;
- next_scan_buffer = 0;
- scan_buffer_extended_p = false;
- extension_overlap_p = false;
- extension_overlap_length = 0;
-}
-
-void
-DEFUN (save_scan_state, (state, scan),
- struct saved_scan_state * state AND
- SCHEME_OBJECT * scan)
-{
- (state -> virtual_scan_pointer) = virtual_scan_pointer;
- (state -> scan_position) = scan_position;
- (state -> scan_offset) = (scan - scan_buffer_bottom);
- if (scan_position != free_position)
- DUMP_SCAN_BUFFER (0);
- reset_scan_buffer ();
-}
-
-SCHEME_OBJECT *
-DEFUN (restore_scan_state, (state), struct saved_scan_state * state)
-{
- virtual_scan_pointer = (state -> virtual_scan_pointer);
- scan_position = (state -> scan_position);
- if (scan_position == free_position)
- {
- scan_buffer = free_buffer;
- scan_buffer_bottom = free_buffer_bottom;
- scan_buffer_top = free_buffer_top;
- }
- else
- {
- scan_buffer = (OTHER_BUFFER (free_buffer));
- scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
- scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
- LOAD_SCAN_BUFFER ();
- }
- return (scan_buffer_bottom + (state -> scan_offset));
-}
-
-void
-DEFUN (set_fixed_scan_area, (bottom, top),
- SCHEME_OBJECT * bottom AND
- SCHEME_OBJECT * top)
-{
- virtual_scan_pointer = bottom;
- scan_buffer_bottom = bottom;
- scan_buffer_top = top;
-}
-\f
-#ifndef START_TRANSPORT_HOOK
-#define START_TRANSPORT_HOOK() do { } while (0)
-#endif
-
-#ifndef END_TRANSPORT_HOOK
-#define END_TRANSPORT_HOOK() do { } while (0)
-#endif
-
-#ifndef END_WEAK_UPDATE_HOOK
-#define END_WEAK_UPDATE_HOOK() do { } while (0)
-#endif
-
-#ifndef START_RELOAD_HOOK
-#define START_RELOAD_HOOK() do { } while (0)
-#endif
-
-#ifndef END_GC_HOOK
-#define END_GC_HOOK() do { } while (0)
-#endif
-
-/* This hacks the scan buffer also so that Scan is always below
- scan_buffer_top until the scan buffer is initialized.
- Various parts of the garbage collector depend on scan_buffer_top
- having an aligned value.
-*/
-
-SCHEME_OBJECT *
-DEFUN_VOID (initialize_free_buffer)
-{
- STATISTICS_CLEAR ();
- START_TRANSPORT_HOOK ();
- read_queue_bitmask = 0L;
- pre_read_position = gc_file_start_position;
- free_position = gc_file_start_position;
- INITIALIZE_IO ();
- free_buffer = (INITIAL_FREE_BUFFER ());
- free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer));
- free_buffer_top = (GC_BUFFER_TOP (free_buffer));
- reset_scan_buffer ();
- /* Force first write to do an lseek. */
- gc_file_current_position = -1;
- return (free_buffer_bottom);
-}
-\f
-SCHEME_OBJECT *
-DEFUN (initialize_scan_buffer, (block_start), SCHEME_OBJECT * block_start)
-{
- virtual_scan_base = block_start;
- virtual_scan_pointer = virtual_scan_base;
- scan_position = gc_file_start_position;
- scan_buffer = (INITIAL_SCAN_BUFFER ());
- scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
- scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
- reload_scan_buffer (0);
- return (scan_buffer_bottom);
-}
-
-void
-DEFUN (end_transport, (success), Boolean * success)
-{
- DUMP_SCAN_BUFFER (success);
- scan_position += gc_buffer_bytes;
- virtual_scan_pointer += gc_buffer_size;
- free_position = scan_position;
- END_TRANSPORT_HOOK ();
- STATISTICS_PRINT (2, "after transport");
- return;
-}
-
-void
-DEFUN (final_reload, (to, length, noise),
- SCHEME_OBJECT * to AND unsigned long length AND char * noise)
-{
- unsigned long byte_length;
-
- byte_length = (ALIGN_UP_TO_IO_PAGE (length * (sizeof (SCHEME_OBJECT))));
- END_WEAK_UPDATE_HOOK ();
- AWAIT_IO_COMPLETION ();
- START_RELOAD_HOOK ();
- load_data (gc_file_start_position, ((char *) to), byte_length,
- noise, ((Boolean *) NULL));
- END_GC_HOOK ();
- STATISTICS_PRINT (1, "after final reload");
- return;
-}
-\f
-static int
- weak_buffer_pre_read_count;
-
-static long
- weak_pair_buffer_position;
-
-static struct buffer_info
- * weak_pair_buffer;
-
-static SCHEME_OBJECT
- weak_pair_break;
-
-/* This procedure is not very smart.
-
- It does not attempt to figure out whether the position being
- requested is already being pre-read, nor does it look further down
- the weak chain list for duplicate positions, to avoid early writes.
-
- On the other hand, pre_read_buffer will ignore the request if it is
- a duplicate, and will abort a pending write if a read for the same
- position is requested.
- */
-
-static void
-DEFUN (pre_read_weak_pair_buffers, (low_heap), SCHEME_OBJECT * low_heap)
-{
- SCHEME_OBJECT next, * pair_addr, * obj_addr;
- long position, last_position;
-
- last_position = -1;
- next = weak_pair_break;
- while (next != EMPTY_WEAK_CHAIN)
- {
- pair_addr = (OBJECT_ADDRESS (next));
- obj_addr = (OBJECT_ADDRESS (*pair_addr++));
- if (! (obj_addr < low_heap))
- {
- position = (obj_addr - aligned_heap);
- position = (position >> gc_buffer_shift);
- position = (position << gc_buffer_byte_shift);
- position += gc_file_start_position;
-
- if ((position != last_position)
- && (position != weak_pair_buffer_position))
- {
- last_position = position;
- if ((weak_buffer_pre_read_count >= read_overlap)
- || (!(PRE_READ_BUFFER (position, gc_buffer_bytes))))
- break;
- weak_buffer_pre_read_count += 1;
- }
- }
- next = (OBJECT_NEW_TYPE (TC_NULL, (*pair_addr)));
- }
- weak_pair_break = next;
- return;
-}
-\f
-/* The following code depends on being called in between copying objects,
- so that the "free" pointer points to the middle of the free buffer,
- and thus the overlap area at the end of the free buffer is available
- as temporary storage. In addition, because we have not yet moved free,
- next_scan_buffer has not been set even if we are in the middle of a
- scan buffer extension.
- */
-
-SCHEME_OBJECT
-DEFUN (read_newspace_address, (addr), SCHEME_OBJECT * addr)
-{
- long position;
- unsigned long offset;
- SCHEME_OBJECT result;
-
- if ((addr >= Constant_Space) && (addr < Free_Constant))
- return (* addr);
-
- position = (addr - virtual_scan_base);
- offset = (position & gc_buffer_mask);
- position = (position >> gc_buffer_shift);
- position = (position << gc_buffer_byte_shift);
- position += gc_file_start_position;
-
- if (position > free_position)
- {
- outf_fatal
- ("\n%s (read_newspace_address): Reading outside of GC window!\n\
- \t addr = 0x%lx;\t position = 0x%lx.\n\
- \tscan_position = 0x%lx;\tfree_position = 0x%lx.\n",
- scheme_program_name,
- addr, position,
- scan_position, free_position);
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- }
- if (position == scan_position)
- result = (* (scan_buffer_bottom + offset));
- else if (position == free_position)
- result = (* (free_buffer_bottom + offset));
- else if ((position == ((long) (scan_position + gc_buffer_bytes)))
- && scan_buffer_extended_p
- && ((read_overlap != 0) || (offset < gc_extra_buffer_size)))
- {
- /* Note: we need not worry about the state of extension_overlap_p,
- because if there is overlap between the scan extension and the free
- buffer, then (position == free_position) would be true,
- and that case has already been taken care of.
- */
-
- result = ((read_overlap == 0)
- ? (* (scan_buffer_top + offset))
- : (* ((GC_BUFFER_BOTTOM (next_scan_buffer)) + offset)));
- }
- else if ((read_overlap <= 0) || (position > pre_read_position))
- {
- unsigned long position2;
-
- position = (((char *) addr) - ((char *) virtual_scan_base));
- position2 = (ALIGN_DOWN_TO_IO_PAGE (position));
- offset = (position - position2);
- position2 += gc_file_start_position;
-
- load_data (position2,
- ((char *) free_buffer_top),
- IO_PAGE_SIZE,
- "a buffer for read_newspace_address",
- ((Boolean *) NULL));
- result = (* ((SCHEME_OBJECT *) (((char *) free_buffer_top) + offset)));
- }
- else
- {
- /* The buffer is pre-read or in the process of being pre-read.
- Force completion of the read, fetch the location,
- and re-queue the buffer as ready.
- */
-
- LOAD_BUFFER (next_scan_buffer, position, gc_buffer_bytes,
- "a buffer for read_newspace_address");
- result = ((GC_BUFFER_BOTTOM (next_scan_buffer)) [offset]);
- ENQUEUE_READY_BUFFER (next_scan_buffer, position, gc_buffer_bytes);
- next_scan_buffer = ((struct buffer_info *) NULL);
- }
- return (result);
-}
-\f
-static void
-DEFUN (initialize_new_space_buffer, (chain, low_heap),
- SCHEME_OBJECT chain AND
- SCHEME_OBJECT * low_heap)
-{
- if (read_overlap == 0)
- {
- weak_pair_break = EMPTY_WEAK_CHAIN;
- weak_pair_buffer = (INITIAL_FREE_BUFFER ());
- weak_pair_buffer_position = -1;
- }
- else
- {
- weak_pair_break = chain;
- weak_pair_buffer = ((struct buffer_info *) NULL);
- weak_pair_buffer_position = -1;
- weak_buffer_pre_read_count = 0;
- pre_read_weak_pair_buffers (low_heap);
- }
-}
-
-static void
-DEFUN_VOID (flush_new_space_buffer)
-{
- if (weak_pair_buffer_position == -1)
- return;
- DUMP_BUFFER (weak_pair_buffer, weak_pair_buffer_position,
- gc_buffer_bytes, ((Boolean *) NULL),
- "the weak pair buffer");
- weak_pair_buffer_position = -1;
- return;
-}
-
-static SCHEME_OBJECT *
-DEFUN (guarantee_in_memory, (addr, low_heap),
- SCHEME_OBJECT * addr AND
- SCHEME_OBJECT * low_heap)
-{
- long position, offset;
-
- if (addr < low_heap)
- return (addr);
-
- position = (addr - aligned_heap);
- offset = (position & gc_buffer_mask);
- position = (position >> gc_buffer_shift);
- position = (position << gc_buffer_byte_shift);
- position += gc_file_start_position;
-
- if (position != weak_pair_buffer_position)
- {
- flush_new_space_buffer ();
- LOAD_BUFFER (weak_pair_buffer, position, gc_buffer_bytes,
- "the weak pair buffer");
- weak_pair_buffer_position = position;
- if (weak_pair_break != EMPTY_WEAK_CHAIN)
- {
- weak_buffer_pre_read_count -= 1;
- pre_read_weak_pair_buffers (low_heap);
- }
- }
- return ((GC_BUFFER_BOTTOM (weak_pair_buffer)) + offset);
-}
-\f
-/* For a description of the algorithm, see memmag.c and gccode.h.
- This has been modified only to account for the fact that new space
- is on disk. Old space is in memory.
- Note: Compiled_BH requires the names Temp and Old!
-*/
-
-static SCHEME_OBJECT
-DEFUN (update_weak_pointer, (Temp, low_heap),
- SCHEME_OBJECT Temp AND
- SCHEME_OBJECT * low_heap)
-{
- SCHEME_OBJECT * Old;
-
- switch (GC_Type (Temp))
- {
- case GC_Non_Pointer:
- return (Temp);
-
- case GC_Special:
- if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP)
- /* No other special type makes sense here. */
- goto fail;
- if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
- return (Temp);
- /* Otherwise, it is a pointer. Fall through */
-
- /* 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 SHARP_F.
- Eliminating this assignment would keep old data (pl. of datum).
- */
- case GC_Cell:
- case GC_Pair:
- case GC_Triple:
- case GC_Quadruple:
- case GC_Vector:
- Old = (OBJECT_ADDRESS (Temp));
- if (Old < low_heap)
- return (Temp);
-
- if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART)
- return (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old));
- else
- return (SHARP_F);
-
- case GC_Compiled:
- Old = (OBJECT_ADDRESS (Temp));
- if (Old < low_heap)
- return (Temp);
- Compiled_BH (false, { return Temp; });
- return (SHARP_F);
-
- default: /* Non Marked Headers and Broken Hearts */
- case GC_Undefined:
- fail:
- outf_error ("\n%s (update_weak_pointer): Clearing bad object 0x%08lx.\n",
- scheme_program_name, Temp);
- return (SHARP_F);
- }
-}
-\f
-SCHEME_OBJECT
- Weak_Chain,
- * weak_pair_stack_ptr,
- * weak_pair_stack_limit;
-
-void
-DEFUN (initialize_weak_pair_transport, (limit), SCHEME_OBJECT * limit)
-{
- Weak_Chain = EMPTY_WEAK_CHAIN;
- weak_pair_stack_ptr = sp_register;
- weak_pair_stack_limit = (limit + 1); /* in case it's odd */
- return;
-}
-
-void
-DEFUN (fix_weak_chain_1, (low_heap), SCHEME_OBJECT * low_heap)
-{
- fast SCHEME_OBJECT chain, * old_weak_cell, * scan, * ptr, * limit;
-
- chain = Weak_Chain;
- initialize_new_space_buffer (chain, low_heap);
-
- limit = sp_register;
- for (ptr = weak_pair_stack_ptr; ptr < limit ; ptr += 2)
- *ptr = (update_weak_pointer (*ptr, low_heap));
-
- while (chain != EMPTY_WEAK_CHAIN)
- {
- old_weak_cell = (OBJECT_ADDRESS (Weak_Chain));
- scan
- = (guarantee_in_memory ((OBJECT_ADDRESS (*old_weak_cell++)), low_heap));
- Weak_Chain = (* old_weak_cell);
- *scan
- = (update_weak_pointer
- ((MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, (* scan))), low_heap));
- Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
- }
- flush_new_space_buffer ();
- Weak_Chain = chain;
- return;
-}
-
-void
-DEFUN_VOID (fix_weak_chain_2)
-{
- SCHEME_OBJECT * ptr, * limit, new_car, * addr;
-
- limit = sp_register;
- for (ptr = weak_pair_stack_ptr; ptr < limit ; )
- {
- new_car = *ptr++;
- addr = ((SCHEME_OBJECT *) (*ptr++));
- if (new_car != SHARP_F)
- *addr = new_car;
- }
- weak_pair_stack_ptr = limit;
- return;
-}
-\f
-long
-DEFUN (GC_relocate_root, (free_buffer_ptr), SCHEME_OBJECT ** free_buffer_ptr)
-{
- long skip;
- SCHEME_OBJECT * initial_free_buffer, * free_buffer;
-
- free_buffer = * free_buffer_ptr;
- initial_free_buffer = free_buffer;
- SET_MEMTOP (Heap_Top - GC_Reserve);
-
- /* Save the microcode registers so that they can be relocated */
-
- 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_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
- *free_buffer++ = (Get_Current_Stacklet ());
- *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
- SHARP_F :
- (MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
- Prev_Restore_History_Stacklet)));
-
- *free_buffer++ = Current_State_Point;
- *free_buffer++ = Fluid_Bindings;
- skip = (free_buffer - initial_free_buffer);
- if (free_buffer >= free_buffer_top)
- free_buffer = (dump_and_reset_free_buffer (free_buffer, 0));
- * free_buffer_ptr = free_buffer;
- return (skip);
-}
-
-void
-DEFUN (GC_end_root_relocation, (root, root2),
- SCHEME_OBJECT * root AND SCHEME_OBJECT * root2)
-{
- /* Make the microcode registers point to the copies in new-space. */
-
- Fixed_Objects = *root++;
- Set_Fixed_Obj_Slot (Precious_Objects, *root2);
- Set_Fixed_Obj_Slot
- (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2))));
-
- history_register = (OBJECT_ADDRESS (*root++));
- Set_Current_Stacklet (* root);
- root += 1;
- if ((* root) != SHARP_F)
- Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*root++));
- else
- {
- Prev_Restore_History_Stacklet = NULL;
- root += 1;
- }
- Current_State_Point = *root++;
- Fluid_Bindings = *root++;
- Free_Stacklets = NULL;
- COMPILER_TRANSPORT_END ();
- CLEAR_INTERRUPT (INT_GC);
- return;
-}
-\f
-/* Here is the set up for the full garbage collection:
-
- - First it makes the constant space and stack into one large area
- by "hiding" the gap between them with a non-marked header.
-
- - Then it saves away all the relevant microcode registers into new
- space, making this the root for garbage collection.
-
- - Then it does the actual garbage collection in 4 steps:
- 1) Trace constant space.
- 2) Trace objects pointed out by the root and constant space.
- 3) Trace the precious objects, remembering where consing started.
- 4) Update all weak pointers.
-
- - Load new space to memory.
-
- - Finally it restores the microcode registers from the copies in
- new space.
-*/
-
-void
-DEFUN (GC, (weak_pair_transport_initialized_p),
- int weak_pair_transport_initialized_p)
-{
- SCHEME_OBJECT * root;
- SCHEME_OBJECT * end_of_constant_area;
- SCHEME_OBJECT the_precious_objects;
- SCHEME_OBJECT * root2;
- SCHEME_OBJECT * free_buffer;
- SCHEME_OBJECT * block_start;
- SCHEME_OBJECT * saved_ctop;
- long skip_length;
-
- saved_ctop = Constant_Top;
- if (((Constant_Top - Free_Constant) < CONSTANT_SPACE_FUDGE)
- && (update_allocator_parameters (Free_Constant)))
- Constant_Top = saved_ctop;
-
- if (!weak_pair_transport_initialized_p)
- initialize_weak_pair_transport (Stack_Bottom);
-
- free_buffer = (initialize_free_buffer ());
- Free = Heap_Bottom;
- ALIGN_FLOAT (Free);
- block_start = aligned_heap;
- skip_length = (Free - block_start);
- free_buffer += skip_length;
-
- Terminate_Old_Stacklet ();
- SEAL_CONSTANT_SPACE ();
- end_of_constant_area = (CONSTANT_AREA_END ());
- the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects));
- root = Free;
-
- /* The 4 step GC */
-
- Free += (GC_relocate_root (&free_buffer));
-
- {
- SCHEME_OBJECT * new_scan
- = (gc_loop ((CONSTANT_AREA_START ()), (&free_buffer), (&Free),
- Constant_Top, NORMAL_GC, 0));
- if (new_scan != end_of_constant_area)
- {
- gc_death (TERM_EXIT, "gc_loop ended too early", new_scan, free_buffer);
- /*NOTREACHED*/
- }
- }
-
- {
- SCHEME_OBJECT * scan
- = (gc_loop (((initialize_scan_buffer (block_start)) + skip_length),
- (&free_buffer), (&Free), Constant_Top, NORMAL_GC, 1));
-
- root2 = Free;
- (*free_buffer++) = the_precious_objects;
- Free += 1;
- if (free_buffer >= free_buffer_top)
- free_buffer = (dump_and_reset_free_buffer (free_buffer, 0));
-
- gc_loop (scan, (&free_buffer), (&Free), Constant_Top, NORMAL_GC, 1);
- }
-
- end_transport (0);
- fix_weak_chain_1 (Constant_Top);
-
- /* Load new space into memory. */
- final_reload (block_start, (Free - block_start), "new space");
-
- fix_weak_chain_2 ();
- GC_end_root_relocation (root, root2);
- Constant_Top = saved_ctop;
- SET_CONSTANT_TOP ();
-}
-\f
-/* (GARBAGE-COLLECT SLACK)
- Requests a garbage collection leaving the specified amount of slack
- for the top of heap check on the next GC. The primitive ends by
- invoking the GC daemon if there is one.
-*/
-
-DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
-{
- extern unsigned long gc_counter;
- SCHEME_OBJECT daemon;
- PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
-
- STACK_SANITY_CHECK ("GC");
- if (Free > Heap_Top)
- termination_gc_out_of_space ();
-
- GC_Reserve = (arg_nonnegative_integer (1));
- POP_PRIMITIVE_FRAME (1);
-
- ENTER_CRITICAL_SECTION ("garbage collector");
- run_pre_gc_hooks ();
- gc_counter += 1;
- GC (0);
- run_post_gc_hooks ();
- daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
-
- Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_NORMAL_GC_DONE);
- exp_register = (LONG_TO_FIXNUM (MemTop - Free - GC_Space_Needed));
- Save_Cont ();
- Pushed ();
-
- RENAME_CRITICAL_SECTION ("garbage collector daemon");
- if (daemon == SHARP_F)
- PRIMITIVE_ABORT (PRIM_POP_RETURN);
- /*NOTREACHED*/
-
- Will_Push (2);
- STACK_PUSH (daemon);
- STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- return (0);
-}
-\f
-#ifdef RECORD_GC_STATISTICS
-
-static void
-DEFUN_VOID (statistics_clear)
-{
- int cntr, arlen;
- struct bch_GC_statistic * ptr;
-
- arlen = (((sizeof (all_gc_statistics))
- / (sizeof (struct bch_GC_statistic)))
- - 1);
- for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++)
- (* (ptr->counter)) = 0;
- return;
-}
-
-static int statistics_print_level = 0;
-
-static void
-DEFUN (statistics_print, (level, noise), int level AND char * noise)
-{
- char format[30];
- int cntr, arlen, len, name_len;
- struct bch_GC_statistic * ptr;
-
- if (level > statistics_print_level)
- return;
- arlen = (((sizeof (all_gc_statistics))
- / (sizeof (struct bch_GC_statistic)))
- - 1);
- name_len = -1;
- for (cntr = 0, ptr = &all_gc_statistics[0];
- cntr < arlen;
- cntr++, ptr++)
- if ((* (ptr->counter)) != 0L)
- {
- len = (strlen (ptr->name));
- if (len > name_len)
- name_len = len;
- }
-
- if (name_len >= 0)
- {
- sprintf (&format[0], "\t%%-%ds : %%ld\n", name_len);
-
- outf_console ("\nGC I/O statistics %s:\n", noise);
- for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++)
- if ((* (ptr->counter)) != 0L)
- outf_console (&format[0], ptr->name, (* (ptr->counter)));
- outf_flush_console ();
- }
- return;
-}
-#endif /* RECORD_GC_STATISTICS */
-\f
-static SCHEME_OBJECT
-DEFUN_VOID (statistics_names)
-{
- SCHEME_OBJECT vector, * scan;
- struct bch_GC_statistic * ptr;
- int len, cntr;
-
- len = (((sizeof (all_gc_statistics))
- / (sizeof (struct bch_GC_statistic)))
- - 1);
- if (len == 0)
- return (SHARP_F);
-
- vector = (allocate_marked_vector (TC_VECTOR, len, true));
- for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0));
- cntr < len;
- cntr++, ptr++)
- *scan++ = (char_pointer_to_string (ptr->name));
- return (vector);
-}
-
-static void
-DEFUN_VOID (statistics_read)
-{
- SCHEME_OBJECT vector, *scan;
- struct bch_GC_statistic * ptr;
- int len, cntr;
-
- len = (((sizeof (all_gc_statistics))
- / (sizeof (struct bch_GC_statistic)))
- - 1);
- if (len == 0)
- signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
-
- vector = (VECTOR_ARG (1));
- if (len != ((int) (VECTOR_LENGTH (vector))))
- error_bad_range_arg (1);
-
- for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0));
- cntr < len;
- cntr++, ptr++)
- *scan++ = (long_to_integer (* (ptr->counter)));
- return;
-}
-\f
-/* Additional primitives for statistics collection and
- manipulation of parameters from Scheme
- */
-
-DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-NAMES", Prim_bchscheme_stat_names, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (statistics_names ());
-}
-
-DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-READ!", Prim_bchscheme_read_stats, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- statistics_read ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* There are other parameters that could be set, especially the drone program
- to run, and the file to gc from, but...
- */
-
-#ifndef GET_SLEEP_DELTA
-#define GET_SLEEP_DELTA() -1
-#define SET_SLEEP_DELTA(v) do { } while (0)
-#endif
-
-#define N_PARAMS 6
-
-DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-GET", Prim_bchscheme_get_params, 0, 0, 0)
-{
- SCHEME_OBJECT vector;
- PRIMITIVE_HEADER (0);
-
- vector = (allocate_marked_vector (TC_VECTOR, N_PARAMS, true));
-
- VECTOR_SET (vector, 0,
- (long_to_integer ((long) CAN_RECONFIGURE_GC_BUFFERS)));
- VECTOR_SET (vector, 1, (long_to_integer ((long) gc_buffer_size)));
- VECTOR_SET (vector, 2, (long_to_integer ((long) read_overlap)));
- VECTOR_SET (vector, 3, (long_to_integer ((long) write_overlap)));
- VECTOR_SET (vector, 4, (long_to_integer ((long) (GET_SLEEP_DELTA ()))));
- VECTOR_SET (vector, 5, (char_pointer_to_string (drone_file_name)));
-
- PRIMITIVE_RETURN (vector);
-}
-\f
-#if CAN_RECONFIGURE_GC_BUFFERS
-static long
-DEFUN (bchscheme_long_parameter, (vector, index),
- SCHEME_OBJECT vector AND int index)
-{
- SCHEME_OBJECT temp;
- long value;
-
- temp = (VECTOR_REF (vector, index));
- if ((! (INTEGER_P (temp))) || (! (integer_to_long_p (temp))))
- error_bad_range_arg (1);
- value = (integer_to_long (temp));
- if (value < 0)
- error_bad_range_arg (1);
- return (value);
-}
-#endif /* CAN_RECONFIGURE_GC_BUFFERS */
-
-DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-SET!", Prim_bchscheme_set_params, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
-
-#if !CAN_RECONFIGURE_GC_BUFFERS
- signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
- /*NOTREACHED*/
- return (0);
-#else
-
- {
- char * new_drone_ptr;
- SCHEME_OBJECT vector, new_drone;
- long
- new_buffer_size, new_read_overlap,
- new_write_overlap, new_sleep_period,
- old_buffer_size = gc_buffer_size,
- old_buffer_shift = gc_buffer_shift;
-
- vector = (VECTOR_ARG (1));
- if ((VECTOR_LENGTH (vector)) != N_PARAMS)
- error_bad_range_arg (1);
-
- /* Slot 0 ignored. */
- new_buffer_size = (bchscheme_long_parameter (vector, 1));
- new_read_overlap = (bchscheme_long_parameter (vector, 2));
- new_write_overlap = (bchscheme_long_parameter (vector, 3));
- new_sleep_period = (bchscheme_long_parameter (vector, 4));
- new_drone = (VECTOR_REF (vector, 5));
- if (! (STRING_P (new_drone)))
- error_bad_range_arg (1);
- if ((STRING_LENGTH (new_drone)) == 0)
- new_drone_ptr = ((char *) NULL);
- else
- {
- new_drone_ptr = ((char *) (malloc ((STRING_LENGTH (new_drone)) + 1)));
- if (new_drone_ptr != ((char *) NULL))
- strcpy (new_drone_ptr, ((char *) (STRING_LOC (new_drone, 0))));
- }
-
- if (new_buffer_size != old_buffer_size)
- {
- int power = (next_exponent_of_two (new_buffer_size));
-
- if (((1L << power) != new_buffer_size)
- || ((set_gc_buffer_sizes (power)) != 0))
- error_bad_range_arg (1);
- if (! (recompute_gc_end_position ()))
- {
- set_gc_buffer_sizes (old_buffer_shift);
- error_bad_range_arg (1);
- }
- }
-
- BUFFER_SHUTDOWN (0);
- SET_SLEEP_DELTA (new_sleep_period);
- if ((drone_file_name != ((char *) NULL))
- && (drone_file_name != option_gc_drone))
- free ((PTR) drone_file_name);
-
- if ((RE_INITIALIZE_GC_BUFFERS (0,
- Highest_Allocated_Address,
- ((sizeof (SCHEME_OBJECT))
- * (CEILING ((saved_heap_size
- + saved_constant_size),
- gc_buffer_size))),
- new_read_overlap,
- new_write_overlap,
- new_drone_ptr))
- == 0)
- PRIMITIVE_RETURN (UNSPECIFIC);
- else
- {
- if (new_buffer_size != old_buffer_size)
- {
- set_gc_buffer_sizes (old_buffer_shift);
- recompute_gc_end_position ();
- }
-
- BUFFER_SHUTDOWN (0);
- if (new_drone_ptr != ((char *) NULL))
- free (new_drone_ptr);
-
- if ((RE_INITIALIZE_GC_BUFFERS (0,
- Highest_Allocated_Address,
- (saved_heap_size
- * (sizeof (SCHEME_OBJECT))),
- 0, 0,
- option_gc_drone)) != 0)
- Microcode_Termination (TERM_EXIT);
- else
- signal_error_from_primitive (ERR_EXTERNAL_RETURN);
- }
- /*NOTREACHED*/
- return (0);
- }
-#endif /* (CAN_RECONFIGURE_GC_BUFFERS == 0) */
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: bchpur.c,v 9.76 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/*
- * This file contains the code for primitives dealing with pure
- * and constant space. Garbage collection to disk version.
- *
- * Poorly implemented: If there is not enough space, instead of
- * undoing the changes, it crashes.
- * It should be changed to do the job in two passes like the
- * "normal" version.
- */
-
-#include "scheme.h"
-#include "prims.h"
-#include "bchgcc.h"
-#include "zones.h"
-
-static void EXFUN (purify, (SCHEME_OBJECT, Boolean));
-static SCHEME_OBJECT * EXFUN (purify_header_overflow, (SCHEME_OBJECT *));
-\f
-/* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN)
-
- Copy an object from the heap into constant space. It should only
- be used through the wrapper provided in the Scheme runtime system.
-
- To purify an object we just copy it into Pure Space in two
- parts with the appropriate headers and footers. The actual
- copying is done by gc_loop.
-
- Once the copy is complete we run a full GC which handles the
- broken hearts which now point into pure space.
-
- This primitive does not return normally. It always escapes into
- the interpreter because some of its cached registers (e.g.
- history_register) have changed. */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0)
-{
- Boolean pure_p;
- SCHEME_OBJECT object, result, daemon;
- PRIMITIVE_HEADER (3);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
-
- STACK_SANITY_CHECK ("PURIFY");
- Save_Time_Zone (Zone_Purify);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- CHECK_ARG (2, BOOLEAN_P);
- pure_p = (BOOLEAN_ARG (2));
- GC_Reserve = (arg_nonnegative_integer (3));
-
- POP_PRIMITIVE_FRAME (3);
-
- ENTER_CRITICAL_SECTION ("purify");
- purify (object, pure_p);
- result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
- Free += 2;
- Free[-2] = SHARP_T;
- Free[-1] = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
-
- Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_NORMAL_GC_DONE);
- exp_register = result;
- Save_Cont ();
- Pushed ();
-
- RENAME_CRITICAL_SECTION ("purify daemon");
- daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
- if (daemon == SHARP_F)
- {
- PRIMITIVE_ABORT (PRIM_POP_RETURN);
- /*NOTREACHED*/
- }
-
- Will_Push (2);
- STACK_PUSH (daemon);
- STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- return (UNSPECIFIC);
-}
-\f
-static void
-DEFUN (purify, (object, pure_p), SCHEME_OBJECT object AND Boolean pure_p)
-{
- long length;
- long pure_length;
- long delta;
- SCHEME_OBJECT * free_buffer_ptr;
- SCHEME_OBJECT * old_free_const;
- SCHEME_OBJECT * block_start;
- SCHEME_OBJECT * new_free_const;
- SCHEME_OBJECT * pending_scan;
- SCHEME_OBJECT * root;
- SCHEME_OBJECT * root2;
- SCHEME_OBJECT the_precious_objects;
-
- run_pre_gc_hooks ();
- STACK_SANITY_CHECK ("PURIFY");
- initialize_weak_pair_transport (Stack_Bottom);
- free_buffer_ptr = (initialize_free_buffer ());
- Terminate_Old_Stacklet ();
- SEAL_CONSTANT_SPACE ();
- the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects));
-
- Constant_Top = Free_Constant;
- old_free_const = Free_Constant;
- new_free_const = old_free_const;
- block_start = ((SCHEME_OBJECT *) (ALIGN_DOWN_TO_IO_PAGE (old_free_const)));
- delta = (old_free_const - block_start);
-
- free_buffer_ptr += delta;
- (*free_buffer_ptr++) = SHARP_F; /* Pure block header. */
- (*free_buffer_ptr++) = object;
- new_free_const += 2;
- if (free_buffer_ptr >= free_buffer_top)
- free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0));
-
- if (pure_p)
- {
- gc_loop (((initialize_scan_buffer (block_start)) + delta),
- (&free_buffer_ptr), (&new_free_const), Constant_Top,
- PURE_COPY, 1);
- pure_length = ((new_free_const - old_free_const) + 1);
- }
- else
- pure_length = 3;
-
- (*free_buffer_ptr++)
- = (pure_p
- ? (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, new_free_const))
- : (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)));
- (*free_buffer_ptr++) = (MAKE_OBJECT (CONSTANT_PART, pure_length));
- new_free_const += 2;
- if (free_buffer_ptr >= free_buffer_top)
- free_buffer_ptr = (purify_header_overflow (free_buffer_ptr));
-
- {
- SCHEME_OBJECT * scan_start
- = ((initialize_scan_buffer (block_start)) + delta);
- if (pure_p)
- {
- SCHEME_OBJECT * pure_area_limit = (new_free_const - 2);
- SCHEME_OBJECT * result
- = (gc_loop (scan_start, (&free_buffer_ptr), (&new_free_const),
- Constant_Top, CONSTANT_COPY, 0));
- if ((*result)
- != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, pure_area_limit)))
- {
- gc_death (TERM_BROKEN_HEART, "gc_loop ended too early",
- result, free_buffer_ptr);
- /*NOTREACHED*/
- }
- (*result) = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- scan_start = (result + 2);
- }
- pending_scan
- = (gc_loop (scan_start, (&free_buffer_ptr), (&new_free_const),
- Constant_Top, NORMAL_GC, 1));
- }
-
- length = (new_free_const + 1 - old_free_const);
- (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- (*free_buffer_ptr++) = (MAKE_OBJECT (END_OF_BLOCK, length));
- new_free_const += 2;
- if (free_buffer_ptr >= free_buffer_top)
- free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0));
-
- Free_Constant = new_free_const;
- if (!update_allocator_parameters (Free_Constant))
- {
- gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL);
- /*NOTREACHED*/
- }
- while (!FLOATING_ALIGNED_P (Free_Constant))
- {
- (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
- Free_Constant += 1;
- }
- if (Constant_Top > Free_Constant)
- {
- /* This assumes that the distance between the new constant space
- and the new free constant is smaller than a bufferful. */
- long bump = (Constant_Top - Free_Constant);
- (*free_buffer_ptr)
- = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, (bump - 1)));
- free_buffer_ptr += bump;
- if (free_buffer_ptr >= free_buffer_top)
- free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0));
- }
- while (!FLOATING_ALIGNED_P (Free))
- {
- (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
- Free += 1;
- }
-
- root = Free;
- Free += (GC_relocate_root (&free_buffer_ptr));
-
- {
- struct saved_scan_state scan_state;
- save_scan_state ((&scan_state), pending_scan);
- set_fixed_scan_area (0, Highest_Allocated_Address);
- {
- SCHEME_OBJECT * result
- = (gc_loop ((CONSTANT_AREA_START ()), (&free_buffer_ptr), (&Free),
- old_free_const, NORMAL_GC, 0));
- if (result != old_free_const)
- {
- gc_death (TERM_EXIT, "gc_loop ended too early",
- result, free_buffer_ptr);
- /*NOTREACHED*/
- }
- }
- pending_scan = (restore_scan_state (&scan_state));
- }
-
- pending_scan
- = (gc_loop (pending_scan, (&free_buffer_ptr), (&Free),
- old_free_const, NORMAL_GC, 1));
-
- root2 = Free;
- (*free_buffer_ptr++) = the_precious_objects;
- Free += 1;
- if (free_buffer_ptr >= free_buffer_top)
- free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0));
-
- gc_loop (pending_scan, (&free_buffer_ptr), (&Free),
- old_free_const, NORMAL_GC, 1);
-
- end_transport (0);
- fix_weak_chain_1 (old_free_const);
-
- /* Load new space into memory carefully to prevent the shared
- buffer from losing any values. */
- {
- unsigned long counter;
-
- for (counter = 0; (counter < delta); counter += 1)
- (scan_buffer_bottom[counter]) = (block_start[counter]);
-
- final_reload (block_start, (Free - block_start), "new space");
-
- for (counter = 0; (counter < delta); counter += 1)
- (block_start[counter]) = (scan_buffer_bottom[counter]);
- }
-
- fix_weak_chain_2 ();
- GC_end_root_relocation (root, root2);
-
- (*old_free_const++)
- = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length));
- (*old_free_const) = (MAKE_OBJECT (PURE_PART, length));
- SEAL_CONSTANT_SPACE ();
- run_post_gc_hooks ();
-}
-
-/* This is not paranoia!
- The two words in the header may overflow the free buffer. */
-static SCHEME_OBJECT *
-DEFUN (purify_header_overflow, (free_buffer), SCHEME_OBJECT * free_buffer)
-{
- long delta = (free_buffer - free_buffer_top);
- free_buffer = (dump_and_reset_free_buffer (free_buffer, 0));
- {
- SCHEME_OBJECT * scan_buffer
- = (dump_and_reload_scan_buffer (scan_buffer_top, 0));
- if ((scan_buffer + delta) != free_buffer)
- {
- gc_death (TERM_EXIT,
- "purify: scan and free do not meet at the end",
- (scan_buffer + delta), free_buffer);
- /*NOTREACHED*/
- }
- }
- return (free_buffer);
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: bchutl.c,v 1.17 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "config.h"
-#include <stdio.h>
-
-#include <errno.h>
-#ifndef EINTR
-# define EINTR 1999
-#endif
-
-#ifdef HAVE_UNISTD_H
-# include <unistd.h>
-#endif
-
-#ifdef STDC_HEADERS
-# include <string.h>
-#endif
-\f
-#ifdef HAVE_STRERROR
-
-char *
-DEFUN (error_name, (code), int code)
-{
- static char buf [512];
- sprintf (buf, "%d, %s", code, (strerror (code)));
- return (buf);
-}
-
-#else /* not HAVE_STRERROR */
-#ifdef __WIN32__
-
-#define lseek _lseek
-
-char *
-DEFUN (error_name, (code), int code)
-{
- static char buf [512];
- sprintf (buf, "%d, unknown error", code);
- return (buf);
-}
-
-#else /* not __WIN32__ */
-#ifdef __OS2__
-
-#if defined(__IBMC__) || defined(__WATCOMC__) || defined(__EMX__)
-# include <io.h>
-#endif
-
-char *
-DEFUN (error_name, (code), int code)
-{
- static char buf [512];
- sprintf (buf, "%d, unknown error", code);
- return (buf);
-}
-
-#else /* not __OS2__ */
-
-char *
-DEFUN (error_name, (code), int code)
-{
- static char buf [512];
- if ((code >= 0) && (code <= sys_nerr))
- sprintf (buf, "%d, %s", code, sys_errlist[code]);
- else
- sprintf (buf, "%d, unknown error", code);
- return (buf);
-}
-
-#endif /* not __OS2__ */
-#endif /* not __WIN32__ */
-#endif /* not HAVE_STRERROR */
-
-#ifndef SEEK_SET
-# define SEEK_SET 0
-#endif
-
-int
-DEFUN (retrying_file_operation,
- (operation, fid, ptr, position, nbytes, name, noise, curpos, abort_p),
- int EXFUN ((*operation), (int, char *, unsigned int))
- AND int fid AND char * ptr AND long position AND long nbytes
- AND char * name AND char * noise AND long * curpos
- AND int EXFUN ((*abort_p), (char *, char *)))
-{
- char * membuf = ptr;
- long
- bytes_to_transfer = nbytes,
- bytes_transferred;
-
- if (*curpos != position)
- while ((lseek (fid, position, SEEK_SET)) == -1)
- if ((errno != EINTR) && ((*abort_p) ("lseek", noise)))
- goto fail;
-
- while ((bytes_to_transfer > 0)
- && ((bytes_transferred =
- ((*operation) (fid, membuf, ((unsigned int) bytes_to_transfer))))
- != bytes_to_transfer))
- if (bytes_transferred == -1)
- {
- if ((errno != EINTR) && ((*abort_p) (name, noise)))
- goto fail;
-
- while ((lseek (fid, (position + (nbytes - bytes_to_transfer)), SEEK_SET))
- == -1)
- if ((errno != EINTR) && ((*abort_p) ("lseek", noise)))
- goto fail;
- }
- else
- {
- bytes_to_transfer -= bytes_transferred;
- membuf += bytes_transferred;
- }
- *curpos = (position + nbytes);
- return (nbytes);
-
-fail:
- *curpos = -1;
- return (-1);
-}
-
/* -*-C-*-
-$Id: bignmint.h,v 1.10 2007/01/05 21:19:25 cph Exp $
+$Id: bignmint.h,v 1.11 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* The memory model is based on the following definitions, and on the
definition of the type `bignum_type'. The only other special
- definition is `CHAR_BIT', which is defined in the Ansi C header
- file "limits.h". */
+ definition is `CHAR_BIT', which is defined in the header file
+ "limits.h". */
typedef long bignum_digit_type;
typedef long bignum_length_type;
/* BIGNUM_DEALLOCATE is called when disposing of bignums which are
created as intermediate temporaries; Scheme doesn't need this. */
-#define BIGNUM_DEALLOCATE(bignum)
+#define BIGNUM_DEALLOCATE(bignum) do {} while (0)
/* If BIGNUM_FORCE_NEW_RESULTS is defined, all bignum-valued operations
return freshly-allocated results. This is useful for some kinds of
#define BIGNUM_DEALLOCATE free
#define BIGNUM_FORCE_NEW_RESULTS
#define BIGNUM_EXCEPTION abort
-#define fast register
extern void free ();
extern void abort ();
-#endif /* MIT_SCHEME */
+#endif /* not MIT_SCHEME */
\f
#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
-#define BIGNUM_RADIX (((unsigned long) 1) << BIGNUM_DIGIT_LENGTH)
-#define BIGNUM_RADIX_ROOT (((unsigned long) 1) << BIGNUM_HALF_DIGIT_LENGTH)
-#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1)
-#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1)
+#define BIGNUM_RADIX (1UL << BIGNUM_DIGIT_LENGTH)
+#define BIGNUM_RADIX_ROOT (1UL << BIGNUM_HALF_DIGIT_LENGTH)
+#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1UL)
+#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1UL)
#define BIGNUM_START_PTR(bignum) \
((BIGNUM_TO_POINTER (bignum)) + 1)
/* -*-C-*-
-$Id: bignum.c,v 9.56 2007/01/05 21:19:25 cph Exp $
+$Id: bignum.c,v 9.57 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Implementation of Bignums (unlimited precision integers) */
#ifdef MIT_SCHEME
-#include "scheme.h"
-#undef CHAR_BIT /* redefined in "limits.h" */
+# include "scheme.h"
#else
-#include "bignum.h"
+# include "bignum.h"
#endif
#include "bignmint.h"
-#include "limits.h"
-#include "float.h"
-#include <math.h>
\f
#ifndef MIT_SCHEME
static bignum_type
-DEFUN (bignum_malloc, (length), bignum_length_type length)
+bignum_malloc (bignum_length_type length)
{
extern char * malloc ();
char * result = (malloc ((length + 1) * (sizeof (bignum_digit_type))));
}
static bignum_type
-DEFUN (bignum_realloc, (bignum, length),
- bignum_type bignum AND bignum_length_type length)
+bignum_realloc (bignum_type bignum, bignum_length_type length)
{
extern char * realloc ();
char * result =
#endif /* not MIT_SCHEME */
/* Forward references */
-static int EXFUN (bignum_equal_p_unsigned,
- (bignum_type, bignum_type));
-static enum bignum_comparison EXFUN (bignum_compare_unsigned,
- (bignum_type, bignum_type));
-static bignum_type EXFUN (bignum_add_unsigned,
- (bignum_type, bignum_type, int));
-static bignum_type EXFUN (bignum_subtract_unsigned,
- (bignum_type, bignum_type));
-static bignum_type EXFUN (bignum_multiply_unsigned,
- (bignum_type, bignum_type, int));
-static bignum_type EXFUN (bignum_multiply_unsigned_small_factor,
- (bignum_type, bignum_digit_type, int));
-static void EXFUN (bignum_destructive_scale_up,
- (bignum_type, bignum_digit_type));
-static void EXFUN (bignum_destructive_add,
- (bignum_type, bignum_digit_type));
-static void EXFUN (bignum_divide_unsigned_large_denominator,
- (bignum_type, bignum_type, bignum_type *, bignum_type *,
- int, int));
-static void EXFUN (bignum_destructive_normalization,
- (bignum_type, bignum_type, int));
-static void EXFUN (bignum_destructive_unnormalization,
- (bignum_type, int));
-static void EXFUN (bignum_divide_unsigned_normalized,
- (bignum_type, bignum_type, bignum_type));
-static bignum_digit_type EXFUN (bignum_divide_subtract,
- (bignum_digit_type *, bignum_digit_type *,
- bignum_digit_type, bignum_digit_type *));
-static void EXFUN (bignum_divide_unsigned_medium_denominator,
- (bignum_type, bignum_digit_type, bignum_type *,
- bignum_type *, int, int));
-static bignum_digit_type EXFUN (bignum_digit_divide,
- (bignum_digit_type, bignum_digit_type,
- bignum_digit_type, bignum_digit_type *));
-static bignum_digit_type EXFUN (bignum_digit_divide_subtract,
- (bignum_digit_type, bignum_digit_type,
- bignum_digit_type, bignum_digit_type *));
-static void EXFUN (bignum_divide_unsigned_small_denominator,
- (bignum_type, bignum_digit_type, bignum_type *,
- bignum_type *, int, int));
-static bignum_digit_type EXFUN (bignum_destructive_scale_down,
- (bignum_type, bignum_digit_type));
-static bignum_type EXFUN (bignum_remainder_unsigned_small_denominator,
- (bignum_type, bignum_digit_type, int));
-static bignum_type EXFUN (bignum_digit_to_bignum,
- (bignum_digit_type, int));
-static bignum_type EXFUN (bignum_allocate,
- (bignum_length_type, int));
-static bignum_type EXFUN (bignum_allocate_zeroed,
- (bignum_length_type, int));
-static bignum_type EXFUN (bignum_shorten_length,
- (bignum_type, bignum_length_type));
-static bignum_type EXFUN (bignum_trim,
- (bignum_type));
-static bignum_type EXFUN (bignum_copy,
- (bignum_type));
-static bignum_type EXFUN (bignum_new_sign,
- (bignum_type, int));
-static bignum_type EXFUN (bignum_maybe_new_sign,
- (bignum_type, int));
-static void EXFUN (bignum_destructive_copy,
- (bignum_type, bignum_type));
+static int bignum_equal_p_unsigned (bignum_type, bignum_type);
+static enum bignum_comparison bignum_compare_unsigned (bignum_type, bignum_type);
+static bignum_type bignum_add_unsigned (bignum_type, bignum_type, int);
+static bignum_type bignum_subtract_unsigned (bignum_type, bignum_type);
+static bignum_type bignum_multiply_unsigned (bignum_type, bignum_type, int);
+static bignum_type bignum_multiply_unsigned_small_factor (bignum_type, bignum_digit_type, int);
+static void bignum_destructive_scale_up (bignum_type, bignum_digit_type);
+static void bignum_destructive_add (bignum_type, bignum_digit_type);
+static void bignum_divide_unsigned_large_denominator (bignum_type, bignum_type, bignum_type *, bignum_type *,
+ int, int);
+static void bignum_destructive_normalization (bignum_type, bignum_type, int);
+static void bignum_destructive_unnormalization (bignum_type, int);
+static void bignum_divide_unsigned_normalized (bignum_type, bignum_type, bignum_type);
+static bignum_digit_type bignum_divide_subtract (bignum_digit_type *, bignum_digit_type *,
+ bignum_digit_type, bignum_digit_type *);
+static void bignum_divide_unsigned_medium_denominator (bignum_type, bignum_digit_type, bignum_type *,
+ bignum_type *, int, int);
+static bignum_digit_type bignum_digit_divide (bignum_digit_type, bignum_digit_type,
+ bignum_digit_type, bignum_digit_type *);
+static bignum_digit_type bignum_digit_divide_subtract (bignum_digit_type, bignum_digit_type,
+ bignum_digit_type, bignum_digit_type *);
+static void bignum_divide_unsigned_small_denominator (bignum_type, bignum_digit_type, bignum_type *,
+ bignum_type *, int, int);
+static bignum_digit_type bignum_destructive_scale_down (bignum_type, bignum_digit_type);
+static bignum_type bignum_remainder_unsigned_small_denominator (bignum_type, bignum_digit_type, int);
+static bignum_type bignum_digit_to_bignum (bignum_digit_type, int);
+static bignum_type bignum_allocate (bignum_length_type, int);
+static bignum_type bignum_allocate_zeroed (bignum_length_type, int);
+static bignum_type bignum_shorten_length (bignum_type, bignum_length_type);
+static bignum_type bignum_trim (bignum_type);
+static bignum_type bignum_copy (bignum_type);
+static bignum_type bignum_new_sign (bignum_type, int);
+static bignum_type bignum_maybe_new_sign (bignum_type, int);
+static void bignum_destructive_copy (bignum_type, bignum_type);
#define ULONG_LENGTH_IN_BITS(digit, len) \
do { \
- fast unsigned long w = digit; \
+ unsigned long w = digit; \
len = 0; \
while (w > 0xff) { len += 8; w >>= 8; } \
while (w > 0) { len += 1; w >>= 1; } \
/* Exports */
bignum_type
-DEFUN_VOID (bignum_make_zero)
+bignum_make_zero (void)
{
- fast bignum_type result = (BIGNUM_ALLOCATE (0));
+ bignum_type result = (BIGNUM_ALLOCATE (0));
BIGNUM_SET_HEADER (result, 0, 0);
return (result);
}
bignum_type
-DEFUN (bignum_make_one, (negative_p), int negative_p)
+bignum_make_one (int negative_p)
{
- fast bignum_type result = (BIGNUM_ALLOCATE (1));
+ bignum_type result = (BIGNUM_ALLOCATE (1));
BIGNUM_SET_HEADER (result, 1, negative_p);
(BIGNUM_REF (result, 0)) = 1;
return (result);
}
int
-DEFUN (bignum_equal_p, (x, y),
- fast bignum_type x AND fast bignum_type y)
+bignum_equal_p (bignum_type x, bignum_type y)
{
return
((BIGNUM_ZERO_P (x))
}
enum bignum_comparison
-DEFUN (bignum_test, (bignum), fast bignum_type bignum)
+bignum_test (bignum_type bignum)
{
return
((BIGNUM_ZERO_P (bignum))
}
enum bignum_comparison
-DEFUN (bignum_compare, (x, y),
- fast bignum_type x AND fast bignum_type y)
+bignum_compare (bignum_type x, bignum_type y)
{
return
((BIGNUM_ZERO_P (x))
}
\f
bignum_type
-DEFUN (bignum_add, (x, y),
- fast bignum_type x AND fast bignum_type y)
+bignum_add (bignum_type x, bignum_type y)
{
return
((BIGNUM_ZERO_P (x))
}
bignum_type
-DEFUN (bignum_subtract, (x, y),
- fast bignum_type x AND fast bignum_type y)
+bignum_subtract (bignum_type x, bignum_type y)
{
return
((BIGNUM_ZERO_P (x))
}
bignum_type
-DEFUN (bignum_negate, (x), fast bignum_type x)
+bignum_negate (bignum_type x)
{
return
((BIGNUM_ZERO_P (x))
}
\f
bignum_type
-DEFUN (bignum_multiply, (x, y),
- fast bignum_type x AND fast bignum_type y)
+bignum_multiply (bignum_type x, bignum_type y)
{
- fast bignum_length_type x_length = (BIGNUM_LENGTH (x));
- fast bignum_length_type y_length = (BIGNUM_LENGTH (y));
- fast int negative_p =
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ int negative_p =
((BIGNUM_NEGATIVE_P (x))
? (! (BIGNUM_NEGATIVE_P (y)))
: (BIGNUM_NEGATIVE_P (y)));
}
\f
int
-DEFUN (bignum_divide, (numerator, denominator, quotient, remainder),
- bignum_type numerator AND bignum_type denominator
- AND bignum_type * quotient AND bignum_type * remainder)
+bignum_divide (bignum_type numerator, bignum_type denominator
+ , bignum_type * quotient, bignum_type * remainder)
{
if (BIGNUM_ZERO_P (denominator))
return (1);
}
\f
bignum_type
-DEFUN (bignum_quotient, (numerator, denominator),
- bignum_type numerator AND bignum_type denominator)
+bignum_quotient (bignum_type numerator, bignum_type denominator)
{
if (BIGNUM_ZERO_P (denominator))
return (BIGNUM_OUT_OF_BAND);
}
\f
bignum_type
-DEFUN (bignum_remainder, (numerator, denominator),
- bignum_type numerator AND bignum_type denominator)
+bignum_remainder (bignum_type numerator, bignum_type denominator)
{
if (BIGNUM_ZERO_P (denominator))
return (BIGNUM_OUT_OF_BAND);
#ifndef BIGNUM_NO_ULONG
bignum_type
-DEFUN (long_to_bignum, (n), long n)
+long_to_bignum (long n)
{
int negative_p;
bignum_digit_type result_digits [BIGNUM_DIGITS_FOR_LONG];
- fast bignum_digit_type * end_digits = result_digits;
+ bignum_digit_type * end_digits = result_digits;
/* Special cases win when these small constants are cached. */
if (n == 0) return (BIGNUM_ZERO ());
if (n == 1) return (BIGNUM_ONE (0));
if (n == -1) return (BIGNUM_ONE (1));
{
- fast unsigned long accumulator = ((negative_p = (n < 0)) ? (-n) : n);
+ unsigned long accumulator = ((negative_p = (n < 0)) ? (-n) : n);
do
{
(*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK);
{
bignum_type result =
(bignum_allocate ((end_digits - result_digits), negative_p));
- fast bignum_digit_type * scan_digits = result_digits;
- fast bignum_digit_type * scan_result = (BIGNUM_START_PTR (result));
+ bignum_digit_type * scan_digits = result_digits;
+ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result));
while (scan_digits < end_digits)
(*scan_result++) = (*scan_digits++);
return (result);
}
long
-DEFUN (bignum_to_long, (bignum), bignum_type bignum)
+bignum_to_long (bignum_type bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
{
- fast unsigned long accumulator = 0;
- fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ unsigned long accumulator = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
while (start < scan)
accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan));
return
}
bignum_type
-DEFUN (ulong_to_bignum, (n), unsigned long n)
+ulong_to_bignum (unsigned long n)
{
bignum_digit_type result_digits [BIGNUM_DIGITS_FOR_LONG];
- fast bignum_digit_type * end_digits = result_digits;
+ bignum_digit_type * end_digits = result_digits;
/* Special cases win when these small constants are cached. */
if (n == 0) return (BIGNUM_ZERO ());
if (n == 1) return (BIGNUM_ONE (0));
{
- fast unsigned long accumulator = n;
+ unsigned long accumulator = n;
do
{
(*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK);
{
bignum_type result =
(bignum_allocate ((end_digits - result_digits), 0));
- fast bignum_digit_type * scan_digits = result_digits;
- fast bignum_digit_type * scan_result = (BIGNUM_START_PTR (result));
+ bignum_digit_type * scan_digits = result_digits;
+ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result));
while (scan_digits < end_digits)
(*scan_result++) = (*scan_digits++);
return (result);
}
unsigned long
-DEFUN (bignum_to_ulong, (bignum), bignum_type bignum)
+bignum_to_ulong (bignum_type bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
{
- fast unsigned long accumulator = 0;
- fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ unsigned long accumulator = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
while (start < scan)
accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan));
return (accumulator);
} while (0)
bignum_type
-DEFUN (double_to_bignum, (x), double x)
+double_to_bignum (double x)
{
int exponent;
double significand = (frexp (x, (&exponent)));
*/
/*
double
-DEFUN (bignum_to_double, (bignum), bignum_type bignum)
+bignum_to_double (bignum_type bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
{
- fast double accumulator = 0;
- fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ double accumulator = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
while (start < scan)
accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
*/
double
-DEFUN (bignum_to_double, (bignum), bignum_type bignum)
+bignum_to_double (bignum_type bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0.0);
*/
\f
int
-DEFUN (bignum_fits_in_word_p, (bignum, word_length, twos_complement_p),
- bignum_type bignum AND long word_length AND int twos_complement_p)
+bignum_fits_in_word_p (bignum_type bignum, long word_length,
+ int twos_complement_p)
{
unsigned int n_bits = (twos_complement_p ? (word_length - 1) : word_length);
BIGNUM_ASSERT (n_bits > 0);
{
- fast bignum_length_type length = (BIGNUM_LENGTH (bignum));
- fast unsigned int max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits));
+ bignum_length_type length = (BIGNUM_LENGTH (bignum));
+ unsigned int max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits));
if (((unsigned int) length) < max_digits)
return (1);
if (((unsigned int) length) > max_digits)
}
bignum_type
-DEFUN (bignum_length_in_bits, (bignum), bignum_type bignum)
+bignum_length_in_bits (bignum_type bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (BIGNUM_ZERO ());
{
bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
- fast bignum_digit_type digit = (BIGNUM_REF (bignum, index));
- fast bignum_digit_type delta = 0;
- fast bignum_type result = (bignum_allocate (2, 0));
+ bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ bignum_digit_type delta = 0;
+ bignum_type result = (bignum_allocate (2, 0));
(BIGNUM_REF (result, 0)) = index;
(BIGNUM_REF (result, 1)) = 0;
bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
}
bignum_type
-DEFUN_VOID (bignum_length_upper_limit)
+bignum_length_upper_limit (void)
{
- fast bignum_type result = (bignum_allocate (2, 0));
+ bignum_type result = (bignum_allocate (2, 0));
(BIGNUM_REF (result, 0)) = 0;
(BIGNUM_REF (result, 1)) = BIGNUM_DIGIT_LENGTH;
return (result);
}
\f
bignum_type
-DEFUN (bignum_shift_left, (n, m), bignum_type n AND unsigned long m)
+bignum_shift_left (bignum_type n, unsigned long m)
{
unsigned long ln = (BIGNUM_LENGTH (n));
unsigned long delta = 0;
}
bignum_type
-DEFUN (unsigned_long_to_shifted_bignum, (n, m, sign),
- unsigned long n AND
- unsigned long m AND
- int sign)
+unsigned_long_to_shifted_bignum (unsigned long n, unsigned long m, int sign)
{
unsigned long delta = 0;
if (n == 0)
}
\f
bignum_type
-DEFUN (digit_stream_to_bignum,
- (n_digits, producer, context, radix, negative_p),
- fast unsigned int n_digits
- AND unsigned int EXFUN ((*producer), (bignum_procedure_context))
- AND bignum_procedure_context context
- AND fast unsigned int radix
- AND int negative_p)
+digit_stream_to_bignum (unsigned int n_digits,
+ unsigned int (*producer) (bignum_procedure_context),
+ bignum_procedure_context context,
+ unsigned int radix,
+ int negative_p)
{
BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
if (n_digits == 0)
{
bignum_length_type length;
{
- fast unsigned int log_radix = 0;
+ unsigned int log_radix = 0;
ULONG_LENGTH_IN_BITS (radix, log_radix);
/* This length will be at least as large as needed. */
length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
}
{
- fast bignum_type result = (bignum_allocate_zeroed (length, negative_p));
+ bignum_type result = (bignum_allocate_zeroed (length, negative_p));
while ((n_digits--) > 0)
{
bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
}
void
-DEFUN (bignum_to_digit_stream, (bignum, radix, consumer, context),
- bignum_type bignum
- AND unsigned int radix
- AND void EXFUN ((*consumer), (bignum_procedure_context, long))
- AND bignum_procedure_context context)
+bignum_to_digit_stream (bignum_type bignum,
+ unsigned int radix,
+ void (*consumer) (bignum_procedure_context, long),
+ bignum_procedure_context context)
{
BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
if (! (BIGNUM_ZERO_P (bignum)))
{
- fast bignum_type working_copy = (bignum_copy (bignum));
- fast bignum_digit_type * start = (BIGNUM_START_PTR (working_copy));
- fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (working_copy)));
+ bignum_type working_copy = (bignum_copy (bignum));
+ bignum_digit_type * start = (BIGNUM_START_PTR (working_copy));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (working_copy)));
while (start < scan)
{
if ((scan[-1]) == 0)
}
long
-DEFUN_VOID (bignum_max_digit_stream_radix)
+bignum_max_digit_stream_radix (void)
{
return (BIGNUM_RADIX_ROOT);
}
/* Comparisons */
static int
-DEFUN (bignum_equal_p_unsigned, (x, y),
- bignum_type x AND bignum_type y)
+bignum_equal_p_unsigned (bignum_type x, bignum_type y)
{
bignum_length_type length = (BIGNUM_LENGTH (x));
if (length != ((bignum_length_type) (BIGNUM_LENGTH (y))))
return (0);
else
{
- fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- fast bignum_digit_type * end_x = (scan_x + length);
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_x = (scan_x + length);
while (scan_x < end_x)
if ((*scan_x++) != (*scan_y++))
return (0);
}
static enum bignum_comparison
-DEFUN (bignum_compare_unsigned, (x, y),
- bignum_type x AND bignum_type y)
+bignum_compare_unsigned (bignum_type x, bignum_type y)
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
if (x_length > y_length)
return (bignum_comparison_greater);
{
- fast bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
- fast bignum_digit_type * scan_x = (start_x + x_length);
- fast bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
+ bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_x = (start_x + x_length);
+ bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
while (start_x < scan_x)
{
- fast bignum_digit_type digit_x = (*--scan_x);
- fast bignum_digit_type digit_y = (*--scan_y);
+ bignum_digit_type digit_x = (*--scan_x);
+ bignum_digit_type digit_y = (*--scan_y);
if (digit_x < digit_y)
return (bignum_comparison_less);
if (digit_x > digit_y)
/* Addition */
static bignum_type
-DEFUN (bignum_add_unsigned, (x, y, negative_p),
- bignum_type x AND bignum_type y AND int negative_p)
+bignum_add_unsigned (bignum_type x, bignum_type y, int negative_p)
{
if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
{
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_type r = (bignum_allocate ((x_length + 1), negative_p));
- fast bignum_digit_type sum;
- fast bignum_digit_type carry = 0;
- fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- fast bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ bignum_digit_type sum;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
{
- fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- fast bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
while (scan_y < end_y)
{
sum = ((*scan_x++) + (*scan_y++) + carry);
}
}
{
- fast bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
if (carry != 0)
while (scan_x < end_x)
{
/* Subtraction */
static bignum_type
-DEFUN (bignum_subtract_unsigned, (x, y),
- bignum_type x AND bignum_type y)
+bignum_subtract_unsigned (bignum_type x, bignum_type y)
{
int negative_p = 0;
switch (bignum_compare_unsigned (x, y))
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_type r = (bignum_allocate (x_length, negative_p));
- fast bignum_digit_type difference;
- fast bignum_digit_type borrow = 0;
- fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- fast bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ bignum_digit_type difference;
+ bignum_digit_type borrow = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
{
- fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- fast bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
while (scan_y < end_y)
{
difference = (((*scan_x++) - (*scan_y++)) - borrow);
}
}
{
- fast bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
if (borrow != 0)
while (scan_x < end_x)
{
where R == BIGNUM_RADIX_ROOT */
static bignum_type
-DEFUN (bignum_multiply_unsigned, (x, y, negative_p),
- bignum_type x AND bignum_type y AND int negative_p)
+bignum_multiply_unsigned (bignum_type x, bignum_type y, int negative_p)
{
if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
{
y = z;
}
{
- fast bignum_digit_type carry;
- fast bignum_digit_type y_digit_low;
- fast bignum_digit_type y_digit_high;
- fast bignum_digit_type x_digit_low;
- fast bignum_digit_type x_digit_high;
+ bignum_digit_type carry;
+ bignum_digit_type y_digit_low;
+ bignum_digit_type y_digit_high;
+ bignum_digit_type x_digit_low;
+ bignum_digit_type x_digit_high;
bignum_digit_type product_low;
- fast bignum_digit_type * scan_r;
- fast bignum_digit_type * scan_y;
+ bignum_digit_type * scan_r;
+ bignum_digit_type * scan_y;
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
bignum_type r =
}
\f
static bignum_type
-DEFUN (bignum_multiply_unsigned_small_factor, (x, y, negative_p),
- bignum_type x AND bignum_digit_type y AND int negative_p)
+bignum_multiply_unsigned_small_factor (bignum_type x, bignum_digit_type y, int negative_p)
{
bignum_length_type length_x = (BIGNUM_LENGTH (x));
bignum_type p = (bignum_allocate ((length_x + 1), negative_p));
}
static void
-DEFUN (bignum_destructive_scale_up, (bignum, factor),
- bignum_type bignum AND bignum_digit_type factor)
+bignum_destructive_scale_up (bignum_type bignum, bignum_digit_type factor)
{
- fast bignum_digit_type carry = 0;
- fast bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- fast bignum_digit_type two_digits;
- fast bignum_digit_type product_low;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type two_digits;
+ bignum_digit_type product_low;
#define product_high carry
bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
}
static void
-DEFUN (bignum_destructive_add, (bignum, n),
- bignum_type bignum AND bignum_digit_type n)
+bignum_destructive_add (bignum_type bignum, bignum_digit_type n)
{
- fast bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- fast bignum_digit_type digit;
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type digit;
digit = ((*scan) + n);
if (digit < BIGNUM_RADIX)
{
section 4.3.1, "Multiple-Precision Arithmetic". */
static void
-DEFUN (bignum_divide_unsigned_large_denominator, (numerator, denominator,
- quotient, remainder,
- q_negative_p, r_negative_p),
- bignum_type numerator
- AND bignum_type denominator
- AND bignum_type * quotient
- AND bignum_type * remainder
- AND int q_negative_p
- AND int r_negative_p)
+bignum_divide_unsigned_large_denominator (bignum_type numerator,
+ bignum_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
{
bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
int shift = 0;
BIGNUM_ASSERT (length_d > 1);
{
- fast bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
+ bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
while (v1 < (BIGNUM_RADIX / 2))
{
v1 <<= 1;
}
\f
static void
-DEFUN (bignum_divide_unsigned_normalized, (u, v, q),
- bignum_type u AND bignum_type v AND bignum_type q)
+bignum_divide_unsigned_normalized (bignum_type u, bignum_type v, bignum_type q)
{
bignum_length_type u_length = (BIGNUM_LENGTH (u));
bignum_length_type v_length = (BIGNUM_LENGTH (v));
bignum_digit_type * q_scan = 0;
bignum_digit_type v1 = (v_end[-1]);
bignum_digit_type v2 = (v_end[-2]);
- fast bignum_digit_type ph; /* high half of double-digit product */
- fast bignum_digit_type pl; /* low half of double-digit product */
- fast bignum_digit_type guess;
- fast bignum_digit_type gh; /* high half-digit of guess */
- fast bignum_digit_type ch; /* high half of double-digit comparand */
- fast bignum_digit_type v2l = (HD_LOW (v2));
- fast bignum_digit_type v2h = (HD_HIGH (v2));
- fast bignum_digit_type cl; /* low half of double-digit comparand */
+ bignum_digit_type ph; /* high half of double-digit product */
+ bignum_digit_type pl; /* low half of double-digit product */
+ bignum_digit_type guess;
+ bignum_digit_type gh; /* high half-digit of guess */
+ bignum_digit_type ch; /* high half of double-digit comparand */
+ bignum_digit_type v2l = (HD_LOW (v2));
+ bignum_digit_type v2h = (HD_HIGH (v2));
+ bignum_digit_type cl; /* low half of double-digit comparand */
#define gl ph /* low half-digit of guess */
#define uj pl
#define qj ph
}
\f
static bignum_digit_type
-DEFUN (bignum_divide_subtract, (v_start, v_end, guess, u_start),
- bignum_digit_type * v_start
- AND bignum_digit_type * v_end
- AND bignum_digit_type guess
- AND bignum_digit_type * u_start)
+bignum_divide_subtract (bignum_digit_type * v_start,
+ bignum_digit_type * v_end,
+ bignum_digit_type guess,
+ bignum_digit_type * u_start)
{
bignum_digit_type * v_scan = v_start;
bignum_digit_type * u_scan = u_start;
- fast bignum_digit_type carry = 0;
+ bignum_digit_type carry = 0;
if (guess == 0) return (0);
{
bignum_digit_type gl = (HD_LOW (guess));
bignum_digit_type gh = (HD_HIGH (guess));
- fast bignum_digit_type v;
- fast bignum_digit_type pl;
- fast bignum_digit_type vl;
+ bignum_digit_type v;
+ bignum_digit_type pl;
+ bignum_digit_type vl;
#define vh v
#define ph carry
#define diff pl
}
\f
static void
-DEFUN (bignum_divide_unsigned_medium_denominator, (numerator, denominator,
- quotient, remainder,
- q_negative_p, r_negative_p),
- bignum_type numerator
- AND bignum_digit_type denominator
- AND bignum_type * quotient
- AND bignum_type * remainder
- AND int q_negative_p
- AND int r_negative_p)
+bignum_divide_unsigned_medium_denominator (bignum_type numerator,
+ bignum_digit_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
{
bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
bignum_length_type length_q;
bignum_destructive_normalization (numerator, q, shift);
}
{
- fast bignum_digit_type r = 0;
- fast bignum_digit_type * start = (BIGNUM_START_PTR (q));
- fast bignum_digit_type * scan = (start + length_q);
+ bignum_digit_type r = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (q));
+ bignum_digit_type * scan = (start + length_q);
bignum_digit_type qj;
if (quotient != ((bignum_type *) 0))
{
}
\f
static void
-DEFUN (bignum_destructive_normalization, (source, target, shift_left),
- bignum_type source AND bignum_type target AND int shift_left)
+bignum_destructive_normalization (bignum_type source, bignum_type target, int shift_left)
{
- fast bignum_digit_type digit;
- fast bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- fast bignum_digit_type carry = 0;
- fast bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ bignum_digit_type digit;
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
}
static void
-DEFUN (bignum_destructive_unnormalization, (bignum, shift_right),
- bignum_type bignum AND int shift_right)
+bignum_destructive_unnormalization (bignum_type bignum, int shift_right)
{
bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- fast bignum_digit_type digit;
- fast bignum_digit_type carry = 0;
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type digit;
+ bignum_digit_type carry = 0;
int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
bignum_digit_type mask = ((1L << shift_right) - 1);
while (start < scan)
}
static bignum_digit_type
-DEFUN (bignum_digit_divide, (uh, ul, v, q),
- bignum_digit_type uh AND bignum_digit_type ul
- AND bignum_digit_type v AND bignum_digit_type * q) /* return value */
+bignum_digit_divide (bignum_digit_type uh, bignum_digit_type ul,
+ bignum_digit_type v, bignum_digit_type * q) /* return value */
{
- fast bignum_digit_type guess;
- fast bignum_digit_type comparand;
- fast bignum_digit_type v1 = (HD_HIGH (v));
- fast bignum_digit_type v2 = (HD_LOW (v));
- fast bignum_digit_type uj;
- fast bignum_digit_type uj_uj1;
+ bignum_digit_type guess;
+ bignum_digit_type comparand;
+ bignum_digit_type v1 = (HD_HIGH (v));
+ bignum_digit_type v2 = (HD_LOW (v));
+ bignum_digit_type uj;
+ bignum_digit_type uj_uj1;
bignum_digit_type q1;
bignum_digit_type q2;
bignum_digit_type u [4];
}
static bignum_digit_type
-DEFUN (bignum_digit_divide_subtract, (v1, v2, guess, u),
- bignum_digit_type v1 AND bignum_digit_type v2
- AND bignum_digit_type guess AND bignum_digit_type * u)
+bignum_digit_divide_subtract (bignum_digit_type v1, bignum_digit_type v2,
+ bignum_digit_type guess, bignum_digit_type * u)
{
{
- fast bignum_digit_type product;
- fast bignum_digit_type diff;
- fast bignum_digit_type carry;
+ bignum_digit_type product;
+ bignum_digit_type diff;
+ bignum_digit_type carry;
BDDS_MULSUB (v2, (u[2]), 0);
BDDS_MULSUB (v1, (u[1]), carry);
if (carry == 0)
}
}
{
- fast bignum_digit_type sum;
- fast bignum_digit_type carry;
+ bignum_digit_type sum;
+ bignum_digit_type carry;
BDDS_ADD(v2, (u[2]), 0);
BDDS_ADD(v1, (u[1]), carry);
if (carry == 1)
#undef BDDS_ADD
\f
static void
-DEFUN (bignum_divide_unsigned_small_denominator, (numerator, denominator,
- quotient, remainder,
- q_negative_p, r_negative_p),
- bignum_type numerator
- AND bignum_digit_type denominator
- AND bignum_type * quotient
- AND bignum_type * remainder
- AND int q_negative_p
- AND int r_negative_p)
+bignum_divide_unsigned_small_denominator (bignum_type numerator,
+ bignum_digit_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
{
bignum_type q = (bignum_new_sign (numerator, q_negative_p));
bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
that all digits are < BIGNUM_RADIX. */
static bignum_digit_type
-DEFUN (bignum_destructive_scale_down, (bignum, denominator),
- bignum_type bignum AND fast bignum_digit_type denominator)
+bignum_destructive_scale_down (bignum_type bignum, bignum_digit_type denominator)
{
- fast bignum_digit_type numerator;
- fast bignum_digit_type remainder = 0;
- fast bignum_digit_type two_digits;
+ bignum_digit_type numerator;
+ bignum_digit_type remainder = 0;
+ bignum_digit_type two_digits;
#define quotient_high remainder
bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
}
\f
static bignum_type
-DEFUN (bignum_remainder_unsigned_small_denominator, (n, d, negative_p),
- bignum_type n AND bignum_digit_type d AND int negative_p)
+bignum_remainder_unsigned_small_denominator (bignum_type n, bignum_digit_type d, int negative_p)
{
- fast bignum_digit_type two_digits;
+ bignum_digit_type two_digits;
bignum_digit_type * start = (BIGNUM_START_PTR (n));
- fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
- fast bignum_digit_type r = 0;
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
+ bignum_digit_type r = 0;
BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
while (start < scan)
{
}
static bignum_type
-DEFUN (bignum_digit_to_bignum, (digit, negative_p),
- fast bignum_digit_type digit AND int negative_p)
+bignum_digit_to_bignum (bignum_digit_type digit, int negative_p)
{
if (digit == 0)
return (BIGNUM_ZERO ());
else
{
- fast bignum_type result = (bignum_allocate (1, negative_p));
+ bignum_type result = (bignum_allocate (1, negative_p));
(BIGNUM_REF (result, 0)) = digit;
return (result);
}
/* Allocation */
static bignum_type
-DEFUN (bignum_allocate, (length, negative_p),
- fast bignum_length_type length AND int negative_p)
+bignum_allocate (bignum_length_type length, int negative_p)
{
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
{
- fast bignum_type result = (BIGNUM_ALLOCATE (length));
+ bignum_type result = (BIGNUM_ALLOCATE (length));
BIGNUM_SET_HEADER (result, length, negative_p);
return (result);
}
}
static bignum_type
-DEFUN (bignum_allocate_zeroed, (length, negative_p),
- fast bignum_length_type length AND int negative_p)
+bignum_allocate_zeroed (bignum_length_type length, int negative_p)
{
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
{
- fast bignum_type result = (BIGNUM_ALLOCATE (length));
- fast bignum_digit_type * scan = (BIGNUM_START_PTR (result));
- fast bignum_digit_type * end = (scan + length);
+ bignum_type result = (BIGNUM_ALLOCATE (length));
+ bignum_digit_type * scan = (BIGNUM_START_PTR (result));
+ bignum_digit_type * end = (scan + length);
BIGNUM_SET_HEADER (result, length, negative_p);
while (scan < end)
(*scan++) = 0;
}
static bignum_type
-DEFUN (bignum_shorten_length, (bignum, length),
- fast bignum_type bignum AND fast bignum_length_type length)
+bignum_shorten_length (bignum_type bignum, bignum_length_type length)
{
- fast bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
+ bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
if (length < current_length)
{
}
static bignum_type
-DEFUN (bignum_trim, (bignum), bignum_type bignum)
+bignum_trim (bignum_type bignum)
{
- fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- fast bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
- fast bignum_digit_type * scan = end;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type * scan = end;
while ((start <= scan) && ((*--scan) == 0))
;
scan += 1;
if (scan < end)
{
- fast bignum_length_type length = (scan - start);
+ bignum_length_type length = (scan - start);
BIGNUM_SET_HEADER
(bignum, length, ((length != 0) && (BIGNUM_NEGATIVE_P (bignum))));
BIGNUM_REDUCE_LENGTH (bignum, bignum, length);
/* Copying */
static bignum_type
-DEFUN (bignum_copy, (source), fast bignum_type source)
+bignum_copy (bignum_type source)
{
- fast bignum_type target =
+ bignum_type target =
(bignum_allocate ((BIGNUM_LENGTH (source)), (BIGNUM_NEGATIVE_P (source))));
bignum_destructive_copy (source, target);
return (target);
}
static bignum_type
-DEFUN (bignum_new_sign, (bignum, negative_p),
- fast bignum_type bignum AND int negative_p)
+bignum_new_sign (bignum_type bignum, int negative_p)
{
- fast bignum_type result =
+ bignum_type result =
(bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p));
bignum_destructive_copy (bignum, result);
return (result);
}
static bignum_type
-DEFUN (bignum_maybe_new_sign, (bignum, negative_p),
- fast bignum_type bignum AND int negative_p)
+bignum_maybe_new_sign (bignum_type bignum, int negative_p)
{
#ifndef BIGNUM_FORCE_NEW_RESULTS
if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p))
else
#endif /* not BIGNUM_FORCE_NEW_RESULTS */
{
- fast bignum_type result =
+ bignum_type result =
(bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p));
bignum_destructive_copy (bignum, result);
return (result);
}
static void
-DEFUN (bignum_destructive_copy, (source, target),
- bignum_type source AND bignum_type target)
+bignum_destructive_copy (bignum_type source, bignum_type target)
{
- fast bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- fast bignum_digit_type * end_source =
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type * end_source =
(scan_source + (BIGNUM_LENGTH (source)));
- fast bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
while (scan_source < end_source)
(*scan_target++) = (*scan_source++);
return;
/* -*-C-*-
-$Id: bignum.h,v 9.35 2007/01/05 21:19:25 cph Exp $
+$Id: bignum.h,v 9.36 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* External Interface to Bignum Code */
+#ifndef SCM_BIGNUM_H_INCLUDED
+#define SCM_BIGNUM_H_INCLUDED 1
+
/* The `unsigned long' type is used for the conversion procedures
`bignum_to_long' and `long_to_bignum'. Older implementations of C
don't support this type; if you have such an implementation you can
you could write alternate versions that don't require this type). */
/* #define BIGNUM_NO_ULONG */
\f
-#include "ansidecl.h"
-
#ifdef MIT_SCHEME
typedef SCHEME_OBJECT bignum_type;
bignum_comparison_equal, bignum_comparison_less, bignum_comparison_greater
};
-typedef PTR bignum_procedure_context;
-extern bignum_type EXFUN (bignum_make_zero, (void));
-extern bignum_type EXFUN (bignum_make_one, (int negative_p));
-extern int EXFUN (bignum_equal_p, (bignum_type, bignum_type));
-extern enum bignum_comparison EXFUN (bignum_test, (bignum_type));
-extern enum bignum_comparison EXFUN
- (bignum_compare, (bignum_type, bignum_type));
-extern bignum_type EXFUN (bignum_add, (bignum_type, bignum_type));
-extern bignum_type EXFUN (bignum_subtract, (bignum_type, bignum_type));
-extern bignum_type EXFUN (bignum_negate, (bignum_type));
-extern bignum_type EXFUN (bignum_multiply, (bignum_type, bignum_type));
-extern int EXFUN
- (bignum_divide, (bignum_type numerator,
+typedef void * bignum_procedure_context;
+extern bignum_type bignum_make_zero (void);
+extern bignum_type bignum_make_one (int negative_p);
+extern int bignum_equal_p (bignum_type, bignum_type);
+extern enum bignum_comparison bignum_test (bignum_type);
+extern enum bignum_comparison bignum_compare
+ (bignum_type, bignum_type);
+extern bignum_type bignum_add (bignum_type, bignum_type);
+extern bignum_type bignum_subtract (bignum_type, bignum_type);
+extern bignum_type bignum_negate (bignum_type);
+extern bignum_type bignum_multiply (bignum_type, bignum_type);
+extern int bignum_divide
+ (bignum_type numerator,
bignum_type denominator,
bignum_type * quotient,
- bignum_type * remainder));
-extern bignum_type EXFUN (bignum_quotient, (bignum_type, bignum_type));
-extern bignum_type EXFUN (bignum_remainder, (bignum_type, bignum_type));
+ bignum_type * remainder);
+extern bignum_type bignum_quotient (bignum_type, bignum_type);
+extern bignum_type bignum_remainder (bignum_type, bignum_type);
#ifndef BIGNUM_NO_ULONG
-extern bignum_type EXFUN (long_to_bignum, (long));
-extern bignum_type EXFUN (ulong_to_bignum, (unsigned long));
-extern long EXFUN (bignum_to_long, (bignum_type));
-extern unsigned long EXFUN (bignum_to_ulong, (bignum_type));
+extern bignum_type long_to_bignum (long);
+extern bignum_type ulong_to_bignum (unsigned long);
+extern long bignum_to_long (bignum_type);
+extern unsigned long bignum_to_ulong (bignum_type);
#endif /* not BIGNUM_NO_ULONG */
-extern bignum_type EXFUN (double_to_bignum, (double));
-extern double EXFUN (bignum_to_double, (bignum_type));
-extern int EXFUN
- (bignum_fits_in_word_p, (bignum_type,
+extern bignum_type double_to_bignum (double);
+extern double bignum_to_double (bignum_type);
+extern int bignum_fits_in_word_p
+ (bignum_type,
long word_length,
- int twos_complement_p));
-extern bignum_type EXFUN (bignum_length_in_bits, (bignum_type));
-extern bignum_type EXFUN (bignum_length_upper_limit, (void));
-extern bignum_type EXFUN (bignum_shift_left, (bignum_type, unsigned long));
-extern bignum_type EXFUN
- (unsigned_long_to_shifted_bignum, (unsigned long, unsigned long, int));
-extern bignum_type EXFUN
- (digit_stream_to_bignum,
- (unsigned int n_digits,
- unsigned int EXFUN ((*producer), (bignum_procedure_context)),
+ int twos_complement_p);
+extern bignum_type bignum_length_in_bits (bignum_type);
+extern bignum_type bignum_length_upper_limit (void);
+extern bignum_type bignum_shift_left (bignum_type, unsigned long);
+extern bignum_type unsigned_long_to_shifted_bignum
+ (unsigned long, unsigned long, int);
+extern bignum_type digit_stream_to_bignum
+ (unsigned int n_digits,
+ unsigned int (*producer) (bignum_procedure_context),
bignum_procedure_context context,
unsigned int radix,
- int negative_p));
-extern void EXFUN
- (bignum_to_digit_stream,
- (bignum_type, unsigned int radix,
- void EXFUN ((*consumer), (bignum_procedure_context, long)),
- bignum_procedure_context context));
-extern long EXFUN (bignum_max_digit_stream_radix, (void));
+ int negative_p);
+extern void bignum_to_digit_stream
+ (bignum_type, unsigned int radix,
+ void (*consumer) (bignum_procedure_context, long),
+ bignum_procedure_context context);
+extern long bignum_max_digit_stream_radix (void);
+
+#endif /* !SCM_BIGNUM_H_INCLUDED */
/* -*-C-*-
-$Id: bigprm.c,v 1.10 2007/01/05 21:19:25 cph Exp $
+$Id: bigprm.c,v 1.11 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
-#include "zones.h"
\f
#define BIGNUM_TEST(predicate) \
{ \
PRIMITIVE_HEADER (1); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, BIGNUM_P); \
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (predicate (ARG_REF (1)))); \
}
#define BIGNUM_COMPARISON(predicate) \
{ \
PRIMITIVE_HEADER (2); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, BIGNUM_P); \
CHECK_ARG (2, BIGNUM_P); \
PRIMITIVE_RETURN \
#define BIGNUM_BINARY(operator) \
{ \
PRIMITIVE_HEADER (2); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, BIGNUM_P); \
CHECK_ARG (2, BIGNUM_P); \
PRIMITIVE_RETURN (operator ((ARG_REF (1)), (ARG_REF (2)))); \
SCHEME_OBJECT quotient;
SCHEME_OBJECT remainder;
PRIMITIVE_HEADER (2);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, BIGNUM_P);
CHECK_ARG (2, BIGNUM_P);
if (bignum_divide ((ARG_REF (1)), (ARG_REF (2)), ("ient), (&remainder)))
{ \
SCHEME_OBJECT result; \
PRIMITIVE_HEADER (2); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, BIGNUM_P); \
CHECK_ARG (2, BIGNUM_P); \
result = (operator ((ARG_REF (1)), (ARG_REF (2)))); \
BIGNUM_QR (bignum_remainder)
\f
static void
-DEFUN (listify_bignum_consumer, (previous_cdr, digit),
- PTR previous_cdr AND
+listify_bignum_consumer (void * previous_cdr,
long digit)
{
(* ((SCHEME_OBJECT *) previous_cdr)) =
"Returns a list of the digits of BIGNUM in RADIX.")
{
PRIMITIVE_HEADER (2);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, BIGNUM_P);
{
SCHEME_OBJECT bignum = (ARG_REF (1));
DEFINE_PRIMITIVE ("FIXNUM->BIGNUM", Prim_fixnum_to_bignum, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, FIXNUM_P);
PRIMITIVE_RETURN (FIXNUM_TO_BIGNUM (ARG_REF (1)));
}
DEFINE_PRIMITIVE ("BIGNUM->FIXNUM", Prim_bignum_to_fixnum, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, BIGNUM_P);
PRIMITIVE_RETURN (bignum_to_fixnum (ARG_REF (1)));
}
DEFINE_PRIMITIVE ("FLONUM->BIGNUM", Prim_flonum_to_bignum, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, FLONUM_P);
PRIMITIVE_RETURN (FLONUM_TO_BIGNUM (ARG_REF (1)));
}
DEFINE_PRIMITIVE ("BIGNUM->FLONUM", Prim_bignum_to_flonum, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, BIGNUM_P);
PRIMITIVE_RETURN (bignum_to_flonum (ARG_REF (1)));
}
+++ /dev/null
-/* -*-C-*-
-
-$Id: bintopsb.c,v 9.81 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This File contains the code to translate internal format binary
- files to portable format. */
-\f
-/* IO definitions */
-
-#include "psbmap.h"
-#include "limits.h"
-#define internal_file input_file
-#define portable_file output_file
-
-#undef HEAP_MALLOC
-#define HEAP_MALLOC malloc
-
-static long
-DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
-{
- return (fread (((char *) To_Where),
- (sizeof (SCHEME_OBJECT)),
- Count,
- internal_file));
-}
-
-#define INHIBIT_FASL_VERSION_CHECK
-#define INHIBIT_COMPILED_VERSION_CHECK
-#define INHIBIT_CHECKSUMS
-#include "load.c"
-#include "bltdef.h"
-#include "trap.h"
-
-/* Character macros and procedures */
-
-#ifndef __IRIX__
-extern int strlen ();
-#endif
-
-#ifndef isalpha
-
-/* Just in case the stdio library atypically contains the character
- macros, just like the C book claims. */
-
-#include <ctype.h>
-
-#endif /* isalpha */
-
-#ifndef ispunct
-
-/* This is in some libraries but not others */
-
-static char
- punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
-
-static Boolean
-DEFUN (ispunct_local, (c), fast char c)
-{
- fast char * s;
-
- s = &punctuation[0];
- while (*s != '\0')
- if (*s++ == c)
- return (true);
- return (false);
-}
-
-#define ispunct ispunct_local
-
-#endif /* ispunct */
-\f
-/* Needed to upgrade */
-
-#define TC_PRIMITIVE_EXTERNAL 0x10
-
-#define STRING_LENGTH_TO_LONG(value) \
- ((long) (upgrade_lengths_p ? (OBJECT_DATUM (value)) : (value)))
-
-/* In case there is no compiled code support. */
-
-#ifndef FORMAT_WORD_LOW_BYTE
-#define FORMAT_WORD_LOW_BYTE(x) x
-#endif
-
-#ifndef FORMAT_WORD_HIGH_BYTE
-#define FORMAT_WORD_HIGH_BYTE(x) x
-#endif
-
-#ifndef COMPILED_ENTRY_FORMAT_WORD
-#define COMPILED_ENTRY_FORMAT_WORD(entry) 0
-#endif
-
-#ifndef EXTRACT_EXECUTE_CACHE_ARITY
-#define EXTRACT_EXECUTE_CACHE_ARITY(v,a) do { } while (0)
-#endif
-
-#if (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE)
-
-#undef START_CLOSURE_RELOCATION
-#undef END_CLOSURE_RELOCATION
-#undef EXTRACT_CLOSURE_ENTRY_ADDRESS
-#undef STORE_CLOSURE_ENTRY_ADDRESS
-#undef EXTRACT_OPERATOR_LINKAGE_ADDRESS
-#undef STORE_OPERATOR_LINKAGE_ADDRESS
-#undef START_OPERATOR_RELOCATION
-#undef END_OPERATOR_RELOCATION
-
-#define START_CLOSURE_RELOCATION(foo) do {} while (0)
-#define END_CLOSURE_RELOCATION(foo) do {} while (0)
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(var,addr) do {} while (0)
-#define STORE_CLOSURE_ENTRY_ADDRESS(var,addr) do {} while (0)
-#define EXTRACT_OPERATOR_LINKAGE_ADDRESS(var,addr) do {} while (0)
-#define STORE_OPERATOR_LINKAGE_ADDRESS(var,addr) do {} while (0)
-#define START_OPERATOR_RELOCATION(foo) do {} while (0)
-#define END_OPERATOR_RELOCATION(foo) do {} while (0)
-
-#endif /* (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE) */
-\f
-/* Global data */
-
-static Boolean
- allow_bands_p = false,
- allow_compiled_p = false,
- allow_constant_space_p = false,
- allow_nmv_p = false,
- c_compiled_p = false,
- endian_invert_p = false,
- shuffle_bytes_p = false,
- swap_bytes_p = false,
- upgrade_compiled_p = false,
- upgrade_lengths_p = false,
- upgrade_primitives_p = false,
- upgrade_traps_p = false,
- warn_portable_p = true;
-
-static long
- Heap_Relocation, Constant_Relocation,
- Max_Stack_Offset,
- Scan, Free, Objects,
- Scan_Constant, Free_Constant, Constant_Objects,
- Scan_Pure, Free_Pure, Pure_Objects;
-
-static SCHEME_OBJECT
- * Mem_Base, * Constant_Space, * Constant_Top,
- * Free_Objects, * Free_Cobjects, * Free_Pobjects,
- * compiled_entry_table, * compiled_entry_pointer,
- * compiled_entry_table_end,
- * compiled_block_table, * compiled_block_pointer,
- * compiled_block_table_end,
- * primitive_table, * primitive_table_end,
- * c_code_table, * c_code_table_end;
-
-static long
- NFlonums,
- NIntegers, NBits,
- NBitstrs, NBBits,
- NStrings, NChars,
- NPChars, NCChars;
-
-#define NO_ALIGNMENT(index) do { } while (0)
-
-#ifdef FLOATING_ALIGNMENT
-#define INDEX_ALIGN_FLOAT(index) do \
-{ \
- while (((((unsigned long) (& Mem_Base[(index) + 1])) \
- - ((unsigned long) (& Mem_Base[0]))) \
- & FLOATING_ALIGNMENT) \
- != 0) \
- Mem_Base[(index)++] = SHARP_F; \
-} while (0)
-#endif /* FLOATING_ALIGNMENT */
-
-#ifndef INDEX_ALIGN_FLOAT
-#define INDEX_ALIGN_FLOAT NO_ALIGNMENT
-#endif /* INDEX_ALIGN_FLOAT */
-\f
-#define OUT(s) \
-{ \
- fprintf (portable_file, (s)); \
- break; \
-}
-
-static void
-DEFUN (print_a_char, (c, name), fast char c AND char * name)
-{
- switch (c)
- {
- case '\n': OUT ("\\n");
- case '\t': OUT ("\\t");
- case '\b': OUT ("\\b");
- case '\r': OUT ("\\r");
- case '\f': OUT ("\\f");
- case '\\': OUT ("\\\\");
- case '\0': OUT ("\\0");
- case ' ' : OUT (" ");
-
- default:
- if ((isascii (c)) && ((isalpha (c)) || (isdigit (c)) || (ispunct (c))))
- putc (c, portable_file);
- else
- {
- unsigned int x = (((int) c) & ((1 << CHAR_BIT) - 1));
- if (warn_portable_p)
- {
- fprintf (stderr,
- "%s: %s: File may not be portable: c = 0x%x\n",
- program_name, name, x);
- warn_portable_p = false;
- }
- /* This does not follow C conventions, but eliminates ambiguity */
- fprintf (portable_file, "\\X%d ", x);
- }
- }
- return;
-}
-\f
-#undef MAKE_BROKEN_HEART
-#define MAKE_BROKEN_HEART(offset) (BROKEN_HEART_ZERO + (offset))
-
-#define DO_COMPOUND(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) do \
-{ \
- Old_Address += (Rel); \
- Old_Contents = (*Old_Address); \
- if (BROKEN_HEART_P (Old_Contents)) \
- (Mem_Base [(Scn)]) = (OBJECT_NEW_TYPE ((Code), Old_Contents)); \
- else \
- kernel_code; \
-} while (0)
-
-#define STANDARD_KERNEL(kernel_code, type, Code, Scn, Obj, FObj) do \
-{ \
- (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
- { \
- fast long length = (OBJECT_DATUM (Old_Contents)); \
- kernel_code; \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \
- (Obj) += 1; \
- (*(FObj)++) = (MAKE_OBJECT ((type), 0)); \
- (*(FObj)++) = Old_Contents; \
- while ((length--) > 0) \
- (*(FObj)++) = (*Old_Address++); \
- } \
-} while (0)
-\f
-#define DO_STRING_KERNEL() do \
-{ \
- NStrings += 1; \
- NChars += (pointer_to_char (length - 1)); \
-} while (0)
-
-#define DO_BIGNUM_KERNEL() do \
-{ \
- NIntegers += 1; \
- NBits += \
- (((* ((bignum_digit_type *) (Old_Address + 1))) \
- & BIGNUM_DIGIT_MASK) \
- * BIGNUM_DIGIT_LENGTH); \
-} while (0)
-
-#define DO_BIT_STRING_KERNEL() do \
-{ \
- NBitstrs += 1; \
- NBBits += (Old_Address [BIT_STRING_LENGTH_OFFSET]); \
-} while (0)
-
-#define DO_FLONUM_KERNEL(Code, Scn, Obj, FObj) do \
-{ \
- int ctr; \
- SCHEME_OBJECT * dest; \
- \
- (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
- NFlonums += 1; \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \
- (Obj) += 1; \
- (*(FObj)++) = (MAKE_OBJECT (TC_BIG_FLONUM, 0)); \
- dest = (FObj); \
- for (ctr = 0; ctr < float_to_pointer; ctr++) \
- *dest++ = (*Old_Address++); \
- (FObj) = dest; \
-} while (0)
-
-#define DO_STRING(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
- STANDARD_KERNEL (DO_STRING_KERNEL (), \
- TC_CHARACTER_STRING, \
- Code, Scn, Obj, FObj))
-
-#define DO_BIGNUM(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
- STANDARD_KERNEL (DO_BIGNUM_KERNEL (), TC_BIG_FIXNUM, \
- Code, Scn, Obj, FObj))
-
-#define DO_BIT_STRING(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
- STANDARD_KERNEL (DO_BIT_STRING_KERNEL (), TC_BIT_STRING, \
- Code, Scn, Obj, FObj))
-
-#define DO_FLONUM(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
- DO_FLONUM_KERNEL (Code, Scn, Obj, FObj))
-\f
-static void
-DEFUN (print_a_fixnum, (val), long val)
-{
- fast long size_in_bits;
- fast unsigned long temp;
-
- temp = ((val < 0) ? -val : val);
- for (size_in_bits = 0; temp != 0; size_in_bits += 1)
- temp = temp >> 1;
- fprintf (portable_file, "%02x %c ", TC_FIXNUM, (val < 0 ? '-' : '+'));
- if (val == 0)
- fprintf (portable_file, "0\n");
- else
- {
- fprintf (portable_file, "%ld ", size_in_bits);
- temp = ((val < 0) ? -val : val);
- while (temp != 0)
- {
- fprintf (portable_file, "%01lx", (temp & 0xf));
- temp = temp >> 4;
- }
- fprintf (portable_file, "\n");
- }
- return;
-}
-\f
-static void
-DEFUN (print_a_string_internal, (len, str), fast long len AND fast char * str)
-{
- fprintf (portable_file, "%ld ", len);
- if (shuffle_bytes_p)
- {
- while (len > 0)
- {
- print_a_char (str[3], "print_a_string");
- if (len > 1)
- print_a_char (str[2], "print_a_string");
- if (len > 2)
- print_a_char (str[1], "print_a_string");
- if (len > 3)
- print_a_char (str[0], "print_a_string");
- len -= 4;
- str += 4;
- }
- }
- else
- while (--len >= 0)
- print_a_char (*str++, "print_a_string");
- putc ('\n', portable_file);
- return;
-}
-\f
-static void
-DEFUN (print_a_string, (from), SCHEME_OBJECT * from)
-{
- long len, maxlen;
-
- maxlen = ((pointer_to_char ((OBJECT_DATUM (*from++)) - 1)) - 1);
- len = (STRING_LENGTH_TO_LONG (*from++));
-
- /* If compacting, do not compact strings that have non-default
- maximum lengths.
- */
-
- fprintf (portable_file,
- "%02x %ld ",
- TC_CHARACTER_STRING,
- ((compact_p
- && ((BYTES_TO_WORDS (len + 1)) == (BYTES_TO_WORDS (maxlen + 1))))
- ? len
- : maxlen));
-
- print_a_string_internal (len, ((char *) from));
- return;
-}
-
-static void
-DEFUN (print_a_primitive, (arity, length, name),
- long arity AND long length AND char * name)
-{
- fprintf (portable_file, "%ld ", arity);
- print_a_string_internal (length, name);
- return;
-}
-
-static void
-DEFUN (print_a_c_code_block, (nentries, length, name),
- long nentries AND long length AND char * name)
-{
- fprintf (portable_file, "%ld ", nentries);
- print_a_string_internal (length, name);
- return;
-}
-\f
-static long
-DEFUN (bignum_length, (bignum), SCHEME_OBJECT bignum)
-{
- if (BIGNUM_ZERO_P (bignum))
- return (0);
- {
- bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
- fast bignum_digit_type digit = (BIGNUM_REF (bignum, index));
- fast long result;
- if (index >= (LONG_MAX / BIGNUM_DIGIT_LENGTH))
- goto loser;
- result = (index * BIGNUM_DIGIT_LENGTH);
- while (digit > 0)
- {
- result += 1;
- if (result >= LONG_MAX)
- goto loser;
- digit >>= 1;
- }
- return (result);
- }
- loser:
- fprintf (stderr, "%s: Bignum exceeds representable length.\n",
- program_name);
- quit (1);
- /*NOTREACHED*/
- return (0);
-}
-\f
-static void
-DEFUN (print_a_bignum, (bignum_ptr), SCHEME_OBJECT * bignum_ptr)
-{
- SCHEME_OBJECT bignum;
-
- bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, bignum_ptr));
-
- if (BIGNUM_ZERO_P (bignum))
- {
- fprintf (portable_file, "%02x + 0\n",
- (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
- return;
- }
- {
- int the_type = TC_BIG_FIXNUM;
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- fast long length_in_bits = (bignum_length (bignum));
- fast int bits_in_digit = 0;
- fast bignum_digit_type accumulator;
-
- /* This attempts to preserve non-canonicalized bignums as such.
- The test below fails for the most negative fixnum represented
- as a bignum
- */
-
- if (compact_p && (length_in_bits > fixnum_to_bits))
- the_type = TC_FIXNUM;
-
- fprintf (portable_file, "%02x %c %ld ",
- the_type,
- ((BIGNUM_NEGATIVE_P (bignum)) ? '-' : '+'),
- length_in_bits);
- accumulator = (*scan++);
- bits_in_digit = ((length_in_bits < BIGNUM_DIGIT_LENGTH)
- ? length_in_bits
- : BIGNUM_DIGIT_LENGTH);
- while (length_in_bits > 0)
- {
- if (bits_in_digit > 4)
- {
- fprintf (portable_file, "%01lx", (accumulator & 0xf));
- length_in_bits -= 4;
- accumulator >>= 4;
- bits_in_digit -= 4;
- }
- else if (bits_in_digit == 4)
- {
- fprintf (portable_file, "%01lx", accumulator);
- length_in_bits -= 4;
- if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
- {
- accumulator = (*scan++);
- bits_in_digit = BIGNUM_DIGIT_LENGTH;
- }
- else if (length_in_bits > 0)
- {
- accumulator = (*scan++);
- bits_in_digit = length_in_bits;
- }
- else
- break;
- }
- else if (bits_in_digit < length_in_bits)
- {
- long carry = accumulator;
- int diff_bits = (4 - bits_in_digit);
- accumulator = (*scan++);
- fprintf (portable_file, "%01lx",
- (carry
- | ((accumulator & ((1 << diff_bits) - 1)) <<
- bits_in_digit)));
- length_in_bits -= 4;
- bits_in_digit = (BIGNUM_DIGIT_LENGTH - diff_bits);
- if (length_in_bits >= bits_in_digit)
- accumulator >>= diff_bits;
- else if (length_in_bits > 0)
- {
- accumulator >>= diff_bits;
- bits_in_digit = length_in_bits;
- }
- else
- break;
- }
- else
- {
- fprintf (portable_file, "%01lx", accumulator);
- break;
- }
- }
- }
- fprintf (portable_file, "\n");
- return;
-}
-\f
-/* The following procedure assumes that a C long is at least 4 bits. */
-
-static void
-DEFUN (print_a_bit_string, (from), SCHEME_OBJECT * from)
-{
- SCHEME_OBJECT the_bit_string;
- fast long bits_remaining, leftover_bits;
- fast SCHEME_OBJECT accumulator = ((SCHEME_OBJECT) 0), next_word, *scan;
-
- the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, from));
- bits_remaining = (BIT_STRING_LENGTH (the_bit_string));
- fprintf (portable_file, "%02x %ld", TC_BIT_STRING, bits_remaining);
-
- if (bits_remaining != 0)
- {
- fprintf (portable_file, " ");
- scan = (BIT_STRING_LOW_PTR (the_bit_string));
- for (leftover_bits = 0;
- bits_remaining > 0;
- bits_remaining -= OBJECT_LENGTH)
- {
- next_word = (* (INC_BIT_STRING_PTR (scan)));
-
- if (bits_remaining < OBJECT_LENGTH)
- next_word &= (LOW_MASK (bits_remaining));
-
- if (leftover_bits == 0)
- leftover_bits = ((bits_remaining > OBJECT_LENGTH)
- ? OBJECT_LENGTH
- : bits_remaining);
- else
- {
- accumulator &= (LOW_MASK (leftover_bits));
- accumulator |=
- ((next_word & (LOW_MASK (4 - leftover_bits))) << leftover_bits);
- next_word = (next_word >> (4 - leftover_bits));
- leftover_bits += ((bits_remaining > OBJECT_LENGTH)
- ? (OBJECT_LENGTH - 4)
- : (bits_remaining - 4));
- fprintf (portable_file, "%01lx", (accumulator & 0xf));
- }
-
- for (accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
- {
- fprintf (portable_file, "%01lx", (accumulator & 0xf));
- accumulator = (accumulator >> 4);
- }
- }
- if (leftover_bits != 0)
- fprintf (portable_file, "%01lx", (accumulator & 0xf));
- }
- fprintf (portable_file, "\n");
- return;
-}
-\f
-union flonum_u
-{
- double dval;
- unsigned long lval[float_to_pointer];
-};
-
-static void
-DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src)
-{
- double val;
- union flonum_u utemp;
- fast long size_in_bits;
- fast double mant, temp;
- int expt, ctr;
- extern double EXFUN (frexp, (double, int *));
-
- for (ctr = 0; ctr < float_to_pointer; ctr++)
- utemp.lval[ctr] = ((unsigned long) src[ctr]);
- val = utemp.dval;
-
- fprintf (portable_file, "%02x %c ",
- TC_BIG_FLONUM,
- ((val < 0.0) ? '-' : '+'));
- if (val == 0.0)
- {
- fprintf (portable_file, "0\n");
- return;
- }
- mant = frexp (((val < 0.0) ? -val : val), &expt);
- size_in_bits = 1;
-
- for (temp = ((mant * 2.0) - 1.0); temp != 0; size_in_bits += 1)
- {
- temp *= 2.0;
- if (temp >= 1.0)
- temp -= 1.0;
- }
- fprintf (portable_file, "%d %ld ", expt, size_in_bits);
-
- for (size_in_bits = (hex_digits (size_in_bits));
- size_in_bits > 0;
- size_in_bits -= 1)
- {
- fast unsigned int digit;
-
- digit = 0;
- for (expt = 4; --expt >= 0;)
- {
- mant *= 2.0;
- digit = digit << 1;
- if (mant >= 1.0)
- {
- mant -= 1.0;
- digit += 1;
- }
- }
- fprintf (portable_file, "%01x", digit);
- }
- putc ('\n', portable_file);
- return;
-}
-\f
-/* Normal Objects */
-
-#define DO_CELL(Code, Rel, Fre, Scn, Obj, FObj) do \
-{ \
- Old_Address += (Rel); \
- Old_Contents = (*Old_Address); \
- if (BROKEN_HEART_P (Old_Contents)) \
- (Mem_Base [(Scn)]) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
- else \
- { \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
- (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
- (Mem_Base [(Fre)++]) = Old_Contents; \
- } \
-} while (0)
-
-#define DO_PAIR(Code, Rel, Fre, Scn, Obj, FObj) do \
-{ \
- Old_Address += (Rel); \
- Old_Contents = (*Old_Address); \
- if (BROKEN_HEART_P (Old_Contents)) \
- (Mem_Base [(Scn)]) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
- else \
- { \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
- (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
- (Mem_Base [(Fre)++]) = Old_Contents; \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- } \
-} while (0)
-
-#define DO_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do \
-{ \
- Old_Address += (Rel); \
- Old_Contents = (*Old_Address); \
- if (BROKEN_HEART_P (Old_Contents)) \
- (Mem_Base [(Scn)]) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
- else \
- { \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
- (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
- (Mem_Base [(Fre)++]) = Old_Contents; \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- } \
-} while (0)
-
-#define DO_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do \
-{ \
- Old_Address += (Rel); \
- Old_Contents = (*Old_Address); \
- if (BROKEN_HEART_P (Old_Contents)) \
- (Mem_Base [(Scn)]) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
- else \
- { \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
- (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
- (Mem_Base [(Fre)++]) = Old_Contents; \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- } \
-} while (0)
-
-#define DO_RAW_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do \
-{ \
- Old_Address += (Rel); \
- Old_Contents = (* Old_Address); \
- if (BROKEN_HEART_P (Old_Contents)) \
- (Mem_Base [(Scn)]) = (OBJECT_DATUM (Old_Contents)); \
- else \
- { \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
- (Mem_Base [(Scn)]) = (Fre); \
- (Mem_Base [(Fre)++]) = Old_Contents; \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- } \
-} while (0)
-\f
-#define COPY_VECTOR(Fre) do \
-{ \
- fast long len = (OBJECT_DATUM (Old_Contents)); \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
- (Mem_Base [(Fre)++]) = Old_Contents; \
- while ((len--) > 0) \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
-} while (0)
-
-/* This is a hack to get the cross compiler to work
- accross different endianness.
-*/
-
-#define COPY_INVERTED_VECTOR(Fre) do \
-{ \
- fast long len1, len2; \
- SCHEME_OBJECT * Saved; \
- \
- len1 = (OBJECT_DATUM (Old_Contents)); \
- (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
- (Mem_Base [(Fre)++]) = Old_Contents; \
- if ((OBJECT_TYPE (* Old_Address)) != TC_MANIFEST_NM_VECTOR) \
- { \
- fprintf (stderr, "%s: Bad compiled code block found.\n", \
- program_name); \
- quit (1); \
- } \
- len2 = (OBJECT_DATUM (*Old_Address)); \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
- Old_Address += len2; \
- Saved = Old_Address; \
- len1 -= (len2 + 1); \
- while ((len2--) > 0) \
- (Mem_Base [(Fre)++]) = (*--Old_Address); \
- Old_Address = Saved; \
- while ((len1--) > 0) \
- (Mem_Base [(Fre)++]) = (*Old_Address++); \
-} while (0)
-
-#define DO_VECTOR_2(aligner, copier, Code, Rel, Fre, Scn, Obj, FObj) do \
-{ \
- Old_Address += (Rel); \
- Old_Contents = (*Old_Address); \
- if (BROKEN_HEART_P (Old_Contents)) \
- (Mem_Base [(Scn)]) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
- else \
- { \
- aligner (Fre); \
- (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
- copier (Fre); \
- } \
-} while (0)
-
-#define DO_VECTOR(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_VECTOR_2 (NO_ALIGNMENT, COPY_VECTOR, \
- Code, Rel, Fre, Scn, Obj, FObj)
-
-#define DO_INVERTED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_VECTOR_2 (NO_ALIGNMENT, COPY_INVERTED_VECTOR, \
- Code, Rel, Fre, Scn, Obj, FObj)
-\f
-#ifdef HAS_COMPILER_SUPPORT
-
-#define CHAR_OFFSET(a,b) (((char *) (a)) - ((char *) (b)))
-#define OBJ_OFFSET(a,b) (((SCHEME_OBJECT *) (a)) - ((SCHEME_OBJECT *) (b)))
-
-#define DO_ENTRY_INTERNAL(sub, copy, Code, Rel, Fre, Scn, Obj, FObj) do \
-{ \
- long offset; \
- SCHEME_OBJECT * saved; \
- \
- Old_Address += (Rel); \
- saved = Old_Address; \
- Get_Compiled_Block (Old_Address, saved); \
- Old_Contents = (*Old_Address); \
- entry_no = (compiled_entry_pointer - compiled_entry_table); \
- offset = (sub (saved, Old_Address)); \
- (*compiled_entry_pointer++) = (LONG_TO_UNSIGNED_FIXNUM (offset)); \
- if (BROKEN_HEART_P (Old_Contents)) \
- (*compiled_entry_pointer++) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
- else \
- { \
- INDEX_ALIGN_FLOAT (Fre); \
- (*compiled_entry_pointer++) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, (Fre))); \
- copy (Fre); \
- } \
-} while (0)
-
-#define DO_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_VECTOR, \
- Code, Rel, Fre, Scn, Obj, FObj)
-
-#define DO_INVERTED_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_INVERTED_VECTOR, \
- Code, Rel, Fre, Scn, Obj, FObj)
-
-#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_C_COMPILED_BLOCK, \
- Code, Rel, Fre, Scn, Obj, FObj)
-
-#define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_ENTRY_INTERNAL (CHAR_OFFSET, COPY_VECTOR, \
- Code, Rel, Fre, Scn, Obj, FObj)
-
-#define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
- DO_ENTRY_INTERNAL (OBJ_OFFSET, COPY_C_COMPILED_BLOCK, \
- Code, Rel, Fre, Scn, Obj, FObj)
-\f
-/* This depends on the fact that a compiled code block has an NMV
- header in the first or second words.
- */
-
-long
-DEFUN (copy_c_compiled_block, (Fre, Old_Contents, Old_Address),
- long Fre AND SCHEME_OBJECT Old_Contents AND SCHEME_OBJECT * Old_Address)
-{
- SCHEME_OBJECT preserved_nmv, preserved_loc;
- SCHEME_OBJECT nmv_replacement
- = (MAKE_OBJECT (TC_BROKEN_HEART,
- (compiled_block_pointer
- - compiled_block_table)));
- fast long len = (OBJECT_DATUM (Old_Contents));
-
- *Old_Address++ = (MAKE_BROKEN_HEART (Fre));
- if ((OBJECT_TYPE (Old_Contents)) != TC_MANIFEST_CLOSURE)
- {
- if ((OBJECT_TYPE (Old_Contents)) == TC_MANIFEST_NM_VECTOR)
- {
- preserved_nmv = Old_Contents;
- preserved_loc = (LONG_TO_UNSIGNED_FIXNUM (Fre));
- Old_Contents = nmv_replacement;
- }
- else if ((OBJECT_TYPE (*Old_Address)) == TC_MANIFEST_NM_VECTOR)
- {
- preserved_nmv = *Old_Address;
- preserved_loc = (LONG_TO_UNSIGNED_FIXNUM ((Fre) + 1));
- *Old_Address = nmv_replacement;
- }
- else
- {
- fprintf (stderr,
- "%s: Improperly formatted C-compiled code block.\n",
- program_name);
- quit (1);
- }
-
- *compiled_block_pointer++ = preserved_loc;
- *compiled_block_pointer++ = preserved_nmv;
- }
-
- (Mem_Base [(Fre)++]) = Old_Contents;
- while ((len--) > 0)
- (Mem_Base [(Fre)++]) = (*Old_Address++);
- return (Fre);
-}
-
-#define COPY_C_COMPILED_BLOCK(Fre) do \
-{ \
- Fre = copy_c_compiled_block (Fre, Old_Contents, Old_Address); \
-} while (0)
-\f
-#else /* no HAS_COMPILER_SUPPORT */
-
-#define COMPILER_BAD_STMT(name) do \
-{ \
- fprintf (stderr, \
- "%s: Invoking %s with no compiler support!\n", \
- program_name, name); \
- quit (1); \
-} while (0)
-
-#define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
- COMPILER_BAD_STMT ("DO_COMPILED_ENTRY")
-
-#define DO_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \
- COMPILER_BAD_STMT ("DO_COMPILED_BLOCK")
-
-#define DO_INVERTED_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \
- COMPILER_BAD_STMT ("DO_INVERTED_COMPILED_BLOCK")
-
-#define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
- COMPILER_BAD_STMT ("DO_C_COMPILED_ENTRY")
-
-#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \
- COMPILER_BAD_STMT ("DO_C_COMPILED_BLOCK")
-
-#endif /* HAS_COMPILER_SUPPORT */
-\f
-/* Constant/Pure space utilities */
-
-static SCHEME_OBJECT *
-DEFUN (find_constant_top, (constant_space, count),
- SCHEME_OBJECT * constant_space AND unsigned long count)
-{
- SCHEME_OBJECT pattern = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
- SCHEME_OBJECT * limit = (constant_space + count);
-
- while (((* (limit - 1)) == pattern)
- && (limit > constant_space))
- limit -= 1;
- return (limit);
-}
-
-static Boolean
-DEFUN (address_in_pure_space, (addr), SCHEME_OBJECT * addr)
-{
- Boolean result = false;
- SCHEME_OBJECT * where, * low_constant;
-
- low_constant = Constant_Space;
- where = (Constant_Top - 1);
-
- while (where >= low_constant)
- {
- where -= (1 + (OBJECT_DATUM (* where)));
- if (where < addr)
- {
- where += 1; /* block start */
- result = (addr <= (where + (OBJECT_DATUM (* where))));
- break;
- }
- }
- return (result);
-}
-\f
-/* Common Pointer Code */
-
-#define DO_POINTER(Scn, Action) do \
-{ \
- long the_datum; \
- \
- Old_Address = (OBJECT_ADDRESS (This)); \
- the_datum = (OBJECT_DATUM (This)); \
- if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) \
- Action (HEAP_CODE, Heap_Relocation, Free, \
- Scn, Objects, Free_Objects); \
- else if ((the_datum >= Const_Base) \
- && (the_datum < Dumped_Constant_Top)) \
- { \
- SCHEME_OBJECT * new_addr; \
- \
- new_addr = (Old_Address + Constant_Relocation); \
- if (address_in_pure_space (new_addr)) \
- Action (PURE_CODE, Constant_Relocation, Free_Pure, \
- Scn, Pure_Objects, Free_Pobjects); \
- else \
- Action (CONSTANT_CODE, Constant_Relocation, Free_Constant, \
- Scn, Constant_Objects, Free_Cobjects); \
- } \
- else \
- out_of_range_pointer (This); \
- (Scn) += 1; \
-} while (0)
-
-#define DO_RAW_POINTER(ptr, Scn, Action) do \
-{ \
- long the_datum; \
- \
- the_datum = (SCHEME_ADDR_TO_OLD_DATUM (ptr)); \
- Old_Address = (DATUM_TO_ADDRESS (the_datum)); \
- if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) \
- Action (HEAP_CODE, Heap_Relocation, Free, \
- Scn, Objects, Free_Objects); \
- else if ((the_datum >= Const_Base) \
- && (the_datum < Dumped_Constant_Top)) \
- { \
- SCHEME_OBJECT * new_addr; \
- \
- new_addr = (Old_Address + Constant_Relocation); \
- if (address_in_pure_space (new_addr)) \
- Action (PURE_CODE, Constant_Relocation, Free_Pure, \
- Scn, Pure_Objects, Free_Pobjects); \
- else \
- Action (CONSTANT_CODE, Constant_Relocation, Free_Constant, \
- Scn, Constant_Objects, Free_Cobjects); \
- } \
- else \
- out_of_range_pointer (This); \
-} while (0)
-\f
-static void
-DEFUN (out_of_range_pointer, (ptr), SCHEME_OBJECT ptr)
-{
- fprintf (stderr,
- "%s: The input file is not portable: Out of range pointer.\n",
- program_name);
- fprintf (stderr, "Heap_Base = 0x%lx;\tHeap_Top = 0x%lx\n",
- Heap_Base, Dumped_Heap_Top);
- fprintf (stderr, "Const_Base = 0x%lx;\tConst_Top = 0x%lx\n",
- Const_Base, Dumped_Constant_Top);
- fprintf (stderr, "ptr = 0x%02x|0x%lx\n",
- (OBJECT_TYPE (ptr)), (OBJECT_DATUM (ptr)));
- quit (1);
-}
-
-static SCHEME_OBJECT *
-DEFUN (relocate, (object), SCHEME_OBJECT object)
-{
- long the_datum;
- SCHEME_OBJECT * result;
-
- result = (OBJECT_ADDRESS (object));
- the_datum = (OBJECT_DATUM (object));
-
- if ((the_datum >= Heap_Base) &&
- (the_datum < Dumped_Heap_Top))
- result += Heap_Relocation;
- else if ((the_datum >= Const_Base) &&
- (the_datum < Dumped_Constant_Top))
- result += Constant_Relocation;
- else
- out_of_range_pointer (object);
- return (result);
-}
-\f
-/* Primitive upgrading code. */
-
-#define PRIMITIVE_UPGRADE_SPACE 2048
-
-static SCHEME_OBJECT
- * internal_renumber_table,
- * external_renumber_table,
- * external_prim_name_table;
-
-static Boolean
- found_ext_prims = false;
-
-static SCHEME_OBJECT
-DEFUN (upgrade_primitive, (prim), SCHEME_OBJECT prim)
-{
- long the_datum, the_type, new_type, code;
- SCHEME_OBJECT new;
-
- the_datum = (OBJECT_DATUM (prim));
- the_type = (OBJECT_TYPE (prim));
- if (the_type != TC_PRIMITIVE_EXTERNAL)
- {
- code = the_datum;
- new_type = the_type;
- }
- else
- {
- found_ext_prims = true;
- code = (the_datum + (MAX_BUILTIN_PRIMITIVE + 1));
- new_type = TC_PRIMITIVE;
- }
-
- new = internal_renumber_table[code];
- if (new != SHARP_F)
- return (OBJECT_NEW_TYPE (new_type, new));
- else
- {
- /*
- This does not need to check for overflow because the worst case
- was checked in setup_primitive_upgrade;
- */
-
- new = (MAKE_OBJECT (new_type, Primitive_Table_Length));
- internal_renumber_table[code] = new;
- external_renumber_table[Primitive_Table_Length] = prim;
- Primitive_Table_Length += 1;
- if (the_type == TC_PRIMITIVE_EXTERNAL)
- NPChars +=
- STRING_LENGTH_TO_LONG ((((SCHEME_OBJECT *)
- (external_prim_name_table[the_datum]))
- [STRING_LENGTH_INDEX]));
- else
- NPChars += strlen (builtin_prim_name_table[the_datum]);
- return (new);
- }
-}
-\f
-static SCHEME_OBJECT *
-DEFUN (setup_primitive_upgrade, (Heap), SCHEME_OBJECT * Heap)
-{
- fast long count, length;
- SCHEME_OBJECT * old_prims_vector;
-
- internal_renumber_table = &Heap[0];
- external_renumber_table =
- &internal_renumber_table[PRIMITIVE_UPGRADE_SPACE];
- external_prim_name_table =
- &external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
-
- old_prims_vector = (relocate (Ext_Prim_Vector));
- if (*old_prims_vector == SHARP_F)
- length = 0;
- else
- {
- old_prims_vector = (relocate (*old_prims_vector));
- length = (OBJECT_DATUM (*old_prims_vector));
- old_prims_vector += VECTOR_DATA;
- for (count = 0; count < length; count += 1)
- {
- SCHEME_OBJECT *temp;
-
- /* symbol */
- temp = (relocate (old_prims_vector[count]));
- /* string */
- temp = (relocate (temp[SYMBOL_NAME]));
- external_prim_name_table[count] = ((SCHEME_OBJECT) temp);
- }
- }
- length += (MAX_BUILTIN_PRIMITIVE + 1);
- if (length > PRIMITIVE_UPGRADE_SPACE)
- {
- fprintf (stderr, "%s: Too many primitives.\n", program_name);
- fprintf (stderr,
- "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
- program_name);
- quit (1);
- }
- for (count = 0; count < length; count += 1)
- internal_renumber_table[count] = SHARP_F;
-
- NPChars = 0;
- return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
-}
-\f
-/* Processing of a single area */
-
-#define DO_AREA(code, Area, Bound, Obj, FObj) \
- Process_Area (code, &Area, &Bound, &Obj, &FObj)
-
-static void
-DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj),
- int Code
- AND fast long * Area
- AND fast long * Bound
- AND fast long * Obj
- AND fast SCHEME_OBJECT ** FObj)
-{
- unsigned long entry_no;
- fast SCHEME_OBJECT This, * Old_Address, Old_Contents;
-
- while (*Area != *Bound)
- {
- This = Mem_Base[*Area];
-
-#ifdef PRIMITIVE_EXTERNAL_REUSED
- if (upgrade_primitives_p &&
- ((OBJECT_TYPE (This)) == TC_PRIMITIVE_EXTERNAL))
- {
- Mem_Base[*Area] = (upgrade_primitive (This));
- *Area += 1;
- continue;
- }
-#endif /* PRIMITIVE_EXTERNAL_REUSED */
-
- Switch_by_GC_Type (This)
- {
-
-#ifndef PRIMITIVE_EXTERNAL_REUSED
-
- case TC_PRIMITIVE_EXTERNAL:
-
-#endif /* PRIMITIVE_EXTERNAL_REUSED */
-
- case TC_PRIMITIVE:
- case TC_PCOMB0:
- if (upgrade_primitives_p)
- Mem_Base[*Area] = (upgrade_primitive (This));
- *Area += 1;
- break;
-\f
- case TC_MANIFEST_NM_VECTOR:
- nmv_p = true;
- if (null_nmv_p)
- {
- fast long i;
-
- i = (OBJECT_DATUM (This));
- *Area += 1;
- for ( ; --i >= 0; *Area += 1)
- Mem_Base[*Area] = SHARP_F;
- break;
- }
- else if (!allow_nmv_p)
- {
- if (((OBJECT_DATUM (This)) != 0) && warn_portable_p)
- {
- warn_portable_p = false;
- fprintf (stderr, "%s: File is not portable: NMH found\n",
- program_name);
- }
- }
- *Area += (1 + (OBJECT_DATUM (This)));
- break;
-
- case TC_BROKEN_HEART:
- {
- /* [Broken Heart | 0] is the cdr of fasdumped symbols. */
- /* [Broken Heart | x > 0] indicates a C compiled block. */
- unsigned long the_datum = (OBJECT_DATUM (This));
-
- if (the_datum == 0)
- {
- *Area += 1;
- break;
- }
- else if ((! allow_compiled_p)
- || (! c_compiled_p)
- || ((OBJECT_DATUM (This))
- >= (compiled_block_pointer - compiled_block_table))
- || ((*Area)
- != (UNSIGNED_FIXNUM_TO_LONG
- (compiled_block_table [the_datum]))))
- {
- fprintf (stderr, "%s: Broken Heart found in scan.\n",
- program_name);
- quit (1);
- }
- else
- {
- *Area += (1 + (OBJECT_DATUM (compiled_block_table [1 + the_datum])));
- break;
- }
- }
-\f
- case TC_MANIFEST_CLOSURE:
- if ((! allow_compiled_p) || (! c_compiled_p))
- {
- fprintf (stderr,
- "%s: File contains compiled closures.\n",
- program_name);
- quit (1);
- }
- else
- {
- char * word_ptr;
- long count, address = 0;
- SCHEME_OBJECT * area_end, * scan, * i_scan;
-
- i_scan = (&Mem_Base[*Area]);
- START_CLOSURE_RELOCATION (i_scan);
- scan = (i_scan + 1);
- count = (MANIFEST_CLOSURE_COUNT (scan));
- word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan));
- area_end = ((MANIFEST_CLOSURE_END (scan, count)) - 1);
-
- while ((--count) >= 0)
- {
- scan = ((SCHEME_OBJECT *) (word_ptr));
- word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
- EXTRACT_CLOSURE_ENTRY_ADDRESS (address, scan);
- DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY);
- STORE_CLOSURE_ENTRY_ADDRESS (entry_no, scan);
- }
-
- END_CLOSURE_RELOCATION (area_end);
- *Area += (1 + (area_end - i_scan));
- break;
- }
-\f
- case TC_LINKAGE_SECTION:
- if ((! allow_compiled_p) || (! c_compiled_p))
- {
- fprintf (stderr,
- "%s: File contains linked compiled code.\n",
- program_name);
- quit (1);
- }
- else
- {
- switch (READ_LINKAGE_KIND (This))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- long count = (READ_CACHE_LINKAGE_COUNT (This));
-
- *Area += 1;
- while (--count >= 0)
- {
- DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_TRIPLE);
- *Area += 1;
- }
- break;
- }
-
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- {
- char * word_ptr;
- long count, address = 0;
- SCHEME_OBJECT * area_end, * scan, * i_scan;
-
- i_scan = (&Mem_Base[*Area]);
- START_OPERATOR_RELOCATION (i_scan);
- count = (READ_OPERATOR_LINKAGE_COUNT (This));
- word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan));
- area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count));
-
- while (--count >= 0)
- {
- scan = ((SCHEME_OBJECT *) word_ptr);
- word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
- EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan);
- DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY);
- STORE_OPERATOR_LINKAGE_ADDRESS (entry_no, scan);
- }
- END_OPERATOR_RELOCATION (area_end);
- *Area += (1 + (area_end - i_scan));
- break;
- }
-
- default:
- {
- fprintf (stderr, "%s: Unknown linkage kind.\n",
- program_name);
- quit (1);
- }
- }
- break;
- }
-\f
- case TC_COMPILED_CODE_BLOCK:
- compiled_p = true;
- if (! allow_compiled_p)
- {
- fprintf (stderr,
- "%s: File contains compiled code.\n",
- program_name);
- quit (1);
- }
- else if (c_compiled_p)
- DO_POINTER (*Area, DO_C_COMPILED_BLOCK);
- else if (endian_invert_p)
- DO_POINTER (*Area, DO_INVERTED_COMPILED_BLOCK);
- else
- DO_POINTER (*Area, DO_COMPILED_BLOCK);
- break;
-
- case_compiled_entry_point:
- compiled_p = true;
- if (! allow_compiled_p)
- {
- fprintf (stderr,
- "%s: File contains compiled code.\n",
- program_name);
- quit (1);
- }
- else if (c_compiled_p)
- DO_POINTER (*Area, DO_C_COMPILED_ENTRY);
- else
- DO_POINTER (*Area, DO_COMPILED_ENTRY);
- Mem_Base[*Area - 1] = (MAKE_OBJECT (TC_COMPILED_ENTRY, entry_no));
- break;
-
- case TC_STACK_ENVIRONMENT:
- if (! allow_bands_p)
- {
- fprintf (stderr,
- "%s: File contains stack environments.\n",
- program_name);
- quit (1);
- }
- else
- {
- unsigned long delta;
-
- delta = (((SCHEME_OBJECT *) Dumped_Stack_Top)
- - ((SCHEME_OBJECT *) (OBJECT_DATUM (This))));
- if (delta > Max_Stack_Offset)
- Max_Stack_Offset = delta;
- Mem_Base[*Area] = (MAKE_OBJECT (TC_STACK_ENVIRONMENT, delta));
- *Area += 1;
- }
- break;
-\f
- case TC_FIXNUM:
- NIntegers += 1;
- NBits += fixnum_to_bits;
- /* Fall Through */
-
- case TC_CHARACTER:
- Mem_Base[*Area] = (MAKE_OBJECT (Code, *Obj));
- *Obj += 1;
- **FObj = This;
- *FObj += 1;
- /* Fall through */
-
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_simple_Non_Pointer:
- *Area += 1;
- break;
-
- case TC_REFERENCE_TRAP:
- {
- long kind;
-
- kind = (OBJECT_DATUM (This));
-
- if (upgrade_traps_p)
- {
- /* It is an old UNASSIGNED object. */
- if (kind == 0)
- {
- Mem_Base[*Area] = UNASSIGNED_OBJECT;
- *Area += 1;
- break;
- }
- if (kind == 1)
- {
- Mem_Base[*Area] = UNBOUND_OBJECT;
- *Area += 1;
- break;
- }
- fprintf (stderr,
- "%s: Bad old unassigned object. 0x%x.\n",
- program_name, This);
- quit (1);
- }
- if (kind <= TRAP_MAX_IMMEDIATE)
- {
- /* It is a non pointer. */
-
- *Area += 1;
- break;
- }
- }
- /* Fall through */
-\f
- case TC_WEAK_CONS:
- case_Pair:
- DO_POINTER (*Area, DO_PAIR);
- break;
-
- case_Cell:
- DO_POINTER (*Area, DO_CELL);
- break;
-
- case TC_VARIABLE:
- case_Triple:
- DO_POINTER (*Area, DO_TRIPLE);
- break;
-
- case_Quadruple:
- DO_POINTER (*Area, DO_QUAD);
- break;
-
- case TC_BIG_FLONUM:
- DO_POINTER (*Area, DO_FLONUM);
- break;
-
- case TC_BIG_FIXNUM:
- DO_POINTER (*Area, DO_BIGNUM);
- break;
-
- case TC_CHARACTER_STRING:
- DO_POINTER (*Area, DO_STRING);
- break;
-
- case TC_ENVIRONMENT:
- if (upgrade_traps_p)
- {
- fprintf (stderr,
- "%s: Cannot upgrade environments.\n",
- program_name);
- quit (1);
- }
- /* Fall through */
-
- case TC_FUTURE:
- case_simple_Vector:
- if (BIT_STRING_P (This))
- DO_POINTER (*Area, DO_BIT_STRING);
- else
- DO_POINTER (*Area, DO_VECTOR);
- break;
-
- default:
- fprintf (stderr, "%s: Unknown Type Code 0x%x found.\n",
- program_name, (OBJECT_TYPE (This)));
- quit (1);
- }
- }
-}
-\f
-/* Output procedures */
-
-static void
-DEFUN (print_binary_objects, (from, count),
- fast SCHEME_OBJECT * from AND fast long count)
-{
- while (--count >= 0)
- {
- switch (OBJECT_TYPE (* from))
- {
- case TC_FIXNUM:
- print_a_fixnum (FIXNUM_TO_LONG (*from));
- from += 1;
- break;
-
- case TC_BIT_STRING:
- print_a_bit_string (++from);
- from += (1 + (OBJECT_DATUM (*from)));
- break;
-
- case TC_BIG_FIXNUM:
- print_a_bignum (++from);
- from += (1 + (OBJECT_DATUM (*from)));
- break;
-
- case TC_CHARACTER_STRING:
- print_a_string (++from);
- from += (1 + (OBJECT_DATUM (*from)));
- break;
-
- case TC_BIG_FLONUM:
- print_a_flonum (from + 1);
- from += (1 + float_to_pointer);
- break;
-
- case TC_CHARACTER:
- fprintf (portable_file, "%02x %07x\n",
- TC_CHARACTER, ((*from) & MASK_MIT_ASCII));
- from += 1;
- break;
-
-#ifdef FLOATING_ALIGNMENT
-
- case TC_MANIFEST_NM_VECTOR:
- if ((OBJECT_DATUM (*from)) == 0)
- {
- from += 1;
- count += 1;
- break;
- }
- /* fall through */
-
-#endif /* FLOATING_ALIGNMENT */
-
- default:
- fprintf (stderr,
- "%s: Bad Binary Object to print %lx\n",
- program_name, *from);
- quit (1);
- }
- }
- return;
-}
-\f
-static void
-DEFUN (print_c_compiled_entries, (entry, count),
- SCHEME_OBJECT * entry AND unsigned long count)
-{
- while (count > 0)
- {
- unsigned long entry_index = (* ((unsigned long *) entry));
- unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry));
- SCHEME_OBJECT * block;
-
- Get_Compiled_Block (block, entry);
- fprintf (portable_file, "%02x %lx %ld %ld %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_ENTRY_FORMAT),
- ((long) (FORMAT_WORD_LOW_BYTE (format))),
- ((long) (FORMAT_WORD_HIGH_BYTE (format))),
- ((long) (entry - block)));
- fprintf (portable_file, "%02x %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_ENTRY_CODE),
- entry_index);
- count -= 1;
- entry += 2;
- }
- return;
-}
-
-static void
-DEFUN (print_c_closure_entries, (entry, count),
- SCHEME_OBJECT * entry AND unsigned long count)
-{
- while (count > 0)
- {
- unsigned long entry_index = (* ((unsigned long *) entry));
- unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry));
- SCHEME_OBJECT * block, base;
- unsigned long entry_number = 0;
- long offset;
-
- EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_number, entry);
- offset = (UNSIGNED_FIXNUM_TO_LONG
- (compiled_entry_table [entry_number]));
- base = compiled_entry_table[entry_number + 1];
-
- Get_Compiled_Block (block, entry);
- fprintf (portable_file, "%02x %lx %ld %ld %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_ENTRY_FORMAT),
- ((long) (FORMAT_WORD_LOW_BYTE (format))),
- ((long) (FORMAT_WORD_HIGH_BYTE (format))),
- ((long) (entry - block)));
- fprintf (portable_file, "%02x %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_ENTRY_CODE),
- entry_index);
- fprintf (portable_file, "%02x %lx %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_EXECUTE_ENTRY),
- offset,
- (OBJECT_DATUM (base)));
- count -= 1;
- entry += 3;
- }
- return;
-}
-\f
-static void
-DEFUN (print_objects, (from, to),
- fast SCHEME_OBJECT * from AND fast SCHEME_OBJECT * to)
-{
- fast long the_datum, the_type;
-
- while (from < to)
- {
- the_type = (OBJECT_TYPE (* from));
- the_datum = (OBJECT_DATUM (* from));
- from += 1;
-
- switch (the_type)
- {
- case TC_MANIFEST_NM_VECTOR:
- {
- fprintf (portable_file, "%02x %lx\n", the_type, the_datum);
- while (--the_datum >= 0)
- fprintf (portable_file, "%lx\n", ((unsigned long) *from++));
- break;
- }
-
- case TC_COMPILED_ENTRY:
- {
- SCHEME_OBJECT base;
- long offset;
-
- offset = (UNSIGNED_FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
- base = compiled_entry_table[the_datum + 1];
-
- fprintf (portable_file, "%02x %lx %02x %lx\n",
- TC_COMPILED_ENTRY, offset,
- (OBJECT_TYPE (base)), (OBJECT_DATUM (base)));
- break;
- }
-\f
- case TC_LINKAGE_SECTION:
- {
- SCHEME_OBJECT header = (from[-1]);
-
- switch (READ_LINKAGE_KIND (header))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- long count = (READ_CACHE_LINKAGE_COUNT (header));
-
- fprintf (portable_file, "%02x %lx %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_LINKAGE_HEADER),
- ((long) (READ_LINKAGE_KIND (header))),
- ((long) count));
- while (--count >= 0)
- {
- unsigned long the_triple = ((unsigned long) *from++);
-
- fprintf (portable_file, "%02x %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_RAW_TRIPLE),
- the_triple);
- }
- break;
- }
-
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- {
- char * word_ptr;
- long count = 0;
- SCHEME_OBJECT This, * area_end, * scan, * i_scan;
-
- i_scan = (from - 1);
- This = *i_scan;
- START_OPERATOR_RELOCATION (i_scan);
- count = (READ_OPERATOR_LINKAGE_COUNT (This));
- word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan));
- area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count));
-
- fprintf (portable_file, "%02x %lx %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_LINKAGE_HEADER),
- ((long) (READ_LINKAGE_KIND (header))),
- ((long) count));
-
- while (--count >= 0)
- {
- SCHEME_OBJECT base;
- long arity, offset, address = 0;
-
- scan = ((SCHEME_OBJECT *) word_ptr);
- word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
- EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan);
- EXTRACT_EXECUTE_CACHE_ARITY (arity, scan);
-
- offset = (UNSIGNED_FIXNUM_TO_LONG
- (compiled_entry_table[address]));
- base = compiled_entry_table[address + 1];
-
- fprintf (portable_file, "%02x %lx %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_EXECUTE_ENTRY),
- offset,
- (OBJECT_DATUM (base)));
- fprintf (portable_file, "%02x %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_EXECUTE_ARITY),
- arity);
- }
- END_OPERATOR_RELOCATION (area_end);
- from += (area_end - i_scan);
- break;
- }
-
- default:
- {
- fprintf (stderr, "%s: Unknown linkage kind.\n",
- program_name);
- quit (1);
- }
- }
- break;
- }
-\f
- case TC_MANIFEST_CLOSURE:
- {
- unsigned long nentries;
- SCHEME_OBJECT * entry, * area_end;
-
- fprintf (portable_file, "%02x %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_CLOSURE_HEADER),
- the_datum);
-
- nentries = (MANIFEST_CLOSURE_COUNT (from));
- entry = ((SCHEME_OBJECT *) (FIRST_MANIFEST_CLOSURE_ENTRY (from)));
- area_end = ((MANIFEST_CLOSURE_END (from, nentries)) - 1);
-
- if (entry != (from + 1))
- fprintf (portable_file, "%02x %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_MULTI_CLOSURE_HEADER),
- nentries);
-
- print_c_closure_entries (entry, nentries);
- from = (area_end + 1);
- break;
- }
-
- case TC_BROKEN_HEART:
- if (the_datum == 0)
- goto ordinary_object;
- /* An NMV header fending off C-compiled code descriptors.
- This knows in detail the format
- */
-
- {
- unsigned long nmv_length;
-
- nmv_length = (OBJECT_DATUM (compiled_block_table [the_datum + 1]));
- fprintf (portable_file, "%02x %lx %lx\n",
- TC_C_COMPILED_TAG,
- ((long) C_COMPILED_FAKE_NMV),
- nmv_length);
-
- print_c_compiled_entries (from + 1, (nmv_length / 2));
- from += nmv_length;
- break;
- }
-
- default:
- ordinary_object:
- {
- fprintf (portable_file, "%02x %lx\n", the_type, the_datum);
- break;
- }
- }
- }
- return;
-}
-\f
-/* Debugging Aids and Consistency Checks */
-
-#define DEBUG 0
-
-#if (DEBUG > 0)
-
-#define WHEN(condition, message) when(condition, message)
-
-static void
-DEFUN (when, (what, message), Boolean what AND char * message)
-{
- if (what)
- {
- fprintf (stderr, "%s: Inconsistency: %s!\n",
- program_name, (message));
- quit (1);
- }
- return;
-}
-
-#else /* DEBUG <= 0 */
-
-#define WHEN(what, message) do { } while (0)
-
-#endif /* DEBUG > 0 */
-
-#if (DEBUG > 1)
-
-#define DEBUGGING1(action) action
-
-#define WRITE_HEADER(name, format, obj) do \
-{ \
- fprintf (portable_file, (format), (obj)); \
- fprintf (portable_file, "\n"); \
- fprintf (stderr, "%s: ", (name)); \
- fprintf (stderr, (format), (obj)); \
- fprintf (stderr, "\n"); \
-} while (0)
-
-#else /* DEBUG <= 1 */
-
-#define DEBUGGING1(action) do { } while (0)
-
-#define WRITE_HEADER(name, format, obj) do \
-{ \
- fprintf (portable_file, (format), (obj)); \
- fprintf (portable_file, "\n"); \
-} while (0)
-
-#endif /* DEBUG > 1 */
-\f
-/* The main program */
-
-static void
-DEFUN_VOID (do_it)
-{
- while (true)
- {
- /* Load the Data */
-
- SCHEME_OBJECT
- * Heap,
- * Lowest_Allocated_Address,
- * Highest_Allocated_Address;
- long
- Heap_Start, Heap_Objects_Start,
- Constant_Start, Constant_Objects_Start,
- Pure_Start, Pure_Objects_Start;
-
- switch (Read_Header ())
- {
- /* There should really be a difference between no header
- and a short header.
- */
-
- case FASL_FILE_TOO_SHORT:
- return;
-
- case FASL_FILE_FINE:
- break;
-
- default:
- fprintf (stderr,
- "%s: Input is not a Scheme binary file.\n",
- program_name);
- quit (1);
- /*NOTREACHED*/
- }
-
- if ( (Version > FASL_FORMAT_VERSION)
- || (Version < FASL_OLDEST_VERSION)
- || (Sub_Version > FASL_SUBVERSION)
- || (Sub_Version < FASL_OLDEST_SUBVERSION)
- || ((Machine_Type != FASL_INTERNAL_FORMAT) && (! swap_bytes_p)))
- {
- fprintf (stderr, "%s:\n", program_name);
- fprintf (stderr,
- "FASL File Version %ld Subversion %ld Machine Type %ld\n",
- Version, Sub_Version , Machine_Type);
- fprintf (stderr,
- "Expected: Version %d Subversion %d Machine Type %d\n",
- FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
- quit (1);
- }
-\f
- if ((((compiler_processor_type != COMPILER_NONE_TYPE)
- && (dumped_processor_type != COMPILER_NONE_TYPE)
- && (compiler_processor_type != dumped_processor_type))
- || ((compiler_interface_version != 0)
- && (dumped_interface_version != 0)
- && (compiler_interface_version != dumped_interface_version)))
- && (! upgrade_compiled_p))
- {
- fprintf (stderr, "\nread_file:\n");
- fprintf (stderr,
- "FASL File: compiled code interface %4d; processor %4d.\n",
- dumped_interface_version, dumped_processor_type);
- fprintf (stderr,
- "Expected: compiled code interface %4d; processor %4d.\n",
- compiler_interface_version, compiler_processor_type);
- quit (1);
- }
- if (compiler_processor_type != 0)
- dumped_processor_type = compiler_processor_type;
- if (compiler_interface_version != 0)
- dumped_interface_version = compiler_interface_version;
- c_compiled_p = (compiler_processor_type == COMPILER_LOSING_C_TYPE);
- DEBUGGING1 (fprintf (stderr,
- "compiler_processor_type = %d; c_compiled_p = %s\n",
- compiler_processor_type,
- (c_compiled_p ? "true" : "false")));
-
- if (band_p && (! allow_bands_p))
- {
- fprintf (stderr, "%s: Input file is a band.\n", program_name);
- quit (1);
- }
-
- if ((Const_Count != 0) && (! allow_constant_space_p))
- {
- fprintf (stderr,
- "%s: Input file has a constant space area.\n",
- program_name);
- quit (1);
- }
-\f
- shuffle_bytes_p = swap_bytes_p;
- if (Machine_Type == FASL_INTERNAL_FORMAT)
- shuffle_bytes_p = false;
-
- upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
- upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
- upgrade_lengths_p = upgrade_primitives_p;
-
- DEBUGGING1 (fprintf (stderr,
- "Dumped Heap Base = 0x%08x\n",
- Heap_Base));
-
- DEBUGGING1 (fprintf (stderr,
- "Dumped Constant Base = 0x%08x\n",
- Const_Base));
-
- DEBUGGING1 (fprintf (stderr,
- "Dumped Constant Top = 0x%08x\n",
- Dumped_Constant_Top));
-
- DEBUGGING1 (fprintf (stderr,
- "Heap Count = %6d\n",
- Heap_Count));
-
- DEBUGGING1 (fprintf (stderr,
- "Constant Count = %6d\n",
- Const_Count));
-\f
- {
- long Size;
-
- /* This is way larger than needed, but... what the hell? */
-
- Size = (
- /* All pointers must have datum > TRAP_MAX_IMMEDIATE */
- (2 * (TRAP_MAX_IMMEDIATE + 1))
- /* Floating alignment of Heap and Constant Space
- in incoming image, and of output arenas.
- */
- + (5 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))))
- /* Space taken by incoming image. */
- + (Heap_Count + Const_Count)
- /* We don't know the partition of the outgoing image,
- so, make each of the areas large enough:
- Heap pointers and external heap objects,
- Constant pointers and external constant objects,
- Pure pointers and exteranl pure objects
- */
- + (2 * (Heap_Count + (2 * Const_Count)))
- /* Space for the roots */
- + (NROOTS + 1)
- /* Space for the primitive table, or space to upgrade */
- + (upgrade_primitives_p
- ? (3 * PRIMITIVE_UPGRADE_SPACE)
- : Primitive_Table_Size)
- /* Everything might be compiled code blocks, requiring
- extra tables to map entries to objects, and block alignment
- */
- + (allow_compiled_p
- ? (2 + ((c_compiled_p ? 5 : 3) * (Heap_Count + Const_Count)))
- : 0)
- /* C code IDs */
- + C_Code_Table_Size);
-
- ALLOCATE_HEAP_SPACE (Size,
- Lowest_Allocated_Address,
- Highest_Allocated_Address);
-
- if (Lowest_Allocated_Address == ((SCHEME_OBJECT *) NULL))
- {
- fprintf (stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
- program_name, Size);
- quit (1);
- }
- }
-
- Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1));
- ALIGN_FLOAT (Heap);
- if ((Load_Data (Heap_Count, Heap)) != Heap_Count)
- {
- fprintf (stderr, "%s: Could not load the heap's contents.\n",
- program_name);
- quit (1);
- }
- Constant_Space = (Heap + Heap_Count);
- ALIGN_FLOAT (Constant_Space);
- if ((Load_Data (Const_Count, Constant_Space)) != Const_Count)
- {
- fprintf (stderr, "%s: Could not load constant space.\n",
- program_name);
- quit (1);
- }
- Constant_Top = (find_constant_top (Constant_Space, Const_Count));
- Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
- Constant_Relocation = ((&Constant_Space[0]) -
- (OBJECT_ADDRESS (Const_Base)));
- Max_Stack_Offset = 0;
-\f
- /* Setup compiled code and primitive tables. */
-
- compiled_entry_table = &Constant_Space[Const_Count];
- compiled_entry_pointer = compiled_entry_table;
- compiled_entry_table_end = compiled_entry_pointer;
- if (allow_compiled_p)
- compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
-
- compiled_block_table = compiled_entry_table_end;
- compiled_block_pointer = &compiled_block_table[2];
- compiled_block_table_end = compiled_block_pointer;
- if (allow_compiled_p && c_compiled_p)
- compiled_block_table_end += (2 *(Heap_Count + Const_Count));
-
- primitive_table = compiled_block_table_end;
- if (upgrade_primitives_p)
- primitive_table_end = (setup_primitive_upgrade (primitive_table));
- else
- {
- fast SCHEME_OBJECT * table;
- fast long count, char_count;
-
- if ((Load_Data (Primitive_Table_Size, primitive_table))
- != Primitive_Table_Size)
- {
- fprintf (stderr, "%s: Could not load the primitive table.\n",
- program_name);
- quit (1);
- }
- for (char_count = 0,
- count = Primitive_Table_Length,
- table = primitive_table;
- --count >= 0;)
- {
- char_count += (STRING_LENGTH_TO_LONG (table[1 + STRING_LENGTH_INDEX]));
- table += (2 + (OBJECT_DATUM (table[1 + STRING_HEADER])));
- }
- NPChars = char_count;
- primitive_table_end = (&primitive_table[Primitive_Table_Size]);
- }
-
- c_code_table = primitive_table_end;
- c_code_table_end = &c_code_table[C_Code_Table_Size];
- if (C_Code_Table_Size == 0)
- c_code_table[0] = (LONG_TO_UNSIGNED_FIXNUM (0));
- else
- {
- fast SCHEME_OBJECT * table;
- fast long count, char_count;
-
- if ((Load_Data (C_Code_Table_Size, c_code_table)) != C_Code_Table_Size)
- {
- fprintf (stderr, "%s: Could not load the C code table.\n",
- program_name);
- quit (1);
- }
- for (char_count = 0,
- count = C_Code_Table_Length,
- table = &c_code_table[1];
- --count >= 0; )
- {
- long slen;
-
- slen = (strlen ((char *) (table + 1)));
- table += (1 + (BYTES_TO_WORDS (1 + slen)));
- char_count += slen;
- }
- NCChars = char_count;
- }
-
- Mem_Base = c_code_table_end;
-\f
- /* Reformat the data */
-
- NFlonums = NIntegers = NStrings = 0;
- NBits = NBBits = NChars = 0;
-
- Heap_Start = (NROOTS + (TRAP_MAX_IMMEDIATE + 1));
- INDEX_ALIGN_FLOAT (Heap_Start);
- Heap_Objects_Start = (Heap_Start
- + (allow_compiled_p
- ? (2 * Heap_Count)
- : Heap_Count));
- if (! band_p)
- dumped_utilities = SHARP_F;
- Mem_Base[(Heap_Start - NROOTS) + 0] = dumped_utilities;
- if (dumped_utilities != SHARP_F)
- {
- /* This knows the format of the utilities vector. */
- SCHEME_OBJECT * uv = (relocate (dumped_utilities));
- unsigned long len = (OBJECT_DATUM (uv[0]));
-
- uv[len - 1] = ((SCHEME_OBJECT)
- (((unsigned long) uv[len - 1])
- / (sizeof (SCHEME_OBJECT))));
- uv[len - 0] = ((SCHEME_OBJECT)
- (((unsigned long) uv[len - 0])
- / (sizeof (SCHEME_OBJECT))));
- }
- Mem_Base[(Heap_Start - NROOTS) + 1]
- = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
- Scan = (Heap_Start - NROOTS);
- Free = Heap_Start;
- Free_Objects = &Mem_Base[Heap_Objects_Start];
- Objects = 0;
-
- Constant_Start = (Heap_Objects_Start + Heap_Count);
- INDEX_ALIGN_FLOAT (Constant_Start);
- Constant_Objects_Start = (Constant_Start
- + (allow_compiled_p
- ? (2 * Const_Count)
- : Const_Count));
- Scan_Constant = Constant_Start;
- Free_Constant = Constant_Start;
- Free_Cobjects = &Mem_Base[Constant_Objects_Start];
- Constant_Objects = 0;
-
- Pure_Start = (Constant_Objects_Start + Const_Count);
- INDEX_ALIGN_FLOAT (Pure_Start);
- Pure_Objects_Start = (Pure_Start
- + (allow_compiled_p
- ? (2 * Const_Count)
- : Const_Count));
- Scan_Pure = Pure_Start;
- Free_Pure = Pure_Start;
- Free_Pobjects = &Mem_Base[Pure_Objects_Start];
- Pure_Objects = 0;
-\f
- if (Const_Count == 0)
- DO_AREA (HEAP_CODE, Scan, Free, Objects, Free_Objects);
- else
- while ((Scan != Free)
- || (Scan_Constant != Free_Constant)
- || (Scan_Pure != Free_Pure))
- {
- DO_AREA (HEAP_CODE, Scan, Free,
- Objects, Free_Objects);
- DO_AREA (CONSTANT_CODE, Scan_Constant, Free_Constant,
- Constant_Objects, Free_Cobjects);
- DO_AREA (PURE_CODE, Scan_Pure, Free_Pure,
- Pure_Objects, Free_Pobjects);
- }
-
- /* Consistency checks */
-
- WHEN (((Free - Heap_Start) > Heap_Count), "Free overran Heap");
-
- WHEN (((Free_Objects - &Mem_Base[Heap_Objects_Start])
- > Heap_Count),
- "Free_Objects overran Heap Object Space");
-
- WHEN (((Free_Constant - Constant_Start) > Const_Count),
- "Free_Constant overran Constant Space");
-
- WHEN (((Free_Cobjects - &Mem_Base[Constant_Objects_Start])
- > Const_Count),
- "Free_Cobjects overran Constant Object Space");
-
- WHEN (((Free_Pure - Pure_Start) > Const_Count),
- "Free_Pure overran Pure Space");
-
- WHEN (((Free_Cobjects - &Mem_Base[Pure_Objects_Start])
- > Const_Count),
- "Free_Cobjects overran Pure Object Space");
-
- /* Output the data */
-
- if (found_ext_prims)
- {
- fprintf (stderr, "%s:\n", program_name);
- fprintf (stderr, "NOTE: The arity of some primitives is not known.\n");
- fprintf (stderr, " The portable file has %ld as their arity.\n",
- UNKNOWN_PRIMITIVE_ARITY);
- fprintf (stderr, " You may want to fix this by hand.\n");
- }
-
- if (! compiled_p)
- {
- dumped_processor_type = 0;
- dumped_interface_version = 0;
- }
-\f
- /* Header:
- Portable Version
- Machine
- Version
- Sub Version
- Flags
- Heap Count
- Heap Base
- Heap Objects
- Constant Count
- Constant Base
- Constant Objects
- Pure Count
- Pure Base
- Pure Objects
- & Dumped Object
- Maximum Stack Offset
- Number of flonums
- Number of integers
- Number of bits in integers
- Number of bit strings
- Number of bits in bit strings
- Number of character strings
- Number of characters in strings
- Number of primitives
- Number of characters in primitives
- CPU type
- Compiled code interface version
- Compiler utilities vector
- Number of C code blocks
- Number of characters in C code blocks
- Number of reserved C entries
- */
-
- WRITE_HEADER ("Portable Version", "%ld", PORTABLE_VERSION);
- WRITE_HEADER ("Machine", "%ld", FASL_INTERNAL_FORMAT);
- WRITE_HEADER ("Version", "%ld", FASL_FORMAT_VERSION);
- WRITE_HEADER ("Sub Version", "%ld", FASL_SUBVERSION);
- WRITE_HEADER ("Flags", "%ld", (MAKE_FLAGS ()));
-
- WRITE_HEADER ("Heap Count", "%ld", (Free - Heap_Start));
- WRITE_HEADER ("Heap Base", "%ld", Heap_Start);
- WRITE_HEADER ("Heap Objects", "%ld", Objects);
-
- WRITE_HEADER ("Constant Count", "%ld", (Free_Constant - Constant_Start));
- WRITE_HEADER ("Constant Base", "%ld", Constant_Start);
- WRITE_HEADER ("Constant Objects", "%ld", Constant_Objects);
-
- WRITE_HEADER ("Pure Count", "%ld", (Free_Pure - Pure_Start));
- WRITE_HEADER ("Pure Base", "%ld", Pure_Start);
- WRITE_HEADER ("Pure Objects", "%ld", Pure_Objects);
-
- WRITE_HEADER ("& Dumped Object", "%ld",
- (OBJECT_DATUM (Mem_Base[(Heap_Start - NROOTS) + 1])));
- WRITE_HEADER ("Maximum Stack Offset", "%ld", Max_Stack_Offset);
-
- WRITE_HEADER ("Number of flonums", "%ld", NFlonums);
- WRITE_HEADER ("Number of integers", "%ld", NIntegers);
- WRITE_HEADER ("Number of bits in integers", "%ld", NBits);
- WRITE_HEADER ("Number of bit strings", "%ld", NBitstrs);
- WRITE_HEADER ("Number of bits in bit strings", "%ld", NBBits);
- WRITE_HEADER ("Number of character strings", "%ld", NStrings);
- WRITE_HEADER ("Number of characters in strings", "%ld", NChars);
-
- WRITE_HEADER ("Number of primitives", "%ld", Primitive_Table_Length);
- WRITE_HEADER ("Number of characters in primitives", "%ld", NPChars);
-
- WRITE_HEADER ("CPU type", "%ld", dumped_processor_type);
- WRITE_HEADER ("Compiled code interface version", "%ld",
- dumped_interface_version);
- if (allow_bands_p)
- WRITE_HEADER ("Compiler utilities vector", "%ld",
- (OBJECT_DATUM (Mem_Base[(Heap_Start - NROOTS) + 0])));
- else
- WRITE_HEADER ("Compiler utilities vector", "%ld", 0);
-
- WRITE_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length);
- WRITE_HEADER ("Number of characters in C code blocks", "%ld", NCChars);
- WRITE_HEADER ("Number of reserved C entries", "%ld",
- (OBJECT_DATUM (c_code_table[0])));
-\f
- /* Binary Objects */
-
- print_binary_objects (&Mem_Base[Pure_Objects_Start], Pure_Objects);
- print_binary_objects (&Mem_Base[Constant_Objects_Start], Constant_Objects);
- print_binary_objects (&Mem_Base[Heap_Objects_Start], Objects);
-
- /* Normal Objects: pointers, simple non-pointers (e.g. SHARP_F) */
-
- print_objects (&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
- print_objects (&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
- print_objects (&Mem_Base[Heap_Start], &Mem_Base[Free]);
-
- /* Primitives */
-
- if (upgrade_primitives_p)
- {
- SCHEME_OBJECT obj;
- fast SCHEME_OBJECT *table;
- fast long count, the_datum;
-
- for (count = Primitive_Table_Length,
- table = external_renumber_table;
- --count >= 0;)
- {
- obj = *table++;
- the_datum = (OBJECT_DATUM (obj));
- if ((OBJECT_TYPE (obj)) == TC_PRIMITIVE_EXTERNAL)
- {
- SCHEME_OBJECT *strobj;
-
- strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
- print_a_primitive (((long) UNKNOWN_PRIMITIVE_ARITY),
- (STRING_LENGTH_TO_LONG
- (strobj[STRING_LENGTH_INDEX])),
- ((char *) &strobj[STRING_CHARS]));
- }
- else
- {
- char *str;
-
- str = builtin_prim_name_table[the_datum];
- print_a_primitive (((long) builtin_prim_arity_table[the_datum]),
- ((long) strlen(str)),
- str);
- }
- }
- }
- else
- {
- long count;
- SCHEME_OBJECT * table = primitive_table;
-
- for (count = Primitive_Table_Length; --count >= 0; )
- {
- long arity = (FIXNUM_TO_LONG (* table));
- table += 1;
- print_a_primitive
- (arity,
- (STRING_LENGTH_TO_LONG (table[STRING_LENGTH_INDEX])),
- ((char *) &table[STRING_CHARS]));
- table += (1 + (OBJECT_DATUM (table[STRING_HEADER])));
- }
- }
-\f
- /* C Code block information */
-
- {
- long count;
- SCHEME_OBJECT * table = &c_code_table[1];
-
- for (count = C_Code_Table_Length; --count >= 0; )
- {
- char * name;
- long nentries, namelen;
-
- nentries = (FIXNUM_TO_LONG (* table));
- name = ((char *) (table + 1));
- namelen = (strlen (name));
- print_a_c_code_block (nentries, namelen, name);
- table += (1 + (BYTES_TO_WORDS (namelen + 1)));
- }
- }
-
- fflush (portable_file);
- free ((char *) Lowest_Allocated_Address);
- }
-}
-
-/* Top Level */
-
-static Boolean
- allow_constant_sup_p,
- ci_version_sup_p,
- ci_processor_sup_p,
- help_p = false,
- help_sup_p,
- warn_portable_sup_p;
-
-/* The boolean value here is what value to store when the option is present. */
-
-static struct keyword_struct
- options[] = {
- KEYWORD ("swap_bytes", &swap_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
- &ci_version_sup_p),
- KEYWORD ("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
- &ci_processor_sup_p),
- KEYWORD ("endian_invert", &endian_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("allow_bands", &allow_bands_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("allow_constant_space", &allow_constant_space_p,
- BOOLEAN_KYWRD, BFRMT, &allow_constant_sup_p),
- KEYWORD ("warn_portable", &warn_portable_p, BOOLEAN_KYWRD, BFRMT,
- &warn_portable_sup_p),
- KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
- OUTPUT_KEYWORD (),
- INPUT_KEYWORD (),
- END_KEYWORD ()
- };
-\f
-int
-DEFUN (main, (argc, argv), int argc AND char **argv)
-{
- parse_keywords (argc, argv, options, false);
-
- if (help_sup_p && help_p)
- {
- print_usage_and_exit(options, 0);
- /*NOTREACHED*/
- }
-
- upgrade_compiled_p =
- (upgrade_compiled_p || ci_version_sup_p || ci_processor_sup_p);
- allow_compiled_p = (allow_compiled_p || upgrade_compiled_p
- || c_compiled_p || allow_bands_p);
- allow_nmv_p = (allow_nmv_p || allow_compiled_p || endian_invert_p);
- if (null_nmv_p && allow_nmv_p)
- {
- fprintf (stderr,
- "%s: NMVs are both allowed and to be nulled out!\n",
- program_name);
- quit (1);
- }
- if (allow_bands_p && warn_portable_p && (! warn_portable_sup_p))
- warn_portable_p = false;
- if (allow_bands_p && (! allow_constant_space_p) && (! allow_constant_sup_p))
- allow_constant_space_p = true;
-
- setup_io ("rb", "w");
- do_it ();
- quit (0);
- return (0);
-}
/* -*-C-*-
-$Id: bitstr.c,v 9.68 2007/01/05 21:19:25 cph Exp $
+$Id: bitstr.c,v 9.69 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
#include "bitstr.h"
-static void EXFUN
- (copy_bits, (SCHEME_OBJECT *, long, SCHEME_OBJECT *, long, long));
-extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long));
+static void copy_bits
+ (SCHEME_OBJECT *, long, SCHEME_OBJECT *, long, long);
\f
SCHEME_OBJECT
-DEFUN (allocate_bit_string, (length), long length)
+allocate_bit_string (unsigned long length)
{
long total_pointers;
SCHEME_OBJECT result;
total_pointers = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (length)));
result = (allocate_non_marked_vector (TC_BIT_STRING, total_pointers, true));
- FAST_MEMORY_SET (result, BIT_STRING_LENGTH_OFFSET, length);
+ MEMORY_SET (result, BIT_STRING_LENGTH_OFFSET, length);
return (result);
}
DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (allocate_bit_string (arg_nonnegative_integer (1)));
+ PRIMITIVE_RETURN (allocate_bit_string (arg_ulong_integer (1)));
}
/* (BIT-STRING? object)
DEFINE_PRIMITIVE ("BIT-STRING?", Prim_bit_string_p, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (BIT_STRING_P (object)));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (BIT_STRING_P (ARG_REF (1))));
}
\f
void
-DEFUN (fill_bit_string, (bit_string, sense),
- SCHEME_OBJECT bit_string AND
+fill_bit_string (SCHEME_OBJECT bit_string,
int sense)
{
SCHEME_OBJECT *scanner;
(* (DEC_BIT_STRING_PTR (scanner))) = filler;
}
-extern void EXFUN (clear_bit_string, (SCHEME_OBJECT));
-
void
-DEFUN (clear_bit_string, (bit_string), SCHEME_OBJECT bit_string)
+clear_bit_string (SCHEME_OBJECT bit_string)
{
SCHEME_OBJECT *scanner;
long i;
{
SCHEME_OBJECT result;
PRIMITIVE_HEADER (2);
- result = allocate_bit_string (arg_nonnegative_integer (1));
+ result = allocate_bit_string (arg_ulong_integer (1));
fill_bit_string (result, (OBJECT_TO_BOOLEAN (ARG_REF (2))));
PRIMITIVE_RETURN (result);
}
}
\f
#define REF_INITIALIZATION() \
- fast SCHEME_OBJECT bit_string; \
- fast long index; \
- fast SCHEME_OBJECT *ptr; \
- fast long mask; \
+ SCHEME_OBJECT bit_string; \
+ long index; \
+ SCHEME_OBJECT *ptr; \
+ long mask; \
PRIMITIVE_HEADER (2); \
\
CHECK_ARG (1, BIT_STRING_P); \
PRIMITIVE_RETURN (SHARP_T);
}
-DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2, 2,
+DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2, 2,
"(BIT-STRING INDEX)\n\
Sets the indexed bit to one, returning its previous value as a boolean.")
{
"(BIT-STRING)\n\
Returns true the argument has no \"set\" bits.")
{
- fast SCHEME_OBJECT bit_string;
- fast SCHEME_OBJECT *scan;
- fast long i;
+ SCHEME_OBJECT bit_string;
+ SCHEME_OBJECT *scan;
+ long i;
long length, odd_bits;
PRIMITIVE_HEADER (1);
CHECK_ARG (1, BIT_STRING_P);
PRIMITIVE_RETURN (SHARP_T); \
}
-DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2, 2,
+DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2, 2,
"(BIT-STRING-1 BIT-STRING-2)\n\
Returns true iff the two bit strings contain the same bits.")
{
SCHEME_OBJECT bit_string_1, bit_string_2;
long length;
- fast SCHEME_OBJECT *scan1, *scan2;
- fast long i;
+ SCHEME_OBJECT *scan1, *scan2;
+ long i;
long odd_bits;
PRIMITIVE_HEADER (2);
CHECK_ARG (1, BIT_STRING_P);
#define BITWISE_OP(action) \
{ \
SCHEME_OBJECT bit_string_1, bit_string_2; \
- fast long i; \
- fast SCHEME_OBJECT *scan1, *scan2; \
+ long i; \
+ SCHEME_OBJECT *scan1, *scan2; \
PRIMITIVE_HEADER (2); \
bit_string_1 = (ARG_REF (1)); \
bit_string_2 = (ARG_REF (2)); \
DEFINE_PRIMITIVE ("BIT-STRING-XOR!", Prim_bit_string_xor_x, 2, 2, 0)
BITWISE_OP (^=)
\f
-DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5, 5,
+DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5, 5,
"(SOURCE START1 END1 DESTINATION START2)\n\
Destructively copies the substring of SOURCE between START1 and \
END1 into DESTINATION at START2. The copying is done from the \
MSB to the LSB (which only matters when SOURCE and DESTINATION \
are the same).")
{
- fast SCHEME_OBJECT bit_string_1, bit_string_2;
+ SCHEME_OBJECT bit_string_1, bit_string_2;
long start1, end1, start2, end2, nbits;
long end1_mod, end2_mod;
PRIMITIVE_HEADER (5);
starting with the MSB of a bit string and moving down. */
static void
-DEFUN (copy_bits,
- (source, source_offset, destination, destination_offset, nbits),
- SCHEME_OBJECT * source AND
- long source_offset AND
- SCHEME_OBJECT * destination AND
- long destination_offset AND
+copy_bits (SCHEME_OBJECT * source,
+ long source_offset,
+ SCHEME_OBJECT * destination,
+ long destination_offset,
long nbits)
{
\f
/* Integer <-> Bit-string Conversions */
-long
-DEFUN (count_significant_bits, (number, start), long number AND long start)
+static unsigned long
+ulong_significant_bits (unsigned long number)
{
- long significant_bits, i;
-
- significant_bits = start;
- for (i = (1L << (start - 1)); (i >= 0); i >>= 1)
+ unsigned long limit = 1;
+ unsigned int nbits = 1;
+ while (true)
{
- if (number >= i)
- break;
- significant_bits -= 1;
+ if (number <= limit)
+ return (nbits);
+ limit = ((limit * 2) + 1);
+ nbits += 1;
}
- return (significant_bits);
}
-long
-DEFUN (long_significant_bits, (number), long number)
+static SCHEME_OBJECT
+zero_to_bit_string (unsigned long length)
{
- return
- ((number < 0)
- ? ((sizeof (long)) * CHAR_BIT)
- : (count_significant_bits (number, (((sizeof (long)) * CHAR_BIT) - 1))));
-}
-\f
-SCHEME_OBJECT
-DEFUN (zero_to_bit_string, (length), long length)
-{
- SCHEME_OBJECT result;
-
- result = (allocate_bit_string (length));
+ SCHEME_OBJECT result = (allocate_bit_string (length));
clear_bit_string (result);
return (result);
}
-SCHEME_OBJECT
-DEFUN (long_to_bit_string, (length, number), long length AND long number)
+static SCHEME_OBJECT
+ulong_to_bit_string (unsigned long length, unsigned long number)
{
- if (number < 0)
- error_bad_range_arg (2);
-
if (number == 0)
- {
- return (zero_to_bit_string (length));
- }
- else
- {
- SCHEME_OBJECT result;
-
- if (length < (long_significant_bits (number)))
- error_bad_range_arg (2);
- result = (zero_to_bit_string (length));
- (BIT_STRING_LSW (result)) = number;
- return (result);
- }
+ return (zero_to_bit_string (length));
+ if (length < (ulong_significant_bits (number)))
+ error_bad_range_arg (2);
+ {
+ SCHEME_OBJECT result = (zero_to_bit_string (length));
+ (BIT_STRING_LSW (result)) = number;
+ return (result);
+ }
}
\f
static void
-DEFUN (btbs_consumer, (result_ptr, digit),
- PTR result_ptr
- AND long digit)
+btbs_consumer (void * result_ptr,
+ long digit)
{
(* (INC_BIT_STRING_PTR (* ((unsigned char **) result_ptr))))
= ((unsigned char) digit);
}
-SCHEME_OBJECT
-DEFUN (bignum_to_bit_string, (length, bignum),
- long length AND SCHEME_OBJECT bignum)
+static SCHEME_OBJECT
+bignum_to_bit_string (unsigned long length, SCHEME_OBJECT bignum)
{
switch (bignum_test (bignum))
{
error_bad_range_arg (2);
{
SCHEME_OBJECT result = (zero_to_bit_string (length));
- unsigned char * result_ptr =
- ((unsigned char *) (BIT_STRING_LOW_PTR (result)));
+ unsigned char * result_ptr
+ = ((unsigned char *) (BIT_STRING_LOW_PTR (result)));
bignum_to_digit_stream
(bignum, (1L << CHAR_BIT), btbs_consumer, (&result_ptr));
return (result);
struct bitstr_to_bignm_context
{
- unsigned char *source_ptr;
+ unsigned char * source_ptr;
unsigned int mask;
};
static unsigned int
-DEFUN (bstb_producer, (context), PTR context)
+bstb_producer (void * context)
{
struct bitstr_to_bignm_context * c = context;
unsigned int result = (c->mask & (BIT_STRING_WORD (c->source_ptr)));
return (result);
}
-SCHEME_OBJECT
-DEFUN (bit_string_to_bignum, (nbits, bitstr),
- long nbits AND SCHEME_OBJECT bitstr)
+static SCHEME_OBJECT
+bit_string_to_bignum (unsigned long nbits, SCHEME_OBJECT bitstr)
{
+ unsigned long ndigits = ((nbits + (CHAR_BIT - 1)) / CHAR_BIT);
struct bitstr_to_bignm_context context;
- int ndigits, skip;
-
- ndigits = ((nbits + (CHAR_BIT - 1)) / CHAR_BIT);
- context.mask = (LOW_MASK (((nbits - 1) % (CHAR_BIT)) + 1));
- context.source_ptr =
- ((unsigned char *)
- (MEMORY_LOC (bitstr, (BIT_STRING_INDEX_TO_WORD (bitstr, (nbits - 1))))));
+ (context.mask) = (LOW_MASK (((nbits - 1) % (CHAR_BIT)) + 1));
+ (context.source_ptr)
+ = ((unsigned char *)
+ (MEMORY_LOC (bitstr, (BIT_STRING_INDEX_TO_WORD (bitstr, (nbits - 1))))));
if (ndigits != 0)
- {
- skip = ((sizeof (SCHEME_OBJECT)) -
- (((ndigits - 1) % (sizeof (SCHEME_OBJECT))) + 1));
- while ((--skip) >= 0)
{
- DEC_BIT_STRING_PTR (context.source_ptr);
+ unsigned long skip
+ = ((sizeof (SCHEME_OBJECT))
+ - (((ndigits - 1)
+ % (sizeof (SCHEME_OBJECT)))
+ + 1));
+ while (skip > 0)
+ {
+ DEC_BIT_STRING_PTR (context.source_ptr);
+ skip -= 1;
+ }
}
- }
return
(digit_stream_to_bignum (ndigits, bstb_producer,
0));
}
\f
-DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2, 2,
+DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2, 2,
"(LENGTH INTEGER)\n\
INTEGER, which must be a non-negative integer, is converted to \
a bit-string of length LENGTH. If INTEGER is too large, an \
error is signalled.")
{
- fast long length;
- fast SCHEME_OBJECT object;
+ unsigned long length;
+ SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
- length = (arg_nonnegative_integer (1));
+
+ length = (arg_ulong_integer (1));
object = (ARG_REF (2));
if (FIXNUM_P (object))
{
- if (FIXNUM_NEGATIVE_P (object))
+ if (!FIXNUM_TO_ULONG_P (object))
error_bad_range_arg (2);
PRIMITIVE_RETURN
- (long_to_bit_string
- (length, (UNSIGNED_FIXNUM_TO_LONG (object))));
+ (ulong_to_bit_string (length, (FIXNUM_TO_ULONG (object))));
}
if (BIGNUM_P (object))
PRIMITIVE_RETURN (bignum_to_bit_string (length, object));
BIT-STRING is converted to the appropriate non-negative integer. \
This operation is the inverse of `unsigned-integer->bit-string'.")
{
- fast SCHEME_OBJECT bit_string, *scan;
- long nwords, nbits, word;
+ SCHEME_OBJECT bit_string;
+ SCHEME_OBJECT * scan;
+ unsigned long nwords;
+ unsigned long nbits;
+ unsigned long word;
PRIMITIVE_HEADER (1);
+
CHECK_ARG (1, BIT_STRING_P);
bit_string = (ARG_REF (1));
/* Count the number of significant bits.*/
}
if (nwords == 0)
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
- nbits = (((nwords - 1) * OBJECT_LENGTH) + (long_significant_bits (word)));
+ nbits = (((nwords - 1) * OBJECT_LENGTH) + (ulong_significant_bits (word)));
PRIMITIVE_RETURN
((nbits <= FIXNUM_LENGTH)
? (LONG_TO_UNSIGNED_FIXNUM (word))
(BIT_STRING_INDEX_PAIR_TO_INDEX (bit_string, word, bit)));
}
\f
-extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int));
-
void
-DEFUN (bit_string_set, (bitstr, index, value),
- SCHEME_OBJECT bitstr AND long index AND int value)
+bit_string_set (SCHEME_OBJECT bitstr, long index, int value)
{
unsigned long mask;
SCHEME_OBJECT * ptr;
/* -*-C-*-
-$Id: bitstr.h,v 1.14 2007/01/05 21:19:25 cph Exp $
+$Id: bitstr.h,v 1.15 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define ANY_MASK(nbits, offset) ((LOW_MASK (nbits)) << (offset))
#define BIT_STRING_LENGTH(bit_string) \
- ((long) (FAST_MEMORY_REF ((bit_string), BIT_STRING_LENGTH_OFFSET)))
+ ((long) (MEMORY_REF ((bit_string), BIT_STRING_LENGTH_OFFSET)))
#define BIT_STRING_MSW(bit_string) \
(BIT_STRING_WORD (BIT_STRING_HIGH_PTR (bit_string)))
#define BIT_STRING_WORD(ptr) (*((ptr) - 1))
#define DEC_BIT_STRING_PTR(ptr) (--(ptr))
#define INC_BIT_STRING_PTR(ptr) ((ptr)++)
-
+
/* This is off by one so BIT_STRING_WORD will get the correct word. */
#define BIT_STRING_INDEX_TO_WORD(bit_string, index) \
/* -*-C-*-
-$Id: bkpt.c,v 9.36 2007/01/05 21:19:25 cph Exp $
+$Id: bkpt.c,v 9.37 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
\f
#include "scheme.h"
-#ifdef ENABLE_DEBUGGING_FLAGS
+#ifdef ENABLE_DEBUGGING_TOOLS
#define sp_nil ((struct sp_record *) 0)
sp_record_list SP_List = sp_nil;
-extern Boolean EXFUN (Add_a_Pop_Return_Breakpoint, (SCHEME_OBJECT *));
+extern bool Add_a_Pop_Return_Breakpoint (SCHEME_OBJECT *);
static struct sp_record One_Before =
{
sp_nil
};
-Boolean
-DEFUN (Add_a_Pop_Return_Breakpoint, (SP), SCHEME_OBJECT * SP)
+bool
+Add_a_Pop_Return_Breakpoint (SCHEME_OBJECT * SP)
{
sp_record_list old = SP_List;
SP_List = ((sp_record_list) (malloc (sizeof(struct sp_record))));
/* A breakpoint can be placed here from a C debugger to examine
the state of the world. */
-extern Boolean EXFUN (Print_One_Continuation_Frame, (SCHEME_OBJECT));
+extern bool Print_One_Continuation_Frame (SCHEME_OBJECT);
void
-DEFUN_VOID (Handle_Pop_Return_Break)
+Handle_Pop_Return_Break (void)
{
- SCHEME_OBJECT *Old_Stack = sp_register;
+ SCHEME_OBJECT *Old_Stack = stack_pointer;
- printf ("Pop Return Break: SP = 0x%lx\n", ((long) sp_register));
- (void) (Print_One_Continuation_Frame (ret_register));
- sp_register = Old_Stack;
- return;
+ printf ("Pop Return Break: SP = %#lx\n", ((unsigned long) stack_pointer));
+ (void) (Print_One_Continuation_Frame (GET_RET));
+ stack_pointer = Old_Stack;
}
void
-DEFUN_VOID (Pop_Return_Break_Point)
+Pop_Return_Break_Point (void)
{
- SCHEME_OBJECT * SP = sp_register;
+ SCHEME_OBJECT * SP = stack_pointer;
sp_record_list previous = &One_Before;
sp_record_list this = previous->next; /* = SP_List */
}
}
SP_List = One_Before.next;
- return;
}
-#else
-/* Not ENABLE_DEBUGGING_FLAGS */
-#endif
+#endif /* ENABLE_DEBUGGING_TOOLS */
/* -*-C-*-
-$Id: bkpt.h,v 9.38 2007/01/05 21:19:25 cph Exp $
+$Id: bkpt.h,v 9.39 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* This file contains breakpoint utilities.
- Disabled when not debugging the interpreter.
- It "shadows" definitions in default.h */
+/* This file contains breakpoint utility definitions. */
-#ifdef ENABLE_DEBUGGING_FLAGS
+#ifdef ENABLE_DEBUGGING_TOOLS
struct sp_record
{
};
typedef struct sp_record * sp_record_list;
+extern sp_record_list SP_List;
-#define debug_maxslots 100
+#define DEBUG_MAXSLOTS 100
-#define Eval_Ucode_Hook() \
+#define EVAL_UCODE_HOOK() do \
{ \
- (local_circle [local_slotno++]) = exp_register; \
- if (local_slotno >= debug_maxslots) \
+ (local_circle [local_slotno++]) = GET_EXP; \
+ if (local_slotno >= DEBUG_MAXSLOTS) \
local_slotno = 0; \
- if (local_nslots < debug_maxslots) \
+ if (local_nslots < DEBUG_MAXSLOTS) \
local_nslots += 1; \
-}
+} while (0)
-#define Pop_Return_Ucode_Hook() \
+#define POP_RETURN_UCODE_HOOK() do \
{ \
if (SP_List != 0) \
- { \
Pop_Return_Break_Point (); \
- } \
-}
+} while (0)
-/* Not implemented yet */
-
-#define Apply_Ucode_Hook()
-
-#endif /* ENABLE_DEBUGGING_FLAGS */
+#endif /* ENABLE_DEBUGGING_TOOLS */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* $Id: bltdef.h,v 1.8 2007/01/05 21:19:25 cph Exp $
- *
- * Names and arity's of old "built-in" primitives.
- * The tables here are used by Bintopsb to upgrade binaries.
- */
-\f
-#define MAX_BUILTIN_PRIMITIVE 431
-
-int builtin_prim_arity_table[] = {
- 3,
- 2,
- 3,
- 1,
- 2,
- 2,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 2,
- 2,
- 2,
- 1,
- 2,
- 2,
- 2,
- 2,
- 1,
- 0,
- 1,
- 2,
- 3,
- 0,
- 1,
- 2,
- 3,
- 1,
- 1,
- 2,
- 1,
- 1,
- 2,
- 2,
- 0,
- 0,
- 2,
- 3,
- 2,
- 3,
- 3,
- 2,
- 1,
- 2,
- 1,
- 3,
- 1,
- 0,
- 2,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 1,
- 1,
- 1,
- 2,
- 3,
- 1,
- 0,
- 0,
- 0,
- 3,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 1,
- 2,
- 1,
- 3,
- 1,
- 3,
- 2,
- 0,
- 0,
- 2,
- 1,
- 2,
- 1,
- 2,
- 1,
- 1,
- 1,
- 1,
- 1,
- 2,
- 1,
- 1,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 0,
- 0,
- 1,
- 1,
- 3,
- 1,
- 1,
- 1,
- 2,
- 2,
- 1,
- 3,
- 1,
- 1,
- 1,
- 2,
- 2,
- 2,
- 0,
- 2,
- 2,
- 1,
- 2,
- 2,
- 1,
- 2,
- 2,
- 1,
- 2,
- 1,
- 2,
- 3,
- 1,
- 2,
- 3,
- 1,
- 5,
- 5,
- 4,
- 0,
- 0,
- 0,
- 1,
- 1,
- 2,
- 3,
- 1,
- 1,
- 1,
- 2,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 2,
- 1,
- 0,
- 2,
- 2,
- 1,
- 1,
- 1,
- 1,
- 1,
- 2,
- 2,
- 1,
- 1,
- 1,
- 2,
- 1,
- 2,
- 2,
- 1,
- 0,
- 2,
- 3,
- 3,
- 2,
- 1,
- 0,
- 0,
- 0,
- 1,
- 2,
- 1,
- 1,
- 2,
- 5,
- 2,
- 2,
- 1,
- 3,
- 0,
- 2,
- 1,
- 0,
- 3,
- 3,
- 1,
- 4,
- 1,
- 0,
- 0,
- 1,
- 1,
- 1,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 1,
- 0,
- 0,
- 0,
- 1,
- 2,
- 0,
- 0,
- 0,
- 2,
- 0,
- 0,
- 1,
- 0,
- 2,
- 0,
- 0,
- 0,
- 0,
- 2,
- 2,
- 1,
- 3,
- 1,
- 0,
- 1,
- 7,
- 7,
- 7,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 2,
- 1,
- 1,
- 2,
- 3,
- 5,
- 5,
- 1,
- 1,
- 2,
- 4,
- 4,
- 4,
- 4,
- 4,
- 4,
- 4,
- 6,
- 6,
- 6,
- 3,
- 3,
- 6,
- 6,
- 6,
- 6,
- 1,
- 0,
- 2,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 1,
- 4,
- 4,
- 7,
- 7,
- 7,
- 4,
- 4,
- 2,
- 4,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 3,
- 2,
- 2,
- 4,
- 7,
- 7,
- 7,
- 2,
- 3,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 2,
- 0,
- 1,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-};
-\f
-static char No_Name[] = "";
-
-char *builtin_prim_name_table[] = {
- "LEXICAL-ASSIGNMENT",
- "LOCAL-REFERENCE",
- "LOCAL-ASSIGNMENT",
- "CALL-WITH-CURRENT-CONTINUATION",
- "SCODE-EVAL",
- "APPLY",
- "SET-INTERRUPT-ENABLES!",
- "STRING->SYMBOL",
- "GET-WORK",
- "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION",
- "CURRENT-DYNAMIC-STATE",
- "SET-CURRENT-DYNAMIC-STATE!",
- "NULL?",
- "EQ?",
- "STRING-EQUAL?",
- "PRIMITIVE-TYPE?",
- "PRIMITIVE-TYPE",
- "PRIMITIVE-SET-TYPE",
- "LEXICAL-REFERENCE",
- "LEXICAL-UNREFERENCEABLE?",
- "MAKE-CHAR",
- "CHAR-BITS",
- "EXIT",
- "CHAR-CODE",
- "LEXICAL-UNASSIGNED?",
- "INSERT-NON-MARKED-VECTOR!",
- "HALT",
- "CHAR->INTEGER",
- "MEMQ",
- "INSERT-STRING",
- "ENABLE-INTERRUPTS!",
- "MAKE-EMPTY-STRING",
- "CONS",
- "CAR",
- "CDR",
- "SET-CAR!",
- "SET-CDR!",
- "GET-COMMAND-LINE",
- "TTY-GET-CURSOR",
- "GENERAL-CAR-CDR",
- "HUNK3-CONS",
- "HUNK3-CXR",
- "HUNK3-SET-CXR!",
- "INSERT-STRING!",
- "VECTOR-CONS",
- "VECTOR-LENGTH",
- "VECTOR-REF",
- "SET-CURRENT-HISTORY!",
- "VECTOR-SET!",
- "NON-MARKED-VECTOR-CONS",
- No_Name,
- "LEXICAL-UNBOUND?",
- "INTEGER->CHAR",
- "CHAR-DOWNCASE",
- "CHAR-UPCASE",
- "ASCII->CHAR",
- "CHAR-ASCII?",
- "CHAR->ASCII",
- "GARBAGE-COLLECT",
- "PLUS-FIXNUM",
- "MINUS-FIXNUM",
- "MULTIPLY-FIXNUM",
- "DIVIDE-FIXNUM",
- "EQUAL-FIXNUM?",
- "LESS-THAN-FIXNUM?",
- "POSITIVE-FIXNUM?",
- "ONE-PLUS-FIXNUM",
- "MINUS-ONE-PLUS-FIXNUM",
- "TRUNCATE-STRING!",
- "SUBSTRING",
- "ZERO-FIXNUM?",
- No_Name,
- No_Name,
- No_Name,
- "SUBSTRING->LIST",
- "MAKE-FILLED-STRING",
- "PLUS-BIGNUM",
- "MINUS-BIGNUM",
- "MULTIPLY-BIGNUM",
- "DIVIDE-BIGNUM",
- "LISTIFY-BIGNUM",
- "EQUAL-BIGNUM?",
- "LESS-THAN-BIGNUM?",
- "POSITIVE-BIGNUM?",
- "FILE-OPEN-CHANNEL",
- "FILE-CLOSE-CHANNEL",
- "PRIMITIVE-FASDUMP",
- "BINARY-FASLOAD",
- "STRING-POSITION",
- "STRING-LESS?",
- No_Name,
- No_Name,
- "REHASH",
- "LENGTH",
- "ASSQ",
- "LIST->STRING",
- "EQUAL-STRING-TO-LIST?",
- "MAKE-CELL",
- "CELL-CONTENTS",
- "CELL?",
- "CHARACTER-UPCASE",
- "CHARACTER-LIST-HASH",
- "GCD-FIXNUM",
- "COERCE-FIXNUM-TO-BIGNUM",
- "COERCE-BIGNUM-TO-FIXNUM",
- "PLUS-FLONUM",
- "MINUS-FLONUM",
- "MULTIPLY-FLONUM",
- "DIVIDE-FLONUM",
- "EQUAL-FLONUM?",
- "LESS-THAN-FLONUM?",
- "ZERO-BIGNUM?",
- "TRUNCATE-FLONUM",
- "ROUND-FLONUM",
- "COERCE-INTEGER-TO-FLONUM",
- "SINE-FLONUM",
- "COSINE-FLONUM",
- "ARCTAN-FLONUM",
- "EXP-FLONUM",
- "LN-FLONUM",
- "SQRT-FLONUM",
- No_Name,
- "GET-FIXED-OBJECTS-VECTOR",
- "SET-FIXED-OBJECTS-VECTOR!",
- "LIST->VECTOR",
- "SUBVECTOR->LIST",
- "PAIR?",
- "NEGATIVE-FIXNUM?",
- "NEGATIVE-BIGNUM?",
- "GREATER-THAN-FIXNUM?",
- "GREATER-THAN-BIGNUM?",
- "STRING-HASH",
- "SYSTEM-PAIR-CONS",
- "SYSTEM-PAIR?",
- "SYSTEM-PAIR-CAR",
- "SYSTEM-PAIR-CDR",
- "SYSTEM-PAIR-SET-CAR!",
- "SYSTEM-PAIR-SET-CDR!",
- "STRING-HASH-MOD",
- No_Name,
- "SET-CELL-CONTENTS!",
- "&MAKE-OBJECT",
- "SYSTEM-HUNK3-CXR0",
- "SYSTEM-HUNK3-SET-CXR0!",
- "MAP-MACHINE-ADDRESS-TO-CODE",
- "SYSTEM-HUNK3-CXR1",
- "SYSTEM-HUNK3-SET-CXR1!",
- "MAP-CODE-TO-MACHINE-ADDRESS",
- "SYSTEM-HUNK3-CXR2",
- "SYSTEM-HUNK3-SET-CXR2!",
- "PRIMITIVE-PROCEDURE-ARITY",
- "SYSTEM-LIST-TO-VECTOR",
- "SYSTEM-SUBVECTOR-TO-LIST",
- "SYSTEM-VECTOR?",
- "SYSTEM-VECTOR-REF",
- "SYSTEM-VECTOR-SET!",
- "WITH-HISTORY-DISABLED",
- "SUBVECTOR-MOVE-RIGHT!",
- "SUBVECTOR-MOVE-LEFT!",
- "SUBVECTOR-FILL!",
- No_Name,
- No_Name,
- No_Name,
- "VECTOR-8B-CONS",
- "VECTOR-8B?",
- "VECTOR-8B-REF",
- "VECTOR-8B-SET!",
- "ZERO-FLONUM?",
- "POSITIVE-FLONUM?",
- "NEGATIVE-FLONUM?",
- "GREATER-THAN-FLONUM?",
- "INTERN-CHARACTER-LIST",
- "COMPILED-CODE-ADDRESS->OFFSET",
- "VECTOR-8B-SIZE",
- "SYSTEM-VECTOR-SIZE",
- "FORCE",
- "PRIMITIVE-DATUM",
- "MAKE-NON-POINTER-OBJECT",
- "DEBUGGING-PRINTER",
- "STRING-UPCASE",
- "PRIMITIVE-PURIFY",
- "COMPILED-CODE-ADDRESS->BLOCK",
- No_Name,
- "DUMP-BAND",
- "SUBSTRING-SEARCH",
- "LOAD-BAND",
- "CONSTANT?",
- "PURE?",
- "PRIMITIVE-GC-TYPE",
- "PRIMITIVE-IMPURIFY",
- "WITH-THREADED-CONTINUATION",
- "WITHIN-CONTROL-POINT",
- "SET-RUN-LIGHT!",
- "FILE-EOF?",
- "FILE-READ-CHAR",
- "FILE-FILL-INPUT-BUFFER",
- "FILE-LENGTH",
- "FILE-WRITE-CHAR",
- "FILE-WRITE-STRING",
- "CLOSE-LOST-OPEN-FILES",
- No_Name,
- "WITH-INTERRUPTS-REDUCED",
- "PRIMITIVE-EVAL-STEP",
- "PRIMITIVE-APPLY-STEP",
- "PRIMITIVE-RETURN-STEP",
- "TTY-READ-CHAR-READY?",
- "TTY-READ-CHAR",
- "TTY-READ-CHAR-IMMEDIATE",
- "TTY-READ-FINISH",
- "BIT-STRING-ALLOCATE",
- "MAKE-BIT-STRING",
- "BIT-STRING?",
- "BIT-STRING-LENGTH",
- "BIT-STRING-REF",
- "BIT-SUBSTRING-MOVE-RIGHT!",
- "BIT-STRING-SET!",
- "BIT-STRING-CLEAR!",
- "BIT-STRING-ZERO?",
- "BIT-SUBSTRING-FIND-NEXT-SET-BIT",
- No_Name,
- "UNSIGNED-INTEGER->BIT-STRING",
- "BIT-STRING->UNSIGNED-INTEGER",
- No_Name,
- "READ-BITS!",
- "WRITE-BITS!",
- "MAKE-STATE-SPACE",
- "EXECUTE-AT-NEW-POINT",
- "TRANSLATE-TO-STATE-POINT",
- "GET-NEXT-CONSTANT",
- "MICROCODE-IDENTIFY",
- "ZERO?",
- "POSITIVE?",
- "NEGATIVE?",
- "&=",
- "&<",
- "&>",
- "&+",
- "&-",
- "&*",
- "&/",
- "INTEGER-DIVIDE",
- "1+",
- "-1+",
- "TRUNCATE",
- "ROUND",
- "FLOOR",
- "CEILING",
- "SQRT",
- "EXP",
- "LOG",
- "SIN",
- "COS",
- "&ATAN",
- "TTY-WRITE-CHAR",
- "TTY-WRITE-STRING",
- "TTY-BEEP",
- "TTY-CLEAR",
- "GET-PRIMITIVE-COUNTS",
- "GET-PRIMITIVE-NAME",
- "GET-PRIMITIVE-ADDRESS",
- No_Name,
- No_Name,
- "GET-NEXT-INTERRUPT-CHARACTER",
- "CHECK-AND-CLEAN-UP-INPUT-CHANNEL",
- No_Name,
- "SYSTEM-CLOCK",
- "FILE-EXISTS?",
- No_Name,
- "TTY-MOVE-CURSOR",
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- "COPY-FILE",
- "RENAME-FILE",
- "REMOVE-FILE",
- "LINK-FILE",
- "MAKE-DIRECTORY",
- No_Name,
- "SET-WORKING-DIRECTORY-PATHNAME!",
- "RE-MATCH-SUBSTRING",
- "RE-SEARCH-SUBSTRING-FORWARD",
- "RE-SEARCH-SUBSTRING-BACKWARD",
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- "CURRENT-YEAR",
- "CURRENT-MONTH",
- "CURRENT-DAY",
- "CURRENT-HOUR",
- "CURRENT-MINUTE",
- "CURRENT-SECOND",
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- "CLEAR-TO-END-OF-LINE",
- No_Name,
- No_Name,
- "WITH-INTERRUPT-MASK",
- "STRING?",
- "STRING-LENGTH",
- "STRING-REF",
- "STRING-SET!",
- "SUBSTRING-MOVE-RIGHT!",
- "SUBSTRING-MOVE-LEFT!",
- "STRING-ALLOCATE",
- "STRING-MAXIMUM-LENGTH",
- "SET-STRING-LENGTH!",
- "VECTOR-8B-FILL!",
- "VECTOR-8B-FIND-NEXT-CHAR",
- "VECTOR-8B-FIND-PREVIOUS-CHAR",
- "VECTOR-8B-FIND-NEXT-CHAR-CI",
- "VECTOR-8B-FIND-PREVIOUS-CHAR-CI",
- "SUBSTRING-FIND-NEXT-CHAR-IN-SET",
- "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET",
- "SUBSTRING=?",
- "SUBSTRING-CI=?",
- "SUBSTRING<?",
- "SUBSTRING-UPCASE!",
- "SUBSTRING-DOWNCASE!",
- "SUBSTRING-MATCH-FORWARD",
- "SUBSTRING-MATCH-BACKWARD",
- "SUBSTRING-MATCH-FORWARD-CI",
- "SUBSTRING-MATCH-BACKWARD-CI",
- "PHOTO-OPEN",
- "PHOTO-CLOSE",
- "SETUP-TIMER-INTERRUPT",
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- "SCREEN-X-SIZE",
- "SCREEN-Y-SIZE",
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- "STRING->SYNTAX-ENTRY",
- "SCAN-WORD-FORWARD",
- "SCAN-WORD-BACKWARD",
- "SCAN-LIST-FORWARD",
- "SCAN-LIST-BACKWARD",
- "SCAN-SEXPS-FORWARD",
- "SCAN-FORWARD-TO-WORD",
- "SCAN-BACKWARD-PREFIX-CHARS",
- "CHAR->SYNTAX-CODE",
- "QUOTED-CHAR?",
- "MICROCODE-TABLES-FILENAME",
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- "ERROR-PROCEDURE",
- "BIT-STRING-XOR!",
- "RE-CHAR-SET-ADJOIN!",
- "RE-COMPILE-FASTMAP",
- "RE-MATCH-BUFFER",
- "RE-SEARCH-BUFFER-FORWARD",
- "RE-SEARCH-BUFFER-BACKWARD",
- "SYSTEM-MEMORY-REF",
- "SYSTEM-MEMORY-SET!",
- "BIT-STRING-FILL!",
- "BIT-STRING-MOVE!",
- "BIT-STRING-MOVEC!",
- "BIT-STRING-OR!",
- "BIT-STRING-AND!",
- "BIT-STRING-ANDC!",
- "BIT-STRING=?",
- "WORKING-DIRECTORY-PATHNAME",
- "OPEN-DIRECTORY",
- "DIRECTORY-READ",
- "UNDER-EMACS?",
- "TTY-FLUSH-OUTPUT",
- "RELOAD-BAND-NAME",
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name,
- No_Name
-};
-
/* -*-C-*-
-$Id: boot.c,v 9.126 2007/04/07 19:53:49 cph Exp $
+$Id: boot.c,v 9.127 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
#include "option.h"
-#ifndef islower
-#include <ctype.h>
-#endif
#include "ostop.h"
#include "ostty.h"
-#ifdef NATIVE_CODE_IS_C
-# include "osfs.h"
-# define FILE_READABLE(filename) (OS_file_access ((filename), 4))
+extern void init_exit_scheme (void);
+extern void OS_announcement (void);
+extern void OS_syscall_names (unsigned long *, const char ***);
+extern void OS_syserr_names (unsigned long *, const char ***);
+extern SCHEME_OBJECT initialize_history (void);
+extern SCHEME_OBJECT initialize_interrupt_handler_vector (void);
+extern SCHEME_OBJECT initialize_interrupt_mask_vector (void);
+extern SCHEME_OBJECT Re_Enter_Interpreter (void);
+
+#ifdef __WIN32__
+ extern void NT_initialize_win32_system_utilities (void);
+ extern void NT_initialize_fov (SCHEME_OBJECT);
+ extern void win32_enter_interpreter (void (*) (void));
+# define HOOK_ENTER_INTERPRETER win32_enter_interpreter
#endif
-#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__)
-#include <unistd.h>
-#else
-extern PTR EXFUN (malloc, (unsigned int size));
+#ifdef __OS2__
+ extern void OS2_initialize_early (void);
+ extern void OS2_enter_interpreter (void (*) (void));
+# define HOOK_ENTER_INTERPRETER OS2_enter_interpreter
#endif
-extern void EXFUN (free, (PTR ptr));
-extern void EXFUN (init_exit_scheme, (void));
-extern void EXFUN (Clear_Memory, (int, int, int));
-extern void EXFUN (Setup_Memory, (int, int, int));
-extern void EXFUN (compiler_initialize, (long fasl_p));
-extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
-extern void EXFUN (OS_announcement, (void));
+#ifndef HOOK_ENTER_INTERPRETER
+# define HOOK_ENTER_INTERPRETER(func) func ()
+#endif
\f
-static void EXFUN (Start_Scheme, (int, CONST char *));
-static void EXFUN (Enter_Interpreter, (void));
+static void start_scheme (void);
+static void Enter_Interpreter (void);
-CONST char * scheme_program_name;
-CONST char * OS_Name;
-CONST char * OS_Variant;
+const char * scheme_program_name;
+const char * OS_Name;
+const char * OS_Variant;
struct obstack scratch_obstack;
-PTR initial_C_stack_pointer;
+void * initial_C_stack_pointer;
static char * reload_saved_string;
static unsigned int reload_saved_string_length;
-/* If true, this is an executable created by dump-world. */
-Boolean scheme_dumped_p = false;
-
-PTR
-DEFUN (obstack_chunk_alloc, (size), size_t size)
+void *
+obstack_chunk_alloc (size_t size)
{
- PTR result = (malloc (size));
+ void * result = (malloc (size));
if (result == 0)
{
outf_fatal ("\n%s: unable to allocate obstack chunk of %d bytes\n",
#define obstack_chunk_free free
-#ifndef INIT_FIXED_OBJECTS
-#define INIT_FIXED_OBJECTS initialize_fixed_objects_vector
-#endif
-
/* Declare the outermost critical section. */
DECLARE_CRITICAL_SECTION ();
#endif
int
-DEFUN (main_name, (argc, argv),
- int argc AND CONST char ** argv)
+main_name (int argc, const char ** argv)
{
init_exit_scheme ();
scheme_program_name = (argv[0]);
- initial_C_stack_pointer = ((PTR) (&argc));
+ initial_C_stack_pointer = ((void *) (&argc));
#ifdef __WIN32__
- {
- extern void NT_initialize_win32_system_utilities();
- NT_initialize_win32_system_utilities ();
- }
+ NT_initialize_win32_system_utilities ();
#endif
#ifdef PREALLOCATE_HEAP_MEMORY
PREALLOCATE_HEAP_MEMORY ();
#endif
#ifdef __OS2__
- {
- extern void OS2_initialize_early (void);
- OS2_initialize_early ();
- }
+ OS2_initialize_early ();
#endif
obstack_init (&scratch_obstack);
dstack_initialize ();
reload_saved_string_length = 0;
read_command_line_options (argc, argv);
- if (scheme_dumped_p)
- {
- extern SCHEME_OBJECT compiler_utilities;
- extern void EXFUN (compiler_reset, (SCHEME_OBJECT));
-
- if (! ((Heap_Size == ((long) option_heap_size))
- && (Stack_Size == ((long) option_stack_size))
- && (Constant_Size == ((long) option_constant_size))))
- {
- outf_error ("%s: warning: ignoring allocation parameters.\n",
- scheme_program_name);
- outf_flush_error ();
- }
- OS_reset ();
- compiler_reset (compiler_utilities);
- if (!option_band_specified)
- {
- outf_console ("Scheme Microcode Version %s\n", PACKAGE_VERSION);
- OS_initialize ();
- Enter_Interpreter ();
- }
- else
- {
- Clear_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
- (BLOCKS_TO_BYTES (Stack_Size)),
- (BLOCKS_TO_BYTES (Constant_Size)));
- /* We are reloading from scratch anyway. */
- scheme_dumped_p = false;
- if (option_fasl_file)
- Start_Scheme (BOOT_FASLOAD, option_fasl_file);
- else
- Start_Scheme (BOOT_LOAD_BAND, option_band_file);
- }
- }
- else
- {
- extern void EXFUN (initialize_primitives, (void));
-
- Heap_Size = option_heap_size;
- Stack_Size = option_stack_size;
- Constant_Size = option_constant_size;
- Setup_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
- (BLOCKS_TO_BYTES (Stack_Size)),
- (BLOCKS_TO_BYTES (Constant_Size)));
-
-#ifdef EMPTY_LIST_VALUE
- /* EMPTY_LIST_VALUE is defined if it is teh true value for '() and
- EMPTY_LIST is a location used to store '() or #F
- */
- if (option_empty_list_eq_false)
- EMPTY_LIST = SHARP_F;
- else
- EMPTY_LIST = EMPTY_LIST_VALUE;
-#endif
+ setup_memory ((BLOCKS_TO_BYTES (option_heap_size)),
+ (BLOCKS_TO_BYTES (option_stack_size)),
+ (BLOCKS_TO_BYTES (option_constant_size)));
- initialize_primitives ();
- if (! option_fasl_file)
- {
- compiler_initialize (0);
- Start_Scheme (BOOT_LOAD_BAND, option_band_file);
- }
-#ifdef NATIVE_CODE_IS_C
- else if (! (FILE_READABLE (option_fasl_file)))
- {
- compiler_initialize (1);
- Start_Scheme (BOOT_EXECUTE, option_fasl_file);
- }
-#endif
- else
- {
- compiler_initialize (1);
- Start_Scheme (BOOT_FASLOAD, option_fasl_file);
- }
- }
+ initialize_primitives ();
+ compiler_initialize (option_fasl_file != 0);
+ OS_initialize ();
+ start_scheme ();
termination_init_error ();
return (0);
}
\f
static SCHEME_OBJECT
-DEFUN (names_to_vector, (length, names),
- unsigned int length AND
- unsigned char ** names)
+names_to_vector (unsigned long length, const char ** names)
{
- SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, length, 1));
- unsigned int i;
+ SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, length, true));
+ unsigned long i;
for (i = 0; (i < length); i += 1)
- {
- VECTOR_SET (v, i, (char_pointer_to_symbol ((char *) (names [i]))));
- }
+ VECTOR_SET (v, i, (char_pointer_to_symbol (names[i])));
return (v);
}
static SCHEME_OBJECT
-DEFUN_VOID (fixed_objects_syscall_names)
+fixed_objects_syscall_names (void)
{
- unsigned int length;
- unsigned char ** names;
- extern void EXFUN (OS_syscall_names, (unsigned int *, unsigned char ***));
+ unsigned long length;
+ const char ** names;
OS_syscall_names ((&length), (&names));
return (names_to_vector (length, names));
}
static SCHEME_OBJECT
-DEFUN_VOID (fixed_objects_syserr_names)
+fixed_objects_syserr_names (void)
{
- unsigned int length;
- unsigned char ** names;
- extern void EXFUN (OS_syserr_names, (unsigned int *, unsigned char ***));
+ unsigned long length;
+ const char ** names;
OS_syserr_names ((&length), (&names));
return (names_to_vector (length, names));
}
void
-DEFUN_VOID (initialize_fixed_objects_vector)
+initialize_fixed_objects_vector (void)
{
- extern SCHEME_OBJECT EXFUN (initialize_history, (void));
- extern SCHEME_OBJECT EXFUN (initialize_interrupt_handler_vector, (void));
- extern SCHEME_OBJECT EXFUN (initialize_interrupt_mask_vector, (void));
-
- /* Create the fixed objects vector,
- with 4 extra slots for expansion and debugging. */
- fast SCHEME_OBJECT fixed_objects_vector =
- (make_vector ((NFixed_Objects + 4), SHARP_F, false));
- Fixed_Objects = fixed_objects_vector;
- FAST_VECTOR_SET (fixed_objects_vector, Me_Myself, fixed_objects_vector);
- FAST_VECTOR_SET
- (fixed_objects_vector, Non_Object, (MAKE_OBJECT (TC_CONSTANT, 2)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- System_Interrupt_Vector,
- (initialize_interrupt_handler_vector ()));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- FIXOBJ_INTERRUPT_MASK_VECTOR,
- (initialize_interrupt_mask_vector ()));
+ fixed_objects = (make_vector (N_FIXED_OBJECTS, SHARP_F, false));
+ VECTOR_SET (fixed_objects, NON_OBJECT, (MAKE_OBJECT (TC_CONSTANT, 2)));
+ VECTOR_SET (fixed_objects, SYSTEM_INTERRUPT_VECTOR,
+ (initialize_interrupt_handler_vector ()));
+ VECTOR_SET (fixed_objects, FIXOBJ_INTERRUPT_MASK_VECTOR,
+ (initialize_interrupt_mask_vector ()));
/* Error vector is not needed at boot time */
- FAST_VECTOR_SET (fixed_objects_vector, System_Error_Vector, SHARP_F);
- FAST_VECTOR_SET
- (fixed_objects_vector,
- OBArray,
- (make_vector (OBARRAY_SIZE, EMPTY_LIST, false)));
- FAST_VECTOR_SET
- (fixed_objects_vector, Dummy_History, (initialize_history ()));
- FAST_VECTOR_SET (fixed_objects_vector, State_Space_Tag, SHARP_T);
- FAST_VECTOR_SET (fixed_objects_vector, Bignum_One, (long_to_bignum (1)));
- FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_EDWIN_AUTO_SAVE, EMPTY_LIST);
- FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_FILES_TO_DELETE, EMPTY_LIST);
- FAST_VECTOR_SET
- (fixed_objects_vector,
- FIXOBJ_SYSTEM_CALL_NAMES,
- (fixed_objects_syscall_names ()));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- FIXOBJ_SYSTEM_CALL_ERRORS,
- (fixed_objects_syserr_names ()));
-
- (*Free++) = EMPTY_LIST;
- (*Free++) = EMPTY_LIST;
- FAST_VECTOR_SET
- (fixed_objects_vector,
- The_Work_Queue,
- (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2))));
-
- FAST_VECTOR_SET
- (fixed_objects_vector,
- Utilities_Vector,
- (make_vector (0, SHARP_F, false)));
-
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_ZERO_P,
- (make_primitive ("INTEGER-ZERO?", 1)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_POSITIVE_P,
- (make_primitive ("INTEGER-POSITIVE?", 1)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_NEGATIVE_P,
- (make_primitive ("INTEGER-NEGATIVE?", 1)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_SUCCESSOR,
- (make_primitive ("INTEGER-ADD-1", 1)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_PREDECESSOR,
- (make_primitive ("INTEGER-SUBTRACT-1", 1)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_EQUAL_P,
- (make_primitive ("INTEGER-EQUAL?", 2)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_LESS_P,
- (make_primitive ("INTEGER-LESS?", 2)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_GREATER_P,
- (make_primitive ("INTEGER-GREATER?", 2)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_ADD,
- (make_primitive ("INTEGER-ADD", 2)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_SUBTRACT,
- (make_primitive ("INTEGER-SUBTRACT", 2)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_MULTIPLY,
- (make_primitive ("INTEGER-MULTIPLY", 2)));
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_DIVIDE,
- SHARP_F);
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_QUOTIENT,
- SHARP_F);
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_REMAINDER,
- SHARP_F);
- FAST_VECTOR_SET
- (fixed_objects_vector,
- GENERIC_TRAMPOLINE_MODULO,
- SHARP_F);
-
- FAST_VECTOR_SET
- (fixed_objects_vector,
- ARITY_DISPATCHER_TAG,
- char_pointer_to_symbol("#[(microcode)arity-dispatcher-tag]"));
+ VECTOR_SET (fixed_objects, SYSTEM_ERROR_VECTOR, SHARP_F);
+ VECTOR_SET (fixed_objects, OBARRAY,
+ (make_vector (OBARRAY_SIZE, EMPTY_LIST, false)));
+ VECTOR_SET (fixed_objects, DUMMY_HISTORY, (initialize_history ()));
+ VECTOR_SET (fixed_objects, State_Space_Tag, SHARP_T);
+ VECTOR_SET (fixed_objects, Bignum_One, (long_to_bignum (1)));
+ VECTOR_SET (fixed_objects, FIXOBJ_EDWIN_AUTO_SAVE, EMPTY_LIST);
+ VECTOR_SET (fixed_objects, FIXOBJ_FILES_TO_DELETE, EMPTY_LIST);
+ VECTOR_SET (fixed_objects, FIXOBJ_SYSTEM_CALL_NAMES,
+ (fixed_objects_syscall_names ()));
+ VECTOR_SET (fixed_objects, FIXOBJ_SYSTEM_CALL_ERRORS,
+ (fixed_objects_syserr_names ()));
+
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_ZERO_P,
+ (make_primitive ("INTEGER-ZERO?", 1)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_POSITIVE_P,
+ (make_primitive ("INTEGER-POSITIVE?", 1)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_NEGATIVE_P,
+ (make_primitive ("INTEGER-NEGATIVE?", 1)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_SUCCESSOR,
+ (make_primitive ("INTEGER-ADD-1", 1)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_PREDECESSOR,
+ (make_primitive ("INTEGER-SUBTRACT-1", 1)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_EQUAL_P,
+ (make_primitive ("INTEGER-EQUAL?", 2)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_LESS_P,
+ (make_primitive ("INTEGER-LESS?", 2)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_GREATER_P,
+ (make_primitive ("INTEGER-GREATER?", 2)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_ADD,
+ (make_primitive ("INTEGER-ADD", 2)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_SUBTRACT,
+ (make_primitive ("INTEGER-SUBTRACT", 2)));
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_MULTIPLY,
+ (make_primitive ("INTEGER-MULTIPLY", 2)));
+
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_DIVIDE, SHARP_F);
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_QUOTIENT, SHARP_F);
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_REMAINDER, SHARP_F);
+ VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_MODULO, SHARP_F);
+
+ VECTOR_SET (fixed_objects, ARITY_DISPATCHER_TAG,
+ (char_pointer_to_symbol ("#[(microcode)arity-dispatcher-tag]")));
#ifdef __WIN32__
- {
- extern void EXFUN (NT_initialize_fov, (SCHEME_OBJECT));
- NT_initialize_fov (fixed_objects_vector);
- }
+ NT_initialize_fov (fixed_objects);
#endif
}
\f
#endif
static void
-DEFUN (Start_Scheme, (Start_Prim, File_Name),
- int Start_Prim AND CONST char * File_Name)
+start_scheme (void)
{
- SCHEME_OBJECT FName;
- SCHEME_OBJECT expr = SHARP_F;
- SCHEME_OBJECT * inner_arg;
- SCHEME_OBJECT prim;
- /* fast long i; */
- /* Parallel processor test */
- Boolean I_Am_Master = (Start_Prim != BOOT_GET_WORK);
- OS_initialize ();
- if (I_Am_Master)
+ SCHEME_OBJECT expr;
+
+ if (!option_batch_mode)
{
- if (!option_batch_mode)
- {
- outf_console ("MIT/GNU Scheme running under %s\n", OS_Variant);
- OS_announcement ();
- outf_console ("\n");
- outf_flush_console ();
- }
- Current_State_Point = SHARP_F;
- Fluid_Bindings = EMPTY_LIST;
- INIT_FIXED_OBJECTS ();
+ outf_console ("MIT/GNU Scheme running under %s\n", OS_Variant);
+ OS_announcement ();
+ outf_console ("\n");
+ outf_flush_console ();
}
+ current_state_point = SHARP_F;
+ initialize_fixed_objects_vector ();
- /* The initial program to execute is one of
- (SCODE-EVAL (BINARY-FASLOAD <file-name>) SYSTEM-GLOBAL-ENVIRONMENT),
- (LOAD-BAND <file-name>), or
- ((GET-WORK))
- (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK <file>) GLOBAL-ENV)
- depending on the value of Start_Prim. */
- switch (Start_Prim)
- {
- case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD <file>) GLOBAL-ENV) */
- FName = (char_pointer_to_string (File_Name));
- prim = (make_primitive ("BINARY-FASLOAD", 1));
- inner_arg = Free;
- *Free++ = prim;
- *Free++ = FName;
- prim = (make_primitive ("SCODE-EVAL", 2));
- expr = MAKE_POINTER_OBJECT (TC_PCOMB2, Free);
- *Free++ = prim;
- *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg);
- *Free++ = THE_GLOBAL_ENV;
- break;
-
- case BOOT_LOAD_BAND: /* (LOAD-BAND <file>) */
- FName = (char_pointer_to_string (File_Name));
- prim = (make_primitive ("LOAD-BAND", 1));
- inner_arg = Free;
- *Free++ = prim;
- *Free++ = FName;
- expr = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg);
- break;
-\f
- case BOOT_GET_WORK: /* ((GET-WORK)) */
- prim = (make_primitive ("GET-WORK", 0));
- inner_arg = Free;
- *Free++ = prim;
- *Free++ = SHARP_F;
- expr = MAKE_POINTER_OBJECT (TC_COMBINATION, Free);
- *Free++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, 1);
- *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg);
- break;
-
- case BOOT_EXECUTE:
+ if (option_fasl_file != 0)
+ {
+#ifdef CC_IS_C
/* (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK <file>) GLOBAL-ENV) */
- FName = (char_pointer_to_string (File_Name));
- prim = (make_primitive ("INITIALIZE-C-COMPILED-BLOCK", 1));
- inner_arg = Free;
- *Free++ = prim;
- *Free++ = FName;
- prim = (make_primitive ("SCODE-EVAL", 2));
+ SCHEME_OBJECT prim1 = (make_primitive ("INITIALIZE-C-COMPILED-BLOCK", 1));
+#else
+ /* (SCODE-EVAL (BINARY-FASLOAD <file>) GLOBAL-ENV) */
+ SCHEME_OBJECT prim1 = (make_primitive ("BINARY-FASLOAD", 1));
+#endif
+ SCHEME_OBJECT fn_object = (char_pointer_to_string (option_fasl_file));
+ SCHEME_OBJECT prim2 = (make_primitive ("SCODE-EVAL", 2));
+ SCHEME_OBJECT * inner_arg = Free;
+ (*Free++) = prim1;
+ (*Free++) = fn_object;
expr = (MAKE_POINTER_OBJECT (TC_PCOMB2, Free));
- *Free++ = prim;
- *Free++ = (MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg));
- *Free++ = THE_GLOBAL_ENV;
- break;
-
-
- default:
- outf_fatal ("Unknown boot time option: %d\n", Start_Prim);
- Microcode_Termination (TERM_BAD_PRIMITIVE);
- /*NOTREACHED*/
- }
+ (*Free++) = prim2;
+ (*Free++) = (MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg));
+ (*Free++) = THE_GLOBAL_ENV;
+ }
+ else
+ {
+ /* (LOAD-BAND <file>) */
+ SCHEME_OBJECT prim = (make_primitive ("LOAD-BAND", 1));
+ SCHEME_OBJECT fn_object = (char_pointer_to_string (option_band_file));
+ expr = (MAKE_POINTER_OBJECT (TC_PCOMB1, Free));
+ (*Free++) = prim;
+ (*Free++) = fn_object;
+ }
/* Setup registers */
- INITIALIZE_INTERRUPTS ();
- SET_INTERRUPT_MASK (0);
- env_register = THE_GLOBAL_ENV;
- Trapping = false;
- Return_Hook_Address = NULL;
+ INITIALIZE_INTERRUPTS (0);
+ SET_ENV (THE_GLOBAL_ENV);
+ trapping = false;
/* Give the interpreter something to chew on, and ... */
- Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_END_OF_COMPUTATION);
- exp_register = SHARP_F;
- Save_Cont ();
- Pushed ();
+ Will_Push (CONTINUATION_SIZE);
+ SET_RC (RC_END_OF_COMPUTATION);
+ SET_EXP (SHARP_F);
+ SAVE_CONT ();
+ Pushed ();
- exp_register = expr;
+ SET_EXP (expr);
/* Go to it! */
- if ((sp_register <= Stack_Guard) || (Free > MemTop))
- {
- outf_fatal ("Configuration won't hold initial data.\n");
- termination_init_error ();
- }
+ if (! ((SP_OK_P (stack_pointer)) && (Free <= heap_alloc_limit)))
+ {
+ outf_fatal ("Configuration won't hold initial data.\n");
+ termination_init_error ();
+ }
ENTRY_HOOK ();
Enter_Interpreter ();
}
\f
-#ifdef __WIN32__
- extern void EXFUN (win32_enter_interpreter, (void (*) (void)));
-# define HOOK_ENTER_INTERPRETER win32_enter_interpreter
-#else
-# ifdef __OS2__
- extern void EXFUN (OS2_enter_interpreter, (void (*) (void)));
-# define HOOK_ENTER_INTERPRETER OS2_enter_interpreter
-# else
-# define HOOK_ENTER_INTERPRETER(func) func ()
-# endif
-#endif
-
static void
-DEFUN_VOID (Do_Enter_Interpreter)
+Do_Enter_Interpreter (void)
{
- Interpret (scheme_dumped_p);
+ Interpret ();
outf_fatal ("\nThe interpreter returned to top level!\n");
Microcode_Termination (TERM_EXIT);
}
static void
-DEFUN_VOID (Enter_Interpreter)
+Enter_Interpreter (void)
{
HOOK_ENTER_INTERPRETER (Do_Enter_Interpreter);
}
/* This must be used with care, and only synchronously. */
-extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void));
-
SCHEME_OBJECT
-DEFUN_VOID (Re_Enter_Interpreter)
+Re_Enter_Interpreter (void)
{
- Interpret (1);
- return (val_register);
-}
-\f
-/* Garbage collection debugging utilities. */
-
-extern SCHEME_OBJECT
- *deadly_free,
- *deadly_scan;
-
-extern unsigned long
- gc_counter;
-
-extern void EXFUN (gc_death,
- (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *));
-extern void EXFUN (stack_death, (CONST char *));
-
-extern char
- gc_death_message_buffer[];
-
-SCHEME_OBJECT
- *deadly_free,
- *deadly_scan;
-
-unsigned long
- gc_counter = 0;
-
-char
- gc_death_message_buffer[100];
-
-void
-DEFUN (gc_death, (code, message, scan, free),
- long code AND char * message
- AND SCHEME_OBJECT * scan AND SCHEME_OBJECT * free)
-{
- outf_fatal ("\n%s.\n", message);
- outf_fatal ("scan = 0x%lx; free = 0x%lx\n", scan, free);
- deadly_scan = scan;
- deadly_free = free;
- Microcode_Termination (code);
- /*NOTREACHED*/
-}
-
-void
-DEFUN (stack_death, (name), CONST char * name)
-{
- outf_fatal
- ("\n%s: The stack has overflowed and overwritten adjacent memory.\n",
- name);
- outf_fatal ("This was probably caused by a runaway recursion.\n");
- Microcode_Termination (TERM_STACK_OVERFLOW);
- /*NOTREACHED*/
+ Interpret ();
+ return (GET_VAL);
}
\f
/* Utility primitives. */
#define ID_STACK_TYPE 10 /* Scheme stack type (string) */
#define ID_MACHINE_TYPE 11 /* Machine type (string) */
-#ifdef USE_STACKLETS
-#define STACK_TYPE_STRING "stacklets"
-#else
-#define STACK_TYPE_STRING "standard"
-#endif
-
DEFINE_PRIMITIVE ("MICROCODE-IDENTIFY", Prim_microcode_identify, 0, 0, 0)
{
SCHEME_OBJECT Result;
PRIMITIVE_HEADER (0);
Result = (make_vector (IDENTITY_LENGTH, SHARP_F, true));
- FAST_VECTOR_SET (Result, ID_RELEASE, SHARP_F);
- FAST_VECTOR_SET
- (Result, ID_MICRO_VERSION, (char_pointer_to_string (PACKAGE_VERSION)));
- FAST_VECTOR_SET (Result, ID_MICRO_MOD, SHARP_F);
- FAST_VECTOR_SET
+ VECTOR_SET (Result, ID_RELEASE, SHARP_F);
+ VECTOR_SET (Result, ID_MICRO_VERSION,
+ (char_pointer_to_string (PACKAGE_VERSION)));
+ VECTOR_SET (Result, ID_MICRO_MOD, SHARP_F);
+ VECTOR_SET
(Result, ID_PRINTER_WIDTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_x_size ())));
- FAST_VECTOR_SET
+ VECTOR_SET
(Result, ID_PRINTER_LENGTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_y_size ())));
- FAST_VECTOR_SET
- (Result, ID_NEW_LINE_CHARACTER, (ASCII_TO_CHAR ('\n')));
- FAST_VECTOR_SET
+ VECTOR_SET (Result, ID_NEW_LINE_CHARACTER, (ASCII_TO_CHAR ('\n')));
+ VECTOR_SET
(Result, ID_FLONUM_PRECISION, (LONG_TO_UNSIGNED_FIXNUM (DBL_MANT_DIG)));
- FAST_VECTOR_SET
+ VECTOR_SET
(Result, ID_FLONUM_EPSILON, (double_to_flonum ((double) DBL_EPSILON)));
- FAST_VECTOR_SET
- (Result, ID_OS_NAME, (char_pointer_to_string (OS_Name)));
- FAST_VECTOR_SET (Result, ID_OS_VARIANT,
- (char_pointer_to_string (OS_Variant)));
- FAST_VECTOR_SET (Result, ID_STACK_TYPE,
- (char_pointer_to_string (STACK_TYPE_STRING)));
- FAST_VECTOR_SET (Result, ID_MACHINE_TYPE,
- (char_pointer_to_string (MACHINE_TYPE)));
+ VECTOR_SET (Result, ID_OS_NAME, (char_pointer_to_string (OS_Name)));
+ VECTOR_SET (Result, ID_OS_VARIANT, (char_pointer_to_string (OS_Variant)));
+ VECTOR_SET (Result, ID_STACK_TYPE, (char_pointer_to_string ("standard")));
+ VECTOR_SET (Result, ID_MACHINE_TYPE, (char_pointer_to_string (MACHINE_TYPE)));
PRIMITIVE_RETURN (Result);
}
{
PRIMITIVE_HEADER (0);
{
- CONST char ** scan = option_library_path;
- CONST char ** end = option_library_path;
+ const char ** scan = option_library_path;
+ const char ** end = option_library_path;
while (1)
{
if ((*end) == 0)
}
{
SCHEME_OBJECT result =
- (allocate_marked_vector (TC_VECTOR, (end - scan), 1));
+ (allocate_marked_vector (TC_VECTOR, (end - scan), true));
SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
while (scan < end)
(*scan_result++) = (char_pointer_to_string (*scan++));
}
static SCHEME_OBJECT
-DEFUN (argv_to_object, (argc, argv), int argc AND CONST char ** argv)
+argv_to_object (int argc, const char ** argv)
{
SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, argc, 1));
- CONST char ** scan = argv;
- CONST char ** end = (scan + argc);
+ const char ** scan = argv;
+ const char ** end = (scan + argc);
SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
while (scan < end)
(*scan_result++) = (char_pointer_to_string (*scan++));
reload_saved_string = (OS_malloc (length));
reload_saved_string_length = length;
{
- char * scan = ((char *) (STRING_LOC ((ARG_REF (1)), 0)));
+ char * scan = (STRING_POINTER (ARG_REF (1)));
char * end = (scan + length);
char * scan_result = reload_saved_string;
while (scan < end)
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* $Id: breakup.c,v 9.29 2007/01/05 21:19:25 cph Exp $ */
-\f
-#include <stdio.h>
-
-#ifndef isdigit
-#include <ctype.h>
-#endif
-
-#define boolean char
-#define false 0
-#define true 1
-
-#define isoctal(c) (isdigit(c) && (c != '8') && (c != '9'))
-
-int get_a_char()
-{ register int c;
- register int count = 2;
- for (c = getchar();
- isoctal(c) && count >= 0;
- c = getchar(), count -=1)
- putchar(c);
- if (count != 2) return c;
- putchar(c);
- return getchar();
-}
-
-main()
-{ register int c;
- register boolean after_new_line = true;
- while ((c = getchar()) != EOF)
-re_dispatch:
- switch(c)
- { case '\f':
- break;
- case ',':
- putchar(c);
- while (((c = getchar()) == ' ') || (c == '\t'))
- if (c == EOF)
- { fprintf(stderr, "Confused expression: ,\n");
- exit(1);
- }
- if (c == '\n')
- { putchar(c);
- after_new_line = true;
- break;
- }
- putchar(' ');
- goto re_dispatch;
- case ';':
- case ':':
- case '?':
- case '}':
- putchar(c);
- putchar('\n');
- after_new_line = true;
- break;
- case '\n':
- if (!after_new_line)
- { after_new_line = true;
- putchar('\n');
- }
- break;
- case '\'':
- putchar(c);
- c = getchar();
- if (c == EOF)
- { fprintf(stderr, "Confused character: EOF\n");
- exit(1);
- }
- putchar(c);
- if (c == '\n')
- { fprintf(stderr, "Confused character: \\n\n");
- after_new_line = true;
- break;
- }
- if (c == '\'')
- { fprintf(stderr, "Confused character: \\\'\n");
- break;
- }
- if (c == '\\')
- c = get_a_char();
- else c = getchar();
- if (c == EOF)
- { fprintf(stderr, "Confused character: EOF\n");
- exit(1);
- }
- putchar(c);
- if (c != '\'')
- fprintf(stderr, "Confused character: %c = 0x%x\n",
- c);
- break;
- case '"':
- after_new_line = false;
- putchar(c);
- c = getchar();
- while (true)
- { while ((c != EOF) &&
- (c != '"') &&
- (c != '\n') &&
- (c != '\\'))
- { putchar(c);
- c = getchar();
- }
- if (c == EOF)
- { fprintf(stderr, "Confused string: EOF\n");
- exit(1);
- }
- putchar(c);
- if (c == '\n')
- { fprintf(stderr, "Confused string: \\n\n");
- after_new_line = true;
- break;
- }
- if (c == '"') break;
- if (c == '\\')
- c = get_a_char();
- }
- break;
- case '#':
- if (after_new_line)
- { while (((c = getchar()) != EOF) && (c != '\n')) ;
- if (c == EOF) exit(0);
- break;
- }
- putchar(c);
- break;
- case '{':
- if (!after_new_line)
- putchar('\n');
- /* Fall Through */
- default:
- after_new_line = false;
- putchar(c);
- }
- fflush(stdout);
- exit(0);
-}
/* -*-C-*-
-$Id: char.c,v 9.37 2007/01/05 21:19:25 cph Exp $
+$Id: char.c,v 9.38 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include <ctype.h>
\f
long
-DEFUN (arg_ascii_char, (n), int n)
+arg_ascii_char (int n)
{
CHECK_ARG (n, CHARACTER_P);
{
- fast SCHEME_OBJECT object = (ARG_REF (n));
+ SCHEME_OBJECT object = (ARG_REF (n));
if (! (CHAR_TO_ASCII_P (object)))
error_bad_range_arg (n);
return (CHAR_TO_ASCII (object));
}
long
-DEFUN (arg_ascii_integer, (n), int n)
+arg_ascii_integer (int n)
{
return (arg_index_integer (n, MAX_ASCII));
}
}
\f
long
-DEFUN (char_downcase, (c), fast long c)
+char_downcase (long c)
{
return ((isupper (c)) ? ((c - 'A') + 'a') : c);
}
long
-DEFUN (char_upcase, (c), fast long c)
+char_upcase (long c)
{
return ((islower (c)) ? ((c - 'a') + 'A') : c);
}
PRIMITIVE_HEADER (1);
CHECK_ARG (1, CHARACTER_P);
{
- fast SCHEME_OBJECT character = ARG_REF (1);
+ SCHEME_OBJECT character = ARG_REF (1);
PRIMITIVE_RETURN
(((OBJECT_DATUM (character)) >= MAX_ASCII) ?
SHARP_F :
/* -*-C-*-
-$Id: c.c,v 1.21 2007/01/12 06:17:31 cph Exp $
+$Id: c.c,v 1.22 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <string.h>
#define LIARC_IN_MICROCODE
#include "liarc.h"
#include "prims.h"
#include "bitstr.h"
#include "avltree.h"
-#ifdef HAVE_STDLIB_H
-# include <stdlib.h>
-#else
- extern PTR EXFUN (malloc, (unsigned long));
- extern PTR EXFUN (realloc, (PTR, unsigned long));
-#endif
+extern int initialize_compiled_code_blocks (void);
\f
#ifdef BUG_GCC_LONG_CALLS
-extern SCHEME_OBJECT EXFUN (memory_to_string, (unsigned long, CONST void *));
-extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
-extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
-extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
-extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
-extern SCHEME_OBJECT EXFUN (digit_string_to_integer,
- (Boolean, unsigned long, unsigned char *));
-extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string,
- (unsigned long, unsigned long, unsigned char *));
-extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
-extern SCHEME_OBJECT EXFUN (memory_to_uninterned_symbol,
- (unsigned long, unsigned char *));
-
-SCHEME_OBJECT EXFUN ((* (constructor_kludge [11])), ()) =
-{
- ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_string),
- ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_symbol),
- ((SCHEME_OBJECT EXFUN ((*), ())) make_vector),
- ((SCHEME_OBJECT EXFUN ((*), ())) cons),
- ((SCHEME_OBJECT EXFUN ((*), ())) rconsm),
- ((SCHEME_OBJECT EXFUN ((*), ())) double_to_flonum),
- ((SCHEME_OBJECT EXFUN ((*), ())) long_to_integer),
- ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_integer),
- ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_bit_string),
- ((SCHEME_OBJECT EXFUN ((*), ())) make_primitive),
- ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_uninterned_symbol),
+extern SCHEME_OBJECT memory_to_string (unsigned long, const void *);
+extern SCHEME_OBJECT memory_to_symbol (long, const void *);
+extern SCHEME_OBJECT make_vector (long, SCHEME_OBJECT, bool);
+extern SCHEME_OBJECT cons (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT double_to_flonum (double);
+extern SCHEME_OBJECT long_to_integer (long);
+extern SCHEME_OBJECT digit_string_to_integer
+ (bool, unsigned long, const char *);
+extern SCHEME_OBJECT digit_string_to_bit_string
+ (unsigned long, unsigned long, const char *);
+extern SCHEME_OBJECT make_primitive (char *, int);
+extern SCHEME_OBJECT memory_to_uninterned_symbol (unsigned long, const void *);
+
+SCHEME_OBJECT (* (constructor_kludge [11])) () =
+{
+ ((SCHEME_OBJECT (*) ()) memory_to_string),
+ ((SCHEME_OBJECT (*) ()) memory_to_symbol),
+ ((SCHEME_OBJECT (*) ()) make_vector),
+ ((SCHEME_OBJECT (*) ()) cons),
+ ((SCHEME_OBJECT (*) ()) rconsm),
+ ((SCHEME_OBJECT (*) ()) double_to_flonum),
+ ((SCHEME_OBJECT (*) ()) long_to_integer),
+ ((SCHEME_OBJECT (*) ()) digit_string_to_integer),
+ ((SCHEME_OBJECT (*) ()) digit_string_to_bit_string),
+ ((SCHEME_OBJECT (*) ()) make_primitive),
+ ((SCHEME_OBJECT (*) ()) memory_to_uninterned_symbol),
};
#endif /* BUG_GCC_LONG_CALLS */
-extern char * interface_to_C_hook;
-extern long C_return_value, MAX_TRAMPOLINE;
-extern void EXFUN (C_to_interface, (PTR));
-extern void EXFUN (interface_initialize, (void));
-extern SCHEME_OBJECT EXFUN (initialize_C_compiled_block, (int, char *));
-extern int EXFUN (initialize_compiled_code_blocks, (void));
-extern void * scheme_hooks_low, * scheme_hooks_high;
+static SCHEME_OBJECT dummy_entry = ((SCHEME_OBJECT) -1L);
+utility_result_t interface_to_C_hook = ((utility_result_t) (&dummy_entry));
#define TRAMPOLINE_FUDGE 20
-typedef SCHEME_OBJECT * EXFUN ((* code_block),
- (SCHEME_OBJECT *, entry_count_t));
-
-typedef SCHEME_OBJECT * EXFUN ((* data_block), (entry_count_t));
-
-typedef SCHEME_OBJECT EXFUN ((* data_generator), (void));
-
-typedef void EXFUN ((* uninit_data), (void));
-
-struct compiled_entry_s
-{
- code_block code; /* C handler for this entry point */
- entry_count_t dispatch; /* Internal dispatch tag */
-};
-
-#define COMPILED_BLOCK_FLAG_DATA_ONLY 1
-
-struct compiled_block_s
-{
- char * name;
- union
- {
- uninit_data errgen; /* When not initialized yet */
- data_block constructor; /* Data handler for this compiled block */
- data_generator builder; /* Data generator for data-only cc blocks */
- } data;
- entry_count_t nentries; /* Number of entry points in this block */
- entry_count_t dispatch; /* Base of dispatch for this block */
- unsigned flags;
-};
+typedef struct
+{
+ const char * name;
+ liarc_code_proc_t * code_proc; /* C handler for this entry point */
+ void * data_proc; /* Data handler for this compiled block */
+ entry_count_t first_entry; /* Base of dispatch for this block */
+ entry_count_t n_entries; /* Number of entry points in this block */
+ unsigned int flags;
+} compiled_block_t;
+
+static entry_count_t n_compiled_blocks = 0;
+static entry_count_t compiled_blocks_table_size = 0;
+static compiled_block_t * compiled_blocks = 0;
+static tree_node compiled_blocks_tree = 0;
+
+static long initial_entry_number = (-1);
+static entry_count_t n_compiled_entries = 0;
+static entry_count_t compiled_entries_size = 0;
+static compiled_block_t ** compiled_entries = 0;
+
+#define COMPILED_BLOCK_NAME(block) ((block) -> name)
+#define COMPILED_BLOCK_CODE_PROC(block) ((block) -> code_proc)
+#define _COMPILED_BLOCK_DATA_PROC(block) ((block) -> data_proc)
+#define COMPILED_BLOCK_FIRST_ENTRY(block) ((block) -> first_entry)
+#define COMPILED_BLOCK_N_ENTRIES(block) ((block) -> n_entries)
+#define COMPILED_BLOCK_FLAGS(block) ((block) -> flags)
+
+#define COMPILED_BLOCK_DATA_PROC(block) \
+ ((liarc_data_proc_t *) (_COMPILED_BLOCK_DATA_PROC (block)))
+
+#define SET_COMPILED_BLOCK_DATA_PROC(block, proc) do \
+{ \
+ _CBFS (block, _CBF_DATA_INIT); \
+ _CBFC (block, _CBF_DATA_ONLY); \
+ (_COMPILED_BLOCK_DATA_PROC (block)) = (proc); \
+} while (false)
+
+#define COMPILED_BLOCK_OBJECT_PROC(block) \
+ ((liarc_object_proc_t *) (_COMPILED_BLOCK_DATA_PROC (block)))
+
+#define SET_COMPILED_BLOCK_OBJECT_PROC(block, proc) do \
+{ \
+ _CBFS (block, (_CBF_DATA_INIT | _CBF_DATA_ONLY)); \
+ (_COMPILED_BLOCK_DATA_PROC (block)) = (proc); \
+} while (false)
+
+#define _CBFT(block, flag) (((COMPILED_BLOCK_FLAGS (block)) & (flag)) != 0)
+#define _CBFS(block, flag) ((COMPILED_BLOCK_FLAGS (block)) |= (flag))
+#define _CBFC(block, flag) ((COMPILED_BLOCK_FLAGS (block)) &=~ (flag))
+
+#define _CBF_DATA_ONLY 0x01
+#define _CBF_DATA_INIT 0x02
+
+#define COMPILED_BLOCK_DATA_ONLY_P(block) (_CBFT (block, _CBF_DATA_ONLY))
+#define COMPILED_BLOCK_DATA_INIT_P(block) (_CBFT (block, _CBF_DATA_INIT))
+
+static bool grow_compiled_blocks (void);
+static bool grow_compiled_entries (entry_count_t);
+static int declare_trampoline_block (entry_count_t);
+static SCHEME_OBJECT * trampoline_procedure (SCHEME_OBJECT *, entry_count_t);
+static compiled_block_t * find_compiled_block (const char *);
+static SCHEME_OBJECT * unspecified_code (SCHEME_OBJECT *, entry_count_t);
+static void * lrealloc (void *, size_t);
+static unsigned int digit_string_producer (void *);
+static unsigned int hex_digit_to_int (char);
\f
-int pc_zero_bits;
-static SCHEME_OBJECT
- dummy_entry = ((SCHEME_OBJECT) -1L);
-char *
- interface_to_C_hook = ((char *) & dummy_entry);
-void
- * scheme_hooks_low = NULL,
- * scheme_hooks_high = NULL;
-
-#define PSEUDO_STATIC
-
-PSEUDO_STATIC long
- initial_entry_number = -1;
-PSEUDO_STATIC entry_count_t
- max_compiled_entries = 0,
- compiled_entries_size = 0;
-PSEUDO_STATIC struct compiled_entry_s *
- compiled_entries = ((struct compiled_entry_s *) NULL);
-
-PSEUDO_STATIC entry_count_t
- max_compiled_blocks = 0,
- compiled_blocks_table_size = 0;
-PSEUDO_STATIC struct compiled_block_s *
- compiled_blocks_table = ((struct compiled_block_s *) NULL);
-PSEUDO_STATIC tree_node
- compiled_blocks_tree = ((tree_node) NULL);
+long C_return_value;
-SCHEME_OBJECT *
-DEFUN (trampoline_procedure, (trampoline, dispatch),
- SCHEME_OBJECT * trampoline AND entry_count_t dispatch)
-{
- return (invoke_utility (((int) (* ((unsigned long *) trampoline))),
- ((long) (TRAMPOLINE_STORAGE (trampoline))),
- 0, 0, 0));
-}
-
-int
-DEFUN_VOID (NO_SUBBLOCKS)
+long
+C_to_interface (SCHEME_OBJECT * entry)
{
- return (0);
+ while (entry != 0)
+ {
+ entry_count_t index = ((entry_count_t) (*entry));
+ compiled_block_t * block;
+
+ if (index >= n_compiled_entries)
+ {
+ SET_EXP ((SCHEME_OBJECT) entry);
+ return (ERR_EXECUTE_MANIFEST_VECTOR);
+ }
+ block = (compiled_entries[index]);
+ entry = ((* (COMPILED_BLOCK_CODE_PROC (block)))
+ (entry, (COMPILED_BLOCK_FIRST_ENTRY (block))));
+ }
+ return (C_return_value);
}
SCHEME_OBJECT *
-DEFUN (no_data, (base_dispatch), entry_count_t base_dispatch)
+invoke_utility (unsigned int code,
+ unsigned long arg1, unsigned long arg2,
+ unsigned long arg3, unsigned long arg4)
{
- return ((SCHEME_OBJECT *) NULL);
+ SCHEME_OBJECT * res;
+ (* (utility_table[code])) ((&res), arg1, arg2, arg3, arg4);
+ return (res);
}
void
-DEFUN_VOID (uninitialized_data)
+initialize_C_interface (void)
{
- /* Not yet assigned. Cannot construct data. */
- error_external_return ();
- /*NOTREACHED*/
-}
+ if (initial_entry_number == (-1))
+ /* TRAMPOLINE_FUDGE allows for future growth of max_trampoline. */
+ initial_entry_number = (max_trampoline + TRAMPOLINE_FUDGE);
-SCHEME_OBJECT *
-DEFUN (unspecified_code, (entry, dispatch),
- SCHEME_OBJECT * entry AND entry_count_t dispatch)
-{
- exp_register = ((SCHEME_OBJECT) entry);
- C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR);
- return (&dummy_entry);
+ if (! (((declare_trampoline_block (initial_entry_number)) == 0)
+ && ((initialize_compiled_code_blocks ()) == 0)))
+ {
+ if (GET_PRIMITIVE != SHARP_F)
+ signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
+ outf_fatal ("error initializing compiled code.\n");
+ Microcode_Termination (TERM_EXIT);
+ }
}
-\f
-PTR
-DEFUN (lrealloc, (ptr, size), PTR ptr AND unsigned long size)
-{
- if (ptr == ((PTR) NULL))
- return (malloc (size));
- else
- return (realloc (ptr, size));
+
+SCHEME_OBJECT
+initialize_C_compiled_block (int argno, const char * name)
+{
+ compiled_block_t * block = (find_compiled_block (name));
+ return
+ ((block == 0)
+ ? SHARP_F
+ : (COMPILED_BLOCK_DATA_ONLY_P (block))
+ ? ((* (COMPILED_BLOCK_OBJECT_PROC (block))) ())
+ : (MAKE_CC_ENTRY ((* (COMPILED_BLOCK_DATA_PROC (block)))
+ (COMPILED_BLOCK_FIRST_ENTRY (block)))));
}
-int
-DEFUN (declare_trampoline_block, (nentries), entry_count_t nentries)
+SCHEME_OBJECT
+initialize_subblock (const char * name)
{
- int result;
-
- result = (declare_compiled_code ("#trampoline_code_block",
- nentries,
- NO_SUBBLOCKS,
- trampoline_procedure));
-#if 0
- /* trampoline block is special. */
-
- if (result != 0)
- return (result);
+ compiled_block_t * block = (find_compiled_block (name));
+ if ((block == 0) || (COMPILED_BLOCK_DATA_ONLY_P (block)))
+ error_external_return ();
- result = (declare_compiled_data ("#trampoline_code_block",
- NO_SUBBLOCKS,
- no_data));
-#endif
- return (result);
+ return
+ (MAKE_CC_BLOCK
+ (cc_entry_address_to_block_address
+ ((* (COMPILED_BLOCK_DATA_PROC (block)))
+ (COMPILED_BLOCK_FIRST_ENTRY (block)))));
}
-
-void
-DEFUN_VOID (interface_initialize)
+\f
+unsigned long
+c_code_table_export_length (unsigned long * n_blocks_r)
{
- int i, pow, del;
-
- for (i = 0, pow = 1, del = ((sizeof (SCHEME_OBJECT)) / (sizeof (char)));
- pow < del; i+= 1)
- pow = (pow << 1);
-
- if (pow != del)
- {
- /* Not a power of two -- ill-defined pc_zero_bits. */
- outf_fatal ("interface_initialize: bad (sizeof (SCHEME_OBJECT)).\n");
- Microcode_Termination (TERM_EXIT);
- }
- pc_zero_bits = i;
-
- if (initial_entry_number == -1)
- initial_entry_number = (MAX_TRAMPOLINE + TRAMPOLINE_FUDGE);
-
- if (((declare_trampoline_block (initial_entry_number)) != 0)
- || (initialize_compiled_code_blocks ()) != 0)
- {
- if (Registers[REGBLOCK_PRIMITIVE] != SHARP_F)
- signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
- else
+ compiled_block_t * block = compiled_blocks;
+ compiled_block_t * end = (block + n_compiled_blocks);
+ unsigned long n = 1;
+
+ while (block < end)
{
- outf_fatal ("interface_initialize: error initializing compiled code.\n");
- Microcode_Termination (TERM_EXIT);
+ n += (1 + (BYTES_TO_WORDS ((strlen (COMPILED_BLOCK_NAME (block))) + 1)));
+ block += 1;
}
- }
- return;
+ (*n_blocks_r) = n_compiled_blocks;
+ return (n);
}
-\f
-entry_count_t
-DEFUN (find_compiled_block, (name), char * name)
-{
- tree_node node = (tree_lookup (compiled_blocks_tree, name));
- if (node == ((tree_node) NULL))
- return (max_compiled_blocks);
- else
- return (node->value);
-}
+void
+export_c_code_table (SCHEME_OBJECT * start)
+{
+ compiled_block_t * block = compiled_blocks;
+ compiled_block_t * end = (block + n_compiled_blocks);
-int
-DEFUN (declare_compiled_data_ns, (name, data_proc),
- char * name
- AND SCHEME_OBJECT * EXFUN ((* data_proc), (entry_count_t)))
-{
- entry_count_t slot = (find_compiled_block (name));
- if ((slot == max_compiled_blocks)
- || ((compiled_blocks_table[slot].data.errgen != uninitialized_data)
- && (compiled_blocks_table[slot].data.constructor != data_proc)))
- return (-1);
- compiled_blocks_table[slot].flags &= (~ COMPILED_BLOCK_FLAG_DATA_ONLY);
- compiled_blocks_table[slot].data.constructor = data_proc;
- return (0);
+ (*start++) = (LONG_TO_FIXNUM (initial_entry_number));
+ while (block < end)
+ {
+ (*start++) = (LONG_TO_UNSIGNED_FIXNUM (COMPILED_BLOCK_N_ENTRIES (block)));
+ strcpy (((char *) start), (COMPILED_BLOCK_NAME (block)));
+ start += (BYTES_TO_WORDS ((strlen (COMPILED_BLOCK_NAME (block))) + 1));
+ block += 1;
+ }
}
-int
-DEFUN (declare_compiled_data, (name, decl_data, data_proc),
- char * name
- AND int EXFUN ((* decl_data), (void))
- AND SCHEME_OBJECT * EXFUN ((* data_proc), (entry_count_t)))
+bool
+import_c_code_table (SCHEME_OBJECT * table, unsigned long n_blocks)
{
- int rc = (declare_compiled_data_ns (name, data_proc));
- return ((rc == 0) ? ((*decl_data) ()) : rc);
-}
+ long dumped_initial_entry_number = (FIXNUM_TO_LONG (*table++));
+ unsigned long count;
-SCHEME_OBJECT
-DEFUN (initialize_subblock, (name), char * name)
-{
- SCHEME_OBJECT * ep, * block;
- entry_count_t slot = (find_compiled_block (name));
+ if (dumped_initial_entry_number < max_trampoline)
+ return (false);
+ initial_entry_number = dumped_initial_entry_number;
- if ((slot == max_compiled_blocks)
- || ((compiled_blocks_table[slot].flags & COMPILED_BLOCK_FLAG_DATA_ONLY)
- != 0))
- error_external_return ();
+ if (compiled_entries != 0)
+ free (compiled_entries);
+ if (compiled_blocks != 0)
+ free (compiled_blocks);
+ if (compiled_blocks_tree != 0)
+ tree_free (compiled_blocks_tree);
+
+ n_compiled_blocks = 0;
+ compiled_blocks_table_size = 0;
+ compiled_blocks = 0;
+ compiled_blocks_tree = 0;
- ep = ((* compiled_blocks_table[slot].data.constructor)
- (compiled_blocks_table[slot].dispatch));
- Get_Compiled_Block (block, ep);
- return (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block));
-}
+ n_compiled_entries = 0;
+ compiled_entries_size = 0;
+ compiled_entries = 0;
-SCHEME_OBJECT
-DEFUN (initialize_C_compiled_block, (argno, name), int argno AND char * name)
-{
- SCHEME_OBJECT val;
- entry_count_t slot;
+ if ((declare_trampoline_block (initial_entry_number)) != 0)
+ return (false);
- slot = (find_compiled_block (name));
- if (slot == max_compiled_blocks)
- return (SHARP_F);
+ for (count = 0; (count < n_blocks); count += 1)
+ {
+ unsigned long n_entries = (FIXNUM_TO_ULONG (*table++));
+ size_t nb = ((strlen ((const char *) table)) + 1);
+ char * ncopy = (malloc (nb));
+
+ if (ncopy == 0)
+ return (false);
+ strcpy (ncopy, ((const char *) table));
+ if ((declare_compiled_code_ns (ncopy, n_entries, unspecified_code)) != 0)
+ return (false);
+ table += (BYTES_TO_WORDS (nb));
+ }
- if ((compiled_blocks_table[slot].flags & COMPILED_BLOCK_FLAG_DATA_ONLY) != 0)
- val = ((* compiled_blocks_table[slot].data.builder) ());
- else
- {
- SCHEME_OBJECT * block;
-
- block = ((* compiled_blocks_table[slot].data.constructor)
- (compiled_blocks_table[slot].dispatch));
- val = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, block));
- }
- return (val);
+ return (true);
}
\f
int
-DEFUN (declare_compiled_code,
- (name, nentries, decl_code, code_proc),
- char * name
- AND entry_count_t nentries
- AND int EXFUN ((* decl_code), (void))
- AND code_block code_proc)
-{
- entry_count_t slot = (find_compiled_block (name));
-
- if (slot != max_compiled_blocks)
- {
- code_block old_code;
-
- old_code = (compiled_entries[compiled_blocks_table[slot].dispatch].code);
- if (((old_code != unspecified_code)
- && (old_code != code_proc)
- && (code_proc != unspecified_code))
- || (compiled_blocks_table[slot].nentries != nentries))
- return (-1);
- if (old_code == unspecified_code)
+declare_compiled_code_ns (const char * name,
+ entry_count_t n_block_entries,
+ liarc_code_proc_t * code_proc)
+{
+ compiled_block_t * block = (find_compiled_block (name));
+ if (block == 0)
{
- entry_count_t counter, limit;
+ entry_count_t entries_start = n_compiled_entries;
+ entry_count_t entries_end = (entries_start + n_block_entries);
+ tree_node new_tree;
- counter = compiled_blocks_table[slot].dispatch;
- limit = (counter + nentries);
- while (counter < limit)
- compiled_entries[counter++].code = code_proc;
- }
- }
- else
- {
- entry_count_t dispatch = max_compiled_entries;
- entry_count_t n_dispatch = (dispatch + nentries);
- entry_count_t block_index = max_compiled_blocks;
-
- if (n_dispatch < dispatch)
- /* Wrap around */
- return (-1);
-
- if (n_dispatch >= compiled_entries_size)
- {
- struct compiled_entry_s * new_entries;
- entry_count_t new_entries_size = ((compiled_entries_size == 0)
- ? 100
- : ((compiled_entries_size * 3) / 2));
- if (new_entries_size <= n_dispatch)
- new_entries_size = (n_dispatch + 1);
-
- new_entries = ((struct compiled_entry_s *)
- (lrealloc (compiled_entries,
- (new_entries_size
- * (sizeof (struct compiled_entry_s))))));
- if (new_entries == ((struct compiled_entry_s *) NULL))
- return (-1);
- compiled_entries_size = new_entries_size;
- compiled_entries = new_entries;
- }
-\f
- if (block_index >= compiled_blocks_table_size)
- {
- struct compiled_block_s * new_blocks;
- entry_count_t new_blocks_size
- = ((compiled_blocks_table_size == 0)
- ? 10
- : ((compiled_blocks_table_size * 3) / 2));
- new_blocks = ((struct compiled_block_s *)
- (lrealloc (compiled_blocks_table,
- (new_blocks_size
- * (sizeof (struct compiled_block_s))))));
- if (new_blocks == ((struct compiled_block_s *) NULL))
+ if (! ((entries_start <= entries_end)
+ && ((n_compiled_blocks < compiled_blocks_table_size)
+ || (grow_compiled_blocks ()))
+ && ((entries_end < compiled_entries_size)
+ || (grow_compiled_entries (entries_end)))))
return (-1);
- compiled_blocks_table_size = new_blocks_size;
- compiled_blocks_table = new_blocks;
- }
-
- {
- tree_node new_tree;
- tree_error_message = ((char *) NULL);
- new_tree = (tree_insert (compiled_blocks_tree, name, block_index));
- if (tree_error_message != ((char *) NULL))
+ tree_error_message = 0;
+ new_tree = (tree_insert (compiled_blocks_tree, name, n_compiled_blocks));
+ if (tree_error_message != 0)
return (-1);
compiled_blocks_tree = new_tree;
- }
-
- max_compiled_entries = n_dispatch;
- max_compiled_blocks = (block_index + 1);
-
- compiled_blocks_table[block_index].name = name;
- compiled_blocks_table[block_index].flags = 0;
- compiled_blocks_table[block_index].data.errgen = uninitialized_data;
- compiled_blocks_table[block_index].nentries = nentries;
- compiled_blocks_table[block_index].dispatch = dispatch;
- for (block_index = dispatch; block_index < n_dispatch; block_index++)
+ block = (compiled_blocks + (n_compiled_blocks++));
+ (COMPILED_BLOCK_NAME (block)) = name;
+ (COMPILED_BLOCK_CODE_PROC (block)) = code_proc;
+ (_COMPILED_BLOCK_DATA_PROC (block)) = 0;
+ (COMPILED_BLOCK_FIRST_ENTRY (block)) = entries_start;
+ (COMPILED_BLOCK_N_ENTRIES (block)) = n_block_entries;
+ (COMPILED_BLOCK_FLAGS (block)) = 0;
+
+ while (n_compiled_entries < entries_end)
+ (compiled_entries[n_compiled_entries++]) = block;
+ return (0);
+ }
+ else if ((((COMPILED_BLOCK_CODE_PROC (block)) == unspecified_code)
+ || ((COMPILED_BLOCK_CODE_PROC (block)) == code_proc)
+ || (code_proc == unspecified_code))
+ && ((COMPILED_BLOCK_N_ENTRIES (block)) == n_block_entries))
{
- compiled_entries[block_index].code = code_proc;
- compiled_entries[block_index].dispatch = dispatch;
+ (COMPILED_BLOCK_CODE_PROC (block)) = code_proc;
+ return (0);
}
- }
- return (* decl_code) ();
+ else
+ return (-1);
}
\f
-int
-DEFUN (declare_data_object,
- (name, data_proc),
- char * name
- AND SCHEME_OBJECT EXFUN ((* data_proc), (void)))
-{
- entry_count_t slot;
-
- slot = (find_compiled_block (name));
- if (slot == max_compiled_blocks)
- {
- declare_compiled_code (name, 0, NO_SUBBLOCKS, unspecified_code);
- slot = (find_compiled_block (name));
- if (slot == max_compiled_blocks)
- return (-1);
- }
-
- if ((compiled_blocks_table[slot].data.errgen != uninitialized_data)
- && (compiled_blocks_table[slot].data.builder != data_proc))
- return (-1);
-
- compiled_blocks_table[slot].flags |= (COMPILED_BLOCK_FLAG_DATA_ONLY);
- compiled_blocks_table[slot].data.builder = data_proc;
-
- return (0);
+static bool
+grow_compiled_blocks (void)
+{
+ entry_count_t new_blocks_size
+ = ((compiled_blocks_table_size == 0)
+ ? 16
+ : (compiled_blocks_table_size * 2));
+ compiled_block_t * new_blocks
+ = (lrealloc (compiled_blocks,
+ (new_blocks_size * (sizeof (compiled_block_t)))));
+ if (new_blocks == 0)
+ return (false);
+ if (new_blocks != compiled_blocks)
+ {
+ compiled_block_t ** scan = compiled_entries;
+ compiled_block_t ** end = (scan + n_compiled_entries);
+ while (scan < end)
+ {
+ (*scan) = (((*scan) - compiled_blocks) + new_blocks);
+ scan += 1;
+ }
+ }
+ compiled_blocks_table_size = new_blocks_size;
+ compiled_blocks = new_blocks;
+ return (true);
}
-int
-DEFUN (declare_compiled_code_mult, (nslots, slots),
- unsigned nslots AND CONST struct liarc_code_S * slots)
-{
- unsigned i;
- int res = 0;
-
- for (i = 0; (i < nslots); i++)
- {
- res = (declare_compiled_code (((char *) (slots[i].name)),
- (slots[i].nentries),
- NO_SUBBLOCKS,
- (slots[i].code)));
- if (res != 0)
- break;
- }
- return (res);
+static bool
+grow_compiled_entries (entry_count_t entries_end)
+{
+ entry_count_t new_entries_size
+ = ((compiled_entries_size == 0)
+ ? 128
+ : compiled_entries_size);
+ compiled_block_t ** new_entries;
+
+ while (new_entries_size <= entries_end)
+ new_entries_size *= 2;
+ new_entries
+ = (lrealloc (compiled_entries,
+ (new_entries_size * (sizeof (compiled_block_t *)))));
+ if (new_entries == 0)
+ return (false);
+ compiled_entries_size = new_entries_size;
+ compiled_entries = new_entries;
+ return (true);
}
int
-DEFUN (declare_compiled_data_mult, (nslots, slots),
- unsigned nslots AND CONST struct liarc_data_S * slots)
-{
- unsigned i;
- int res = 0;
-
- for (i = 0; (i < nslots); i++)
- {
- res = (declare_compiled_data (((char *) (slots[i].name)),
- NO_SUBBLOCKS,
- (slots[i].data)));
- if (res != 0)
- break;
- }
- return (res);
-}
-\f
-/* For now */
-
-extern SCHEME_OBJECT
- * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
-
-extern Boolean
- EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
-
-static SCHEME_OBJECT *
-DEFUN (copy_c_code_block_information, (index, start, limit),
- long index AND SCHEME_OBJECT * start AND SCHEME_OBJECT * limit)
+declare_compiled_code (const char * name,
+ entry_count_t n_block_entries,
+ liarc_decl_code_t * decl_code,
+ liarc_code_proc_t * code_proc)
{
- long char_count;
- char * src, * dest;
-
- if (start < limit)
- *start++
- = (LONG_TO_UNSIGNED_FIXNUM (compiled_blocks_table[index].nentries));
-
- src = compiled_blocks_table[index].name;
- dest = ((char *) start);
-
- while ((dest < ((char *) limit)) && ((*dest++ = *src++) != '\0'))
- ;
- if (dest >= ((char *) limit))
- while (*src++ != '\0')
- dest += 1;
-
- char_count = (dest - ((char *) start));
- return (start + (BYTES_TO_WORDS (dest - ((char *) start))));
+ int rc = (declare_compiled_code_ns (name, n_block_entries, code_proc));
+ return ((rc == 0) ? ((*decl_code) ()) : rc);
}
\f
-SCHEME_OBJECT *
-DEFUN (cons_c_code_table, (start, limit, length),
- SCHEME_OBJECT * start AND SCHEME_OBJECT * limit AND long * length)
+int
+declare_compiled_data_ns (const char * name, liarc_data_proc_t * data_proc)
{
- long count;
-
- * length = max_compiled_blocks;
-
- if (start < limit)
- *start++ = (LONG_TO_FIXNUM (initial_entry_number));
-
- for (count = 0; ((count < max_compiled_blocks) && (start < limit)); count++)
- start = (copy_c_code_block_information (count, start, limit));
-
- return (start);
+ compiled_block_t * block = (find_compiled_block (name));
+ if ((block == 0)
+ || ((COMPILED_BLOCK_DATA_INIT_P (block))
+ && ((COMPILED_BLOCK_DATA_PROC (block)) != data_proc)))
+ return (-1);
+ SET_COMPILED_BLOCK_DATA_PROC (block, data_proc);
+ return (0);
}
-Boolean
-DEFUN (install_c_code_table, (table, length),
- SCHEME_OBJECT * table AND long length)
+int
+declare_compiled_data (const char * name,
+ liarc_decl_data_t * decl_data,
+ liarc_data_proc_t * data_proc)
{
- SCHEME_OBJECT the_fixnum;
- long count, dumped_initial_entry_number;
-
- the_fixnum = *table++;
- dumped_initial_entry_number = (FIXNUM_TO_LONG (the_fixnum));
- if (dumped_initial_entry_number < MAX_TRAMPOLINE)
- return (false);
- initial_entry_number = dumped_initial_entry_number;
+ int rc = (declare_compiled_data_ns (name, data_proc));
+ return ((rc == 0) ? ((*decl_data) ()) : rc);
+}
- if (compiled_entries != ((struct compiled_entry_s *) NULL))
- free (compiled_entries);
- if (compiled_blocks_table != ((struct compiled_block_s *) NULL))
- free (compiled_blocks_table);
- if (compiled_blocks_tree != ((tree_node) NULL))
- tree_free (compiled_blocks_tree);
-
- max_compiled_entries = 0;
- compiled_entries_size = 0;
- compiled_entries = ((struct compiled_entry_s *) NULL);
- max_compiled_blocks = 0;
- compiled_blocks_table_size = 0;
- compiled_blocks_table = ((struct compiled_block_s *) NULL);
- compiled_blocks_tree = ((tree_node) NULL);
+int
+declare_data_object (const char * name, liarc_object_proc_t * object_proc)
+{
+ compiled_block_t * block = (find_compiled_block (name));
+ if (block == 0)
+ {
+ declare_compiled_code_ns (name, 0, unspecified_code);
+ block = (find_compiled_block (name));
+ if (block == 0)
+ return (-1);
+ }
- if ((declare_trampoline_block (initial_entry_number)) != 0)
- return (false);
-
- for (count = 0; count < length; count++)
- {
- long nentries = (UNSIGNED_FIXNUM_TO_LONG (* table++));
- int nlen = (strlen ((char *) table));
- char * ncopy = ((char *) (malloc (nlen + 1)));
-
- if (ncopy == ((char *) NULL))
- return (false);
- strcpy (ncopy, ((char *) table));
- if ((declare_compiled_code (ncopy,
- nentries,
- NO_SUBBLOCKS,
- unspecified_code))
- != 0)
- return (false);
- table += (BYTES_TO_WORDS (nlen + 1));
- }
+ if ((COMPILED_BLOCK_DATA_INIT_P (block))
+ && ((COMPILED_BLOCK_OBJECT_PROC (block)) != object_proc))
+ return (-1);
- return (true);
+ SET_COMPILED_BLOCK_OBJECT_PROC (block, object_proc);
+ return (0);
}
-\f
-#define C_COUNT_TRANSFERS
-unsigned long c_to_interface_transfers = 0;
-void
-DEFUN (C_to_interface, (in_entry), PTR in_entry)
+int
+declare_compiled_code_mult (unsigned int nslots,
+ const struct liarc_code_S * slots)
{
- SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) in_entry);
-
- while (1)
- {
- unsigned long entry_index = (* ((unsigned long *) entry));
-
-#ifdef C_COUNT_TRANSFERS
- c_to_interface_transfers += 1;
-#endif /* C_COUNT_TRANSFERS */
-
- if (entry_index < ((unsigned long) max_compiled_entries))
- entry = ((* (compiled_entries[entry_index].code))
- (entry, compiled_entries[entry_index].dispatch));
- else
+ unsigned int i = 0;
+ while (i < nslots)
{
- if (entry != &dummy_entry)
- {
- exp_register = ((SCHEME_OBJECT) entry);
- C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR);
- }
- return;
+ int res = (declare_compiled_code_ns (((char *) ((slots[i]) . name)),
+ ((slots[i]) . nentries),
+ ((slots[i]) . code)));
+ if (res != 0)
+ return (res);
+ i += 1;
}
- }
+ return (0);
}
-DEFINE_PRIMITIVE ("SWAP-C-COUNTER!", Prim_swap_c_counter, 1, 1,
- "(new-value)\n\
-Set the C transfer counter to new-value. Return the old value.")
+int
+declare_compiled_data_mult (unsigned int nslots,
+ const struct liarc_data_S * slots)
{
- unsigned long new_counter, old_counter;
- PRIMITIVE_HEADER (1);
-
- new_counter = (arg_integer (1));
- old_counter = c_to_interface_transfers;
- c_to_interface_transfers = new_counter;
- PRIMITIVE_RETURN (ulong_to_integer (old_counter));
+ unsigned int i = 0;
+ while (i < nslots)
+ {
+ int res = (declare_compiled_data_ns (((char *) ((slots[i]) . name)),
+ ((slots[i]) . data)));
+ if (res != 0)
+ return (res);
+ i += 1;
+ }
+ return (0);
+}
+\f
+static int
+declare_trampoline_block (entry_count_t n_block_entries)
+{
+ return (declare_compiled_code_ns ("#trampoline_code_block",
+ n_block_entries,
+ trampoline_procedure));
}
-typedef SCHEME_OBJECT * utility_result;
-
-typedef void EXFUN
- ((* utility_table_entry), (utility_result *, long, long, long, long));
+bool
+store_trampoline_insns (insn_t * entry, byte_t code)
+{
+ /* Trampoline entries are stored in the lowest part of the
+ compiled_entries table. That's why we reserve those above. */
+ (*entry) = code;
+ return (false);
+}
-extern utility_table_entry utility_table[];
+static SCHEME_OBJECT *
+trampoline_procedure (SCHEME_OBJECT * trampoline, entry_count_t dispatch)
+{
+ return (invoke_utility (((unsigned int) (* ((insn_t *) trampoline))),
+ ((unsigned long)
+ (trampoline_storage
+ (cc_entry_address_to_block_address
+ ((insn_t *) trampoline)))),
+ 0, 0, 0));
+}
-SCHEME_OBJECT *
-DEFUN (invoke_utility, (code, arg1, arg2, arg3, arg4),
- int code AND long arg1 AND long arg2 AND long arg3 AND long arg4)
+static compiled_block_t *
+find_compiled_block (const char * name)
{
- utility_result res;
+ tree_node node = (tree_lookup (compiled_blocks_tree, name));
+ return ((node == 0) ? 0 : (compiled_blocks + (node->value)));
+}
- (* utility_table[code]) ((& res), arg1, arg2, arg3, arg4);
+static SCHEME_OBJECT *
+unspecified_code (SCHEME_OBJECT * entry, entry_count_t dispatch)
+{
+ SET_EXP ((SCHEME_OBJECT) entry);
+ C_return_value = ERR_EXECUTE_MANIFEST_VECTOR;
+ return (0);
+}
- return ((SCHEME_OBJECT *) res);
+static void *
+lrealloc (void * ptr, size_t size)
+{
+ return ((ptr == 0) ? (malloc (size)) : (realloc (ptr, size)));
}
\f
int
-DEFUN (multiply_with_overflow, (x, y, res), long x AND long y AND long * res)
+multiply_with_overflow (long x, long y, long * res)
{
- extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT));
- SCHEME_OBJECT ans;
-
- ans = (Mul ((LONG_TO_FIXNUM (x)), (LONG_TO_FIXNUM (y))));
+ SCHEME_OBJECT ans = (Mul ((LONG_TO_FIXNUM (x)), (LONG_TO_FIXNUM (y))));
if (ans == SHARP_F)
- {
- /* Bogus... */
- (* res) = (x * y);
- return (1);
- }
+ {
+ /* Bogus... */
+ (*res) = (x * y);
+ return (1);
+ }
else
- {
- (* res) = (FIXNUM_TO_LONG (ans));
- return (0);
- }
-}
-
-static unsigned int
-DEFUN (hex_digit_to_int, (h_digit), unsigned char h_digit)
-{
- unsigned int digit = ((unsigned int) h_digit);
-
- return (((digit >= '0') && (digit <= '9'))
- ? (digit - '0')
- : (((digit >= 'A') && (digit <= 'F'))
- ? ((digit - 'A') + 10)
- : ((digit - 'a') + 10)));
+ {
+ (*res) = (FIXNUM_TO_LONG (ans));
+ return (0);
+ }
}
SCHEME_OBJECT
-DEFUN (digit_string_to_bit_string, (n_bits, n_digits, digits),
- unsigned long n_bits
- AND unsigned long n_digits
- AND unsigned char * digits)
-{
- extern void EXFUN (clear_bit_string, (SCHEME_OBJECT));
- extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long));
- extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int));
- SCHEME_OBJECT result = (allocate_bit_string ((long) n_bits));
- unsigned int digit, mask;
- long i, posn;
- int j;
-
- posn = 0;
- clear_bit_string (result);
-
- for (i = 0; i < ((long) n_digits); i++)
- {
- digit = (hex_digit_to_int (*digits++));
- for (j = 0, mask = 1;
- j < 4;
- j++, mask = (mask << 1), posn++)
- if ((digit & mask) != 0)
- bit_string_set (result, posn, 1);
- }
- return (result);
-}
-\f
-/* This avoids consing the string and symbol if it already exists. */
-
-SCHEME_OBJECT
-DEFUN (memory_to_uninterned_symbol, (length, string),
- unsigned long length AND unsigned char * string)
+memory_to_uninterned_symbol (unsigned long length, const void * string)
{
SCHEME_OBJECT name = (memory_to_string (length, string));
SCHEME_OBJECT res = (CONS (name, UNBOUND_OBJECT));
return (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, res));
}
-static unsigned int
-DEFUN (digit_string_producer, (digit_ptr), PTR v_digit_ptr)
-{
- char ** digit_ptr = ((char **) v_digit_ptr);
- char digit = ** digit_ptr;
- * digit_ptr = ((* digit_ptr) + 1);
- return (hex_digit_to_int (digit));
-}
-
SCHEME_OBJECT
-DEFUN (digit_string_to_integer, (negative_p, n_digits, digits),
- Boolean negative_p
- AND unsigned long n_digits
- AND unsigned char * digits)
+rconsm (unsigned int nargs, SCHEME_OBJECT tail, ...)
{
- SCHEME_OBJECT bignum;
- unsigned char * digit = digits;
- extern SCHEME_OBJECT EXFUN (bignum_to_integer, (SCHEME_OBJECT));
+ SCHEME_OBJECT result;
+ unsigned int i;
+ va_list arg_ptr;
+ va_start (arg_ptr, tail);
- bignum = (digit_stream_to_bignum (((int) n_digits),
- digit_string_producer,
- ((PTR) & digit),
- 16,
- ((int) negative_p)));
+ result = tail;
+ for (i = 1; (i < nargs); i += 1)
+ result
+ = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)),
+ result));
- return (bignum_to_integer (bignum));
+ va_end (arg_ptr);
+ return (result);
}
\f
-#ifdef USE_STDARG
-
SCHEME_OBJECT
-DEFUN (rconsm, (nargs, tail DOTS),
- int nargs AND SCHEME_OBJECT tail DOTS)
+digit_string_to_bit_string (unsigned long n_bits,
+ unsigned long n_digits,
+ const char * digits)
{
- va_list arg_ptr;
- va_start (arg_ptr, tail);
-
- {
- int i;
- SCHEME_OBJECT result = tail;
-
- for (i = 1; i < nargs; i++)
- result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)),
- result));
+ SCHEME_OBJECT result = (allocate_bit_string (n_bits));
+ unsigned long posn = 0;
+ unsigned long i;
- va_end (arg_ptr);
- return (result);
- }
+ clear_bit_string (result);
+ for (i = 0; (i < n_digits); i += 1)
+ {
+ unsigned int digit = (hex_digit_to_int (*digits++));
+ unsigned int j = 0;
+ unsigned int mask = 1;
+ while (j < 4)
+ {
+ if ((digit & mask) != 0)
+ bit_string_set (result, posn, 1);
+ j += 1;
+ mask <<= 1;
+ posn += 1;
+ }
+ }
+ return (result);
}
-#else /* not USE_STDARG */
-
SCHEME_OBJECT
-rconsm (va_alist)
-va_dcl
+digit_string_to_integer (bool negative_p,
+ unsigned long n_digits,
+ const char * digits)
{
- va_list arg_ptr;
- int nargs;
- SCHEME_OBJECT tail;
-
- va_start (arg_ptr);
- nargs = (va_arg (arg_ptr, int));
- tail = (va_arg (arg_ptr, SCHEME_OBJECT));
-
- {
- int i;
- SCHEME_OBJECT result = tail;
+ SCHEME_OBJECT bignum
+ = (digit_stream_to_bignum (((int) n_digits),
+ digit_string_producer,
+ ((void *) (&digits)),
+ 16,
+ ((int) negative_p)));
- for (i = 1; i < nargs; i++)
- result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)),
- result));
+ return (bignum_to_integer (bignum));
+}
- va_end (arg_ptr);
- return (result);
- }
+static unsigned int
+digit_string_producer (void * v_digit_ptr)
+{
+ const char ** digit_ptr = v_digit_ptr;
+ char digit = (**digit_ptr);
+ (*digit_ptr) = ((*digit_ptr) + 1);
+ return (hex_digit_to_int (digit));
}
-#endif /* USE_STDARG */
+static unsigned int
+hex_digit_to_int (char h_digit)
+{
+ unsigned int digit = ((unsigned int) h_digit);
+ return (((digit >= '0') && (digit <= '9'))
+ ? (digit - '0')
+ : (((digit >= 'A') && (digit <= 'F'))
+ ? ((digit - 'A') + 10)
+ : ((digit - 'a') + 10)));
+}
### -*-Midas-*-
###
-### $Id: i386.m4,v 1.66 2007/01/05 21:19:26 cph Exp $
+### $Id: i386.m4,v 1.67 2007/04/22 16:31:24 cph Exp $
###
### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
declare_alignment(2)
use_external_data(EVR(Free))
-use_external_data(EVR(sp_register))
+use_external_data(EVR(stack_pointer))
use_external_data(EVR(utility_table))
ifdef(`WIN32',`
# These two moves must happen _before_ the ffree instructions below.
# Otherwise recovery from SIGFPE there will fail.
- OP(mov,l) TW(REG(esp),EVR(sp_register))
+ OP(mov,l) TW(REG(esp),EVR(stack_pointer))
OP(mov,l) TW(rfree,EVR(Free))
IF387(`
OP(mov,l) TW(LOF(REGBLOCK_VAL(),regs),REG(eax)) # Value/dynamic link
OP(mov,l) TW(IMM(ADDRESS_MASK),rmask) # = %ebp
- OP(mov,l) TW(EVR(sp_register),REG(esp))
+ OP(mov,l) TW(EVR(stack_pointer),REG(esp))
OP(mov,l) TW(REG(eax),REG(ecx)) # Preserve if used
OP(and,l) TW(rmask,REG(ecx)) # Restore potential dynamic link
OP(mov,l) TW(REG(ecx),LOF(REGBLOCK_DLINK(),regs))
/* -*-C-*-
-$Id: cmpgc.h,v 1.36 2007/01/05 21:19:25 cph Exp $
+$Id: cmpgc.h,v 1.37 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/*
+/* Utilities to relocate compiled code in garbage collection-like
+ processes. */
-Utilities to relocate compiled code in garbage collection-like processes.
+#ifndef SCM_CMPGC_H
+#define SCM_CMPGC_H 1
-This file is included by gccode.h.
+#include "cmpint.h"
-See cmpint.txt, cmpint.c, cmpint-md.h, and cmpaux-md.m4 for more details.
-*/
-
-#ifndef CMPGC_H_INCLUDED
-#define CMPGC_H_INCLUDED
-\f
-#define NOP() do {} while (0) /* A useful macro */
-
-/* These are needed whether or not there is a compiler,
- so their definition must be outside the HAS_COMPILER_SUPPORT ifdef.
- */
-
-#define OPERATOR_LINKAGE_KIND 0x000000
-#define REFERENCE_LINKAGE_KIND 0x010000
-#define ASSIGNMENT_LINKAGE_KIND 0x020000
-#define GLOBAL_OPERATOR_LINKAGE_KIND 0x030000
-#define CLOSURE_PATTERN_LINKAGE_KIND 0x040000
-
-#ifdef HAS_COMPILER_SUPPORT
-
-#include "cmpintmd.h"
-\f
-/*
- The following is a kludge which is used to get return_to_interpreter
- to work. The return to interpreter block is never dumped on normal
- bin files, but is dumped in complete bands. As long as it does not
- change in position with respect to the beginning of constant space,
- it will be relocated correctly on reload.
-*/
-
-#ifndef In_Fasdump
-
-#define COMPILED_CODE_PRE_TEST(then_what)
-
-#else
-
-extern SCHEME_OBJECT compiler_utilities;
-
-#define COMPILED_CODE_PRE_TEST(then_what) \
-if (Old == (OBJECT_ADDRESS (compiler_utilities))) \
- then_what; \
-else
-
-#endif
-\f
-/*
- The following code handles compiled entry points, where the
- addresses point to the "middle" of the code vector. From the entry
- address, the offset word can be extracted, and this offset allows
- us to find the beginning of the block, so it can be copied as a
- whole. The broken heart for the whole block lives in its usual
- place (first word in the vector).
-
- The offset word contains an encoding of the offset and an encoding
- of whether the resulting pointer points to the beginning of the
- block or is another entry, so the process may have to be repeated.
-
- Pointers to char are used here because compiled entry points do not
- in general point to Pointer boundaries.
- */
-
-#define Get_Compiled_Block(var, address) \
-{ \
- long offset_word; \
- \
- var = (address); \
- \
- do \
- { \
- offset_word = (COMPILED_ENTRY_OFFSET_WORD(var)); \
- var = ((SCHEME_OBJECT *) \
- (((char *) (var)) \
- - ((long) (OFFSET_WORD_TO_BYTE_OFFSET(offset_word))))); \
- } while (OFFSET_WORD_CONTINUATION_P (offset_word)); \
-}
-
-#define RELOCATE_COMPILED_INTERNAL(addr, new_block, old_block) \
- ((SCHEME_OBJECT *) \
- (((char *) new_block) \
- + (((char *) (addr)) - ((char *) old_block))))
-
-#define RELOCATE_COMPILED_RAW_ADDRESS(addr, new_block, old_block) \
- (ADDR_TO_SCHEME_ADDR \
- (RELOCATE_COMPILED_INTERNAL ((SCHEME_ADDR_TO_ADDR (addr)), \
- new_block, old_block)))
-
-#define RELOCATE_COMPILED_ADDRESS(object, new_block, old_block) \
- ((SCHEME_OBJECT *) \
- (RELOCATE_COMPILED_INTERNAL ((OBJECT_ADDRESS (object)), \
- new_block, old_block)))
-
-#define RELOCATE_COMPILED(object, new_block, old_block) \
-MAKE_POINTER_OBJECT ((OBJECT_TYPE (object)), \
- (RELOCATE_COMPILED_ADDRESS (object, new_block, \
- old_block)))
-
-#define Compiled_BH(In_GC, then_what) \
-{ \
- /* Has it already been relocated? */ \
- \
- Get_Compiled_Block (Old, Old); \
- COMPILED_CODE_PRE_TEST (then_what) \
- if (BROKEN_HEART_P (* Old)) \
- { \
- Temp = (RELOCATE_COMPILED (Temp, (OBJECT_ADDRESS (* Old)), Old)); \
- then_what; \
- } \
-}
-
-#define RAW_COMPILED_BH(In_GC, then_what) \
-{ \
- Get_Compiled_Block (Old, Old); \
- COMPILED_CODE_PRE_TEST (then_what) \
- if (BROKEN_HEART_P (* Old)) \
- { \
- Temp = (RELOCATE_COMPILED_RAW_ADDRESS (Temp, \
- (OBJECT_ADDRESS (* Old)), \
- Old)); \
- then_what; \
- } \
-}
-
-#ifdef AUTOCLOBBER_BUG
-
-# define AUTOCLOBBER_BUMP(Old, To) do \
-{ \
- if ((OBJECT_TYPE (* Old)) == TC_MANIFEST_VECTOR) \
- { \
- *To = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \
- ((PAGE_SIZE / (sizeof (SCHEME_OBJECT))) \
- - 1))); \
- To += (PAGE_SIZE / (sizeof (SCHEME_OBJECT))); \
- } \
-} while (0)
-
-#else
-
-# define AUTOCLOBBER_BUMP(Old, To) do { } while (0)
-
-#endif
-
-#define Transport_Compiled() do \
-{ \
- SCHEME_OBJECT * Saved_Old = Old; \
- \
- Real_Transport_Vector (); \
- AUTOCLOBBER_BUMP (Saved_Old, To); \
- *Saved_Old = New_Address; \
- Temp = (RELOCATE_COMPILED (Temp, \
- (OBJECT_ADDRESS (New_Address)), \
- Saved_Old)); \
-} while (0)
-
-#define TRANSPORT_RAW_COMPILED() do \
-{ \
- SCHEME_OBJECT * Saved_Old = Old; \
- \
- Real_Transport_Vector (); \
- AUTOCLOBBER_BUMP (Saved_Old, To); \
- *Saved_Old = New_Address; \
- Temp = (RELOCATE_COMPILED_RAW_ADDRESS \
- (Temp, \
- (OBJECT_ADDRESS (New_Address)), \
- Saved_Old)); \
-} while (0)
-\f
-/* Manifest and implied types */
-
-/* Manifest closures */
-
-/* A manifest closure header is followed by one or more closure entry
- points. Each entry point consist of a pair of machine words (16
- bits each) that contain a format word and a GC offset followed by
- the machine code for the closure (typically a jsr-type
- instruction). If there is only one entry point to a closure, the
- GC offset will be 8 bytes, pointing back to the manifest closure
- header itself. Otherwise what would have been the first GC offset
- is 0, and what would have been the first format word is the count
- in entry points. The format word and GC offset for the first entry
- follow this additional word. After the entry points there are the
- values of the variables closed over:
-
- >=1 Entry Point =1 Entry Point
- (offset in bytes from 1st instruction of 1st (only) entry)
-
- -12: Manifest Closure | tot. length
- - 8: Count format word (with 0 GC) Manifest Closure | tot. length
- - 4: Format word, 1st entry Format word, only entry
- - 2: GC offset to -12 GC offset to -8
- 0: jsr instr., 1st entry jsr instr.
- xx: more instructions if needed same
- : Format word, 2nd entry closed over variable values
- : GC offset to -16
- ...: etc.
- ...: closed over variable values
-
- The following five macros are the only ones used outside of this
- file to deal with closures. They can be overridden for specific
- machines that use different formats.
-
- MANIFEST_CLOSURE_COUNT receives the address of the word past the
- manifest closure header and extracts the count of entry points
- in the closure block.
-
- FIRST_MANIFEST_CLOSURE_ENTRY receives the address of the word past
- the manifest closure header (-4 for single entry point closures in
- the above picture). It bumps it to the first entry point (i.e. to
- 0 above), past the format word and the gc offset and the count
- formart word if present.
-
- NEXT_MANIFEST_CLOSURE_ENTRY given an entry point in a multiclosure,
- bump to the immediately following entry point
-
- CLOSURE_ENTRY_END given an entry point, return the address of the
- first byte past the code in this entry point.
-
- MANIFEST_CLOSURE_END receives the address of the word past
- the manifest closure header (-4 for single entry point closures in
- the above picture). Returns the address of the word that precedes
- the first free variable in the closure.
-
- CLOSURE_HEADER_TO_ENTRY is the distance (in bytes) from the
- manifest closure header to the 1st instruction of the (1st) entry.
- */
-
-#define CLOSURE_HEADER_TO_ENTRY \
-((sizeof (SCHEME_OBJECT)) + (2 * (sizeof (format_word))))
-
-#define CLOSURE_HEADER_TO_ENTRY_WORD \
-((format_word) (BYTE_OFFSET_TO_OFFSET_WORD (CLOSURE_HEADER_TO_ENTRY)))
-
-#ifndef MANIFEST_CLOSURE_COUNT
-#define MANIFEST_CLOSURE_COUNT(scan) \
-(((((format_word *) (scan))[1]) == \
- CLOSURE_HEADER_TO_ENTRY_WORD) ? \
- 1 : \
- ((long) (((format_word *) (scan))[0])))
-#endif
-
-#ifndef FIRST_MANIFEST_CLOSURE_ENTRY
-#define FIRST_MANIFEST_CLOSURE_ENTRY(scan) \
-(((((format_word *) (scan))[1]) == CLOSURE_HEADER_TO_ENTRY_WORD) \
- ? (((char *) (scan)) + (2 * (sizeof (format_word)))) \
- : (((char *) (scan)) + (4 * (sizeof (format_word)))))
-#endif
-
-#ifndef NEXT_MANIFEST_CLOSURE_ENTRY
-#define NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr) \
- (((char *) (word_ptr)) + (COMPILED_CLOSURE_ENTRY_SIZE))
-#endif
+/* When the target address of a closure is stored as a relative
+ reference, the following three macros are used to aid relocation of
+ these targets.
-/* Where this closure entry ends with respect to the entry point.
- Since an entry point is preceded by a format word and a gc offset,
- it is the address of the next entry minus these two words.
- */
+ DECLARE_RELOCATION_REFERENCE(reference) declares a variable to hold
+ reference information when code pointers are relative.
-#ifndef CLOSURE_ENTRY_END
-#define CLOSURE_ENTRY_END(word_ptr) \
- (((char *) (word_ptr)) + \
- ((COMPILED_CLOSURE_ENTRY_SIZE) - (2 * (sizeof (format_word)))))
-#endif
-
-#define CHAR_TO_SCHEME_OBJECT(chars) \
-(((chars) + ((sizeof (SCHEME_OBJECT)) - 1)) / (sizeof (SCHEME_OBJECT)))
-
-/* This assumes that closures with exactly one entry point
- are always represented in short format. */
-
-#ifndef MANIFEST_CLOSURE_END
-#define MANIFEST_CLOSURE_END(start, count) \
-(((SCHEME_OBJECT *) (start)) \
- + (CHAR_TO_SCHEME_OBJECT (((count) * COMPILED_CLOSURE_ENTRY_SIZE) \
- + (((count) == 1) \
- ? 0 \
- : (2 * sizeof(format_word))))))
-#endif
-\f
-/* Linkage sections */
-
-#define READ_LINKAGE_KIND(header) \
- ((header) & 0xff0000)
+ START_CLOSURE_RELOCATION(block_addr, reference) is called
+ immediately before relocating a block of closure entries. */
-#define READ_CACHE_LINKAGE_COUNT(header) \
- ((header) & 0xffff)
-
-#ifndef FIRST_OPERATOR_LINKAGE_OFFSET
-# define FIRST_OPERATOR_LINKAGE_OFFSET 1
+#ifndef DECLARE_RELOCATION_REFERENCE
+# define DECLARE_RELOCATION_REFERENCE(reference)
#endif
-
-#define READ_OPERATOR_LINKAGE_COUNT(header) \
- (EXECUTE_CACHE_COUNT_TO_ENTRIES \
- (((header) & 0xffff) - (FIRST_OPERATOR_LINKAGE_OFFSET - 1)))
-
-#define MAKE_LINKAGE_SECTION_HEADER(kind, count) \
- (MAKE_OBJECT(TC_LINKAGE_SECTION, \
- ((kind) \
- | ((((kind) == OPERATOR_LINKAGE_KIND) \
- || ((kind) == GLOBAL_OPERATOR_LINKAGE_KIND)) \
- ? ((EXECUTE_CACHE_ENTRIES_TO_COUNT (count)) \
- + (FIRST_OPERATOR_LINKAGE_OFFSET - 1)) \
- : (count)))))
-
-/* This takes into account the 1 added by the main loop of the
- relocators.
- */
-
-#ifndef END_OPERATOR_LINKAGE_AREA
-# define END_OPERATOR_LINKAGE_AREA(scan, count) \
- (((SCHEME_OBJECT *) (scan)) \
- + (((count) * EXECUTE_CACHE_ENTRY_SIZE)) \
- + (FIRST_OPERATOR_LINKAGE_OFFSET - 1))
-#endif
-
-#define FIRST_OPERATOR_LINKAGE_ENTRY(scan) \
- ((char *) (((SCHEME_OBJECT *) (scan)) + FIRST_OPERATOR_LINKAGE_OFFSET))
-
-#define NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr) \
- ((char *) (((SCHEME_OBJECT *) (word_ptr)) + \
- EXECUTE_CACHE_ENTRY_SIZE))
-
-#ifndef EXTRACT_OPERATOR_LINKAGE_ADDRESS
-# define EXTRACT_OPERATOR_LINKAGE_ADDRESS(target, source) \
-{ \
- EXTRACT_EXECUTE_CACHE_ADDRESS (target, source); \
-}
-#endif
-
-#ifndef STORE_OPERATOR_LINKAGE_ADDRESS
-# define STORE_OPERATOR_LINKAGE_ADDRESS(source, target) \
-{ \
- STORE_EXECUTE_CACHE_ADDRESS (target, source); \
-}
-#endif
-
-/* Heuristic recovery aid. See uxtrap.c for its use.
- block is the address of a vector header followed by a non-marked
- header (the way that compiled blocks start).
- PLAUSIBLE_CC_BLOCK_P returns true if it is likely that compiled
- code is contained in the header. This is done by checking whether
- an entry is the first thing in the compiled code section.
- There are two kinds of "possible entries": expressions (first thing
- in the block) and procedures/continuations, which follow an interrupt
- check.
- */
-
-#define PLAUSIBLE_CC_BLOCK_P(block) \
- (((PLAUSIBLE_BLOCK_START_P((block), CC_BLOCK_FIRST_ENTRY_OFFSET)) || \
- (PLAUSIBLE_BLOCK_START_P((block), \
- (CC_BLOCK_FIRST_ENTRY_OFFSET + \
- ENTRY_PREFIX_LENGTH)))) \
- && \
- (PLAUSIBLE_BLOCK_SPAN_AND_END_P(block, \
- (VECTOR_LOC((SCHEME_OBJECT)block, \
- ((VECTOR_LENGTH((SCHEME_OBJECT)block)) - 1))))))
-
-#define PLAUSIBLE_BLOCK_START_P(addr, offset) \
-((*((format_word *) \
- (((char *) (addr)) + ((offset) - (sizeof (format_word)))))) == \
- ((BYTE_OFFSET_TO_OFFSET_WORD(offset))))
-
-#define PLAUSIBLE_BLOCK_SPAN_AND_END_P(addr,end) \
- (((ADDRESS_HEAP_P(addr) && ADDRESS_HEAP_P(end)) || \
- (ADDRESS_CONSTANT_P(addr) && ADDRESS_CONSTANT_P(end))) \
- && \
- (ENVIRONMENT_P (*(SCHEME_OBJECT *) end)))
-\f
-#else /* not HAS_COMPILER_SUPPORT */
-
-/* This can be anything. */
-
-typedef unsigned short format_word;
-
-/* Is there anything else that can be done here? */
-
-#define GC_NO_COMPILER_STMT() \
- gc_death \
- (TERM_COMPILER_DEATH, \
- "relocate_compiled: No compiler support!", \
- 0, 0)
-
-#define GC_NO_COMPILER_EXPR(value_type) \
- ((GC_NO_COMPILER_STMT ()), (value_type 0))
-
-#define RELOCATE_COMPILED(obj, nb, ob) \
- (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT)))
-#define RELOCATE_COMPILED_INTERNAL(ad,nb,ob) \
- (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT)))
-#define RELOCATE_COMPILED_RAW_ADDRESS(ad,nb,ob) \
- (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT)))
-
-#define Transport_Compiled() (GC_NO_COMPILER_STMT ())
-#define TRANSPORT_RAW_COMPILED() (GC_NO_COMPILER_STMT ())
-#define Compiled_BH(flag, then_what) (GC_NO_COMPILER_STMT ())
-#define RAW_COMPILED_BH(flag, then_what) (GC_NO_COMPILER_STMT ())
-#define Get_Compiled_Block(var, address) (GC_NO_COMPILER_STMT ())
-
-#define FIRST_MANIFEST_CLOSURE_ENTRY(scan) \
- (GC_NO_COMPILER_EXPR ((char *)))
-
-#define MANIFEST_CLOSURE_COUNT(scan) \
- (GC_NO_COMPILER_EXPR ((long)))
-
-#define NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr) \
- (GC_NO_COMPILER_EXPR ((char *)))
-
-#define CLOSURE_ENTRY_END(word_ptr) \
- (GC_NO_COMPILER_EXPR ((char *)))
-
-#define MANIFEST_CLOSURE_END(end, start) \
- (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT *)))
-
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(target, source) \
- (GC_NO_COMPILER_STMT ())
-
-#define STORE_CLOSURE_ENTRY_ADDRESS(source, target) \
- (GC_NO_COMPILER_STMT ())
-
-#define READ_LINKAGE_KIND(header) \
- (GC_NO_COMPILER_EXPR ((int)))
-
-#define READ_CACHE_LINKAGE_COUNT(header) \
- (GC_NO_COMPILER_EXPR ((int)))
-
-#define READ_OPERATOR_LINKAGE_COUNT(header) \
- (GC_NO_COMPILER_EXPR ((int)))
-
-#define END_OPERATOR_LINKAGE_AREA(scan, count) \
- (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT *)))
-
-#define FIRST_OPERATOR_LINKAGE_ENTRY(scan) \
- (GC_NO_COMPILER_EXPR ((char *)))
-
-#define NEXT_LINKAGE_OPERATOR_ENTRY(ptr) \
- (GC_NO_COMPILER_EXPR ((char *)))
-
-#define EXTRACT_OPERATOR_LINKAGE_ADDRESS(target, source) \
- (GC_NO_COMPILER_STMT ())
-
-#define STORE_OPERATOR_LINKAGE_ADDRESS(source, target) \
- (GC_NO_COMPILER_STMT ())
-
-#endif /* HAS_COMPILER_SUPPORT */
-
-#ifndef FLUSH_I_CACHE
-# define FLUSH_I_CACHE() do {} while (0)
+#ifndef START_CLOSURE_RELOCATION
+# define START_CLOSURE_RELOCATION(scan, reference) do {} while (false)
#endif
-
-#if !defined(PUSH_D_CACHE_REGION) && defined(FLUSH_I_CACHE_REGION)
-# define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords)
+#ifndef START_OPERATOR_RELOCATION
+# define START_OPERATOR_RELOCATION(scan, reference) do {} while (false)
#endif
-#ifndef COMPILER_TRANSPORT_END
-# define COMPILER_TRANSPORT_END() do \
+#ifdef CC_SUPPORT_P
+#define CC_TRANSPORT_END() do \
{ \
- Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0); \
- Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL); \
+ SET_CLOSURE_FREE (0); \
+ SET_CLOSURE_SPACE (0); \
FLUSH_I_CACHE (); \
-} while (0)
-#endif /* COMPILER_TRANSPORT_END */
-
-#ifndef START_CLOSURE_RELOCATION
-# define START_CLOSURE_RELOCATION(scan) do { } while (0)
-#endif
-#ifndef END_CLOSURE_RELOCATION
-# define END_CLOSURE_RELOCATION(scan) do { } while (0)
-#endif
-
-#ifndef START_OPERATOR_RELOCATION
-# define START_OPERATOR_RELOCATION(scan) do { } while (0)
-#endif
-#ifndef END_OPERATOR_RELOCATION
-# define END_OPERATOR_RELOCATION(scan) do { } while (0)
+} while (false)
+#else
+# define CC_TRANSPORT_END() do {} while (false)
#endif
-#endif /* CMPGC_H_INCLUDED */
+#endif /* SCM_CMPGC_H */
/* -*-C-*-
-$Id: cmpint.c,v 1.108 2007/02/04 21:55:45 riastradh Exp $
+$Id: cmpint.c,v 1.109 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/*
- *
- * Compiled code interface. Portable version.
- * This file requires a bit of assembly language from cmpaux-md.m4
- * See also the files cmpint.txt, cmpgc.h, and cmpint-md.h .
- *
- */
-\f
-/*
- * Procedures in this file belong to the following categories:
- *
- * Local C procedures. These are local procedures called only by
- * other procedures in this file, and have been separated only for
- * modularity reasons. They are tagged with the C keyword `static'.
- * They can return any C type.
- *
- * C utility procedures. These procedures are called from C
- * primitives and other subsystems and never leave the C world. They
- * constitute the compiled code data abstraction as far as other C
- * parts of the Scheme "microcode" are concerned. They are tagged
- * with the noise word `C_UTILITY'. They can return any C type.
- *
- * C interface entries. These procedures are called from the
- * interpreter (written in C) and ultimately enter the Scheme compiled
- * code world by using the assembly language utility
- * `C_to_interface'. They are tagged with the noise word
- * `C_TO_SCHEME'. They MUST return a C long indicating what
- * the interpreter should do next.
- *
- * Scheme interface utilities. These procedures are called from the
- * assembly language interface and return to it, and perform all the
- * tasks that the compiler does not code inline. They are referenced
- * by compiled scheme code by index, and the assembly language
- * interface fetches them from an array. They are tagged with the
- * noise word `SCHEME_UTILITY'. They return a C structure (struct
- * utility_result) which describes whether computation should proceed
- * in the interpreter or in compiled code, and how.
- *
- */
-
-/* Macro imports */
-
-#include "config.h"
-#include <stdio.h>
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-#endif
-#include "dstack.h" /* Dynamic-stack support */
-#include "outf.h" /* error reporting */
-#include "types.h" /* Needed by const.h */
-#include "const.h" /* REGBLOCK_MINIMUM_LENGTH and PRIM_... codes */
-#include "object.h" /* Making and destructuring Scheme objects */
-#include "intrpt.h" /* Interrupt processing macros */
-#include "gc.h" /* Request_GC, etc. */
-#include "sdata.h" /* ENTITY_OPERATOR */
-#include "errors.h" /* Error codes and Termination codes */
-#include "returns.h" /* Return addresses in the interpreter */
-#include "fixobj.h" /* To find the error handlers */
-#include "stack.h" /* Stacks and stacklets */
-#include "interp.h" /* Interpreter state and primitive destructuring */
-#include "default.h" /* various definitions */
-#include "extern.h" /* External decls (missing Cont_Debug, etc.) */
-#include "trap.h" /* CACHE_TYPE */
-#include "prims.h" /* LEXPR */
-#include "prim.h" /* Primitive_Procedure_Table, etc. */
-
-#define ENTRY_TO_OBJECT(entry) \
- (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))))
-
-#define IN_CMPINT_C
-#include "cmpgc.h" /* Compiled code object relocation */
+/* Compiled-code interface */
+/* Some of the cmpintmd/FOO.h files use this macro to alter their
+ behavior when included here. */
+#define IN_CMPINT_C 1
+
+#include "scheme.h"
+#include "prims.h"
#include "lookup.h"
+#include "trap.h"
+#include "history.h"
+#include "cmpgc.h"
+
+/* Two special classes of procedures are used in this file:
+
+ Scheme interface entries. These procedures are called from C and
+ ultimately invoke 'ENTER_SCHEME' to enter compiled code, or return
+ a status code.
+
+ Scheme interface utilities. These procedures are called from the
+ Scheme interface and perform tasks that the compiler does not code
+ inline. They are referenced from compiled Scheme code by index,
+ and the assembly language interface fetches them from an array.
+ They are defined with 'SCHEME_UTILITY_n' for some 'n', and
+ ultimately invoke either 'RETURN_TO_SCHEME' (in the normal case) or
+ 'RETURN_TO_C' (in the error case). */
+\f
+typedef long cache_handler_t (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+
+typedef struct
+{
+ SCHEME_OBJECT * block_address;
+ SCHEME_OBJECT * scan;
+ unsigned long n_sections;
+ insn_t * return_address;
+ unsigned long n_linked_sections;
+ SCHEME_OBJECT * scan0;
+ linkage_section_type_t type;
+ unsigned long n_entries;
+ unsigned long n_linked_entries;
+} link_cc_state_t;
+
+/* Ways to bypass the interpreter */
+typedef enum
+{
+ REFLECT_CODE_INTERNAL_APPLY,
+ REFLECT_CODE_RESTORE_INTERRUPT_MASK,
+ REFLECT_CODE_STACK_MARKER,
+ REFLECT_CODE_CC_BKPT
+} reflect_code_t;
-#ifdef HAS_COMPILER_SUPPORT
+#define PUSH_REFLECTION(code) do \
+{ \
+ STACK_PUSH (ULONG_TO_FIXNUM (code)); \
+ STACK_PUSH (reflect_to_interface); \
+} while (false)
+
+typedef enum
+{
+ TRAMPOLINE_K_RETURN_TO_INTERPRETER,
+ TRAMPOLINE_K_APPLY,
+ TRAMPOLINE_K_ARITY, /* unused */
+ TRAMPOLINE_K_ENTITY, /* unused */
+ TRAMPOLINE_K_INTERPRETED, /* unused */
+ TRAMPOLINE_K_LEXPR_PRIMITIVE,
+ TRAMPOLINE_K_PRIMITIVE,
+ TRAMPOLINE_K_LOOKUP,
+ TRAMPOLINE_K_1_0,
+ TRAMPOLINE_K_2_1,
+ TRAMPOLINE_K_2_0,
+ TRAMPOLINE_K_3_2,
+ TRAMPOLINE_K_3_1,
+ TRAMPOLINE_K_3_0,
+ TRAMPOLINE_K_4_3,
+ TRAMPOLINE_K_4_2,
+ TRAMPOLINE_K_4_1,
+ TRAMPOLINE_K_4_0,
+ TRAMPOLINE_K_REFLECT_TO_INTERFACE = 0x3A
+} trampoline_type_t;
+
+#define TC_TRAMPOLINE_HEADER TC_FIXNUM
+#define TRAMPOLINE_TABLE_SIZE 4
+
+static trampoline_type_t
+trampoline_arity_table [TRAMPOLINE_TABLE_SIZE * TRAMPOLINE_TABLE_SIZE] =
+{
+ TRAMPOLINE_K_1_0, /* 1_0 */
+ TRAMPOLINE_K_APPLY, /* 1_1 should not get here */
+ TRAMPOLINE_K_APPLY, /* 1_2 should not get here */
+ TRAMPOLINE_K_APPLY, /* 1_3 should not get here */
+ TRAMPOLINE_K_2_0, /* 2_0 */
+ TRAMPOLINE_K_2_1, /* 2_1 */
+ TRAMPOLINE_K_APPLY, /* 2_2 should not get here */
+ TRAMPOLINE_K_APPLY, /* 2_3 should not get here */
+ TRAMPOLINE_K_3_0, /* 3_0 */
+ TRAMPOLINE_K_3_1, /* 3_1 */
+ TRAMPOLINE_K_3_2, /* 3_2 */
+ TRAMPOLINE_K_APPLY, /* 3_3 should not get here */
+ TRAMPOLINE_K_4_0, /* 4_0 */
+ TRAMPOLINE_K_4_1, /* 4_1 */
+ TRAMPOLINE_K_4_2, /* 4_2 */
+ TRAMPOLINE_K_4_3 /* 4_3 */
+};
\f
-/* ASM_ENTRY_POINT and EXFNX are for OS/2. The IBM C Set++/2
- compiler has several different external calling conventions. The
- default calling convention is called _Optlink, uses a combination
- of registers and the stack, and is complicated. The calling
- convention used for operating system interface procedures is called
- _System, uses only the stack, and is very similar to the calling
- conventions used with our DOS compilers. So, in order to simplify
- the changes to the assembly language, we use _System conventions
- for calling C procedures from the assembly language file.
+cc_arch_t compiler_processor_type;
+unsigned int compiler_interface_version;
+
+SCHEME_OBJECT compiler_utilities;
+SCHEME_OBJECT return_to_interpreter;
+SCHEME_OBJECT reflect_to_interface;
+
+static bool linking_cc_block_p = 0;
+
+static SCHEME_OBJECT make_compiler_utilities (void);
+static void open_stack_gap (unsigned long, unsigned long);
+static void close_stack_gap (unsigned long, unsigned long);
+static void recover_from_apply_error (SCHEME_OBJECT, unsigned long);
+static long link_remaining_sections (link_cc_state_t *);
+static void start_linking_cc_block (void);
+static void end_linking_cc_block (link_cc_state_t *);
+static void abort_linking_cc_block (void *);
+static void update_cache_after_link (link_cc_state_t *);
+static void start_linking_section (link_cc_state_t *);
+static long link_section (link_cc_state_t *);
+static bool link_section_handler
+ (linkage_section_type_t, cache_handler_t **, bool *);
+static void back_out_of_link_section (link_cc_state_t *);
+static void restore_link_cc_state (link_cc_state_t *);
+static long setup_compiled_invocation (SCHEME_OBJECT, unsigned long);
+static long setup_lexpr_invocation
+ (SCHEME_OBJECT, unsigned long, unsigned long);
+static bool open_gap (unsigned long, unsigned long);
+static bool cc_block_address_closure_p (SCHEME_OBJECT *);
+static void write_uuo_link (SCHEME_OBJECT, SCHEME_OBJECT *);
+static long make_fake_uuo_link (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+static long make_trampoline
+ (SCHEME_OBJECT *, cc_entry_type_t *, trampoline_type_t, unsigned int, ...);
+static void make_trampoline_headers
+ (unsigned long, unsigned long,
+ SCHEME_OBJECT *, SCHEME_OBJECT *, unsigned long *);
+static bool fill_trampoline
+ (SCHEME_OBJECT *, unsigned long, cc_entry_type_t *, trampoline_type_t);
+static long make_redirection_trampoline
+ (SCHEME_OBJECT *, trampoline_type_t, SCHEME_OBJECT);
+static long make_apply_trampoline
+ (SCHEME_OBJECT *, trampoline_type_t, SCHEME_OBJECT, unsigned long);
+
+/* ASM_ENTRY_POINT is for OS/2, but it could also be used for any
+ compiler that supports multiple calling conventions, such as GCC.
+
+ The IBM C Set++/2 compiler has several different external calling
+ conventions. The default calling convention is called _Optlink,
+ uses a combination of registers and the stack, and is complicated.
+ The calling convention used for operating system interface
+ procedures is called _System, uses only the stack, and is very
+ similar to the calling conventions used with our DOS compilers.
+ So, in order to simplify the changes to the assembly language, we
+ use _System conventions for calling C procedures from the assembly
+ language file.
Since _Optlink is the default, we must somehow cause the relevant
procedures to be compiled using _System. The easiest way to do
#ifndef ASM_ENTRY_POINT
# define ASM_ENTRY_POINT(name) name
#endif
-
-#define EXFNX(name, proto) EXFUN (ASM_ENTRY_POINT (name), proto)
-
-/* Make noise words invisible to the C compiler. */
-
-#define C_UTILITY
-#define C_TO_SCHEME
-
-#define DEFINE_SCHEME_UTILITY_0(pname) \
-void \
-DEFUN (ASM_ENTRY_POINT (pname), \
- (DSU_result, ignore1, ignore2, ignore3, ignore4), \
- utility_result * DSU_result \
- AND long ignore1 \
- AND long ignore2 \
- AND long ignore3 \
- AND long ignore4)
-
-#define DEFINE_SCHEME_UTILITY_1(pname, av1) \
-void \
-DEFUN (ASM_ENTRY_POINT (pname), \
- (DSU_result, av1, ignore2, ignore3, ignore4), \
- utility_result * DSU_result \
- AND long av1 \
- AND long ignore2 \
- AND long ignore3 \
- AND long ignore4)
-
-#define DEFINE_SCHEME_UTILITY_2(pname, av1, av2) \
-void \
-DEFUN (ASM_ENTRY_POINT (pname), \
- (DSU_result, av1, av2, ignore3, ignore4), \
- utility_result * DSU_result \
- AND long av1 \
- AND long av2 \
- AND long ignore3 \
- AND long ignore4)
-
-#define DEFINE_SCHEME_UTILITY_3(pname, av1, av2, av3) \
-void \
-DEFUN (ASM_ENTRY_POINT (pname), \
- (DSU_result, av1, av2, av3, ignore4), \
- utility_result * DSU_result \
- AND long av1 \
- AND long av2 \
- AND long av3 \
- AND long ignore4)
-
-#define DEFINE_SCHEME_UTILITY_4(pname, av1, av2, av3, av4) \
-void \
-DEFUN (ASM_ENTRY_POINT (pname), \
- (DSU_result, av1, av2, av3, av4), \
- utility_result * DSU_result \
- AND long av1 \
- AND long av2 \
- AND long av3 \
- AND long av4)
-
-/* For clarity */
-
-typedef char instruction;
\f
+#ifndef UTILITY_RESULT_DEFINED
#ifdef CMPINT_USE_STRUCS
#ifdef C_FUNC_PTR_IS_CLOSURE
-# define REFENTRY(name) (name)
-# define VARENTRY(name) instruction * name
-# define EXTENTRY(name) extern instruction * name
+ typedef insn_t * c_func_t;
#else
-# ifdef __OPEN_WATCOM_14__
-# define REFENTRY(name) ((void *) name)
-# else
-# define REFENTRY(name) ((void EXFUN ((*), (void))) name)
+ typedef void c_func_t (void);
+/* From trunk, but may not be needed: */
+# if 0
+# ifdef __OPEN_WATCOM_14__
+# define REFENTRY(name) ((void *) name)
+# else
+# define REFENTRY(name) ((c_func_t *) name)
+# endif
+# define VARENTRY(name) c_func_t * name
+# define EXTENTRY(name) extern c_func_t ASM_ENTRY_POINT (name)
# endif
-# define VARENTRY(name) void EXFUN ((*name), (void))
-# define EXTENTRY(name) extern void EXFNX (name, (void))
#endif
-/* Structure returned by SCHEME_UTILITYs */
-
-typedef struct
-{
- VARENTRY (interface_dispatch);
- union additional_info
- {
- long code_to_interpreter;
- instruction * entry_point;
- } extra;
-} utility_result;
-
-/* Imports from assembly language */
-
-extern long EXFNX (C_to_interface, (PTR));
-
-EXTENTRY (interface_to_C);
-EXTENTRY (interface_to_scheme);
-
-/* Convenience macros */
-
#define RETURN_TO_C(code) do \
{ \
- (DSU_result -> interface_dispatch) = (REFENTRY (interface_to_C)); \
- ((DSU_result -> extra) . code_to_interpreter) = (code); \
+ (DSU_result->interface_dispatch) = interface_to_C; \
+ ((DSU_result->extra) . code_to_interpreter) = (code); \
return; \
-} while (0)
+} while (false)
#define RETURN_TO_SCHEME(ep) do \
{ \
- (DSU_result -> interface_dispatch) \
- = (REFENTRY (interface_to_scheme)); \
- ((DSU_result -> extra) . entry_point) \
- = ((instruction *) (ep)); \
+ (DSU_result->interface_dispatch) = interface_to_scheme; \
+ ((DSU_result->extra) . entry_point) = (ep); \
return; \
-} while (0)
-
-#define ENTER_SCHEME(ep) return (C_to_interface ((PTR) (ep)))
+} while (false)
-#else /* not CMPINT_USE_STRUCS */
+extern c_func_t ASM_ENTRY_POINT (interface_to_C);
+extern c_func_t ASM_ENTRY_POINT (interface_to_scheme);
-typedef instruction * utility_result;
+#define ENTER_SCHEME(ep) return (C_to_interface (ep))
+extern long ASM_ENTRY_POINT (C_to_interface) (insn_t *);
-/* Imports from assembly language */
-
-extern void EXFNX (C_to_interface, (PTR));
-extern utility_result interface_to_C_hook;
-
-extern long C_return_value;
-long C_return_value;
-
-/* Convenience macros */
+#else /* !CMPINT_USE_STRUCS */
#define RETURN_TO_C(code) do \
{ \
- (*DSU_result) = ((instruction *) interface_to_C_hook); \
+ (*DSU_result) = interface_to_C_hook; \
C_return_value = (code); \
return; \
-} while (0)
+} while (false)
#define RETURN_TO_SCHEME(ep) do \
{ \
- (*DSU_result) = ((instruction *) (ep)); \
+ (*DSU_result) = (ep); \
return; \
-} while (0)
+} while (false)
#define ENTER_SCHEME(ep) do \
{ \
- C_to_interface ((PTR) (ep)); \
+ C_to_interface (ep); \
return (C_return_value); \
-} while (0)
-
-#endif /* not CMPINT_USE_STRUCS */
-\f
-/* utility table entries. */
-
-typedef void EXFUN
- ((* (ASM_ENTRY_POINT (utility_table_entry))),
- (utility_result *, long, long, long, long));
-
-#define RETURN_UNLESS_EXCEPTION(code, entry_point) do \
-{ \
- int return_code = (code); \
- if (return_code == PRIM_DONE) \
- { \
- RETURN_TO_SCHEME (entry_point); \
- } \
- else \
- { \
- RETURN_TO_C (return_code); \
- } \
-} while (0)
-
-#define TAIL_CALL_1(pname, a1) do \
-{ \
- pname (DSU_result, (a1), 0, 0, 0); \
- return; \
-} while (0)
+} while (false)
-#define TAIL_CALL_2(pname, a1, a2) do \
-{ \
- pname (DSU_result, (a1), (a2), 0, 0); \
- return; \
-} while (0)
+extern utility_result_t interface_to_C_hook;
+extern void ASM_ENTRY_POINT (C_to_interface) (insn_t *);
+long C_return_value;
-#define MAKE_CC_BLOCK(block_addr) \
- (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
+#endif /* !CMPINT_USE_STRUCS */
+#endif /* !UTILITY_RESULT_DEFINED */
-/* Imports from the rest of the "microcode" */
-\f
-/* Exports to the rest of the "microcode" */
-
-extern long
- compiler_interface_version,
- compiler_processor_type;
-
-extern SCHEME_OBJECT
- compiler_utilities,
- return_to_interpreter;
-
-extern C_UTILITY long
- EXFUN (make_fake_uuo_link,
- (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
- EXFUN (make_uuo_link,
- (SCHEME_OBJECT value, SCHEME_OBJECT extension,
- SCHEME_OBJECT block, long offset)),
- EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
- EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
- EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
- EXFUN (coerce_to_compiled,
- (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location));
-
-extern C_UTILITY SCHEME_OBJECT
- EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
- EXFUN (extract_variable_cache,
- (SCHEME_OBJECT extension, long offset)),
- EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
- EXFUN (compiled_block_environment, (SCHEME_OBJECT block)),
- EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
- EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)),
- EXFUN (apply_compiled_from_primitive, (int)),
- EXFUN (compiled_with_interrupt_mask, (unsigned long,
- SCHEME_OBJECT,
- unsigned long)),
- EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)),
- * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
-
-extern C_UTILITY Boolean
- EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
-
-extern C_UTILITY void
- EXFUN (compiler_initialize, (long fasl_p)),
- EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
- EXFUN (store_variable_cache,
- (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
- EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block));
-
-extern utility_table_entry utility_table[];
-
-static SCHEME_OBJECT reflect_to_interface;
-
-/* Breakpoint stuff. */
-
-extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
-extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
-extern C_UTILITY Boolean EXFUN (bkpt_p, (PTR));
-extern C_UTILITY SCHEME_OBJECT EXFUN
- (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
-extern C_UTILITY void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
+#define JUMP_TO_CC_ENTRY(entry) ENTER_SCHEME (CC_ENTRY_ADDRESS (entry))
\f
-/* These definitions reflect the indices into the table above. */
-
-#define TRAMPOLINE_K_RETURN 0x0
-#define TRAMPOLINE_K_APPLY 0x1
-#define TRAMPOLINE_K_ARITY 0x2
-#define TRAMPOLINE_K_ENTITY 0x3
-#define TRAMPOLINE_K_INTERPRETED 0x4
-#define TRAMPOLINE_K_LEXPR_PRIMITIVE 0x5
-#define TRAMPOLINE_K_PRIMITIVE 0x6
-#define TRAMPOLINE_K_LOOKUP 0x7
-#define TRAMPOLINE_K_1_0 0x8
-#define TRAMPOLINE_K_2_1 0x9
-#define TRAMPOLINE_K_2_0 0xa
-#define TRAMPOLINE_K_3_2 0xb
-#define TRAMPOLINE_K_3_1 0xc
-#define TRAMPOLINE_K_3_0 0xd
-#define TRAMPOLINE_K_4_3 0xe
-#define TRAMPOLINE_K_4_2 0xf
-#define TRAMPOLINE_K_4_1 0x10
-#define TRAMPOLINE_K_4_0 0x11
-#define TRAMPOLINE_K_REFLECT_TO_INTERFACE 0x3a
-
-#define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED
-
-/* Ways to bypass the interpreter */
-
-#define REFLECT_CODE_INTERNAL_APPLY 0
-#define REFLECT_CODE_RESTORE_INTERRUPT_MASK 1
-#define REFLECT_CODE_STACK_MARKER 2
-#define REFLECT_CODE_CC_BKPT 3
-
-/* Markers for special entry points */
-
-#ifndef FORMAT_BYTE_EXPR
-#define FORMAT_BYTE_EXPR 0xFF
-#endif
-#ifndef FORMAT_BYTE_COMPLR
-#define FORMAT_BYTE_COMPLR 0xFE
-#endif
-#ifndef FORMAT_BYTE_CMPINT
-#define FORMAT_BYTE_CMPINT 0xFD
-#endif
-#ifndef FORMAT_BYTE_DLINK
-#define FORMAT_BYTE_DLINK 0xFC
-#endif
-#ifndef FORMAT_BYTE_RETURN
-#define FORMAT_BYTE_RETURN 0xFB
-#endif
-#ifndef FORMAT_BYTE_CLOSURE
-#define FORMAT_BYTE_CLOSURE 0xFA
+#ifndef COMPILER_REGBLOCK_N_FIXED
+# define COMPILER_REGBLOCK_N_FIXED REGBLOCK_MINIMUM_LENGTH
#endif
-#ifndef FORMAT_BYTE_FRAMEMAX
-#define FORMAT_BYTE_FRAMEMAX 0x7F
+
+#ifndef COMPILER_REGBLOCK_N_TEMPS
+# define COMPILER_REGBLOCK_N_TEMPS 0
#endif
-#ifndef FORMAT_WORD_EXPR
-#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_EXPR))
+#ifndef COMPILER_TEMP_SIZE
+# define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
#endif
-#ifndef FORMAT_WORD_CMPINT
-#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CMPINT))
+
+#ifndef COMPILER_REGBLOCK_EXTRA_SIZE
+# define COMPILER_REGBLOCK_EXTRA_SIZE 0
#endif
-#ifndef FORMAT_WORD_RETURN
-#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_RETURN))
+
+#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
+# include "ERROR: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
#endif
-\f
-/* Utilities for application of compiled procedures. */
-/* NOTE: In this file, the number of arguments (or minimum
- number of arguments, etc.) is always 1 greater than the number of
- arguments (it includes the procedure object).
- */
+#define REGBLOCK_LENGTH \
+ (COMPILER_REGBLOCK_N_FIXED \
+ + (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) \
+ + COMPILER_REGBLOCK_EXTRA_SIZE)
-/* open_gap: Default some optional parameters, and return the location
- of the return address (one past the last actual argument location).
- */
+#ifndef REGBLOCK_ALLOCATED_BY_INTERFACE
+ SCHEME_OBJECT Registers [REGBLOCK_LENGTH];
+#endif
-static SCHEME_OBJECT *
-DEFUN (open_gap,
- (nactuals, delta),
- register long nactuals AND register long delta)
-{
- register SCHEME_OBJECT *gap_location, *source_location;
+#ifndef ASM_RESET_HOOK
+# define ASM_RESET_HOOK() do {} while (false)
+#endif
- /* Need to fill in optionals */
+#define SAVE_LAST_RETURN_CODE(code) do \
+{ \
+ { \
+ long SLRC_offset \
+ = (STACK_LOCATIVE_DIFFERENCE (stack_pointer, last_return_code)); \
+ assert (SLRC_offset > 0); \
+ STACK_PUSH (LONG_TO_FIXNUM (SLRC_offset)); \
+ } \
+ PUSH_RC (code); \
+ COMPILER_NEW_SUBPROBLEM (); \
+} while (false)
- gap_location = STACK_LOC (delta);
- source_location = STACK_LOC (0);
- sp_register = gap_location;
- while ((--nactuals) > 0)
- {
- STACK_LOCATIVE_POP (gap_location) = STACK_LOCATIVE_POP (source_location);
- }
- delta = (- delta);
- while ((--delta) >= 0)
- {
- STACK_LOCATIVE_POP (gap_location) = DEFAULT_OBJECT;
- }
- return (source_location);
-}
+#define RESTORE_LAST_RETURN_CODE() do \
+{ \
+ last_return_code = (STACK_LOC (FIXNUM_TO_ULONG (GET_EXP))); \
+ CHECK_LAST_RETURN_CODE (); \
+ COMPILER_END_SUBPROBLEM (); \
+} while (false)
+
+#define CHECK_LAST_RETURN_CODE() do \
+{ \
+ assert \
+ (RETURN_CODE_P \
+ (STACK_LOCATIVE_REFERENCE (last_return_code, \
+ CONTINUATION_RETURN_CODE))); \
+} while (false)
\f
-/* setup_lexpr_invocation: Setup a rest argument as appropriate. */
+/* Initialization */
-static long
-DEFUN (setup_lexpr_invocation,
- (nactuals, nmax, entry_address),
- register long nactuals AND register long nmax
- AND instruction * entry_address)
+void
+compiler_initialize (bool fasl_p)
{
- register long delta;
+ /* Called when scheme started. */
+ SET_PRIMITIVE (SHARP_F);
+ compiler_processor_type = COMPILER_PROCESSOR_TYPE;
+ compiler_interface_version = COMPILER_INTERFACE_VERSION;
+ if (fasl_p)
+ compiler_reset (make_compiler_utilities ());
+ else
+ {
+ /* Delay until after band-load, when compiler_reset will be invoked. */
+ compiler_utilities = SHARP_F;
+ return_to_interpreter = SHARP_F;
+#ifdef CC_ARCH_INITIALIZE
+ CC_ARCH_INITIALIZE ();
+#endif
+ }
+}
- /* nmax is negative! */
+#define COMPILER_UTILITIES_HEADERS(h1, h2, n) \
+ make_trampoline_headers (2, 2, (h1), (h2), (n))
- delta = (nactuals + nmax);
+static SCHEME_OBJECT
+make_compiler_utilities (void)
+{
+ SCHEME_OBJECT h1;
+ SCHEME_OBJECT h2;
+ unsigned long n_words;
+ SCHEME_OBJECT * block;
- if (delta < 0)
- {
- /* Not enough arguments have been passed to allocate a list.
- The missing optional arguments must be defaulted, and the
- rest parameter needs to be set to the empty list.
- */
+ COMPILER_UTILITIES_HEADERS ((&h1), (&h2), (&n_words));
+ if (GC_NEEDED_P (n_words))
+ {
+ outf_fatal ("Can't allocate compiler_utilities.\n");
+ Microcode_Termination (TERM_NO_SPACE);
+ }
+ h1 = (OBJECT_NEW_TYPE (TC_MANIFEST_VECTOR, h1));
- SCHEME_OBJECT *last_loc;
+ block = Free;
+ Free += n_words;
+ (block[0]) = h1;
+ (block[1]) = h2;
- last_loc = open_gap (nactuals, delta);
- (STACK_LOCATIVE_PUSH (last_loc)) = EMPTY_LIST;
- return (PRIM_DONE);
- }
- else if (delta == 0)
{
- /* The number of arguments passed matches exactly the number of
- formal paramters. The last argument needs to be replaced by
- a list containing it, but there is no need to pop anything
- since the frame has the right size.
- This does not check for gc!
- The procedure should (and currently will) on entry.
- */
-
- register SCHEME_OBJECT temp, *gap_location, *local_free;
-
- local_free = Free;
- Free += 2;
- gap_location = STACK_LOC (nactuals - 2);
- temp = *gap_location;
- *gap_location = (MAKE_POINTER_OBJECT (TC_LIST, local_free));
- *local_free++ = temp;
- *local_free = EMPTY_LIST;
- return (PRIM_DONE);
+ cc_entry_type_t cet;
+ make_cc_entry_type ((&cet), CET_RETURN_TO_INTERPRETER);
+ if ((fill_trampoline (block, 0, (&cet), TRAMPOLINE_K_RETURN_TO_INTERPRETER))
+ ||
+ (fill_trampoline (block, 1, (&cet), TRAMPOLINE_K_REFLECT_TO_INTERFACE)))
+ {
+ outf_fatal ("\nError in make_compiler_utilities\n");
+ Microcode_Termination (TERM_COMPILER_DEATH);
+ /*NOTREACHED*/
+ }
}
- else /* (delta > 0) */
- {
- /* The number of arguments passed is greater than the number of
- formal parameters named by the procedure. Excess arguments
- need to be placed in a list passed at the last parameter
- location. The extra arguments must then be popped from the stack.
- */
- long list_size;
- register SCHEME_OBJECT *gap_location, *source_location;
-\f
- /* Allocate the list, and GC if necessary. */
-
- list_size = (2 * (delta + 1));
- if (GC_Check (list_size))
- {
- Request_GC (list_size);
- STACK_PUSH (ENTRY_TO_OBJECT (entry_address));
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
- return (PRIM_APPLY_INTERRUPT);
- }
- gap_location = &Free[list_size];
- Free = gap_location;
- /* Place the arguments in the list, and link it. */
+ /* These entries are no longer used, but are provided for
+ compatibility with the previous structure. */
+ {
+ SCHEME_OBJECT * store = (trampoline_storage (block));
+ (store[0]) = ((trampoline_entry_addr (block, 0)) - ((insn_t *) block));
+ (store[1]) = ((trampoline_entry_addr (block, 1)) - ((insn_t *) block));
+ }
- source_location = (STACK_LOC (nactuals - 1));
- (*(--gap_location)) = EMPTY_LIST;
+ block = (copy_to_constant_space (block, n_words));
+ return (MAKE_CC_BLOCK (block));
+}
- while ((--delta) >= 0)
+void
+compiler_reset (SCHEME_OBJECT new_block)
+{
+ /* Called after a disk restore */
+ SCHEME_OBJECT h1;
+ SCHEME_OBJECT h2;
+ unsigned long n_words;
+ SCHEME_OBJECT * nbp;
+
+ COMPILER_UTILITIES_HEADERS ((&h1), (&h2), (&n_words));
+ h1 = (OBJECT_NEW_TYPE (TC_MANIFEST_VECTOR, h1));
+ if (! ((CC_BLOCK_P (new_block))
+ && ((MEMORY_REF (new_block, 0)) == h1)
+ && ((MEMORY_REF (new_block, 1)) == h2)))
{
- gap_location -= 2;
- (*(gap_location + 1)) = (STACK_LOCATIVE_PUSH (source_location));
- (*(gap_location)) = (MAKE_POINTER_OBJECT (TC_LIST, (gap_location + 1)));
+ outf_fatal ("\nThe world image being restored is incompatible"
+ " with this microcode.\n");
+ Microcode_Termination (TERM_COMPILER_DEATH);
+ /*NOTREACHED*/
}
- (*(--gap_location)) = (STACK_LOCATIVE_PUSH (source_location));
-
- /* Place the list at the appropriate location in the stack. */
-
- STACK_LOCATIVE_REFERENCE (source_location, 0) =
- (MAKE_POINTER_OBJECT (TC_LIST, (gap_location)));
-
- /* Now move the arguments into their correct location in the stack
- popping any unneeded locations.
- */
+ nbp = (OBJECT_ADDRESS (new_block));
+ compiler_utilities = new_block;
+ return_to_interpreter = (MAKE_CC_ENTRY (trampoline_entry_addr (nbp, 0)));
+ reflect_to_interface = (MAKE_CC_ENTRY (trampoline_entry_addr (nbp, 1)));
+ SET_CLOSURE_FREE (0);
+ SET_CLOSURE_SPACE (0);
+ SET_REFLECTOR (reflect_to_interface);
- gap_location = (STACK_LOC (nactuals - 1));
- STACK_LOCATIVE_INCREMENT (source_location);
+ ASM_RESET_HOOK ();
+}
+\f
+/* Main compiled-code entry points */
- /* Remember that nmax is originally negative! */
+#define DEFINE_SCHEME_ENTRY(pname) long pname (void)
- for (nmax = ((-nmax) - 1); ((--nmax) >= 0); )
- {
- (STACK_LOCATIVE_PUSH (gap_location)) =
- (STACK_LOCATIVE_PUSH (source_location));
- }
- sp_register = gap_location;
- return (PRIM_DONE);
+DEFINE_SCHEME_ENTRY (enter_compiled_expression)
+{
+ SCHEME_OBJECT entry = GET_EXP;
+ {
+ cc_entry_type_t cet;
+ if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (entry))))
+ return (ERR_COMPILED_CODE_ERROR);
+ if (cet.marker != CET_EXPRESSION)
+ {
+ /* evaluate to self */
+ SET_VAL (entry);
+ return (PRIM_DONE);
+ }
}
+ guarantee_cc_return (0);
+ JUMP_TO_CC_ENTRY (entry);
}
-\f
-/* setup_compiled_invocation: Prepare the application frame the way that
- the called procedure expects it (optional arguments and rest argument
- initialized.
- */
-static long
-DEFUN (setup_compiled_invocation,
- (nactuals, compiled_entry_address),
- long nactuals AND instruction * compiled_entry_address)
+DEFINE_SCHEME_ENTRY (apply_compiled_procedure)
{
- long nmin, nmax, delta; /* all +1 */
+ unsigned long n_args = (POP_APPLY_FRAME_HEADER ());
+ SCHEME_OBJECT procedure = (STACK_POP ());
+ long code = (setup_compiled_invocation (procedure, n_args));
+ if (code != PRIM_DONE)
+ return (code);
+ JUMP_TO_CC_ENTRY (procedure);
+}
- nmax = (COMPILED_ENTRY_MAXIMUM_ARITY (compiled_entry_address));
- if (nactuals == nmax)
- {
- /* Either the procedure takes exactly the number of arguments
- given, or it has optional arguments, no rest argument, and
- all the optional arguments have been provided. Thus the
- frame is in the right format and we are done.
- */
- return (PRIM_DONE);
- }
- nmin = (COMPILED_ENTRY_MINIMUM_ARITY (compiled_entry_address));
- if (nmin < 0)
- {
- /* Not a procedure. */
- STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
- return (ERR_INAPPLICABLE_OBJECT);
- }
- if (nactuals < nmin)
- {
- /* Too few arguments. */
- STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
- return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- delta = (nactuals - nmax);
- if (delta <= 0)
- {
- /* The procedure takes optional arguments but no rest argument
- and not all the optional arguments have been provided.
- They must be defaulted.
- */
- ((void) (open_gap (nactuals, delta)));
- return (PRIM_DONE);
- }
- if (nmax > 0)
+DEFINE_SCHEME_ENTRY (return_to_compiled_code)
+{
+ RESTORE_LAST_RETURN_CODE ();
{
- /* Too many arguments */
- STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
- return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ SCHEME_OBJECT cont = (STACK_POP ());
+ {
+ cc_entry_type_t cet;
+ if ((read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (cont))))
+ || (! ((cet.marker == CET_CONTINUATION)
+ || (cet.marker == CET_INTERNAL_CONTINUATION)
+ || (cet.marker == CET_RETURN_TO_INTERPRETER))))
+ {
+ STACK_PUSH (cont);
+ SAVE_CONT ();
+ return (ERR_INAPPLICABLE_OBJECT);
+ }
+ }
+ JUMP_TO_CC_ENTRY (cont);
}
- /* The procedure can take arbitrarily many arguments, ie.
- it is a lexpr.
- */
- return (setup_lexpr_invocation (nactuals, nmax, compiled_entry_address));
}
\f
-/* Main compiled code entry points.
-
- These are the primary entry points that the interpreter
- uses to execute compiled code.
- The other entry points are special purpose return
- points to compiled code invoked after the interpreter has been
- employed to take corrective action (interrupt, error, etc).
- They are coded adjacent to the place where the interpreter
- is invoked.
- */
-
-C_TO_SCHEME long
-DEFUN_VOID (enter_compiled_expression)
-{
- instruction * compiled_entry_address;
-
- compiled_entry_address =
- ((instruction *) (OBJECT_ADDRESS (exp_register)));
- if ((COMPILED_ENTRY_FORMAT_WORD (compiled_entry_address)) !=
- FORMAT_WORD_EXPR)
- {
- /* It self evaluates. */
- val_register = exp_register;
- ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
- }
- ENTER_SCHEME (compiled_entry_address);
+void
+guarantee_cc_return (unsigned long offset)
+{
+ if (CC_ENTRY_P (STACK_REF (offset)))
+ return;
+ assert (RETURN_CODE_P (CONT_RET (offset)));
+ if (CHECK_RETURN_CODE (RC_REENTER_COMPILED_CODE, offset))
+ {
+ unsigned long lrc = (FIXNUM_TO_ULONG (CONT_EXP (offset)));
+ close_stack_gap (offset, CONTINUATION_SIZE);
+ last_return_code = (STACK_LOC (offset + lrc));
+ CHECK_LAST_RETURN_CODE ();
+ COMPILER_END_SUBPROBLEM ();
+ }
+ else
+ {
+ last_return_code = (STACK_LOC (offset));
+ CHECK_LAST_RETURN_CODE ();
+ open_stack_gap (offset, 1);
+ (STACK_REF (offset)) = return_to_interpreter;
+ }
}
-C_TO_SCHEME long
-DEFUN_VOID (apply_compiled_procedure)
+void
+guarantee_interp_return (void)
{
- SCHEME_OBJECT nactuals, procedure;
- instruction * procedure_entry;
- long result;
-
- nactuals = (STACK_POP ());
- procedure = (STACK_POP ());
- procedure_entry = ((instruction *) (OBJECT_ADDRESS (procedure)));
- result = setup_compiled_invocation ((OBJECT_DATUM (nactuals)),
- procedure_entry);
- if (result == PRIM_DONE)
- /* Go into compiled code. */
- ENTER_SCHEME (procedure_entry);
+ unsigned long offset = (1 + (APPLY_FRAME_SIZE ()));
+ if (RETURN_CODE_P (CONT_RET (offset)))
+ return;
+ assert (CC_ENTRY_P (STACK_REF (offset)));
+ if ((STACK_REF (offset)) == return_to_interpreter)
+ {
+ assert (RETURN_CODE_P (CONT_RET (offset + 1)));
+ close_stack_gap (offset, 1);
+ COMPILER_NEW_REDUCTION ();
+ }
else
- return (result);
+ {
+ open_stack_gap (offset, CONTINUATION_SIZE);
+ {
+ SCHEME_OBJECT * sp = stack_pointer;
+ stack_pointer = (STACK_LOC (offset + CONTINUATION_SIZE));
+ SAVE_LAST_RETURN_CODE (RC_REENTER_COMPILED_CODE);
+ stack_pointer = sp;
+ }
+ }
}
-/* Note that this does not check that compiled_entry_address
- is a valid return address. -- Should it?
- */
+static void
+open_stack_gap (unsigned long offset, unsigned long n_words)
+{
+ SCHEME_OBJECT * scan_from = (STACK_LOC (0));
+ SCHEME_OBJECT * scan_end = (STACK_LOC (offset));
+ SCHEME_OBJECT * scan_to = (STACK_LOC (-n_words));
+ while (scan_from != scan_end)
+ (STACK_LOCATIVE_POP (scan_to)) = (STACK_LOCATIVE_POP (scan_from));
+ stack_pointer = (STACK_LOC (-n_words));
+}
-C_TO_SCHEME long
-DEFUN_VOID (return_to_compiled_code)
+static void
+close_stack_gap (unsigned long offset, unsigned long n_words)
{
- instruction *compiled_entry_address;
+ SCHEME_OBJECT * scan_from = (STACK_LOC (offset));
+ SCHEME_OBJECT * scan_end = (STACK_LOC (0));
+ SCHEME_OBJECT * scan_to = (STACK_LOC (offset + n_words));
+ while (scan_from != scan_end)
+ (STACK_LOCATIVE_PUSH (scan_to)) = (STACK_LOCATIVE_PUSH (scan_from));
+ stack_pointer = (STACK_LOC (n_words));
+}
- compiled_entry_address =
- ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
- ENTER_SCHEME (compiled_entry_address);
+static void
+recover_from_apply_error (SCHEME_OBJECT procedure, unsigned long n_args)
+{
+ STACK_PUSH (procedure);
+ PUSH_APPLY_FRAME_HEADER (n_args);
+ guarantee_interp_return ();
}
\f
-C_UTILITY SCHEME_OBJECT
-DEFUN (apply_compiled_from_primitive, (arity), int arity)
+void
+compiled_with_interrupt_mask (unsigned long old_mask,
+ SCHEME_OBJECT receiver,
+ unsigned long new_mask)
{
- SCHEME_OBJECT frame_size, procedure;
- long result;
-
- frame_size = (STACK_POP ());
- procedure = (STACK_POP ());
-
- switch (OBJECT_TYPE (procedure))
+ STACK_PUSH (ULONG_TO_FIXNUM (old_mask));
+ PUSH_REFLECTION (REFLECT_CODE_RESTORE_INTERRUPT_MASK);
+ STACK_PUSH (ULONG_TO_FIXNUM (new_mask));
{
- case TC_ENTITY:
- {
- SCHEME_OBJECT data, operator;
- unsigned long nactuals = (OBJECT_DATUM (frame_size));
-
- data = (MEMORY_REF (procedure, ENTITY_DATA));
- if ((VECTOR_P (data))
- && (nactuals < (VECTOR_LENGTH (data)))
- && (COMPILED_CODE_ADDRESS_P (VECTOR_REF (data, nactuals)))
- && ((VECTOR_REF (data, 0))
- == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
- procedure = (VECTOR_REF (data, nactuals));
- else
+ long code = (setup_compiled_invocation (receiver, 1));
+ if (code != PRIM_DONE)
{
- operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
- if (!COMPILED_CODE_ADDRESS_P (operator))
- goto defer_application;
- STACK_PUSH (procedure);
- frame_size += 1;
- procedure = operator;
+ PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
+ PRIMITIVE_ABORT (code);
}
- /* fall through */
- }
+ }
+ /* Pun: receiver is being invoked as a return address. */
+ STACK_PUSH (receiver);
+}
- case TC_COMPILED_ENTRY:
- {
- result = setup_compiled_invocation ((OBJECT_DATUM (frame_size)),
- ((instruction *)
- (OBJECT_ADDRESS (procedure))));
- if (result == PRIM_DONE)
+void
+compiled_with_stack_marker (SCHEME_OBJECT thunk)
+{
+ PUSH_REFLECTION (REFLECT_CODE_STACK_MARKER);
+ {
+ long code = (setup_compiled_invocation (thunk, 0));
+ switch (code)
{
- STACK_PUSH (procedure);
- sp_register = (STACK_LOC (- arity));
- return (SHARP_F);
- }
- else
+ case PRIM_DONE:
+ /* Pun: thunk is being invoked as a return address. */
+ STACK_PUSH (thunk);
break;
- }
- case TC_PRIMITIVE:
- /* For now, fall through */
+ case PRIM_APPLY_INTERRUPT:
+ PRIMITIVE_ABORT (code);
+ break;
- default:
-defer_application:
- STACK_PUSH (procedure);
- STACK_PUSH (frame_size);
- break;
+ default:
+ PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
+ PRIMITIVE_ABORT (code);
+ break;
+ }
}
-
- STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
- STACK_PUSH (reflect_to_interface);
- sp_register = (STACK_LOC (- arity));
- return (SHARP_F);
}
\f
-C_UTILITY SCHEME_OBJECT
-DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask),
- unsigned long old_mask
- AND SCHEME_OBJECT receiver
- AND unsigned long new_mask)
-{
- long result;
+/* SCHEME_UTILITY procedures
- STACK_PUSH (LONG_TO_FIXNUM (old_mask));
- STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_RESTORE_INTERRUPT_MASK);
- STACK_PUSH (reflect_to_interface);
+ Here's a mass of procedures that are called (via
+ 'scheme_to_interface', an assembly language hook) by compiled code
+ to do various jobs. */
- STACK_PUSH (LONG_TO_FIXNUM (new_mask));
- result = (setup_compiled_invocation (2,
- ((instruction *)
- (OBJECT_ADDRESS (receiver)))));
- STACK_PUSH (receiver);
+#define DEFINE_SCHEME_UTILITY_0(pname) \
+void \
+ASM_ENTRY_POINT (pname) \
+ (utility_result_t * DSU_result, \
+ unsigned long ignore1, \
+ unsigned long ignore2, \
+ unsigned long ignore3, \
+ unsigned long ignore4)
- if (result != PRIM_DONE)
- {
- STACK_PUSH (STACK_FRAME_HEADER + 1);
- STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
- STACK_PUSH (reflect_to_interface);
- }
+#define DEFINE_SCHEME_UTILITY_1(pname, av1) \
+void \
+ASM_ENTRY_POINT (pname) \
+ (utility_result_t * DSU_result, \
+ unsigned long av1##_raw, \
+ unsigned long ignore2, \
+ unsigned long ignore3, \
+ unsigned long ignore4)
- sp_register = (STACK_LOC (- 2));
- return (SHARP_F);
-}
+#define DEFINE_SCHEME_UTILITY_2(pname, av1, av2) \
+void \
+ASM_ENTRY_POINT (pname) \
+ (utility_result_t * DSU_result, \
+ unsigned long av1##_raw, \
+ unsigned long av2##_raw, \
+ unsigned long ignore3, \
+ unsigned long ignore4)
-C_UTILITY SCHEME_OBJECT
-DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk)
-{
- long result;
+#define DEFINE_SCHEME_UTILITY_3(pname, av1, av2, av3) \
+void \
+ASM_ENTRY_POINT (pname) \
+ (utility_result_t * DSU_result, \
+ unsigned long av1##_raw, \
+ unsigned long av2##_raw, \
+ unsigned long av3##_raw, \
+ unsigned long ignore4)
- STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_STACK_MARKER);
- STACK_PUSH (reflect_to_interface);
+#define DEFINE_SCHEME_UTILITY_4(pname, av1, av2, av3, av4) \
+void \
+ASM_ENTRY_POINT (pname) \
+ (utility_result_t * DSU_result, \
+ unsigned long av1##_raw, \
+ unsigned long av2##_raw, \
+ unsigned long av3##_raw, \
+ unsigned long av4##_raw)
- result = (setup_compiled_invocation (1,
- ((instruction *)
- (OBJECT_ADDRESS (thunk)))));
- STACK_PUSH (thunk);
+#define DECLARE_UTILITY_ARG(at1, av1) at1 av1 = ((at1) av1##_raw)
- if (result != PRIM_DONE)
- {
- STACK_PUSH (STACK_FRAME_HEADER);
- STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
- STACK_PUSH (reflect_to_interface);
- }
+#define INVOKE_RETURN_ADDRESS() do \
+{ \
+ if (Free >= GET_MEMTOP) \
+ { \
+ compiler_interrupt_common (DSU_result, 0, GET_VAL); \
+ return; \
+ } \
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (STACK_POP ())); \
+} while (false)
- sp_register = (STACK_LOC (- 3));
- return (SHARP_F);
-}
+#define TAIL_CALL_1(pname, a1) do \
+{ \
+ pname (DSU_result, ((unsigned long) (a1)), 0, 0, 0); \
+ return; \
+} while (false)
+
+#define TAIL_CALL_2(pname, a1, a2) do \
+{ \
+ pname (DSU_result, \
+ ((unsigned long) (a1)), \
+ ((unsigned long) (a2)), \
+ 0, \
+ 0); \
+ return; \
+} while (false)
\f
-/*
- SCHEME_UTILITYs
+DEFINE_SCHEME_UTILITY_2 (comutil_apply, procedure, frame_size)
+{
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT, procedure);
+ DECLARE_UTILITY_ARG (unsigned long, frame_size);
- Here's a mass of procedures that are called (via scheme_to_interface,
- an assembly language hook) by compiled code to do various jobs.
- */
+ while (1)
+ switch (OBJECT_TYPE (procedure))
+ {
+ case TC_ENTITY:
+ {
+ SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA));
+ if ((VECTOR_P (data))
+ && ((VECTOR_LENGTH (data)) > frame_size)
+ && ((VECTOR_REF (data, 0))
+ == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG)))
+ && ((VECTOR_REF (data, frame_size)) != SHARP_F))
+ {
+ procedure = (VECTOR_REF (data, frame_size));
+ break;
+ }
+ }
+ {
+ SCHEME_OBJECT operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
+ if (!CC_ENTRY_P (operator))
+ goto handle_in_interpreter;
+ STACK_PUSH (procedure);
+ procedure = operator;
+ frame_size += 1;
+ }
+ /* fall through */
-/*
- This is how compiled Scheme code normally returns back to the
- Scheme interpreter.
- It is invoked by a trampoline, which passes the address of the
- trampoline storage block (empty) to it.
- */
+ case TC_COMPILED_ENTRY:
+ {
+ long code
+ = (setup_compiled_invocation (procedure, (frame_size - 1)));
+ if (code != PRIM_DONE)
+ RETURN_TO_C (code);
+ }
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
-DEFINE_SCHEME_UTILITY_1 (comutil_return_to_interpreter, tramp_data_raw)
-{
- RETURN_TO_C (PRIM_DONE);
+ case TC_PRIMITIVE:
+ if (IMPLEMENTED_PRIMITIVE_P (procedure))
+ {
+ int arity = (PRIMITIVE_ARITY (procedure));
+ if (arity == (frame_size - 1))
+ TAIL_CALL_1 (comutil_primitive_apply, procedure);
+ else if (arity == LEXPR)
+ {
+ SET_LEXPR_ACTUALS (frame_size - 1);
+ TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure);
+ }
+ else
+ {
+ recover_from_apply_error (procedure, (frame_size - 1));
+ RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ }
+ /* fall through */
+
+ handle_in_interpreter:
+ default:
+ {
+ recover_from_apply_error (procedure, (frame_size - 1));
+ RETURN_TO_C (PRIM_APPLY);
+ }
+ }
}
\f
-static void EXFUN
- (compiler_interrupt_common, (utility_result *, SCHEME_ADDR, SCHEME_OBJECT));
-
-#define COMPILER_INTERRUPT_COMMON(a1, a2) do \
-{ \
- compiler_interrupt_common (DSU_result, (a1), (a2)); \
- return; \
-} while (0)
-
-#if (COMPILER_PROCESSOR_TYPE != COMPILER_IA32_TYPE)
+/* comutil_lexpr_apply is invoked to reformat the frame when compiled
+ code calls a known lexpr. The actual arguments are on the stack,
+ and it is given the number of arguments and the real entry point of
+ the procedure. */
-#define INVOKE_RETURN_ADDRESS() \
- RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()))
+DEFINE_SCHEME_UTILITY_2 (comutil_lexpr_apply, address, n_args)
+{
+ DECLARE_UTILITY_ARG (insn_t *, address);
+ DECLARE_UTILITY_ARG (unsigned long, n_args);
+ cc_entry_type_t cet;
-#else /* COMPILER_IA32_TYPE */
+ if (! ((!read_cc_entry_type ((&cet), address))
+ && ((cet.marker) == CET_PROCEDURE)
+ && (cet.args.for_procedure.rest_p)
+ && (n_args >= (cet.args.for_procedure.n_required))))
+ {
+ recover_from_apply_error ((MAKE_CC_ENTRY (address)), n_args);
+ RETURN_TO_C (ERR_COMPILED_CODE_ERROR);
+ }
+ {
+ long code
+ = (setup_lexpr_invocation ((MAKE_CC_ENTRY (address)),
+ n_args,
+ ((cet.args.for_procedure.n_required)
+ + (cet.args.for_procedure.n_optional))));
+ if (code != PRIM_DONE)
+ RETURN_TO_C (code);
+ }
+ RETURN_TO_SCHEME (address);
+}
-#define INVOKE_RETURN_ADDRESS() do \
-{ \
- if (((long) (ADDR_TO_SCHEME_ADDR (Free))) \
- >= ((long) (Registers[REGBLOCK_MEMTOP]))) \
- COMPILER_INTERRUPT_COMMON (0, val_register); \
- else \
- RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \
-} while (0)
-
-#endif /* COMPILER_IA32_TYPE */
-
-/*
- comutil_primitive_apply is used to invoked a C primitive.
- Note that some C primitives (the so called interpreter hooks)
- will not return normally, but will "longjmp" to the interpreter
- instead. Thus the assembly language invoking this should have
- set up the appropriate locations in case this happens.
- After invoking the primitive, it pops the arguments off the
- Scheme stack, and proceeds by invoking the continuation on top
- of the stack.
- */
+/* comutil_primitive_apply is used to invoked a C primitive. Note
+ that some C primitives (the so called interpreter hooks) will not
+ return normally, but will "longjmp" to the interpreter instead.
+ Thus the assembly language invoking this should have set up the
+ appropriate locations in case this happens. After invoking the
+ primitive, it pops the arguments off the Scheme stack, and proceeds
+ by invoking the continuation on top of the stack. */
DEFINE_SCHEME_UTILITY_1 (comutil_primitive_apply, primitive)
-{
- PRIMITIVE_APPLY (val_register, primitive);
+{
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive);
+ PRIMITIVE_APPLY (primitive);
POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
INVOKE_RETURN_ADDRESS ();
}
-/*
- comutil_primitive_lexpr_apply is like comutil_primitive_apply
- except that it is used to invoke primitives that take
- an arbitrary number of arguments.
- The number of arguments is in the REGBLOCK_LEXPR_ACTUALS slot
- of the register block.
- */
+/* comutil_primitive_lexpr_apply is like comutil_primitive_apply
+ except that it is used to invoke primitives that take an arbitrary
+ number of arguments. The number of arguments is in the
+ REGBLOCK_LEXPR_ACTUALS slot of the register block. */
DEFINE_SCHEME_UTILITY_1 (comutil_primitive_lexpr_apply, primitive)
{
- PRIMITIVE_APPLY (val_register, primitive);
- POP_PRIMITIVE_FRAME (((long) (Registers[REGBLOCK_LEXPR_ACTUALS])));
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive);
+ PRIMITIVE_APPLY (primitive);
+ POP_PRIMITIVE_FRAME (GET_LEXPR_ACTUALS);
INVOKE_RETURN_ADDRESS ();
}
+
+/* comutil_error is used by compiled code to signal an error. It
+ expects the arguments to the error procedure to be pushed on the
+ stack, and is passed the number of arguments (+ 1). */
+
+DEFINE_SCHEME_UTILITY_1 (comutil_error, frame_size)
+{
+ DECLARE_UTILITY_ARG (unsigned long, frame_size);
+ TAIL_CALL_2 (comutil_apply,
+ (VECTOR_REF (fixed_objects, CC_ERROR_PROCEDURE)),
+ frame_size);
+}
\f
-/*
- comutil_apply is used by compiled code to invoke an unknown
- procedure. It dispatches on its type to the correct place. It
- expects the procedure to invoke, and the number of arguments (+ 1).
- */
+/* comutil_link is used to initialize all the variable cache slots for
+ a compiled code block. It is called at load time, by the compiled
+ code itself. It assumes that the return address has been saved on
+ the stack. If an error occurs during linking, or an interrupt must
+ be processed (because of the need to GC, etc.), it backs out and
+ sets up a return code that will invoke comp_link_caches_restart
+ when the error/interrupt processing is done. */
-DEFINE_SCHEME_UTILITY_2 (comutil_apply, procedure, nactuals)
+DEFINE_SCHEME_UTILITY_4 (comutil_link,
+ return_addr,
+ block_addr,
+ constant_addr,
+ n_sections)
{
- SCHEME_OBJECT orig_proc = procedure;
+ DECLARE_UTILITY_ARG (insn_t *, return_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, block_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, constant_addr);
+ DECLARE_UTILITY_ARG (unsigned long, n_sections);
+ link_cc_state_t s;
-loop:
- switch (OBJECT_TYPE (procedure))
- {
- case TC_COMPILED_ENTRY:
- callee_is_compiled:
- {
- instruction * entry_point;
+ (s.return_address) = return_addr;
+ (s.block_address) = block_addr;
+ (s.scan) = constant_addr;
+ (s.n_sections) = n_sections;
+ (s.n_linked_sections) = 0;
- entry_point = ((instruction *) (OBJECT_ADDRESS (procedure)));
- RETURN_UNLESS_EXCEPTION
- ((setup_compiled_invocation (nactuals, entry_point)),
- entry_point);
- }
+ start_linking_cc_block ();
+ {
+ long result = (link_remaining_sections (&s));
+ end_linking_cc_block (&s);
+ if (result != PRIM_DONE)
+ RETURN_TO_C (result);
+ }
+ RETURN_TO_SCHEME (s.return_address);
+}
- case TC_ENTITY:
- {
- SCHEME_OBJECT data, operator;
-
- data = (MEMORY_REF (procedure, ENTITY_DATA));
- if ((VECTOR_P (data))
- && (nactuals < (VECTOR_LENGTH (data)))
- && ((VECTOR_REF (data, nactuals)) != SHARP_F)
- && ((VECTOR_REF (data, 0))
- == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
- {
- /* No loops allowed! */
- SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals));
+/* comp_link_caches_restart is used to continue the linking process
+ started by comutil_link after the garbage collector has run. */
- if ((procedure == orig_proc) && (nproc != procedure))
- {
- procedure = nproc;
- goto loop;
- }
- else
- procedure = orig_proc;
- }
+DEFINE_SCHEME_ENTRY (comp_link_caches_restart)
+{
+ link_cc_state_t s;
+ long result;
- operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
- if (!(COMPILED_CODE_ADDRESS_P (operator)))
- goto callee_is_interpreted;
+ restore_link_cc_state (&s);
+ SET_ENV (cc_block_environment (MAKE_CC_BLOCK (s.block_address)));
- STACK_PUSH (procedure); /* The entity itself */
- procedure = operator;
- nactuals += 1;
- goto callee_is_compiled;
- }
- case TC_PRIMITIVE:
- {
- /* This code depends on the fact that unimplemented
- primitives map into a "fake" primitive which accepts
- any number of arguments, thus the arity test will
- fail for unimplemented primitives.
- */
+ start_linking_cc_block ();
- long arity;
+ result = (link_section (&s));
+ if (result == PRIM_DONE)
+ result = (link_remaining_sections (&s));
+
+ end_linking_cc_block (&s);
+ if (result != PRIM_DONE)
+ return (result);
- arity = (PRIMITIVE_ARITY (procedure));
- if (arity == ((long) (nactuals - 1)))
- TAIL_CALL_1 (comutil_primitive_apply, procedure);
+ ENTER_SCHEME (s.return_address);
+}
- if (arity != LEXPR)
+static long
+link_remaining_sections (link_cc_state_t * s)
+{
+ while ((s->n_linked_sections) < (s->n_sections))
+ {
+ start_linking_section (s);
{
- /* Wrong number of arguments. */
- STACK_PUSH (procedure);
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
- RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ long result = (link_section (s));
+ if (result != PRIM_DONE)
+ return (result);
}
- if (!(IMPLEMENTED_PRIMITIVE_P (procedure)))
- /* Let the interpreter handle it. */
- goto callee_is_interpreted;
-
- /* "Lexpr" primitive. */
- (Registers[REGBLOCK_LEXPR_ACTUALS]) = ((SCHEME_OBJECT) (nactuals - 1));
- TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure);
- }
-
- callee_is_interpreted:
- default:
- {
- STACK_PUSH (procedure);
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
- RETURN_TO_C (PRIM_APPLY);
}
- }
+ return (PRIM_DONE);
}
\f
-/*
- comutil_error is used by compiled code to signal an error. It
- expects the arguments to the error procedure to be pushed on the
- stack, and is passed the number of arguments (+ 1).
-*/
-
-DEFINE_SCHEME_UTILITY_1 (comutil_error, nactuals)
+static void
+start_linking_cc_block (void)
{
- TAIL_CALL_2
- (comutil_apply, (Get_Fixed_Obj_Slot (Compiler_Err_Procedure)), nactuals);
+ bool * ap = (dstack_alloc (sizeof (bool)));
+ (*ap) = linking_cc_block_p;
+ transaction_begin ();
+ transaction_record_action (tat_always, abort_linking_cc_block, ap);
+ linking_cc_block_p = 1;
}
-/*
- comutil_lexpr_apply is invoked to reformat the frame when compiled
- code calls a known lexpr. The actual arguments are on the stack,
- and it is given the number of arguments (WITHOUT counting the entry
- point being invoked), and the real entry point of the procedure.
-
- Important: This code assumes that it is always invoked with a valid
- number of arguments (the compiler checked it), and will not check.
- */
-
-DEFINE_SCHEME_UTILITY_2 (comutil_lexpr_apply, entry_address_raw, nactuals)
+static void
+end_linking_cc_block (link_cc_state_t * s)
{
- instruction * entry_address
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_address_raw)));
-
- RETURN_UNLESS_EXCEPTION
- ((setup_lexpr_invocation
- ((nactuals + 1),
- (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)),
- entry_address)),
- entry_address);
+ transaction_commit ();
+ update_cache_after_link (s);
}
-\f
-static long
-DEFUN (compiler_link_closure_pattern, (distance, block, offset),
- SCHEME_OBJECT distance AND
- SCHEME_OBJECT block AND
- unsigned long offset)
-{
- long objdist = (FIXNUM_TO_LONG (distance));
- long nmv_length = (OBJECT_DATUM (MEMORY_REF (block, 1)));
- SCHEME_OBJECT * location = (MEMORY_LOC (block, offset));
- SCHEME_OBJECT * closptr = (location - objdist);
- SCHEME_OBJECT * end_closptr = (MEMORY_LOC (block, (2 + nmv_length)));
- SCHEME_OBJECT entry_offset, * area_end;
- char * word_ptr;
- long count;
-
- nmv_length -= (end_closptr - closptr);
- while (closptr < end_closptr)
- {
- while ((* closptr) == ((SCHEME_OBJECT) 0))
- closptr ++;
- closptr ++;
- count = (MANIFEST_CLOSURE_COUNT (closptr));
- word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (closptr));
- area_end = ((MANIFEST_CLOSURE_END (closptr, count)) - 1);
- while ((--count) >= 0)
- {
- closptr = ((SCHEME_OBJECT *) word_ptr);
- word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
- EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr);
- entry_offset = ((SCHEME_OBJECT)
- (((long) closptr) - ((long) entry_offset)));
- STORE_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr);
- }
- closptr = &area_end[1];
- }
- MEMORY_SET (block, 1, (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length)));
- return (PRIM_DONE);
+static void
+abort_linking_cc_block (void * ap)
+{
+ linking_cc_block_p = (* ((bool *) (ap)));
}
-static Boolean linking_cc_block_p = false;
-
static void
-DEFUN (abort_link_cc_block, (ap), PTR ap)
+update_cache_after_link (link_cc_state_t * s)
{
- linking_cc_block_p = (* ((Boolean *) (ap)));
- return;
+#if defined(FLUSH_I_CACHE_REGION) || defined(PUSH_D_CACHE_REGION)
+ SCHEME_OBJECT * addr = (s->block_address);
+ if ((cc_entry_address_to_block_address (s->return_address)) == addr)
+#ifdef FLUSH_I_CACHE_REGION
+ FLUSH_I_CACHE_REGION (addr, (CC_BLOCK_ADDR_LENGTH (addr)));
+#else
+ ;
+#endif
+ else
+#ifdef PUSH_D_CACHE_REGION
+ PUSH_D_CACHE_REGION (addr, (CC_BLOCK_ADDR_LENGTH (addr)));
+#else
+ ;
+#endif
+#endif
}
-
-/* Core of comutil_link and comp_link_caches_restart. */
-
-static long
-DEFUN (link_cc_block,
- (block_address, offset, last_header_offset,
- sections, original_count, ret_add),
- SCHEME_OBJECT * block_address AND
- unsigned long offset AND
- unsigned long last_header_offset AND
- long sections AND
- long original_count AND
- instruction * ret_add)
-{
- Boolean execute_p = false;
- register long entry_size, count;
- SCHEME_OBJECT block;
- SCHEME_OBJECT header;
- long result, kind, total_count;
- long EXFUN ((*cache_handler), (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long));
-
- transaction_begin ();
- {
- Boolean * ap = (dstack_alloc (sizeof (Boolean)));
- *ap = linking_cc_block_p;
- transaction_record_action (tat_abort, abort_link_cc_block, ap);
- }
- linking_cc_block_p = true;
\f
- result = PRIM_DONE;
- block = (MAKE_CC_BLOCK (block_address));
-
- while ((--sections) >= 0)
+static void
+start_linking_section (link_cc_state_t * s)
+{
+ (s->scan0) = (s->scan);
+ (s->n_linked_entries) = 0;
{
- SCHEME_OBJECT * scan = &(block_address[last_header_offset]);
- header = (*scan);
+ SCHEME_OBJECT header = (*(s->scan)++);
+ (s->type) = (linkage_section_type (header));
+ (s->n_entries) = (linkage_section_count (header));
+ }
+}
- kind = (READ_LINKAGE_KIND (header));
- switch (kind)
+static long
+link_section (link_cc_state_t * s)
+{
+ SCHEME_OBJECT * scan1 = ((s->scan0) + 1);
+ SCHEME_OBJECT * scan = (s->scan);
+ SCHEME_OBJECT * block_address = (s->block_address);
+ unsigned long n_linked = (s->n_linked_entries);
+ unsigned long n_entries = (s->n_entries);
+ cache_handler_t * handler;
+ bool execute_p;
+ unsigned long entry_size;
+ long result = PRIM_DONE;
+ DECLARE_RELOCATION_REFERENCE (ref);
+
+ if (!link_section_handler ((s->type), (&handler), (&execute_p)))
{
- case OPERATOR_LINKAGE_KIND:
- cache_handler = compiler_cache_operator;
-
- handle_operator:
- execute_p = true;
- entry_size = EXECUTE_CACHE_ENTRY_SIZE;
- START_OPERATOR_RELOCATION (scan);
- count = (READ_OPERATOR_LINKAGE_COUNT (header));
- break;
-
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- cache_handler = compiler_cache_global_operator;
- goto handle_operator;
-
- case ASSIGNMENT_LINKAGE_KIND:
- cache_handler = compiler_cache_assignment;
- goto handle_reference;
-
- case REFERENCE_LINKAGE_KIND:
- cache_handler = compiler_cache_lookup;
- handle_reference:
- execute_p = false;
- entry_size = 1;
- count = (READ_CACHE_LINKAGE_COUNT (header));
- break;
-
- case CLOSURE_PATTERN_LINKAGE_KIND:
- cache_handler = compiler_link_closure_pattern;
- /* Not really a reference, but the same format. */
- goto handle_reference;
-
- default:
- offset += 1;
- total_count = (READ_CACHE_LINKAGE_COUNT (header));
- count = (total_count - 1);
- result = ERR_COMPILED_CODE_ERROR;
- goto back_out;
+ result = ERR_COMPILED_CODE_ERROR;
+ goto done;
}
- /* This accomodates the re-entry case after a GC.
- It undoes the effects of the "smash header" code below.
- */
-
- if ((OBJECT_TYPE (header)) == TC_LINKAGE_SECTION)
+ if (execute_p)
{
- count = (original_count - count);
- total_count = original_count;
- }
- else
- {
- total_count = count;
- if (execute_p)
- offset += (FIRST_OPERATOR_LINKAGE_OFFSET - 1);
- }
-\f
- block_address[last_header_offset] =
- (MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
- for (offset += 1; ((--count) >= 0); offset += entry_size)
- {
- SCHEME_OBJECT info; /* A symbol or a fixnum */
-
- if (! execute_p)
- info = (block_address[offset]);
+ /* Hair: START_OPERATOR_RELOCATION requires scan to be pointing
+ to the first word after the header. Also, it might move scan
+ forward. If we are just starting the link, just use scan as
+ the argument and let it be changed. If we are restarting, we
+ need to use use a temporary variable that points to the right
+ place. */
+ if (n_linked == 0)
+ START_OPERATOR_RELOCATION (scan, ref);
else
- EXTRACT_EXECUTE_CACHE_SYMBOL (info, &(block_address[offset]));
+ START_OPERATOR_RELOCATION (scan1, ref);
+ entry_size = UUO_LINK_SIZE;
+ }
+ else
+ entry_size = 1;
- result = ((*cache_handler) (info, block, offset));
+ while (n_linked < n_entries)
+ {
+ result = ((*handler) ((execute_p
+ ? (read_uuo_symbol (scan))
+ : (*scan)),
+ (MAKE_CC_BLOCK (block_address)),
+ (scan - block_address)));
if (result != PRIM_DONE)
- {
- /* Save enough state to continue.
- Note that offset is decremented to compensate for it being
- incremented by the for loop header.
- Similary sections and count are incremented to compensate
- for loop headers pre-decrementing.
- count is saved although it's not needed for re-entry to
- match the assembly language versions.
- */
-
- back_out:
- if (execute_p)
- END_OPERATOR_RELOCATION (&(block_address[offset]));
- STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (sections + 1));
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (last_header_offset));
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (offset - 1));
- STACK_PUSH (block);
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (count + 1));
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (total_count));
-
- exp_register = SHARP_F;
- Store_Return (RC_COMP_LINK_CACHES_RESTART);
- Save_Cont ();
-
- /* Smash header for the garbage collector.
- It is smashed back on return. See the comment above.
- */
-
- block_address[last_header_offset] =
- (MAKE_LINKAGE_SECTION_HEADER (kind, (total_count - (count + 1))));
- goto exit_proc;
- }
+ break;
+ scan += entry_size;
+ n_linked += 1;
}
- if (execute_p)
- END_OPERATOR_RELOCATION (&(block_address[offset - 1]));
- last_header_offset = offset;
- }
-exit_proc:
- /* Rather than commit, since we want to undo */
- transaction_abort ();
-#if defined(FLUSH_I_CACHE_REGION) || defined(PUSH_D_CACHE_REGION)
- {
- SCHEME_OBJECT * ret_add_block;
- unsigned long block_len = (((unsigned long) (* block_address)) + 1);
-
- Get_Compiled_Block (ret_add_block, ((SCHEME_OBJECT *) ret_add));
- if (ret_add_block == block_address)
- {
-#ifdef FLUSH_I_CACHE_REGION
- FLUSH_I_CACHE_REGION (block_address, block_len);
-#endif
- }
- else
- {
-#ifdef PUSH_D_CACHE_REGION
- PUSH_D_CACHE_REGION (block_address, block_len);
-#endif
- }
- }
-#endif
+ done:
+ /* If we failed on the first entry, back scan up to where it was
+ before START_OPERATOR_RELOCATION possibly changed it. */
+ (s->scan) = ((n_linked == 0) ? scan1 : scan);
+ (s->n_linked_entries) = n_linked;
+ (* (s->scan0)) = (make_linkage_section_marker ((s->type), n_linked));
+ if (result == PRIM_DONE)
+ (s->n_linked_sections) += 1;
+ else
+ back_out_of_link_section (s);
return (result);
}
\f
-/*
- comutil_link is used to initialize all the variable cache slots for
- a compiled code block. It is called at load time, by the compiled
- code itself. It assumes that the return address has been saved on
- the stack.
- If an error occurs during linking, or an interrupt must be processed
- (because of the need to GC, etc.), it backs out and sets up a return
- code that will invoke comp_link_caches_restart when the error/interrupt
- processing is done.
-*/
-
-DEFINE_SCHEME_UTILITY_4 (comutil_link, ret_add_raw, block_address_raw,
- constant_address_raw, sections)
+static bool
+link_section_handler (linkage_section_type_t type,
+ cache_handler_t ** handler_r,
+ bool * execute_p_r)
{
- instruction * ret_add
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw)));
- SCHEME_OBJECT * block_address
- = (SCHEME_ADDR_TO_ADDR (block_address_raw));
- SCHEME_OBJECT * constant_address
- = (SCHEME_ADDR_TO_ADDR (constant_address_raw));
- unsigned long offset;
-
-#ifdef AUTOCLOBBER_BUG
- block_address[OBJECT_DATUM (* block_address)] = env_register;
-#endif
+ switch (type)
+ {
+ case LINKAGE_SECTION_TYPE_OPERATOR:
+ (*handler_r) = compiler_cache_operator;
+ (*execute_p_r) = true;
+ return (true);
+
+ case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
+ (*handler_r) = compiler_cache_global_operator;
+ (*execute_p_r) = true;
+ return (true);
+
+ case LINKAGE_SECTION_TYPE_REFERENCE:
+ (*handler_r) = compiler_cache_lookup;
+ (*execute_p_r) = false;
+ return (true);
+
+ case LINKAGE_SECTION_TYPE_ASSIGNMENT:
+ (*handler_r) = compiler_cache_assignment;
+ (*execute_p_r) = false;
+ return (true);
- offset = (constant_address - block_address);
-
- RETURN_UNLESS_EXCEPTION
- ((link_cc_block (block_address,
- offset,
- offset,
- sections,
- -1,
- ret_add)),
- ret_add);
-}
-
-/*
- comp_link_caches_restart is used to continue the linking process
- started by comutil_link after the garbage collector has run.
- It expects the top of the stack to be as left by link_cc_block.
- */
-
-C_TO_SCHEME long
-DEFUN_VOID (comp_link_caches_restart)
-{
- SCHEME_OBJECT block, environment;
- long original_count, sections, code;
- unsigned long offset;
- unsigned long last_header_offset;
- instruction * ret_add;
-
- original_count = (OBJECT_DATUM (STACK_POP()));
- (void) STACK_POP (); /* Loop count, for debugger */
- block = (STACK_POP ());
- environment = (compiled_block_environment (block));
- env_register = environment;
- offset = (OBJECT_DATUM (STACK_POP ()));
- last_header_offset = (OBJECT_DATUM (STACK_POP ()));
- sections = (OBJECT_DATUM (STACK_POP ()));
- ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
- code = (link_cc_block ((OBJECT_ADDRESS (block)),
- offset,
- last_header_offset,
- sections,
- original_count,
- ret_add));
- if (code == PRIM_DONE)
- /* Return to the block being linked. */
- ENTER_SCHEME (ret_add);
- else
- {
- /* Another GC or error. We should be ready for back-out. */
- return (code);
- }
+ default:
+ return (false);
+ }
}
-\f
-/* TRAMPOLINE code
- When a free variable appears in operator position in compiled code,
- there must be a directly callable procedure in the corresponding
- execute cache cell. If, at link time, there is no appropriate
- value for the free variable, a fake compiled Scheme procedure that
- calls one of these procedures will be placed into the cell instead.
-
- The trampolines themselves are made by make_uuo_link,
- make_fake_uuo_link, and coerce_to_compiled. The trampoline looks
- like a Scheme closure, containing some code to jump to one of
- these procedures and additional information to be used by the
- procedure.
-
- These procedures expect a single argument, the address of the
- information block where they can find the relevant data, typically
- the procedure to invoke and the number of arguments to invoke it
- with.
-*/
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_apply_trap, tramp_data_raw)
+static void
+back_out_of_link_section (link_cc_state_t * s)
{
- /* Used by coerce_to_compiled. TRAMPOLINE_K_APPLY */
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
- TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1])));
+ /* Save enough state to restart. */
+ STACK_PUSH (MAKE_CC_ENTRY (s->return_address));
+ STACK_PUSH (ULONG_TO_FIXNUM ((s->n_sections) - (s->n_linked_sections)));
+ STACK_PUSH (ULONG_TO_FIXNUM ((s->scan0) - (s->block_address)));
+ STACK_PUSH (ULONG_TO_FIXNUM ((s->scan) - (s->block_address)));
+ STACK_PUSH (MAKE_CC_BLOCK (s->block_address));
+ STACK_PUSH (ULONG_TO_FIXNUM ((s->n_entries) - (s->n_linked_entries)));
+ STACK_PUSH (ULONG_TO_FIXNUM (s->n_entries));
+ SAVE_LAST_RETURN_CODE (RC_COMP_LINK_CACHES_RESTART);
}
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_arity_trap, tramp_data_raw)
+static void
+restore_link_cc_state (link_cc_state_t * s)
{
- /* Linker saw an argument count mismatch. TRAMPOLINE_K_ARITY */
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
- TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1])));
-}
+ RESTORE_LAST_RETURN_CODE ();
+ (s->n_entries) = (OBJECT_DATUM (STACK_POP ()));
+ (s->n_linked_entries) = ((s->n_entries) - (OBJECT_DATUM (STACK_POP ())));
+ (s->block_address) = (OBJECT_ADDRESS (STACK_POP ()));
+ (s->scan) = ((s->block_address) + (OBJECT_DATUM (STACK_POP ())));
+ (s->scan0) = ((s->block_address) + (OBJECT_DATUM (STACK_POP ())));
+ (s->n_sections) = (OBJECT_DATUM (STACK_POP ()));
+ (s->return_address) = (CC_ENTRY_ADDRESS (STACK_POP ()));
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_entity_trap, tramp_data_raw)
-{
- /* Linker saw an entity to be applied. TRAMPOLINE_K_ENTITY */
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
- TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1])));
+ (s->n_linked_sections) = 0;
+ (s->type) = (linkage_section_type (* (s->scan0)));
}
\f
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_interpreted_trap, tramp_data_raw)
-{
- /* Linker saw an interpreted procedure or a procedure that it cannot
- link directly. TRAMPOLINE_K_INTERPRETED */
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
- TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1])));
-}
+/* Interrupt/GC from Scheme
+
+ These procedures are called from compiled code at the start
+ (respectively) of a procedure or continuation if an interrupt has
+ been detected. They must not be called unless there is an
+ interrupt to be serviced.
+
+ The code that handles RC_COMP_INTERRUPT_RESTART in "interp.c" will
+ return control to comp_interrupt_restart (below). This assumes
+ that the Scheme stack contains a compiled code entry address (start
+ of continuation, procedure, etc.). The GET_EXP saved with the
+ continuation is a piece of state that will be returned to
+ GET_VAL and GET_ENV (both) upon return. */
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_lexpr_trap, tramp_data_raw)
+DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_closure)
{
- /* Linker saw a primitive of arbitrary number of arguments.
- TRAMPOLINE_K_LEXPR_PRIMITIVE */
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
- (Registers[REGBLOCK_LEXPR_ACTUALS]) =
- ((SCHEME_OBJECT) ((OBJECT_DATUM (tramp_data[1])) - 1));
- TAIL_CALL_1 (comutil_primitive_lexpr_apply, (tramp_data[0]));
+ compiler_interrupt_common (DSU_result, 0, SHARP_F);
}
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_primitive_trap, tramp_data_raw)
+DEFINE_SCHEME_UTILITY_2 (comutil_interrupt_dlink, entry_point, dlink)
{
- /* Linker saw a primitive of fixed matching arity. TRAMPOLINE_K_PRIMITIVE */
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
- TAIL_CALL_1 (comutil_primitive_apply, (tramp_data[0]));
+ DECLARE_UTILITY_ARG (insn_t *, entry_point);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, dlink);
+ compiler_interrupt_common (DSU_result,
+ entry_point,
+ (MAKE_CC_STACK_ENV (dlink)));
}
-\f
-/* The linker either couldn't find a binding or the binding was
- unassigned, unbound, or a deep-bound (parallel processor) fluid.
- This must report the correct name of the missing variable and the
- environment in which the lookup begins for the error cases, or do
- the correct deep reference for fluids.
-
- "extension" is the linker object corresponding to the operator
- variable (it contains the actual value cell, the name, and linker
- tables). code_block and offset point to the cache cell in question.
- tramp_data contains extension, code_block, offset. TRAMPOLINE_K_LOOKUP
-*/
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_lookup_trap, tramp_data_raw)
-{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
- SCHEME_OBJECT cache = (tramp_data[0]);
- SCHEME_OBJECT block = (tramp_data[1]);
- unsigned long offset = (OBJECT_DATUM (tramp_data[2]));
- SCHEME_OBJECT true_operator;
- long code
- = (compiler_operator_reference_trap (cache, (&true_operator)));
- SCHEME_OBJECT * cache_cell = (MEMORY_LOC (block, offset));
- long nargs;
-
- EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell);
- if (code == PRIM_DONE)
- TAIL_CALL_2 (comutil_apply, true_operator, nargs);
- /* Error or interrupt */
- {
- SCHEME_OBJECT trampoline;
-
- /* This could be done by bumping tramp_data to the entry point.
- It would probably be better. */
- EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell);
- STACK_PUSH (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (trampoline)));
- /* Next three for debugger. */
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs));
- STACK_PUSH (compiled_block_environment (block));
- STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR));
- exp_register = SHARP_F;
- Store_Return (RC_COMP_OP_REF_TRAP_RESTART);
- Save_Cont ();
- RETURN_TO_C (code);
- }
+DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_procedure, entry_point)
+{
+ DECLARE_UTILITY_ARG (insn_t *, entry_point);
+ compiler_interrupt_common (DSU_result, entry_point, SHARP_F);
}
-/*
- Re-start after processing an error/interrupt encountered in the previous
- utility.
- Extract the new trampoline or procedure (the user may have defined the
- missing variable) and invoke it.
- */
+/* GET_VAL has live data, and there is no entry address on the stack */
-C_TO_SCHEME long
-DEFUN_VOID (comp_op_lookup_trap_restart)
+DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_continuation, return_addr)
{
- SCHEME_OBJECT * old_trampoline, code_block, new_procedure;
- long offset;
+ DECLARE_UTILITY_ARG (insn_t *, return_addr);
+ compiler_interrupt_common (DSU_result, return_addr, GET_VAL);
+}
- /* Discard name, env. and nargs */
+/* GET_ENV has live data; no entry point on the stack */
- sp_register = (STACK_LOC (3));
- old_trampoline = (OBJECT_ADDRESS (STACK_POP ()));
- code_block = ((TRAMPOLINE_STORAGE (old_trampoline))[1]);
- offset = (OBJECT_DATUM ((TRAMPOLINE_STORAGE (old_trampoline))[2]));
- EXTRACT_EXECUTE_CACHE_ADDRESS (new_procedure,
- (MEMORY_LOC (code_block, offset)));
- ENTER_SCHEME (SCHEME_ADDR_TO_ADDR (new_procedure));
+DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_ic_procedure, entry_point)
+{
+ DECLARE_UTILITY_ARG (insn_t *, entry_point);
+ compiler_interrupt_common (DSU_result, entry_point, GET_ENV);
}
-\f
-/* ARITY Mismatch handling
- These receive the entry point as an argument and must fill the
- Scheme stack with the missing default values.
- They are invoked by TRAMPOLINE_K_n_m where n and m are the same
- as in the name of the procedure.
- The single item of information in the trampoline data area is
- the real procedure to invoke. All the arguments are on the
- Scheme stack.
- */
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_1_0_trap, tramp_data_raw)
+DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_continuation_2)
{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
+ compiler_interrupt_common (DSU_result, 0, GET_VAL);
+}
- STACK_PUSH (DEFAULT_OBJECT);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
+void
+compiler_interrupt_common (utility_result_t * DSU_result,
+ insn_t * address,
+ SCHEME_OBJECT state)
+{
+ if (!FREE_OK_P (Free))
+ REQUEST_GC (Free - heap_alloc_limit);
+ STACK_CHECK (0);
+ if (address != 0)
+ STACK_PUSH (MAKE_CC_ENTRY (address));
+ STACK_PUSH (state);
+ SAVE_LAST_RETURN_CODE (RC_COMP_INTERRUPT_RESTART);
+ RETURN_TO_C (PRIM_INTERRUPT);
}
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_2_1_trap, tramp_data_raw)
+DEFINE_SCHEME_ENTRY (comp_interrupt_restart)
{
- SCHEME_OBJECT Top;
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
- Top = (STACK_POP ());
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (Top);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
+ RESTORE_LAST_RETURN_CODE ();
+ {
+ SCHEME_OBJECT state = (STACK_POP ());
+ SET_ENV (state);
+ SET_VAL (state);
+ }
+ JUMP_TO_CC_ENTRY (STACK_POP ());
}
+\f
+/* Other traps */
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_2_0_trap, tramp_data_raw)
-{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
+/* Assigning a variable that contains a trap. */
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
+DEFINE_SCHEME_UTILITY_3 (comutil_assignment_trap,
+ ret_addr, cache_addr, new_val)
+{
+ DECLARE_UTILITY_ARG (insn_t *, ret_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT, new_val);
+ SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
+ SCHEME_OBJECT old_val;
+ long code = (compiler_assignment_trap (cache, new_val, (&old_val)));
+ if (code != PRIM_DONE)
+ {
+ SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
+ SCHEME_OBJECT block = (cc_entry_to_block (sra));
+ STACK_PUSH (sra);
+ STACK_PUSH (new_val);
+ STACK_PUSH (cc_block_environment (block));
+ STACK_PUSH
+ (compiler_var_error (cache, block, CACHE_REFERENCES_ASSIGNMENT));
+ SAVE_LAST_RETURN_CODE (RC_COMP_ASSIGNMENT_TRAP_RESTART);
+ RETURN_TO_C (code);
+ }
+ SET_VAL (old_val);
+ RETURN_TO_SCHEME (ret_addr);
}
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_2_trap, tramp_data_raw)
+DEFINE_SCHEME_ENTRY (comp_assignment_trap_restart)
{
- SCHEME_OBJECT Top, Next;
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
- Top = (STACK_POP ());
- Next = (STACK_POP ());
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (Next);
- STACK_PUSH (Top);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
+ RESTORE_LAST_RETURN_CODE ();
+ {
+ SCHEME_OBJECT name = (STACK_POP ());
+ SCHEME_OBJECT environment = (STACK_POP ());
+ SCHEME_OBJECT new_val = (STACK_POP ());
+ SCHEME_OBJECT old_val;
+ long code = (assign_variable (environment, name, new_val, (&old_val)));
+ if (code != PRIM_DONE)
+ {
+ STACK_PUSH (new_val);
+ STACK_PUSH (environment);
+ STACK_PUSH (name);
+ SAVE_LAST_RETURN_CODE (RC_COMP_ASSIGNMENT_TRAP_RESTART);
+ return (code);
+ }
+ SET_VAL (old_val);
+ JUMP_TO_CC_ENTRY (STACK_POP ());
+ }
}
\f
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_1_trap, tramp_data_raw)
+DEFINE_SCHEME_UTILITY_3 (comutil_cache_lookup_apply,
+ cache_addr, block_addr, frame_size)
{
- SCHEME_OBJECT Top;
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
- Top = (STACK_POP ());
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (Top);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, block_addr);
+ DECLARE_UTILITY_ARG (unsigned long, frame_size);
+ SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
+ SCHEME_OBJECT value;
+ long code = (compiler_lookup_trap (cache, (&value)));
+ if (code != PRIM_DONE)
+ {
+ SCHEME_OBJECT block = (MAKE_CC_BLOCK (block_addr));
+ STACK_PUSH (block);
+ STACK_PUSH (ULONG_TO_FIXNUM (frame_size));
+ STACK_PUSH (cc_block_environment (block));
+ STACK_PUSH
+ (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR));
+ SAVE_LAST_RETURN_CODE (RC_COMP_CACHE_REF_APPLY_RESTART);
+ RETURN_TO_C (code);
+ }
+ TAIL_CALL_2 (comutil_apply, value, frame_size);
}
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_0_trap, tramp_data_raw)
+DEFINE_SCHEME_ENTRY (comp_cache_lookup_apply_restart)
{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
-}
-
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_3_trap, tramp_data_raw)
-{
- SCHEME_OBJECT Top, Middle, Bottom;
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
- Top = (STACK_POP ());
- Middle = (STACK_POP ());
- Bottom = (STACK_POP ());
-
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (Bottom);
- STACK_PUSH (Middle);
- STACK_PUSH (Top);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
-}
-
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_2_trap, tramp_data_raw)
-{
- SCHEME_OBJECT Top, Next;
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
- Top = (STACK_POP ());
- Next = (STACK_POP ());
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (Next);
- STACK_PUSH (Top);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
-}
-\f
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_1_trap, tramp_data_raw)
-{
- SCHEME_OBJECT Top;
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
- Top = (STACK_POP ());
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (Top);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
-}
-
-DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_0_trap, tramp_data_raw)
-{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- STACK_PUSH (DEFAULT_OBJECT);
- RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
+ RESTORE_LAST_RETURN_CODE ();
+ {
+ SCHEME_OBJECT name = (STACK_POP ());
+ SCHEME_OBJECT environment = (STACK_POP ());
+ SCHEME_OBJECT frame_size = (STACK_POP ());
+ SCHEME_OBJECT block = (STACK_POP ());
+ SCHEME_OBJECT value;
+ {
+ long code = (lookup_variable (environment, name, (&value)));
+ if (code != PRIM_DONE)
+ {
+ STACK_PUSH (block);
+ STACK_PUSH (frame_size);
+ STACK_PUSH (environment);
+ STACK_PUSH (name);
+ SAVE_LAST_RETURN_CODE (RC_COMP_CACHE_REF_APPLY_RESTART);
+ return (code);
+ }
+ }
+ STACK_PUSH (value);
+ PUSH_APPLY_FRAME_HEADER ((FIXNUM_TO_ULONG (frame_size)) - 1);
+ if (CC_ENTRY_P (value))
+ return (apply_compiled_procedure ());
+ guarantee_interp_return ();
+ return (PRIM_APPLY);
+ }
}
\f
-/* INTERRUPT/GC from Scheme
-
- These procedures are called from compiled code at the start
- (respectively) of a procedure or continuation if an interrupt has
- been detected. They must not be called unless there is an
- interrupt to be serviced.
-
- The code that handles RC_COMP_INTERRUPT_RESTART in "interp.c" will
- return control to comp_interrupt_restart (below). This assumes
- that the Scheme stack contains a compiled code entry address
- (start of continuation, procedure, etc.). The exp_register
- saved with the continuation is a piece of state that will be
- returned to val_register and env_register (both) upon return.
- */
-
-#define MAYBE_REQUEST_INTERRUPTS() \
-{ \
- if (Free >= MemTop) \
- Request_GC (Free - MemTop); \
- if (sp_register <= Stack_Guard) \
- REQUEST_INTERRUPT (INT_Stack_Overflow); \
-}
+/* Variable reference traps:
+ Reference to a free variable that contains a reference trap. */
-static void
-DEFUN (compiler_interrupt_common, (DSU_result, entry_point_raw, state),
- utility_result * DSU_result
- AND SCHEME_ADDR entry_point_raw
- AND SCHEME_OBJECT state)
+DEFINE_SCHEME_UTILITY_2 (comutil_lookup_trap, ret_addr, cache_addr)
{
- MAYBE_REQUEST_INTERRUPTS ();
- if (entry_point_raw != ((SCHEME_ADDR) 0))
+ DECLARE_UTILITY_ARG (insn_t *, ret_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
+ SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
+ SCHEME_OBJECT val;
+ long code = (compiler_lookup_trap (cache, (&val)));
+ if (code != PRIM_DONE)
{
- instruction * entry_point
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
- STACK_PUSH (ENTRY_TO_OBJECT (entry_point));
+ SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
+ SCHEME_OBJECT block = (cc_entry_to_block (sra));
+ STACK_PUSH (sra);
+ STACK_PUSH (cc_block_environment (block));
+ STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
+ SAVE_LAST_RETURN_CODE (RC_COMP_LOOKUP_TRAP_RESTART);
+ RETURN_TO_C (code);
}
- STACK_PUSH (state);
- exp_register = SHARP_F;
- Store_Return (RC_COMP_INTERRUPT_RESTART);
- Save_Cont ();
- RETURN_TO_C (PRIM_INTERRUPT);
-}
-
-DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_closure)
-{
- COMPILER_INTERRUPT_COMMON (0, SHARP_F);
-}
-
-DEFINE_SCHEME_UTILITY_2 (comutil_interrupt_dlink, entry_point_raw, dlink_raw)
-{
- SCHEME_OBJECT * dlink = (SCHEME_ADDR_TO_ADDR (dlink_raw));
- COMPILER_INTERRUPT_COMMON
- (((PTR) entry_point_raw),
- (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, dlink)));
-}
-
-DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_procedure, entry_point_raw)
-{
- COMPILER_INTERRUPT_COMMON (((PTR) entry_point_raw), SHARP_F);
-}
-
-/* val_register has live data, and there is no entry address on the stack */
-
-DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_continuation, return_address_raw)
-{
- COMPILER_INTERRUPT_COMMON (((PTR) return_address_raw), val_register);
-}
-
-/* env_register has live data; no entry point on the stack */
-
-DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_ic_procedure, entry_point_raw)
-{
- COMPILER_INTERRUPT_COMMON (((PTR) entry_point_raw), env_register);
+ SET_VAL (val);
+ RETURN_TO_SCHEME (ret_addr);
}
-DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_continuation_2)
+DEFINE_SCHEME_ENTRY (comp_lookup_trap_restart)
{
- COMPILER_INTERRUPT_COMMON (0, val_register);
+ RESTORE_LAST_RETURN_CODE ();
+ {
+ SCHEME_OBJECT name = GET_EXP;
+ SCHEME_OBJECT environment = (STACK_POP ());
+ SCHEME_OBJECT val;
+ long code = (lookup_variable (environment, name, (&val)));
+ if (code != PRIM_DONE)
+ {
+ STACK_PUSH (environment);
+ STACK_PUSH (name);
+ SAVE_LAST_RETURN_CODE (RC_COMP_LOOKUP_TRAP_RESTART);
+ return (code);
+ }
+ SET_VAL (val);
+ JUMP_TO_CC_ENTRY (STACK_POP ());
+ }
}
-C_TO_SCHEME long
-DEFUN_VOID (comp_interrupt_restart)
+DEFINE_SCHEME_UTILITY_2 (comutil_safe_lookup_trap, ret_addr, cache_addr)
{
- SCHEME_OBJECT state = (STACK_POP ());
- env_register = state;
- val_register = state;
- ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
-}
-\f
-/* Other TRAPS */
-
-/* Assigning a variable that has a trap in it (except unassigned) */
-
-DEFINE_SCHEME_UTILITY_3 (comutil_assignment_trap,
- return_address_raw, cache_addr_raw, value)
-{
- instruction * return_address
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw)));
- SCHEME_OBJECT cache
- = (MAKE_POINTER_OBJECT
- (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw))));
- long code = (compiler_assignment_trap (cache, value, (&val_register)));
- if (code == PRIM_DONE)
- RETURN_TO_SCHEME (return_address);
- else
+ DECLARE_UTILITY_ARG (insn_t *, ret_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
+ SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
+ SCHEME_OBJECT val;
+ long code = (compiler_safe_lookup_trap (cache, (&val)));
+ if (code != PRIM_DONE)
{
- SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address));
- SCHEME_OBJECT block = (compiled_entry_to_block (sra));
+ SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
+ SCHEME_OBJECT block = (cc_entry_to_block (sra));
STACK_PUSH (sra);
- STACK_PUSH (value);
- STACK_PUSH (compiled_block_environment (block));
- STACK_PUSH
- (compiler_var_error (cache, block, CACHE_REFERENCES_ASSIGNMENT));
- exp_register = SHARP_F;
- Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART);
- Save_Cont ();
+ STACK_PUSH (cc_block_environment (block));
+ STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
+ SAVE_LAST_RETURN_CODE (RC_COMP_SAFE_REF_TRAP_RESTART);
RETURN_TO_C (code);
}
+ SET_VAL (val);
+ RETURN_TO_SCHEME (ret_addr);
}
-C_TO_SCHEME long
-DEFUN_VOID (comp_assignment_trap_restart)
+DEFINE_SCHEME_ENTRY (comp_safe_lookup_trap_restart)
{
- SCHEME_OBJECT name = (STACK_POP ());
- SCHEME_OBJECT environment = (STACK_POP ());
- SCHEME_OBJECT value = (STACK_POP ());
- long code = (assign_variable (environment, name, value, (&val_register)));
- if (code == PRIM_DONE)
- ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
- else
- {
- STACK_PUSH (value);
- STACK_PUSH (environment);
- STACK_PUSH (name);
- exp_register = SHARP_F;
- Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART);
- Save_Cont ();
- return (code);
- }
-}
-\f
-DEFINE_SCHEME_UTILITY_3 (comutil_cache_lookup_apply,
- cache_addr_raw, block_address_raw, nactuals)
-{
- SCHEME_OBJECT cache
- = (MAKE_POINTER_OBJECT
- (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw))));
- SCHEME_OBJECT value;
- long code = (compiler_lookup_trap (cache, (&value)));
- if (code == PRIM_DONE)
- TAIL_CALL_2 (comutil_apply, value, nactuals);
+ RESTORE_LAST_RETURN_CODE ();
{
- SCHEME_OBJECT block
- = (MAKE_CC_BLOCK (SCHEME_ADDR_TO_ADDR (block_address_raw)));
- STACK_PUSH (block);
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
- STACK_PUSH (compiled_block_environment (block));
- STACK_PUSH
- (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR));
- exp_register = SHARP_F;
- Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
- Save_Cont ();
- RETURN_TO_C (code);
+ SCHEME_OBJECT name = GET_EXP;
+ SCHEME_OBJECT environment = (STACK_POP ());
+ SCHEME_OBJECT val;
+ long code = (safe_lookup_variable (environment, name, (&val)));
+ if (code != PRIM_DONE)
+ {
+ STACK_PUSH (environment);
+ STACK_PUSH (name);
+ SAVE_LAST_RETURN_CODE (RC_COMP_SAFE_REF_TRAP_RESTART);
+ return (code);
+ }
+ SET_VAL (val);
+ JUMP_TO_CC_ENTRY (STACK_POP ());
}
}
-C_TO_SCHEME long
-DEFUN_VOID (comp_cache_lookup_apply_restart)
+DEFINE_SCHEME_UTILITY_2 (comutil_unassigned_p_trap, ret_addr, cache_addr)
{
- SCHEME_OBJECT name = (STACK_POP ());
- SCHEME_OBJECT environment = (STACK_POP ());
- SCHEME_OBJECT value;
- long code = (lookup_variable (environment, name, (&value)));
- if (code == PRIM_DONE)
- {
- /* Replace block with actual operator */
- (* (STACK_LOC (1))) = value;
- if (COMPILED_CODE_ADDRESS_P (value))
- return (apply_compiled_procedure ());
- else
- return (PRIM_APPLY);
- }
- else
+ DECLARE_UTILITY_ARG (insn_t *, ret_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
+ SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
+ SCHEME_OBJECT val;
+ long code = (compiler_unassigned_p_trap (cache, (&val)));
+ if (code != PRIM_DONE)
{
- STACK_PUSH (environment);
- STACK_PUSH (name);
- exp_register = SHARP_F;
- Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
- Save_Cont ();
- return (code);
+ SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
+ SCHEME_OBJECT block = (cc_entry_to_block (sra));
+ STACK_PUSH (sra);
+ STACK_PUSH (cc_block_environment (block));
+ STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
+ SAVE_LAST_RETURN_CODE (RC_COMP_UNASSIGNED_TRAP_RESTART);
+ RETURN_TO_C (code);
}
+ SET_VAL (val);
+ RETURN_TO_SCHEME (ret_addr);
}
-\f
-/* Variable reference traps:
- Reference to a free variable that has a reference trap -- either a
- fluid or an error (unassigned / unbound). */
-#define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup) \
-DEFINE_SCHEME_UTILITY_2 (name, return_address_raw, cache_addr_raw) \
-{ \
- instruction * return_address \
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw))); \
- SCHEME_OBJECT cache \
- = (MAKE_POINTER_OBJECT \
- (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw)))); \
- long code = (c_trap (cache, (&val_register))); \
- if (code == PRIM_DONE) \
- RETURN_TO_SCHEME (return_address); \
- else \
- { \
- SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address)); \
- SCHEME_OBJECT block = (compiled_entry_to_block (sra)); \
- STACK_PUSH (sra); \
- STACK_PUSH (compiled_block_environment (block)); \
- STACK_PUSH \
- (compiler_var_error \
- (cache, block, CACHE_REFERENCES_LOOKUP)); \
- exp_register = SHARP_F; \
- Store_Return (ret_code); \
- Save_Cont (); \
- RETURN_TO_C (code); \
- } \
-} \
- \
-C_TO_SCHEME long \
-DEFUN_VOID (restart) \
-{ \
- SCHEME_OBJECT name = (STACK_POP ()); \
- SCHEME_OBJECT environment = (STACK_POP ()); \
- long code = (c_lookup (environment, name, (&val_register))); \
- if (code == PRIM_DONE) \
- ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \
- else \
- { \
- STACK_PUSH (environment); \
- STACK_PUSH (name); \
- exp_register = SHARP_F; \
- Store_Return (ret_code); \
- Save_Cont (); \
- return (code); \
- } \
+DEFINE_SCHEME_ENTRY (comp_unassigned_p_trap_restart)
+{
+ RESTORE_LAST_RETURN_CODE ();
+ {
+ SCHEME_OBJECT name = GET_EXP;
+ SCHEME_OBJECT environment = (STACK_POP ());
+ SCHEME_OBJECT val;
+ long code = (variable_unassigned_p (environment, name, (&val)));
+ if (code != PRIM_DONE)
+ {
+ STACK_PUSH (environment);
+ STACK_PUSH (name);
+ SAVE_LAST_RETURN_CODE (RC_COMP_UNASSIGNED_TRAP_RESTART);
+ return (code);
+ }
+ SET_VAL (val);
+ JUMP_TO_CC_ENTRY (STACK_POP ());
+ }
}
\f
-/* Actual traps */
-
-CMPLR_REF_TRAP(comutil_lookup_trap,
- compiler_lookup_trap,
- RC_COMP_LOOKUP_TRAP_RESTART,
- comp_lookup_trap_restart,
- lookup_variable)
+/* Numeric routines
-CMPLR_REF_TRAP(comutil_safe_lookup_trap,
- compiler_safe_lookup_trap,
- RC_COMP_SAFE_REF_TRAP_RESTART,
- comp_safe_lookup_trap_restart,
- safe_lookup_variable)
-
-CMPLR_REF_TRAP(comutil_unassigned_p_trap,
- compiler_unassigned_p_trap,
- RC_COMP_UNASSIGNED_TRAP_RESTART,
- comp_unassigned_p_trap_restart,
- variable_unassigned_p)
-
-
-/* NUMERIC ROUTINES
- Invoke the arithmetic primitive in the fixed objects vector.
- The Scheme arguments are expected on the Scheme stack.
- */
+ Invoke the arithmetic primitive in the fixed objects vector. The
+ Scheme arguments are expected on the Scheme stack. */
#define COMPILER_ARITH_PRIM(name, fobj_index, arity) \
DEFINE_SCHEME_UTILITY_0 (name) \
{ \
TAIL_CALL_2 \
- (comutil_apply, (Get_Fixed_Obj_Slot (fobj_index)), (arity)); \
+ (comutil_apply, (VECTOR_REF (fixed_objects, fobj_index)), (arity)); \
}
COMPILER_ARITH_PRIM (comutil_decrement, GENERIC_TRAMPOLINE_PREDECESSOR, 2)
COMPILER_ARITH_PRIM (comutil_quotient, GENERIC_TRAMPOLINE_QUOTIENT, 3)
COMPILER_ARITH_PRIM (comutil_remainder, GENERIC_TRAMPOLINE_REMAINDER, 3)
COMPILER_ARITH_PRIM (comutil_zero, GENERIC_TRAMPOLINE_ZERO_P, 2)
-\f
-/*
- Obsolete SCHEME_UTILITYs used to handle first class environments.
- They have been superseded by the variable caching code.
- They are here for completeness, and because the code in the compiler
- that uses them has not yet been spliced out, although it is switched
- off.
-*/
-
-#define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name) \
-DEFINE_SCHEME_UTILITY_3 (util_name, ret_add_raw, environment, variable) \
-{ \
- instruction * ret_add \
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); \
- long code = (c_proc (environment, variable, (&val_register))); \
- if (code == PRIM_DONE) \
- { \
- RETURN_TO_SCHEME (ret_add); \
- } \
- else \
- { \
- STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); \
- STACK_PUSH (variable); \
- STACK_PUSH (environment); \
- exp_register = SHARP_F; \
- Store_Return (ret_code); \
- Save_Cont (); \
- RETURN_TO_C (code); \
- } \
-} \
- \
-C_TO_SCHEME long \
-DEFUN_VOID (restart_name) \
-{ \
- SCHEME_OBJECT environment, variable; \
- long code; \
- \
- environment = (STACK_POP ()); \
- variable = (STACK_POP ()); \
- code = (c_proc (environment, variable, (&val_register))); \
- if (code == PRIM_DONE) \
- { \
- env_register = environment; \
- ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \
- } \
- else \
- { \
- STACK_PUSH (variable); \
- STACK_PUSH (environment); \
- exp_register = SHARP_F; \
- Store_Return (ret_code); \
- Save_Cont (); \
- return (code); \
- } \
-}
-\f
-#define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name) \
-DEFINE_SCHEME_UTILITY_4 (util_name, \
- ret_add_raw, environment, variable, value) \
-{ \
- instruction * ret_add \
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); \
- long code = (c_proc (environment, variable, value)); \
- if (code == PRIM_DONE) \
- RETURN_TO_SCHEME (ret_add); \
- else \
- { \
- STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); \
- STACK_PUSH (value); \
- STACK_PUSH (variable); \
- STACK_PUSH (environment); \
- exp_register = SHARP_F; \
- Store_Return (ret_code); \
- Save_Cont (); \
- RETURN_TO_C (code); \
- } \
-} \
- \
-C_TO_SCHEME long \
-DEFUN_VOID (restart_name) \
-{ \
- SCHEME_OBJECT environment, variable, value; \
- long code; \
- \
- environment = exp_register; \
- variable = (STACK_POP ()); \
- value = (STACK_POP ()); \
- code = (c_proc (environment, variable, value)); \
- if (code == PRIM_DONE) \
- { \
- env_register = environment; \
- ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \
- } \
- else \
- { \
- STACK_PUSH (value); \
- STACK_PUSH (variable); \
- STACK_PUSH (environment); \
- exp_register = SHARP_F; \
- Store_Return (ret_code); \
- Save_Cont (); \
- return (code); \
- } \
-}
-\f
-CMPLR_REFERENCE(comutil_access,
- lookup_variable,
- RC_COMP_ACCESS_RESTART,
- comp_access_restart)
-
-CMPLR_REFERENCE(comutil_reference,
- lookup_variable,
- RC_COMP_REFERENCE_RESTART,
- comp_reference_restart)
-
-CMPLR_REFERENCE(comutil_safe_reference,
- safe_lookup_variable,
- RC_COMP_SAFE_REFERENCE_RESTART,
- comp_safe_reference_restart)
-
-CMPLR_REFERENCE(comutil_unassigned_p,
- variable_unassigned_p,
- RC_COMP_UNASSIGNED_P_RESTART,
- comp_unassigned_p_restart)
-
-CMPLR_REFERENCE(comutil_unbound_p,
- variable_unbound_p,
- RC_COMP_UNBOUND_P_RESTART,
- comp_unbound_p_restart)
-static long
-compiler_assign_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
- SCHEME_OBJECT value)
+DEFINE_SCHEME_UTILITY_2 (comutil_primitive_error, ret_addr, primitive)
{
- return (assign_variable (environment, symbol, value, (&val_register)));
+ DECLARE_UTILITY_ARG (insn_t *, ret_addr);
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive);
+ STACK_PUSH (MAKE_CC_ENTRY (ret_addr));
+ STACK_PUSH (primitive);
+ SAVE_LAST_RETURN_CODE (RC_COMP_ERROR_RESTART);
+ RETURN_TO_C (ERR_COMPILED_CODE_ERROR);
}
-CMPLR_ASSIGNMENT(comutil_assignment,
- compiler_assign_variable,
- RC_COMP_ASSIGNMENT_RESTART,
- comp_assignment_restart)
-
-static long
-compiler_define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
- SCHEME_OBJECT value)
+DEFINE_SCHEME_ENTRY (comp_error_restart)
{
- long result = (define_variable (environment, symbol, value));
- if (result == PRIM_DONE)
- val_register = symbol;
- return (result);
+ RESTORE_LAST_RETURN_CODE ();
+ (void) STACK_POP (); /* primitive */
+ JUMP_TO_CC_ENTRY (STACK_POP ());
}
-
-CMPLR_ASSIGNMENT(comutil_definition,
- compiler_define_variable,
- RC_COMP_DEFINITION_RESTART,
- comp_definition_restart)
\f
-DEFINE_SCHEME_UTILITY_3 (comutil_lookup_apply, environment, variable, nactuals)
+long
+apply_compiled_from_primitive (unsigned long n_args,
+ SCHEME_OBJECT procedure)
{
- long code = (lookup_variable (environment, variable, (&val_register)));
- if (code == PRIM_DONE)
- TAIL_CALL_2 (comutil_apply, val_register, nactuals);
- {
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
- STACK_PUSH (variable);
- STACK_PUSH (environment);
- exp_register = SHARP_F;
- Store_Return (RC_COMP_LOOKUP_APPLY_RESTART);
- Save_Cont ();
- RETURN_TO_C (code);
- }
+ while ((OBJECT_TYPE (procedure)) == TC_ENTITY)
+ {
+ {
+ unsigned long frame_size = (n_args + 1);
+ SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA));
+ if ((VECTOR_P (data))
+ && (frame_size < (VECTOR_LENGTH (data)))
+ && (CC_ENTRY_P (VECTOR_REF (data, frame_size)))
+ && ((VECTOR_REF (data, 0))
+ == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG))))
+ {
+ procedure = (VECTOR_REF (data, frame_size));
+ continue;
+ }
+ }
+ {
+ SCHEME_OBJECT operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
+ if (CC_ENTRY_P (operator))
+ {
+ STACK_PUSH (procedure);
+ n_args += 1;
+ procedure = operator;
+ }
+ }
+ break;
+ }
+
+ if (CC_ENTRY_P (procedure))
+ {
+ long code = (setup_compiled_invocation (procedure, n_args));
+ if (code != PRIM_DONE)
+ {
+ PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
+ return (code);
+ }
+ STACK_PUSH (procedure);
+ return (PRIM_DONE);
+ }
+
+ STACK_PUSH (procedure);
+ PUSH_APPLY_FRAME_HEADER (n_args);
+ PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
+ return (PRIM_DONE);
}
+\f
+/* Adjust the stack frame for applying a compiled procedure. Returns
+ PRIM_DONE when successful, otherwise sets up the call frame for
+ application by the interpreter and returns the appropriate code. */
-C_TO_SCHEME long
-DEFUN_VOID (comp_lookup_apply_restart)
+static long
+setup_compiled_invocation (SCHEME_OBJECT procedure, unsigned long n_args)
{
- SCHEME_OBJECT environment = (STACK_POP ());
- SCHEME_OBJECT variable = (STACK_POP ());
- SCHEME_OBJECT value;
- long code = (lookup_variable (environment, variable, (&value)));
- if (code == PRIM_DONE)
+ cc_entry_type_t cet;
+ unsigned long n_min;
+ unsigned long n_max;
+
+ if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (procedure))))
{
- SCHEME_OBJECT nactuals = (STACK_POP ());
- STACK_PUSH (value);
- STACK_PUSH (nactuals);
- if (COMPILED_CODE_ADDRESS_P (value))
- return (apply_compiled_procedure ());
- else
- return (PRIM_APPLY);
+ recover_from_apply_error (procedure, n_args);
+ return (ERR_COMPILED_CODE_ERROR);
}
- else
+ if ((cet.marker) != CET_PROCEDURE)
+ {
+ recover_from_apply_error (procedure, n_args);
+ return (ERR_INAPPLICABLE_OBJECT);
+ }
+ n_min = (cet.args.for_procedure.n_required);
+ if (n_args < n_min)
+ {
+ recover_from_apply_error (procedure, n_args);
+ return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ n_max = (n_min + (cet.args.for_procedure.n_optional));
+ if (cet.args.for_procedure.rest_p)
+ return (setup_lexpr_invocation (procedure, n_args, n_max));
+ if (n_args == n_max)
+ return (PRIM_DONE);
+ if (n_args > n_max)
+ {
+ recover_from_apply_error (procedure, n_args);
+ return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ if (open_gap (n_args, n_max))
{
- STACK_PUSH (variable);
- STACK_PUSH (environment);
- exp_register = SHARP_F;
- Store_Return (RC_COMP_LOOKUP_APPLY_RESTART);
- Save_Cont ();
- return (code);
+ recover_from_apply_error (procedure, n_args);
+ return (PRIM_APPLY_INTERRUPT);
}
+ return (PRIM_DONE);
}
\f
-DEFINE_SCHEME_UTILITY_2 (comutil_primitive_error, ret_add_raw, primitive)
+static long
+setup_lexpr_invocation (SCHEME_OBJECT procedure,
+ unsigned long n_args,
+ unsigned long n_max)
{
- instruction * ret_add =
- ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw)));
-
- STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
- STACK_PUSH (primitive);
- exp_register = SHARP_F;
- Store_Return (RC_COMP_ERROR_RESTART);
- Save_Cont ();
- RETURN_TO_C (ERR_COMPILED_CODE_ERROR);
+ if (n_args <= n_max)
+ {
+ if (open_gap (n_args, (n_max + 1)))
+ {
+ recover_from_apply_error (procedure, n_args);
+ return (PRIM_APPLY_INTERRUPT);
+ }
+ (STACK_REF (n_max)) = EMPTY_LIST;
+ return (PRIM_DONE);
+ }
+ {
+ unsigned long n_words = ((n_args - n_max) * 2);
+ if (GC_NEEDED_P (n_words))
+ {
+ REQUEST_GC (n_words);
+ recover_from_apply_error (procedure, n_args);
+ return (PRIM_APPLY_INTERRUPT);
+ }
+ }
+ {
+ SCHEME_OBJECT rest_arg = (MAKE_POINTER_OBJECT (TC_LIST, Free));
+ SCHEME_OBJECT * p1 = (STACK_LOC (n_max));
+ {
+ unsigned long i;
+ for (i = n_max; (i < n_args); i += 1)
+ {
+ (Free[0]) = (STACK_LOCATIVE_POP (p1));
+ (Free[1]) = (MAKE_POINTER_OBJECT (TC_LIST, (Free + 2)));
+ Free += 2;
+ }
+ }
+ (Free[-1]) = EMPTY_LIST;
+ (STACK_LOCATIVE_PUSH (p1)) = rest_arg;
+ {
+ SCHEME_OBJECT * p2 = (STACK_LOC (n_max));
+ unsigned long i;
+ for (i = 0; (i < n_max); i += 1)
+ (STACK_LOCATIVE_PUSH (p1)) = (STACK_LOCATIVE_PUSH (p2));
+ }
+ stack_pointer = p1;
+ }
+ return (PRIM_DONE);
}
-C_TO_SCHEME long
-DEFUN_VOID (comp_error_restart)
+static bool
+open_gap (unsigned long n_args, unsigned long n_needed)
{
- instruction * ret_add;
+ unsigned long n_defaults = (n_needed - n_args);
- (void) STACK_POP (); /* primitive */
- ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
- ENTER_SCHEME (ret_add);
+ STACK_CHECK (n_defaults);
+ if (PENDING_INTERRUPTS_P)
+ return (true);
+
+ open_stack_gap (n_args, n_defaults);
+ {
+ SCHEME_OBJECT * scan = (STACK_LOC (n_args));
+ SCHEME_OBJECT * end = (STACK_LOC (n_needed));
+ while (scan != end)
+ (STACK_LOCATIVE_POP (scan)) = DEFAULT_OBJECT;
+ }
+ return (false);
}
\f
-/* Procedures to destructure compiled entries and closures. */
+void
+make_compiled_procedure_type (cc_entry_type_t * cet,
+ unsigned int n_required,
+ unsigned int n_optional,
+ bool rest_p)
+{
+ (cet->marker) = CET_PROCEDURE;
+ (cet->args.for_procedure.n_required) = n_required;
+ (cet->args.for_procedure.n_optional) = n_optional;
+ (cet->args.for_procedure.rest_p) = rest_p;
+}
-/*
- Extract the debugging information attached to `block'. Usually
- this is a string which contains the filename where the debugging
- info is stored.
- */
+void
+make_compiled_continuation_type (cc_entry_type_t * cet, unsigned long offset)
+{
+ (cet->marker) = CET_CONTINUATION;
+ (cet->args.for_continuation.offset) = offset;
+}
-C_UTILITY SCHEME_OBJECT
-DEFUN (compiled_block_debugging_info,
- (block),
- SCHEME_OBJECT block)
+void
+make_cc_entry_type (cc_entry_type_t * cet, cc_entry_type_marker_t marker)
{
- long length;
+ assert (! ((marker == CET_PROCEDURE) || (marker == CET_CONTINUATION)));
+ (cet->marker) = marker;
+ memset ((& (cet->args)), 0, (sizeof (cet->marker)));
+}
- length = (VECTOR_LENGTH (block));
- return (FAST_MEMORY_REF (block, (length - 1)));
+SCHEME_OBJECT
+cc_entry_to_block (SCHEME_OBJECT entry)
+{
+ return (MAKE_CC_BLOCK (cc_entry_to_block_address (entry)));
}
-/* Extract the environment where the `block' was "loaded". */
+SCHEME_OBJECT *
+cc_entry_to_block_address (SCHEME_OBJECT entry)
+{
+ return (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (entry)));
+}
-C_UTILITY SCHEME_OBJECT
-DEFUN (compiled_block_environment,
- (block),
- SCHEME_OBJECT block)
+SCHEME_OBJECT *
+cc_entry_address_to_block_address (insn_t * entry)
+{
+ insn_t * p = entry;
+ while (1)
+ {
+ cc_entry_offset_t ceo;
+ read_cc_entry_offset ((&ceo), p);
+ p -= (ceo.offset);
+ if (! (ceo.continued_p))
+ {
+ assert ((((unsigned long) p) % (sizeof (SCHEME_OBJECT))) == 0);
+ assert (((SCHEME_OBJECT *) entry)
+ < (CC_BLOCK_ADDR_END ((SCHEME_OBJECT *) p)));
+ return ((SCHEME_OBJECT *) p);
+ }
+ }
+}
+\f
+int
+plausible_cc_block_p (SCHEME_OBJECT * block)
{
- long length;
+ insn_t * zero = ((insn_t *) block);
+ insn_t * entry = (((insn_t *) (block + 2)) + CC_ENTRY_HEADER_SIZE);
+ {
+ cc_entry_type_t cet;
+ if ((read_cc_entry_type ((&cet), entry))
+ || ((cet.marker) != CET_EXPRESSION))
+ {
+ entry += CC_ENTRY_GC_TRAP_SIZE;
+ if ((read_cc_entry_type ((&cet), entry))
+ || (! (((cet.marker) == CET_PROCEDURE)
+ || ((cet.marker) == CET_CONTINUATION))))
+ return (0);
+ }
+ }
+ {
+ cc_entry_offset_t ceo;
+ if ((read_cc_entry_offset ((&ceo), entry))
+ || ((ceo.offset) != (entry - zero)))
+ return (0);
+ }
+ {
+ SCHEME_OBJECT * block_end = ((CC_BLOCK_ADDR_END (block)) - 1);
+ return
+ ((((HEAP_ADDRESS_P (block)) && (HEAP_ADDRESS_P (block_end)))
+ || ((ADDRESS_IN_CONSTANT_P (block))
+ && (ADDRESS_IN_CONSTANT_P (block_end))))
+ && (ENVIRONMENT_P (*block_end)));
+ }
+}
- length = (VECTOR_LENGTH (block));
- return (FAST_MEMORY_REF (block, length));
+linkage_section_type_t
+linkage_section_type (SCHEME_OBJECT marker)
+{
+ unsigned long type = ((OBJECT_DATUM (marker)) >> 16);
+ assert (type < N_LINKAGE_SECTION_TYPES);
+ return ((linkage_section_type_t) type);
}
-/*
- Given `entry', a Scheme object representing a compiled code entry point,
- it returns the address of the block to which it belongs.
- */
+#ifndef UUO_WORDS_TO_COUNT
+# define UUO_WORDS_TO_COUNT(nw) ((nw) / UUO_LINK_SIZE)
+# define UUO_COUNT_TO_WORDS(nc) ((nc) * UUO_LINK_SIZE)
+#endif
-C_UTILITY SCHEME_OBJECT *
-DEFUN (compiled_entry_to_block_address,
- (entry),
- SCHEME_OBJECT entry)
+unsigned long
+linkage_section_count (SCHEME_OBJECT marker)
{
- SCHEME_OBJECT *block_address;
-
- Get_Compiled_Block (block_address, (OBJECT_ADDRESS (entry)));
- return (block_address);
+ linkage_section_type_t type = (linkage_section_type (marker));
+ unsigned long n_words = ((OBJECT_DATUM (marker)) & 0xFFFFUL);
+ return (((type == LINKAGE_SECTION_TYPE_OPERATOR)
+ || (type == LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR))
+ ? (UUO_WORDS_TO_COUNT (n_words))
+ : n_words);
}
-C_UTILITY SCHEME_OBJECT
-DEFUN (compiled_entry_to_block,
- (entry),
- SCHEME_OBJECT entry)
+SCHEME_OBJECT
+make_linkage_section_marker (linkage_section_type_t type, unsigned long count)
{
- SCHEME_OBJECT *block_address;
+ unsigned long n_words;
- Get_Compiled_Block (block_address, (OBJECT_ADDRESS (entry)));
- return (MAKE_CC_BLOCK (block_address));
+ assert (type < N_LINKAGE_SECTION_TYPES);
+ n_words
+ = (((type == LINKAGE_SECTION_TYPE_OPERATOR)
+ || (type == LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR))
+ ? (UUO_COUNT_TO_WORDS (count))
+ : count);
+ assert (n_words < 0x10000);
+ return (MAKE_OBJECT (TC_LINKAGE_SECTION,
+ ((((unsigned long) (type)) << 16) | n_words)));
}
\f
-/* Returns the offset from the block to the entry point. */
+/* Procedures to destructure compiled entries and closures. */
-#ifndef CC_BLOCK_DISTANCE
+/* Returns the debugging information attached to 'block'. Usually
+ this is a string that contains the filename where the debugging
+ info is stored. */
-#define CC_BLOCK_DISTANCE(block,entry) \
- (((char *) (entry)) - ((char *) (block)))
+SCHEME_OBJECT
+cc_block_debugging_info (SCHEME_OBJECT block)
+{
+ return (VECTOR_REF (block, ((VECTOR_LENGTH (block)) - 2)));
+}
-#endif /* CC_BLOCK_DISTANCE */
+/* Returns the environment where 'block' was evaluated. */
-C_UTILITY long
-DEFUN (compiled_entry_to_block_offset,
- (entry),
- SCHEME_OBJECT entry)
+SCHEME_OBJECT
+cc_block_environment (SCHEME_OBJECT block)
{
- SCHEME_OBJECT *entry_address, *block_address;
+ return (VECTOR_REF (block, ((VECTOR_LENGTH (block)) - 1)));
+}
- entry_address = (OBJECT_ADDRESS (entry));
- Get_Compiled_Block (block_address, entry_address);
- return (CC_BLOCK_DISTANCE (block_address, entry_address));
+unsigned long
+cc_entry_to_block_offset (SCHEME_OBJECT entry)
+{
+ return ((CC_ENTRY_ADDRESS (entry))
+ - ((insn_t *) (cc_entry_to_block_address (entry))));
}
-/*
- Check whether the compiled code block whose address is `block_addr'
- is a compiled closure block.
- */
-
-static long
-DEFUN (block_address_closure_p,
- (block_addr),
- SCHEME_OBJECT * block_addr)
+bool
+cc_block_closure_p (SCHEME_OBJECT block)
{
- SCHEME_OBJECT header_word;
-
- header_word = (*block_addr);
- return (((OBJECT_TYPE (header_word)) == TC_MANIFEST_CLOSURE));
+ return (cc_block_address_closure_p (OBJECT_ADDRESS (block)));
}
-/*
- Check whether the compiled code block `block' is a compiled closure block.
- */
-
-C_UTILITY long
-DEFUN (compiled_block_closure_p,
- (block),
- SCHEME_OBJECT block)
+bool
+cc_entry_closure_p (SCHEME_OBJECT entry)
{
- return (block_address_closure_p (OBJECT_ADDRESS (block)));
+ return (cc_block_address_closure_p (cc_entry_to_block_address (entry)));
}
-/*
- Check whether the compiled entry point `entry' is a compiled closure.
- */
-
-C_UTILITY long
-DEFUN (compiled_entry_closure_p,
- (entry),
- SCHEME_OBJECT entry)
+static bool
+cc_block_address_closure_p (SCHEME_OBJECT * block_addr)
{
- return (block_address_closure_p (compiled_entry_to_block_address (entry)));
+ SCHEME_OBJECT header_word = (*block_addr);
+ return (((OBJECT_TYPE (header_word)) == TC_MANIFEST_CLOSURE));
}
-/*
- Extract the entry point ultimately invoked by the compiled closure
- represented by `entry'.
- */
+/* Return the entry point ultimately invoked by the compiled closure
+ 'entry'. */
-C_UTILITY SCHEME_OBJECT
-DEFUN (compiled_closure_to_entry,
- (entry),
- SCHEME_OBJECT entry)
+SCHEME_OBJECT
+cc_closure_to_entry (SCHEME_OBJECT entry)
{
- SCHEME_OBJECT real_entry;
-
- EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry, (OBJECT_ADDRESS (entry)));
- return (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (real_entry)));
+ return (compiled_closure_entry_to_target (CC_ENTRY_ADDRESS (entry)));
}
\f
-/*
- Store the information for `entry' into `buffer'.
- This is used by the printer and debugging utilities.
- */
-
-/* Kinds and subkinds of entries. */
-
-#define KIND_PROCEDURE 0
-#define KIND_CONTINUATION 1
-#define KIND_EXPRESSION 2
-#define KIND_OTHER 3
-#define KIND_ILLEGAL 4
-
-/* Continuation subtypes */
-
-#define CONTINUATION_NORMAL 0
-#define CONTINUATION_DYNAMIC_LINK 1
-#define CONTINUATION_RETURN_TO_INTERPRETER 2
-
-/* Other subtypes */
-
-#define OTHER_CLOSURE 0
-#define OTHER_RANDOM 1
-
-C_UTILITY void
-DEFUN (compiled_entry_type,
- (entry, buffer),
- SCHEME_OBJECT entry AND long * buffer)
-{
- long kind, min_arity, max_arity, field1, field2;
- SCHEME_OBJECT * entry_address;
-
- entry_address = (OBJECT_ADDRESS (entry));
- max_arity = (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address));
- min_arity = (COMPILED_ENTRY_MINIMUM_ARITY (entry_address));
- field1 = min_arity;
- field2 = max_arity;
- if (min_arity >= 0)
- kind = KIND_PROCEDURE;
- else if (max_arity >= 0)
- kind = KIND_ILLEGAL;
- else if ((((unsigned long) max_arity) & 0xff) < 0xe0)
- {
- /* Field2 is the offset to the next continuation */
-
- kind = KIND_CONTINUATION;
- field1 = CONTINUATION_NORMAL;
- field2 = (((((unsigned long) max_arity) & 0x3f) << 7)
- | (((unsigned long) min_arity) & 0x7f));
- }
- else if (min_arity != -1)
- kind = KIND_ILLEGAL;
-\f
- else
- {
- switch (((unsigned long) max_arity) & 0xff)
- {
- case FORMAT_BYTE_EXPR:
- {
- kind = KIND_EXPRESSION;
- break;
- }
- case FORMAT_BYTE_CLOSURE:
- {
- kind = KIND_OTHER;
- field1 = OTHER_CLOSURE;
- break;
- }
- case FORMAT_BYTE_COMPLR:
- case FORMAT_BYTE_CMPINT:
- {
- kind = KIND_OTHER;
- field1 = OTHER_RANDOM;
- break;
- }
- case FORMAT_BYTE_DLINK:
- {
- kind = KIND_CONTINUATION;
- field1 = CONTINUATION_DYNAMIC_LINK;
- field2 = -1;
- break;
- }
- case FORMAT_BYTE_RETURN:
- {
- kind = KIND_CONTINUATION;
- field1 = CONTINUATION_RETURN_TO_INTERPRETER;
- field2 = ((long) (entry != return_to_interpreter));
- break;
- }
- default:
- {
- kind = KIND_ILLEGAL;
- break;
- }
- }
- }
- buffer[0] = kind;
- buffer[1] = field1;
- buffer[2] = field2;
-}
-
void
-DEFUN (declare_compiled_code_block, (block), SCHEME_OBJECT block)
+declare_compiled_code_block (SCHEME_OBJECT block)
{
#ifdef PUSH_D_CACHE_REGION
- SCHEME_OBJECT * block_addr = (OBJECT_ADDRESS (block));
- PUSH_D_CACHE_REGION (block_addr, (1+ (OBJECT_DATUM (* block_addr))));
+ PUSH_D_CACHE_REGION ((OBJECT_ADDRESS (block)), (CC_BLOCK_END (block)));
#endif
}
-\f
-/* Destructuring free variable caches. */
-
-C_UTILITY void
-DEFUN (store_variable_cache,
- (extension, block, offset),
- SCHEME_OBJECT extension AND SCHEME_OBJECT block
- AND long offset)
-{
- FAST_MEMORY_SET (block, offset,
- ((SCHEME_OBJECT)
- (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (extension)))));
-}
-C_UTILITY SCHEME_OBJECT
-DEFUN (extract_variable_cache,
- (block, offset),
- SCHEME_OBJECT block AND long offset)
+void
+write_variable_cache (SCHEME_OBJECT cache,
+ SCHEME_OBJECT block,
+ unsigned long offset)
{
- return (MAKE_POINTER_OBJECT (CACHE_TYPE,
- ((SCHEME_OBJECT *)
- (SCHEME_ADDR_TO_ADDR
- (FAST_MEMORY_REF (block, offset))))));
+ MEMORY_SET (block, offset, ((SCHEME_OBJECT) (OBJECT_ADDRESS (cache))));
}
/* Get a compiled procedure from a cached operator reference. */
-C_UTILITY SCHEME_OBJECT
-DEFUN (extract_uuo_link,
- (block, offset),
- SCHEME_OBJECT block AND long offset)
+SCHEME_OBJECT
+read_uuo_link (SCHEME_OBJECT block, unsigned long offset)
{
- SCHEME_OBJECT * cache_address, compiled_entry_address;
-
- cache_address = (MEMORY_LOC (block, offset));
- EXTRACT_EXECUTE_CACHE_ADDRESS (compiled_entry_address, cache_address);
- return (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (compiled_entry_address)));
+ return
+ (MAKE_CC_ENTRY (read_uuo_target_no_reloc (MEMORY_LOC (block, offset))));
}
static void
-DEFUN (store_uuo_link,
- (entry, cache_address),
- SCHEME_OBJECT entry AND SCHEME_OBJECT * cache_address)
+write_uuo_link (SCHEME_OBJECT target, SCHEME_OBJECT * cache_address)
{
- SCHEME_OBJECT * entry_address;
-
- entry_address = (OBJECT_ADDRESS (entry));
- STORE_EXECUTE_CACHE_CODE (cache_address);
- STORE_EXECUTE_CACHE_ADDRESS (cache_address,
- (ADDR_TO_SCHEME_ADDR (entry_address)));
+ write_uuo_target ((CC_ENTRY_ADDRESS (target)), cache_address);
#ifdef FLUSH_I_CACHE_REGION
if (!linking_cc_block_p)
{
/* The linker will flush the whole region afterwards. */
- FLUSH_I_CACHE_REGION (cache_address, EXECUTE_CACHE_ENTRY_SIZE);
+ FLUSH_I_CACHE_REGION (cache_address, UUO_LINK_SIZE);
}
#endif
}
-\f
-/* This makes a fake compiled procedure which traps to kind handler when
- invoked.
- */
-
-#define TRAMPOLINE_SIZE (TRAMPOLINE_ENTRY_SIZE + 2)
-
-/* Enabled so that the profiler can distinguish trampolines */
-#if 1 || defined(AUTOCLOBBER_BUG)
-# define TC_TRAMPOLINE_HEADER TC_FIXNUM
-#else
-# define TC_TRAMPOLINE_HEADER TC_MANIFEST_VECTOR
-#endif
-
-static void
-DEFUN (fill_trampoline,
- (block, entry_point, fmt_word, kind),
- SCHEME_OBJECT * block
- AND instruction * entry_point
- AND format_word fmt_word
- AND long kind)
+SCHEME_OBJECT *
+compiled_closure_objects (SCHEME_OBJECT * block)
{
- (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word;
- (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
- (MAKE_OFFSET_WORD (entry_point, block, false));
- STORE_TRAMPOLINE_ENTRY (entry_point, kind);
- return;
-}
+ insn_t * start = (compiled_closure_start (block));
+ unsigned long count = (compiled_closure_count (block));
-static long
-DEFUN (make_trampoline,
- (slot, fmt_word, kind, size, value1, value2, value3),
- SCHEME_OBJECT * slot
- AND format_word fmt_word
- AND long kind AND long size
- AND SCHEME_OBJECT value1 AND SCHEME_OBJECT value2
- AND SCHEME_OBJECT value3)
-{
- instruction * entry_point;
- SCHEME_OBJECT * ptr;
-
- if (GC_Check (TRAMPOLINE_SIZE + size))
- {
- Request_GC (TRAMPOLINE_SIZE + size);
- return (PRIM_INTERRUPT);
- }
+ /* Skip to end of entries. */
+ while (count > 0)
+ {
+ start = (compiled_closure_next (start));
+ count -= 1;
+ }
- ptr = Free;
- Free += (TRAMPOLINE_SIZE + size);
- ptr[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER,
- ((TRAMPOLINE_SIZE - 1) + size)));
- ptr[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- TRAMPOLINE_ENTRY_SIZE));
- entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (ptr)));
- fill_trampoline (ptr, entry_point, fmt_word, kind);
- *slot = (ENTRY_TO_OBJECT (entry_point));
- ptr = (TRAMPOLINE_STORAGE (entry_point));
- if ((--size) >= 0)
- *ptr++ = value1;
- if ((--size) >= 0)
- *ptr++ = value2;
- if ((--size) >= 0)
- *ptr++ = value3;
- return (PRIM_DONE);
+ /* Skip to first object. */
+ return (skip_compiled_closure_padding (start));
}
\f
-/* Standard trampolines. */
-
-static long
-DEFUN (make_redirection_trampoline,
- (slot, kind, procedure),
- SCHEME_OBJECT * slot AND long kind AND SCHEME_OBJECT procedure)
+bool
+decode_old_style_format_word (cc_entry_type_t * cet, uint16_t fw)
{
- return (make_trampoline (slot,
- ((format_word) FORMAT_WORD_CMPINT),
- kind,
- 1,
- procedure,
- SHARP_F,
- SHARP_F));
-}
+ uint16_t low = (fw & 0x00FF);
+ uint16_t high = ((fw & 0xFF00) >> 8);
+ bool rest_p = false;
-static long
-DEFUN (make_apply_trampoline,
- (slot, kind, procedure, nactuals),
- SCHEME_OBJECT * slot AND long kind
- AND SCHEME_OBJECT procedure AND long nactuals)
-{
- return (make_trampoline (slot,
- ((format_word) FORMAT_WORD_CMPINT),
- kind,
- 2,
- procedure,
- (LONG_TO_UNSIGNED_FIXNUM (nactuals)),
- SHARP_F));
-}
-
-#define TRAMPOLINE_TABLE_SIZE 4
-
-static long
-trampoline_arity_table[TRAMPOLINE_TABLE_SIZE * TRAMPOLINE_TABLE_SIZE] =
-{
- TRAMPOLINE_K_1_0, /* 1_0 */
- TRAMPOLINE_K_ARITY, /* 1_1 should not get here */
- TRAMPOLINE_K_ARITY, /* 1_2 should not get here */
- TRAMPOLINE_K_ARITY, /* 1_3 should not get here */
- TRAMPOLINE_K_2_0, /* 2_0 */
- TRAMPOLINE_K_2_1, /* 2_1 */
- TRAMPOLINE_K_ARITY, /* 2_2 should not get here */
- TRAMPOLINE_K_ARITY, /* 2_3 should not get here */
- TRAMPOLINE_K_3_0, /* 3_0 */
- TRAMPOLINE_K_3_1, /* 3_1 */
- TRAMPOLINE_K_3_2, /* 3_2 */
- TRAMPOLINE_K_ARITY, /* 3_3 should not get here */
- TRAMPOLINE_K_4_0, /* 4_0 */
- TRAMPOLINE_K_4_1, /* 4_1 */
- TRAMPOLINE_K_4_2, /* 4_2 */
- TRAMPOLINE_K_4_3 /* 4_3 */
-};
-\f
-/*
- make_uuo_link is called by C and initializes a compiled procedure
- cache at a location given by a block and an offset.
-
- make_uuo_link checks its procedure argument, and:
-
- - If it is not a compiled procedure, an entity, or a primitive
- procedure with a matching number of arguments, it stores a fake
- compiled procedure which will invoke comutil_operator_interpreted_trap
- when invoked.
-
- - If its argument is an entity, it stores a fake compiled procedure
- which will invoke comutil_operator_entity_trap when invoked.
-
- - If its argument is a primitive, it stores a fake compiled procedure
- which will invoke comutil_operator_primitive_trap, or
- comutil_operator_lexpr_trap when invoked.
-
- - If its argument is a compiled procedure that expects more or
- less arguments than those provided, it stores a fake compiled
- procedure which will invoke comutil_operator_arity_trap, or one of
- its specialized versions when invoked.
-
- - Otherwise, the actual (compatible) operator is stored.
-*/
-
-C_UTILITY long
-DEFUN (make_uuo_link,
- (procedure, extension, block, offset),
- SCHEME_OBJECT procedure AND SCHEME_OBJECT extension
- AND SCHEME_OBJECT block AND long offset)
-{
- long kind, result;
- unsigned long nactuals;
- SCHEME_OBJECT orig_proc, trampoline, *cache_address;
-
- cache_address = (MEMORY_LOC (block, offset));
- EXTRACT_EXECUTE_CACHE_ARITY (nactuals, cache_address);
- /* nactuals >= 0 */
-
- orig_proc = procedure;
-loop:
- switch (OBJECT_TYPE (procedure))
- {
- case TC_COMPILED_ENTRY:
+ if (high < 0x80)
{
- SCHEME_OBJECT * entry;
- long nmin, nmax;
-
- entry = (OBJECT_ADDRESS (procedure));
- nmax = (COMPILED_ENTRY_MAXIMUM_ARITY (entry));
- if (((long) nactuals) == nmax)
- {
- store_uuo_link (procedure, cache_address);
- return (PRIM_DONE);
- }
- nmin = (COMPILED_ENTRY_MINIMUM_ARITY (entry));
- if ((nmax > 1) && (nmin > 0) && (nmin <= ((long) nactuals)) &&
- (nactuals <= TRAMPOLINE_TABLE_SIZE) &&
- (nmax <= (TRAMPOLINE_TABLE_SIZE + 1)))
- {
- kind = (trampoline_arity_table[((nmax - 2) * TRAMPOLINE_TABLE_SIZE) +
- (nactuals - 1)]);
- /* Paranoia */
- if (kind != TRAMPOLINE_K_ARITY)
+ if ((high == 0x00)
+ || (low == 0x00)
+ || (low == 0x80))
+ return (true);
+ if (low > 0x80)
{
- nactuals = 0;
- break;
+ low = (0xFF - low);
+ rest_p = true;
}
- }
- kind = TRAMPOLINE_K_ARITY;
- break;
+ if (! (high <= low))
+ return (true);
+ make_compiled_procedure_type (cet, (high - 1), (low - high), rest_p);
+ return (false);
}
-
- case TC_ENTITY:
+ if (low < 0x80)
+ return (true);
+ if (low < 0xE0)
{
- SCHEME_OBJECT data;
-
- data = (MEMORY_REF (procedure, ENTITY_DATA));
- if ((VECTOR_P (data))
- && (nactuals < (VECTOR_LENGTH (data)))
- && ((VECTOR_REF (data, nactuals)) != SHARP_F)
- && ((VECTOR_REF (data, 0))
- == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
- {
- /* No loops allowed! */
- SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals));
-
- if ((procedure == orig_proc) && (nproc != procedure))
- {
- procedure = nproc;
- goto loop;
- }
- else
- procedure = orig_proc;
- }
- kind = TRAMPOLINE_K_ENTITY;
- break;
+ make_compiled_continuation_type
+ (cet,
+ (((low & 0x7F) << 7) | (high & 0x7F)));
+ return (false);
}
-
- case TC_PRIMITIVE:
+ if (high != 0xFF)
+ return (true);
+ switch (low)
{
- long arity;
-
- arity = (PRIMITIVE_ARITY (procedure));
- if (arity == ((long) (nactuals - 1)))
- {
- nactuals = 0;
- kind = TRAMPOLINE_K_PRIMITIVE;
- }
- else if (arity == LEXPR_PRIMITIVE_ARITY)
- kind = TRAMPOLINE_K_LEXPR_PRIMITIVE;
- else
- kind = TRAMPOLINE_K_OTHER;
+ case 0xFF:
+ make_cc_entry_type (cet, CET_EXPRESSION);
break;
- }
-
- case TC_PROCEDURE: /* and some others... */
- default:
- /* uuo_link_interpreted: */
- {
- kind = TRAMPOLINE_K_INTERPRETED;
+ case 0xFE:
+ make_cc_entry_type (cet, CET_INTERNAL_PROCEDURE);
+ break;
+ case 0xFD:
+ make_cc_entry_type (cet, CET_TRAMPOLINE);
+ break;
+ case 0xFC:
+ make_cc_entry_type (cet, CET_INTERNAL_CONTINUATION);
+ break;
+ case 0xFB:
+ make_cc_entry_type (cet, CET_RETURN_TO_INTERPRETER);
+ break;
+ case 0xFA:
+ make_cc_entry_type (cet, CET_CLOSURE);
break;
+ default:
+ return (true);
}
- }
- if (nactuals == 0)
- result = (make_redirection_trampoline (&trampoline, kind, procedure));
- else
- result = (make_apply_trampoline (&trampoline, kind, procedure, nactuals));
- if (result != PRIM_DONE)
- return (result);
- store_uuo_link (trampoline, cache_address);
- return (PRIM_DONE);
+ return (false);
}
\f
-C_UTILITY long
-DEFUN (make_fake_uuo_link,
- (extension, block, offset),
- SCHEME_OBJECT extension AND SCHEME_OBJECT block AND long offset)
+bool
+encode_old_style_format_word (cc_entry_type_t * cet, uint16_t * fw_r)
{
- long result;
- SCHEME_OBJECT trampoline, *cache_address;
-
- result = (make_trampoline (&trampoline,
- ((format_word) FORMAT_WORD_CMPINT),
- TRAMPOLINE_K_LOOKUP,
- 3,
- extension,
- block,
- (LONG_TO_UNSIGNED_FIXNUM (offset))));
- if (result != PRIM_DONE)
- {
- return (result);
- }
- cache_address = (MEMORY_LOC (block, offset));
- store_uuo_link (trampoline, cache_address);
- return (PRIM_DONE);
-}
+ unsigned int low;
+ unsigned int high;
-/* C_UTILITY long fake_uuo_link_p does not appear to be used anymore */
+ switch (cet->marker)
+ {
+ case CET_PROCEDURE:
+ high = ((cet->args.for_procedure.n_required) + 1);
+ low = (high + (cet->args.for_procedure.n_optional));
+ if (! (low < 0x80))
+ return (true);
+ if (cet->args.for_procedure.rest_p)
+ low = (0xFF - low);
+ break;
-C_UTILITY long
-DEFUN (coerce_to_compiled,
- (procedure, arity, location),
- SCHEME_OBJECT procedure AND long arity AND SCHEME_OBJECT * location)
-{
- long frame_size;
+ case CET_CONTINUATION:
+ {
+ unsigned long n = (cet->args.for_continuation.offset);
+ if (! (n < 0x3000))
+ return (true);
+ high = ((n & 0x7F) | 0x80);
+ low = ((n >> 7) | 0x80);
+ }
+ break;
- frame_size = (arity + 1);
- if ((!(COMPILED_CODE_ADDRESS_P (procedure))) ||
- (((long) (COMPILED_ENTRY_MAXIMUM_ARITY (OBJECT_ADDRESS (procedure)))) !=
- frame_size))
- {
- if (frame_size > FORMAT_BYTE_FRAMEMAX)
- return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- return (make_trampoline (location,
- ((format_word)
- (MAKE_FORMAT_WORD (frame_size, frame_size))),
- TRAMPOLINE_K_APPLY,
- 2,
- procedure,
- (LONG_TO_UNSIGNED_FIXNUM (frame_size)),
- SHARP_F));
- }
- (*location) = procedure;
- return (PRIM_DONE);
-}
-\f
-#ifndef HAVE_BKPT_SUPPORT
+ case CET_EXPRESSION:
+ low = 0xFF;
+ high = 0xFF;
+ break;
-C_UTILITY SCHEME_OBJECT
-DEFUN (bkpt_install, (ep), PTR ep)
-{
- return (SHARP_F);
-}
+ case CET_INTERNAL_PROCEDURE:
+ low = 0xFE;
+ high = 0xFF;
+ break;
-C_UTILITY SCHEME_OBJECT
-DEFUN (bkpt_closure_install, (ep), PTR ep)
-{
- return (SHARP_F);
-}
+ case CET_TRAMPOLINE:
+ low = 0xFD;
+ high = 0xFF;
+ break;
-C_UTILITY void
-DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle)
-{
- error_external_return ();
-}
+ case CET_INTERNAL_CONTINUATION:
+ low = 0xFC;
+ high = 0xFF;
+ break;
-C_UTILITY Boolean
-DEFUN (bkpt_p, (ep), PTR ep)
-{
- return (FALSE);
-}
+ case CET_RETURN_TO_INTERPRETER:
+ low = 0xFB;
+ high = 0xFF;
+ break;
-C_UTILITY SCHEME_OBJECT
-DEFUN (bkpt_proceed, (ep, handle, state),
- PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
-{
- error_external_return ();
- return (UNSPECIFIC);
-}
+ case CET_CLOSURE:
+ low = 0xFA;
+ high = 0xFF;
+ break;
-C_UTILITY PTR
-DEFUN (do_bkpt_proceed, (value), unsigned long * value)
-{
- * value = ((unsigned long) ERR_EXTERNAL_RETURN);
- return (FALSE);
+ default:
+ return (true);
+ }
+ (*fw_r) = ((high << 8) | low);
+ return (false);
}
+\f
+/* Trampolines
-#else /* HAVE_BKPT_SUPPORT */
-
-#define BKPT_PROCEED_FRAME_SIZE 3
+ When a free variable appears in operator position in compiled code,
+ there must be a directly callable procedure in the corresponding
+ UUO cell. If, at link time, there is no appropriate value for the
+ free variable, a fake compiled Scheme procedure that calls one of
+ these procedures will be placed into the cell instead.
+
+ The trampolines themselves are made by 'make_uuo_link',
+ 'make_fake_uuo_link', and 'coerce_to_compiled'. The trampoline
+ looks like a Scheme closure, containing some code that jumps to one
+ of these procedures, and additional information to be used by the
+ procedure.
-C_UTILITY SCHEME_OBJECT
-DEFUN (bkpt_proceed, (ep, handle, state),
- PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
-{
- if ((! (COMPILED_CODE_ADDRESS_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE))))
- || ((OBJECT_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE)))
- != ((SCHEME_OBJECT *) ep)))
- error_external_return ();
+ These procedures expect a single argument, the address of the
+ information block where they can find the relevant data: typically
+ the procedure to invoke and the number of arguments to invoke it
+ with. */
- STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT);
- STACK_PUSH (reflect_to_interface);
- sp_register = (STACK_LOC (- BKPT_PROCEED_FRAME_SIZE));
- return (SHARP_F);
-}
-#endif /* HAVE_BKPT_SUPPORT */
-\f
-DEFINE_SCHEME_UTILITY_2 (comutil_compiled_code_bkpt,
- entry_point_raw, state_raw)
-{
- long type_info[3];
- instruction * entry_point_a
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
- SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a));
- SCHEME_OBJECT state;
- SCHEME_OBJECT stack_ptr;
+#define DEFINE_TRAMPOLINE(pname) \
+DEFINE_SCHEME_UTILITY_1 (pname, TRAMP_store)
- STACK_PUSH (entry_point); /* return address */
+#define INIT_TRAMPOLINE_1(av1) \
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \
+ SCHEME_OBJECT av1 = (TRAMP_store[0])
- /* Potential bug: This does not preserve the environment for
- IC procedures. There is no way to tell that we have
- an IC procedure in our hands. It is not safe to preserve
- it in general because the contents of the register may
- be stale (predate the last GC).
- However, the compiler no longer generates IC procedures, and
- will probably never do it again.
- */
+#define INIT_TRAMPOLINE_2(av1, av2) \
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \
+ SCHEME_OBJECT av1 = (TRAMP_store[0]); \
+ SCHEME_OBJECT av2 = (TRAMP_store[1])
- compiled_entry_type (entry_point, &type_info[0]);
- if ((type_info[0] == KIND_OTHER) && (type_info[1] == OTHER_CLOSURE))
- {
- entry_point_a = ((instruction *) (SCHEME_ADDR_TO_ADDR (state_raw)));
- state = (ENTRY_TO_OBJECT (entry_point_a));
- }
- else if (type_info[0] != KIND_CONTINUATION)
- state = SHARP_F;
- else if (type_info[1] == CONTINUATION_DYNAMIC_LINK)
- state = (MAKE_POINTER_OBJECT
- (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (state_raw))));
- else
- state = val_register;
+#define INIT_TRAMPOLINE_3(av1, av2, av3) \
+ DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \
+ SCHEME_OBJECT av1 = (TRAMP_store[0]); \
+ SCHEME_OBJECT av2 = (TRAMP_store[1]); \
+ SCHEME_OBJECT av3 = (TRAMP_store[2])
- stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, sp_register));
- STACK_PUSH (state); /* state to preserve */
- STACK_PUSH (stack_ptr); /* "Environment" pointer */
- STACK_PUSH (entry_point); /* argument to handler */
- TAIL_CALL_2
- (comutil_apply, (Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)), 4);
-}
+/* This is how compiled Scheme code normally returns back to the
+ Scheme interpreter. It is invoked by a trampoline, which passes
+ the address of the (empty) trampoline storage block to it. */
-DEFINE_SCHEME_UTILITY_1 (comutil_compiled_closure_bkpt, entry_point_raw)
+DEFINE_TRAMPOLINE (comutil_return_to_interpreter)
{
- instruction * entry_point_a
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
- SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a));
- SCHEME_OBJECT stack_ptr;
-
- STACK_PUSH (entry_point); /* return address */
-
- stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, sp_register));
- STACK_PUSH (SHARP_F); /* state to preserve */
- STACK_PUSH (stack_ptr); /* "Environment" pointer */
- STACK_PUSH (entry_point); /* argument to handler */
- TAIL_CALL_2
- (comutil_apply, (Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)), 4);
+ RETURN_TO_C (PRIM_DONE);
}
\f
-DEFINE_SCHEME_UTILITY_1 (comutil_reflect_to_interface, tramp_data_raw)
+DEFINE_TRAMPOLINE (comutil_reflect_to_interface)
{
SCHEME_OBJECT code = (STACK_POP ());
switch (OBJECT_DATUM (code))
- {
- case REFLECT_CODE_INTERNAL_APPLY:
{
- long frame_size = (OBJECT_DATUM (STACK_POP ()));
- SCHEME_OBJECT procedure = (STACK_POP ());
- TAIL_CALL_2 (comutil_apply, procedure, frame_size);
- }
+ case REFLECT_CODE_INTERNAL_APPLY:
+ {
+ unsigned long frame_size = (OBJECT_DATUM (STACK_POP ()));
+ SCHEME_OBJECT procedure = (STACK_POP ());
+ TAIL_CALL_2 (comutil_apply, procedure, frame_size);
+ }
case REFLECT_CODE_RESTORE_INTERRUPT_MASK:
- {
SET_INTERRUPT_MASK (OBJECT_DATUM (STACK_POP ()));
INVOKE_RETURN_ADDRESS ();
- }
case REFLECT_CODE_STACK_MARKER:
- {
(void) STACK_POP (); /* marker1 */
(void) STACK_POP (); /* marker2 */
INVOKE_RETURN_ADDRESS ();
- }
case REFLECT_CODE_CC_BKPT:
- {
- unsigned long value;
-
/* Attempt to process interrupts before really proceeding. */
-
- if (((long) (ADDR_TO_SCHEME_ADDR (Free)))
- >= ((long) (Registers[REGBLOCK_MEMTOP])))
+ if (Free >= GET_MEMTOP)
+ {
+ PUSH_REFLECTION (REFLECT_CODE_CC_BKPT);
+ compiler_interrupt_common (DSU_result, 0, SHARP_F);
+ return;
+ }
{
- STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT);
- STACK_PUSH (reflect_to_interface);
- COMPILER_INTERRUPT_COMMON (0, SHARP_F);
+ insn_t * addr;
+ long code = (do_bkpt_proceed (&addr));
+ if (code != PRIM_DONE)
+ {
+ STACK_PUSH (code);
+ RETURN_TO_C (code);
+ }
+ RETURN_TO_SCHEME (addr);
}
- if (do_bkpt_proceed (& value))
- RETURN_TO_SCHEME (value);
- else
- RETURN_TO_C (value);
- }
-
default:
STACK_PUSH (code);
RETURN_TO_C (ERR_EXTERNAL_RETURN);
- }
-}
-\f
-/*
- Utility table used by the assembly language interface to invoke
- the SCHEME_UTILITY procedures that appear in this file.
-
- Important: Do NOT reorder this table without changing the indices
- defined on the following page and the corresponding table in the
- compiler.
-
- In addition, this table must be declared before compiler_reset_internal.
- */
-
-#define UTE(name) ((utility_table_entry) name)
-
-utility_table_entry utility_table[] =
-{
- UTE(comutil_return_to_interpreter), /* 0x0 */
- UTE(comutil_operator_apply_trap), /* 0x1 */
- UTE(comutil_operator_arity_trap), /* 0x2 */
- UTE(comutil_operator_entity_trap), /* 0x3 */
- UTE(comutil_operator_interpreted_trap), /* 0x4 */
- UTE(comutil_operator_lexpr_trap), /* 0x5 */
- UTE(comutil_operator_primitive_trap), /* 0x6 */
- UTE(comutil_operator_lookup_trap), /* 0x7 */
- UTE(comutil_operator_1_0_trap), /* 0x8 */
- UTE(comutil_operator_2_1_trap), /* 0x9 */
- UTE(comutil_operator_2_0_trap), /* 0xa */
- UTE(comutil_operator_3_2_trap), /* 0xb */
- UTE(comutil_operator_3_1_trap), /* 0xc */
- UTE(comutil_operator_3_0_trap), /* 0xd */
- UTE(comutil_operator_4_3_trap), /* 0xe */
- UTE(comutil_operator_4_2_trap), /* 0xf */
- UTE(comutil_operator_4_1_trap), /* 0x10 */
- UTE(comutil_operator_4_0_trap), /* 0x11 */
- UTE(comutil_primitive_apply), /* 0x12 */
- UTE(comutil_primitive_lexpr_apply), /* 0x13 */
- UTE(comutil_apply), /* 0x14 */
- UTE(comutil_error), /* 0x15 */
- UTE(comutil_lexpr_apply), /* 0x16 */
- UTE(comutil_link), /* 0x17 */
- UTE(comutil_interrupt_closure), /* 0x18 */
- UTE(comutil_interrupt_dlink), /* 0x19 */
- UTE(comutil_interrupt_procedure), /* 0x1a */
- UTE(comutil_interrupt_continuation), /* 0x1b */
- UTE(comutil_interrupt_ic_procedure), /* 0x1c */
- UTE(comutil_assignment_trap), /* 0x1d */
- UTE(comutil_cache_lookup_apply), /* 0x1e */
- UTE(comutil_lookup_trap), /* 0x1f */
- UTE(comutil_safe_lookup_trap), /* 0x20 */
- UTE(comutil_unassigned_p_trap), /* 0x21 */
- UTE(comutil_decrement), /* 0x22 */
- UTE(comutil_divide), /* 0x23 */
- UTE(comutil_equal), /* 0x24 */
- UTE(comutil_greater), /* 0x25 */
- UTE(comutil_increment), /* 0x26 */
- UTE(comutil_less), /* 0x27 */
- UTE(comutil_minus), /* 0x28 */
- UTE(comutil_multiply), /* 0x29 */
- UTE(comutil_negative), /* 0x2a */
- UTE(comutil_plus), /* 0x2b */
- UTE(comutil_positive), /* 0x2c */
- UTE(comutil_zero), /* 0x2d */
- UTE(comutil_access), /* 0x2e */
- UTE(comutil_reference), /* 0x2f */
- UTE(comutil_safe_reference), /* 0x30 */
- UTE(comutil_unassigned_p), /* 0x31 */
- UTE(comutil_unbound_p), /* 0x32 */
- UTE(comutil_assignment), /* 0x33 */
- UTE(comutil_definition), /* 0x34 */
- UTE(comutil_lookup_apply), /* 0x35 */
- UTE(comutil_primitive_error), /* 0x36 */
- UTE(comutil_quotient), /* 0x37 */
- UTE(comutil_remainder), /* 0x38 */
- UTE(comutil_modulo), /* 0x39 */
- UTE(comutil_reflect_to_interface), /* 0x3a */
- UTE(comutil_interrupt_continuation_2), /* 0x3b */
- UTE(comutil_compiled_code_bkpt), /* 0x3c */
- UTE(comutil_compiled_closure_bkpt) /* 0x3d */
- };
-
-extern long MAX_TRAMPOLINE;
-long MAX_TRAMPOLINE = ((sizeof (utility_table))
- / (sizeof (utility_table_entry)));
-\f
-/* Support for trap handling. */
-
-static void
-DEFUN_VOID (end_of_utils)
-{
- return;
-}
-
-struct util_descriptor_s
-{
- PTR pc;
- char * name;
-};
-
-#ifdef STDC_HEADERS
-# define UTLD(name) { ((PTR) name), #name }
-#else
-/* Hope that this works. */
-# define UTLD(name) { ((PTR) name), "name" }
-#endif
-
-static
-struct util_descriptor_s utility_descriptor_table[] =
-{
-#ifdef DECLARE_CMPINTMD_UTILITIES
- DECLARE_CMPINTMD_UTILITIES(),
-#endif /* DECLARE_CMPINTMD_UTILITIES */
- UTLD(C_to_interface),
- UTLD(open_gap),
- UTLD(setup_lexpr_invocation),
- UTLD(setup_compiled_invocation),
- UTLD(enter_compiled_expression),
- UTLD(apply_compiled_procedure),
- UTLD(return_to_compiled_code),
- UTLD(apply_compiled_from_primitive),
- UTLD(compiled_with_interrupt_mask),
- UTLD(compiled_with_stack_marker),
- UTLD(comutil_return_to_interpreter),
- UTLD(comutil_primitive_apply),
- UTLD(comutil_primitive_lexpr_apply),
- UTLD(comutil_apply),
- UTLD(comutil_error),
- UTLD(comutil_lexpr_apply),
- UTLD(abort_link_cc_block),
- UTLD(link_cc_block),
- UTLD(comutil_link),
- UTLD(comp_link_caches_restart),
- UTLD(comutil_operator_apply_trap),
- UTLD(comutil_operator_arity_trap),
- UTLD(comutil_operator_entity_trap),
- UTLD(comutil_operator_interpreted_trap),
- UTLD(comutil_operator_lexpr_trap),
- UTLD(comutil_operator_primitive_trap),
- UTLD(comutil_operator_lookup_trap),
- UTLD(comp_op_lookup_trap_restart),
- UTLD(comutil_operator_1_0_trap),
- UTLD(comutil_operator_2_1_trap),
- UTLD(comutil_operator_2_0_trap),
- UTLD(comutil_operator_3_2_trap),
- UTLD(comutil_operator_3_1_trap),
- UTLD(comutil_operator_3_0_trap),
- UTLD(comutil_operator_4_3_trap),
- UTLD(comutil_operator_4_2_trap),
- UTLD(comutil_operator_4_1_trap),
- UTLD(comutil_operator_4_0_trap),
- UTLD(compiler_interrupt_common),
- UTLD(comutil_interrupt_closure),
- UTLD(comutil_interrupt_dlink),
- UTLD(comutil_interrupt_procedure),
- UTLD(comutil_interrupt_continuation),
- UTLD(comutil_interrupt_ic_procedure),
- UTLD(comutil_interrupt_continuation_2),
- UTLD(comp_interrupt_restart),
-\f
- UTLD(comutil_assignment_trap),
- UTLD(comp_assignment_trap_restart),
- UTLD(comutil_cache_lookup_apply),
- UTLD(comp_cache_lookup_apply_restart),
- UTLD(comutil_lookup_trap),
- UTLD(comp_lookup_trap_restart),
- UTLD(comutil_safe_lookup_trap),
- UTLD(comp_safe_lookup_trap_restart),
- UTLD(comutil_unassigned_p_trap),
- UTLD(comp_unassigned_p_trap_restart),
- UTLD(comutil_decrement),
- UTLD(comutil_divide),
- UTLD(comutil_equal),
- UTLD(comutil_greater),
- UTLD(comutil_increment),
- UTLD(comutil_less),
- UTLD(comutil_minus),
- UTLD(comutil_modulo),
- UTLD(comutil_multiply),
- UTLD(comutil_negative),
- UTLD(comutil_plus),
- UTLD(comutil_positive),
- UTLD(comutil_quotient),
- UTLD(comutil_remainder),
- UTLD(comutil_zero),
- UTLD(comutil_access),
- UTLD(comp_access_restart),
- UTLD(comutil_reference),
- UTLD(comp_reference_restart),
- UTLD(comutil_safe_reference),
- UTLD(comp_safe_reference_restart),
- UTLD(comutil_unassigned_p),
- UTLD(comp_unassigned_p_restart),
- UTLD(comutil_unbound_p),
- UTLD(comp_unbound_p_restart),
- UTLD(comutil_assignment),
- UTLD(comp_assignment_restart),
- UTLD(comutil_definition),
- UTLD(comp_definition_restart),
- UTLD(comutil_lookup_apply),
- UTLD(comp_lookup_apply_restart),
- UTLD(comutil_primitive_error),
- UTLD(comp_error_restart),
- UTLD(compiled_block_debugging_info),
- UTLD(compiled_block_environment),
- UTLD(compiled_entry_to_block_address),
- UTLD(compiled_entry_to_block),
- UTLD(compiled_entry_to_block_offset),
- UTLD(block_address_closure_p),
- UTLD(compiled_block_closure_p),
- UTLD(compiled_entry_closure_p),
- UTLD(compiled_closure_to_entry),
- UTLD(compiled_entry_type),
- UTLD(declare_compiled_code_block),
- UTLD(store_variable_cache),
- UTLD(extract_variable_cache),
- UTLD(extract_uuo_link),
- UTLD(store_uuo_link),
- UTLD(fill_trampoline),
- UTLD(make_trampoline),
- UTLD(make_redirection_trampoline),
- UTLD(make_apply_trampoline),
- UTLD(make_uuo_link),
- UTLD(make_fake_uuo_link),
- UTLD(coerce_to_compiled),
-#ifndef HAVE_BKPT_SUPPORT
- UTLD(bkpt_install),
- UTLD(bkpt_closure_install),
- UTLD(bkpt_remove),
- UTLD(bkpt_p),
- UTLD(do_bkpt_proceed),
-#endif
- UTLD(bkpt_proceed),
- UTLD(comutil_compiled_code_bkpt),
- UTLD(comutil_compiled_closure_bkpt),
- UTLD(comutil_reflect_to_interface),
- UTLD(end_of_utils)
-};
-\f
-extern char * EXFUN (utility_index_to_name, (int));
-extern int EXFUN (pc_to_utility_index, (unsigned long));
-
-#define UTIL_TABLE_PC_REF_REAL(index) \
- ((unsigned long) (utility_descriptor_table[index].pc))
-
-#ifndef UTIL_TABLE_PC_REF
-# define UTIL_TABLE_PC_REF(index) (UTIL_TABLE_PC_REF_REAL (index))
-#endif
-
-static int last_util_table_index =
- (((sizeof (utility_descriptor_table)) / (sizeof (struct util_descriptor_s)))
- - 1);
-
-char *
-DEFUN (utility_index_to_name, (index), int index)
-{
- if ((index < 0) || (index >= last_util_table_index))
- return ((char *) NULL);
- else
- return (utility_descriptor_table[index].name);
-}
-
-int
-DEFUN (pc_to_utility_index, (pc), unsigned long pc)
-{
- /* Binary search */
-
- extern int EXFUN (pc_to_builtin_index, (unsigned long));
-
- if ((pc < (UTIL_TABLE_PC_REF (0)))
- || (pc >= (UTIL_TABLE_PC_REF (last_util_table_index))))
- return (-1);
- else if (pc < (UTIL_TABLE_PC_REF (1)))
- return (((pc_to_builtin_index (pc)) == -1) ? 0 : -1);
- else
- {
- int low, high, middle;
-
- low = 0;
- high = last_util_table_index;
- while ((low + 1) < high)
- {
- middle = ((low + high) / 2);
- if (pc < (UTIL_TABLE_PC_REF (middle)))
- high = middle;
- else if (pc > (UTIL_TABLE_PC_REF (middle)))
- low = middle;
- else
- return (middle);
}
- return ((pc == (UTIL_TABLE_PC_REF (high))) ? high : low);
- }
}
-\f
-extern char * EXFUN (builtin_index_to_name, (int));
-extern void EXFUN (declare_builtin, (unsigned long, char *));
-extern int EXFUN (pc_to_builtin_index, (unsigned long));
-extern unsigned long * builtins;
-static int n_builtins = 0;
-static int s_builtins = 0;
-unsigned long * builtins = ((unsigned long *) NULL);
-char ** builtin_names = ((char **) NULL);
-
-void
-DEFUN (declare_builtin, (builtin, name),
- unsigned long builtin AND char * name)
-{
- if (n_builtins == s_builtins)
- {
- if (s_builtins == 0)
- {
- s_builtins = 30;
- builtins = ((unsigned long *)
- (malloc (s_builtins * (sizeof (unsigned long)))));
- builtin_names = ((char **) (malloc (s_builtins * (sizeof (char *)))));
- }
- else
- {
- s_builtins += s_builtins;
- builtins = ((unsigned long *)
- (realloc (builtins,
- (s_builtins * (sizeof (unsigned long))))));
- builtin_names = ((char **)
- (realloc (builtin_names,
- (s_builtins * (sizeof (char *))))));
- }
- if ((builtins == ((unsigned long *) NULL))
- || (builtin_names == ((char **) NULL)))
- {
- outf_fatal ("declare_builtin: malloc/realloc failed (size = %d).\n",
- s_builtins);
- termination_init_error ();
- }
- }
- {
- unsigned int low = 0;
- unsigned int high = n_builtins;
- while (1)
- {
- if (low < high)
- {
- unsigned int middle = ((low + high) / 2);
- if (builtin < (builtins[middle]))
- high = middle;
- else if (builtin > (builtins[middle]))
- low = (middle + 1);
- else
- {
- (builtin_names[middle]) = name;
- return;
- }
- }
- else
- {
- unsigned int scan = n_builtins;
- while (low < scan)
- {
- (builtins [scan]) = (builtins [scan - 1]);
- (builtin_names [scan]) = (builtin_names [scan - 1]);
- scan -= 1;
- }
- (builtins [low]) = builtin;
- (builtin_names [low]) = name;
- return;
- }
- }
- }
-}
-\f
-char *
-DEFUN (builtin_index_to_name, (index), int index)
+DEFINE_TRAMPOLINE (comutil_operator_apply_trap)
{
- if ((index < 0) || (index >= n_builtins))
- return ((char *) NULL);
- else
- return (builtin_names[index]);
+ INIT_TRAMPOLINE_2 (procedure, frame_header);
+ TAIL_CALL_2 (comutil_apply, procedure, (OBJECT_DATUM (frame_header)));
}
-int
-DEFUN (pc_to_builtin_index, (pc), unsigned long pc)
+DEFINE_TRAMPOLINE (comutil_operator_primitive_trap)
{
- /* Binary search */
-
- if ((builtins == ((unsigned long *) NULL))
- || (pc < (builtins[0]))
- || (pc >= (builtins[n_builtins - 1])))
- return (-1);
- else
- {
- int low, high, middle;
-
- low = 0;
- high = (n_builtins - 1);
- while ((low + 1) < high)
- {
- middle = ((low + high) / 2);
- if (pc < (builtins[middle]))
- high = middle;
- else if (pc > (builtins[middle]))
- low = middle;
- else
- return (middle);
- }
- return ((pc == (builtins[high])) ? high : low);
- }
+ INIT_TRAMPOLINE_1 (primitive);
+ TAIL_CALL_1 (comutil_primitive_apply, primitive);
}
-\f
-/* Initialization */
-
-#define COMPILER_INTERFACE_VERSION 3
-
-#ifndef COMPILER_REGBLOCK_N_FIXED
-# define COMPILER_REGBLOCK_N_FIXED 16
-#endif
-
-#ifndef COMPILER_REGBLOCK_N_TEMPS
-# define COMPILER_REGBLOCK_N_TEMPS 256
-#endif
-
-#ifndef COMPILER_REGBLOCK_EXTRA_SIZE
-# define COMPILER_REGBLOCK_EXTRA_SIZE 0
-#endif
-
-#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
-# include "ERROR: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
-#endif
-
-/* ((sizeof(SCHEME_OBJECT)) / (sizeof(SCHEME_OBJECT))) */
-
-#define COMPILER_FIXED_SIZE 1
-
-#ifndef COMPILER_TEMP_SIZE
-# define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
-#endif
-
-#define REGBLOCK_LENGTH \
- ((COMPILER_REGBLOCK_N_FIXED * COMPILER_FIXED_SIZE) + \
- (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) + \
- COMPILER_REGBLOCK_EXTRA_SIZE)
-#ifndef ASM_RESET_HOOK
-# define ASM_RESET_HOOK() NOP()
-#endif
-\f
-long
- compiler_processor_type,
- compiler_interface_version;
-
-SCHEME_OBJECT
- compiler_utilities,
- return_to_interpreter;
-
-#if !defined(REGBLOCK_ALLOCATED_BY_INTERFACE) && !defined(__WIN32__)
-SCHEME_OBJECT Registers [REGBLOCK_LENGTH];
-#endif
-
-static void
-DEFUN_VOID (compiler_reset_internal)
+DEFINE_TRAMPOLINE (comutil_operator_lexpr_trap)
{
- long len;
- SCHEME_OBJECT * block;
-
- /* Other stuff can be placed here. */
-
- block = (OBJECT_ADDRESS (compiler_utilities));
- len = (OBJECT_DATUM (block[0]));
-
- return_to_interpreter =
- (ENTRY_TO_OBJECT (((char *) block)
- + ((unsigned long) (block [len - 1]))));
-
- reflect_to_interface =
- (ENTRY_TO_OBJECT (((char *) block)
- + ((unsigned long) (block [len]))));
-
- (Registers[REGBLOCK_CLOSURE_FREE]) = ((SCHEME_OBJECT) NULL);
- (Registers[REGBLOCK_CLOSURE_SPACE]) = ((SCHEME_OBJECT) 0);
- (Registers[REGBLOCK_REFLECT_TO_INTERFACE]) = reflect_to_interface;
-
- ASM_RESET_HOOK();
-
- return;
+ INIT_TRAMPOLINE_2 (procedure, frame_header);
+ SET_LEXPR_ACTUALS (APPLY_FRAME_HEADER_N_ARGS (frame_header));
+ TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure);
}
\f
-#define COMPILER_UTILITIES_N_ENTRIES 2
-#define COMPILER_UTILITIES_LENGTH \
- ((COMPILER_UTILITIES_N_ENTRIES * (TRAMPOLINE_ENTRY_SIZE + 1)) + 2)
+/* ARITY mismatch handling
-C_UTILITY void
-DEFUN (compiler_initialize, (fasl_p), long fasl_p)
-{
- /* Start-up of whole interpreter */
-
- (Registers[REGBLOCK_PRIMITIVE]) = SHARP_F;
- compiler_processor_type = COMPILER_PROCESSOR_TYPE;
- compiler_interface_version = COMPILER_INTERFACE_VERSION;
- if (fasl_p)
- {
- long len;
- instruction * tramp1, * tramp2;
- SCHEME_OBJECT * block;
- extern SCHEME_OBJECT * EXFUN (copy_to_constant_space,
- (SCHEME_OBJECT *, long));
-
- len = COMPILER_UTILITIES_LENGTH;
- if (GC_Check (len))
- {
- outf_fatal ("compiler_initialize: Not enough space!\n");
- Microcode_Termination (TERM_NO_SPACE);
- }
+ These receive the entry point as an argument and must fill the
+ Scheme stack with the missing default values. They are invoked by
+ TRAMPOLINE_K_n_m where n and m are the same as in the name of the
+ procedure. All the arguments are on the Scheme stack. */
- block = Free;
- Free += len;
- block[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (len - 1)));
- block[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- (COMPILER_UTILITIES_N_ENTRIES
- * TRAMPOLINE_ENTRY_SIZE)));
-
- tramp1 = ((instruction *) (TRAMPOLINE_ENTRY_POINT (block)));
- fill_trampoline (block, tramp1,
- ((format_word) FORMAT_WORD_RETURN),
- TRAMPOLINE_K_RETURN);
- block[len - 2] = (((char *) tramp1) - ((char *) block));
-
- tramp2 = ((instruction *)
- (((char *) tramp1)
- + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT)))));
- fill_trampoline (block, tramp2,
- ((format_word) FORMAT_WORD_RETURN),
- TRAMPOLINE_K_REFLECT_TO_INTERFACE);
- block[len - 1] = (((char *) tramp2) - ((char *) block));
-
- block = (copy_to_constant_space (block, len));
- compiler_utilities = (MAKE_CC_BLOCK (block));
- compiler_reset_internal ();
- }
- else
- {
- /* Delay until after band-load, when compiler_reset will be invoked. */
- compiler_utilities = SHARP_F;
- return_to_interpreter = SHARP_F;
-#ifdef sonyrisc
- /* On the Sony NEWS 3250, this procedure initializes the
- floating-point CPU control register to enable the IEEE traps.
- This is normally executed by `compiler_reset' from LOAD-BAND,
- but the Sony operating system saves the control register in
- `setjmp' and restores it on `longjmp', so we must initialize
- the register before `setjmp' is called. */
- interface_initialize ();
-#endif
-#ifdef __OS2__
- /* Same as for Sony. */
- i386_interface_initialize ();
-#endif
- }
- return;
-}
-\f
-C_UTILITY void
-DEFUN (compiler_reset,
- (new_block),
- SCHEME_OBJECT new_block)
+DEFINE_TRAMPOLINE (comutil_operator_1_0_trap)
{
- /* Called after a disk restore */
-
- if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
- {
- extern void EXFUN (compiler_reset_error, (void));
-
-lose:
- compiler_reset_error ();
- return;
- }
- else if ((MEMORY_REF (new_block, 0))
- != (MAKE_OBJECT (TC_MANIFEST_VECTOR,
- (COMPILER_UTILITIES_LENGTH - 1))))
- {
- /* Backwards compatibility */
- if ((MEMORY_REF (new_block, 0))
- != (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- (COMPILER_UTILITIES_N_ENTRIES
- * (TRAMPOLINE_ENTRY_SIZE + 1)))))
- goto lose;
- }
- else if ((MEMORY_REF (new_block, 1))
- != (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- (COMPILER_UTILITIES_N_ENTRIES
- * TRAMPOLINE_ENTRY_SIZE))))
- goto lose;
-
- compiler_utilities = new_block;
- compiler_reset_internal ();
- return;
+ INIT_TRAMPOLINE_1 (procedure);
+ STACK_PUSH (DEFAULT_OBJECT);
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-#ifndef NATIVE_CODE_IS_C
-
-SCHEME_OBJECT *
-DEFUN (cons_c_code_table, (start, limit, length),
- SCHEME_OBJECT * start
- AND SCHEME_OBJECT * limit
- AND long * length)
+DEFINE_TRAMPOLINE (comutil_operator_2_0_trap)
{
- * length = 0;
- return (start);
+ INIT_TRAMPOLINE_1 (procedure);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-Boolean
-DEFUN (install_c_code_table, (table, length),
- SCHEME_OBJECT * table AND long length)
+DEFINE_TRAMPOLINE (comutil_operator_2_1_trap)
{
- return (length == 0);
+ INIT_TRAMPOLINE_1 (procedure);
+ {
+ SCHEME_OBJECT a1 = (STACK_POP ());
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (a1);
+ }
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-#endif /* NATIVE_CODE_IS_C */
-\f
-#else /* not HAS_COMPILER_SUPPORT */
-
-/* Stubs for compiler utilities.
- All entries error out or kill the microcode.
- */
-
-extern void EXFUN (Microcode_Termination, (int code));
-extern void EXFUN (compiler_reset_error, (void));
-
-extern long
- compiler_interface_version,
- compiler_processor_type;
-
-extern SCHEME_OBJECT
- compiler_utilities,
- return_to_interpreter;
-
-extern long
- EXFUN (enter_compiled_expression, (void)),
- EXFUN (apply_compiled_procedure, (void)),
- EXFUN (return_to_compiled_code, (void)),
- EXFUN (make_fake_uuo_link,
- (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
- EXFUN (make_uuo_link,
- (SCHEME_OBJECT value, SCHEME_OBJECT extension,
- SCHEME_OBJECT block, long offset)),
- EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
- EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
- EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
- EXFUN (coerce_to_compiled,
- (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location));
-
-extern SCHEME_OBJECT
- EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
- EXFUN (extract_variable_cache,
- (SCHEME_OBJECT extension, long offset)),
- EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
- EXFUN (compiled_block_environment, (SCHEME_OBJECT block)),
- EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
- * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)),
- EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)),
- EXFUN (apply_compiled_from_primitive, (int)),
- EXFUN (compiled_with_interrupt_mask, (unsigned long,
- SCHEME_OBJECT,
- unsigned long)),
- EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)),
- * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
-
-extern Boolean
- EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
-
-extern void
- EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
- EXFUN (compiler_initialize, (long fasl_p)),
- EXFUN (store_variable_cache,
- (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
- EXFUN (compiled_entry_type, (SCHEME_OBJECT entry, long *buffer)),
- EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block));
-
-/* Breakpoint stuff. */
-
-extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
-extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
-extern Boolean EXFUN (bkpt_p, (PTR));
-extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
-extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
-\f
-SCHEME_OBJECT
-#ifndef __WIN32__
- Registers [REGBLOCK_MINIMUM_LENGTH],
-#endif
- compiler_utilities,
- return_to_interpreter;
-
-long
- compiler_interface_version,
- compiler_processor_type;
-
-long
-DEFUN_VOID (enter_compiled_expression)
+DEFINE_TRAMPOLINE (comutil_operator_3_0_trap)
{
- return (ERR_EXECUTE_MANIFEST_VECTOR);
+ INIT_TRAMPOLINE_1 (procedure);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-long
-DEFUN_VOID (apply_compiled_procedure)
+DEFINE_TRAMPOLINE (comutil_operator_3_1_trap)
{
- return (ERR_INAPPLICABLE_OBJECT);
+ INIT_TRAMPOLINE_1 (procedure);
+ {
+ SCHEME_OBJECT a1 = (STACK_POP ());
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (a1);
+ }
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-
-long
-DEFUN_VOID (return_to_compiled_code)
+\f
+DEFINE_TRAMPOLINE (comutil_operator_3_2_trap)
{
- return (ERR_INAPPLICABLE_CONTINUATION);
+ INIT_TRAMPOLINE_1 (procedure);
+ {
+ SCHEME_OBJECT a1 = (STACK_POP ());
+ SCHEME_OBJECT a2 = (STACK_POP ());
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (a2);
+ STACK_PUSH (a1);
+ }
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-SCHEME_OBJECT
-DEFUN (apply_compiled_from_primitive, (arity), int arity)
+DEFINE_TRAMPOLINE (comutil_operator_4_0_trap)
{
- signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
- /*NOTREACHED*/
+ INIT_TRAMPOLINE_1 (procedure);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-SCHEME_OBJECT
-DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask),
- unsigned long old_mask
- AND SCHEME_OBJECT receiver
- AND unsigned long new_mask)
+DEFINE_TRAMPOLINE (comutil_operator_4_1_trap)
{
- signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
- /*NOTREACHED*/
+ INIT_TRAMPOLINE_1 (procedure);
+ {
+ SCHEME_OBJECT a1 = (STACK_POP ());
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (a1);
+ }
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-SCHEME_OBJECT
-DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk)
+DEFINE_TRAMPOLINE (comutil_operator_4_2_trap)
{
- signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
- /*NOTREACHED*/
+ INIT_TRAMPOLINE_1 (procedure);
+ {
+ SCHEME_OBJECT a1 = (STACK_POP ());
+ SCHEME_OBJECT a2 = (STACK_POP ());
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (a2);
+ STACK_PUSH (a1);
+ }
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
}
-SCHEME_OBJECT *
-DEFUN (cons_c_code_table, (start, limit, length),
- SCHEME_OBJECT * start
- AND SCHEME_OBJECT * limit
- AND long * length)
+DEFINE_TRAMPOLINE (comutil_operator_4_3_trap)
{
- * length = 0;
- return (start);
+ INIT_TRAMPOLINE_1 (procedure);
+ {
+ SCHEME_OBJECT a1 = (STACK_POP ());
+ SCHEME_OBJECT a2 = (STACK_POP ());
+ SCHEME_OBJECT a3 = (STACK_POP ());
+ STACK_PUSH (DEFAULT_OBJECT);
+ STACK_PUSH (a3);
+ STACK_PUSH (a2);
+ STACK_PUSH (a1);
+ }
+ RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
+}
+\f
+/* The linker either couldn't find a binding or the binding was
+ unassigned. This must report the correct name of the missing
+ variable and the environment in which the lookup begins for the
+ error cases.
+
+ 'cache' is the linker object corresponding to the operator variable
+ (it contains the actual value cell, the name, and linker tables).
+ 'block' and 'offset' point to the cache cell in question. */
+
+DEFINE_TRAMPOLINE (comutil_operator_lookup_trap)
+{
+ INIT_TRAMPOLINE_3 (cache, block, offset);
+ SCHEME_OBJECT * cache_addr = (MEMORY_LOC (block, (OBJECT_DATUM (offset))));
+ unsigned long frame_size = (read_uuo_frame_size (cache_addr));
+ SCHEME_OBJECT procedure;
+ long code = (compiler_operator_reference_trap (cache, (&procedure)));
+ if (code != PRIM_DONE)
+ {
+ STACK_PUSH (MAKE_CC_ENTRY (read_uuo_target_no_reloc (cache_addr)));
+ /* Next three for debugger. */
+ STACK_PUSH (ULONG_TO_FIXNUM (frame_size));
+ STACK_PUSH (cc_block_environment (block));
+ STACK_PUSH
+ (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR));
+ SAVE_LAST_RETURN_CODE (RC_COMP_OP_REF_TRAP_RESTART);
+ RETURN_TO_C (code);
+ }
+ TAIL_CALL_2 (comutil_apply, procedure, frame_size);
}
-Boolean
-DEFUN (install_c_code_table, (table, length),
- SCHEME_OBJECT * table AND long length)
+/* Re-start after processing an error/interrupt encountered in the
+ previous utility. Extract the new trampoline or procedure (the
+ user may have defined the missing variable) and invoke it. */
+
+DEFINE_SCHEME_ENTRY (comp_op_lookup_trap_restart)
{
- return (length == 0);
+ RESTORE_LAST_RETURN_CODE ();
+ /* Discard debugger info. */
+ stack_pointer = (STACK_LOC (3));
+ {
+ SCHEME_OBJECT * store
+ = (trampoline_storage (cc_entry_to_block_address (STACK_POP ())));
+ SCHEME_OBJECT block = (store[1]);
+ unsigned long offset = (OBJECT_DATUM (store[2]));
+ ENTER_SCHEME (read_uuo_target_no_reloc (MEMORY_LOC (block, offset)));
+ }
}
\f
-/* Bad entry points. */
+/* make_uuo_link is called by C and initializes a compiled procedure
+ cache at a location given by a block and an offset. */
long
-DEFUN (make_fake_uuo_link,
- (extension, block, offset),
- SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
- long offset)
+make_uuo_link (SCHEME_OBJECT procedure,
+ SCHEME_OBJECT cache,
+ SCHEME_OBJECT block,
+ unsigned long offset)
+{
+ SCHEME_OBJECT * cache_address = (MEMORY_LOC (block, offset));
+ unsigned long frame_size = (read_uuo_frame_size (cache_address));
+ SCHEME_OBJECT orig_proc;
+ trampoline_type_t kind;
+ long result;
+ SCHEME_OBJECT trampoline;
+
+ if (REFERENCE_TRAP_P (procedure))
+ return (make_fake_uuo_link (cache, block, offset));
+
+ orig_proc = procedure;
+ loop:
+ switch (OBJECT_TYPE (procedure))
+ {
+ case TC_COMPILED_ENTRY:
+ {
+ insn_t * entry = (CC_ENTRY_ADDRESS (procedure));
+ unsigned long nargs = (frame_size - 1);
+ cc_entry_type_t cet;
+ unsigned long nmin;
+ unsigned long nmax;
+
+ if ((read_cc_entry_type ((&cet), entry))
+ || ((cet.marker) != CET_PROCEDURE))
+ return (ERR_COMPILED_CODE_ERROR);
+ nmin = (cet.args.for_procedure.n_required);
+ nmax = (nmin + (cet.args.for_procedure.n_optional));
+ if (cet.args.for_procedure.rest_p)
+ kind = TRAMPOLINE_K_APPLY;
+ else if (nargs == nmax)
+ {
+ /* No defaulting is needed. */
+ write_uuo_link (procedure, cache_address);
+ return (PRIM_DONE);
+ }
+ else if ((nargs < nmax)
+ && (nargs >= nmin)
+ && (nmin < nmax)
+ && (nmax <= TRAMPOLINE_TABLE_SIZE))
+ {
+ /* We have optimized defaulting for this case. */
+ kind
+ = (trampoline_arity_table
+ [(((nmax - 1) * TRAMPOLINE_TABLE_SIZE) + nargs)]);
+ assert (kind != TRAMPOLINE_K_APPLY);
+ frame_size = 0;
+ }
+ else
+ /* Use unoptimized defaulting. */
+ kind = TRAMPOLINE_K_APPLY;
+ break;
+ }
+
+ case TC_ENTITY:
+ {
+ SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA));
+ if ((VECTOR_P (data))
+ && (frame_size < (VECTOR_LENGTH (data)))
+ && ((VECTOR_REF (data, frame_size)) != SHARP_F)
+ && ((VECTOR_REF (data, 0))
+ == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG))))
+ {
+ procedure = (VECTOR_REF (data, frame_size));
+ goto loop;
+ }
+ kind = TRAMPOLINE_K_APPLY;
+ break;
+ }
+
+ case TC_PRIMITIVE:
+ {
+ long arity = (PRIMITIVE_ARITY (procedure));
+ if (arity == ((long) (frame_size - 1)))
+ {
+ kind = TRAMPOLINE_K_PRIMITIVE;
+ frame_size = 0;
+ }
+ else if (arity == LEXPR_PRIMITIVE_ARITY)
+ kind = TRAMPOLINE_K_LEXPR_PRIMITIVE;
+ else
+ kind = TRAMPOLINE_K_APPLY;
+ break;
+ }
+
+ default:
+ kind = TRAMPOLINE_K_APPLY;
+ break;
+ }
+ result
+ = ((frame_size == 0)
+ ? (make_redirection_trampoline ((&trampoline), kind, procedure))
+ : (make_apply_trampoline ((&trampoline), kind, procedure, frame_size)));
+ if (result == PRIM_DONE)
+ write_uuo_link (trampoline, cache_address);
+ return (result);
+}
+\f
+static long
+make_fake_uuo_link (SCHEME_OBJECT cache,
+ SCHEME_OBJECT block,
+ unsigned long offset)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ cc_entry_type_t cet;
+ SCHEME_OBJECT trampoline;
+
+ make_cc_entry_type ((&cet), CET_TRAMPOLINE);
+ {
+ long result = (make_trampoline ((&trampoline),
+ (&cet),
+ TRAMPOLINE_K_LOOKUP,
+ 3,
+ cache,
+ block,
+ (ULONG_TO_FIXNUM (offset))));
+ if (result != PRIM_DONE)
+ return (result);
+ }
+ {
+ SCHEME_OBJECT * cache_address = (MEMORY_LOC (block, offset));
+ write_uuo_link (trampoline, cache_address);
+ }
+ return (PRIM_DONE);
}
long
-DEFUN (make_uuo_link,
- (value, extension, block, offset),
- SCHEME_OBJECT value AND SCHEME_OBJECT extension AND
- SCHEME_OBJECT block AND long offset)
+coerce_to_compiled (SCHEME_OBJECT procedure,
+ unsigned int arity,
+ SCHEME_OBJECT * location)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ cc_entry_type_t cet;
+
+ if (CC_ENTRY_P (procedure))
+ {
+ if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (procedure))))
+ return (ERR_COMPILED_CODE_ERROR);
+ if ((cet.marker) == CET_PROCEDURE)
+ {
+ (*location) = procedure;
+ return (PRIM_DONE);
+ }
+ }
+ make_compiled_procedure_type ((&cet), arity, 0, false);
+ return (make_trampoline (location,
+ (&cet),
+ TRAMPOLINE_K_APPLY,
+ 2,
+ procedure,
+ (ULONG_TO_FIXNUM (arity + 1))));
}
+\f
+static long
+make_trampoline (SCHEME_OBJECT * slot,
+ cc_entry_type_t * cet,
+ trampoline_type_t kind,
+ unsigned int n_values,
+ ...)
+{
+ SCHEME_OBJECT h1;
+ SCHEME_OBJECT h2;
+ unsigned long n_words;
+ SCHEME_OBJECT * block;
-SCHEME_OBJECT
-DEFUN (extract_uuo_link,
- (block, offset),
- SCHEME_OBJECT block AND long offset)
-{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ make_trampoline_headers (1, n_values, (&h1), (&h2), (&n_words));
+ if (GC_NEEDED_P (n_words))
+ {
+ REQUEST_GC (n_words);
+ return (PRIM_INTERRUPT);
+ }
+ block = Free;
+ Free += n_words;
+ (block[0]) = h1;
+ (block[1]) = h2;
+ if (fill_trampoline (block, 0, cet, kind))
+ return (ERR_COMPILED_CODE_ERROR);
+ {
+ SCHEME_OBJECT * p = (trampoline_storage (block));
+ va_list ap;
+
+ va_start (ap, n_values);
+ while (n_values > 0)
+ {
+ (*p++) = (va_arg (ap, SCHEME_OBJECT));
+ n_values -= 1;
+ }
+ va_end (ap);
+ }
+ (*slot) = (MAKE_CC_ENTRY (trampoline_entry_addr (block, 0)));
+ return (PRIM_DONE);
}
-void
-DEFUN (store_variable_cache,
- (extension, block, offset),
- SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
- long offset)
-{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+static void
+make_trampoline_headers (unsigned long n_entries, unsigned long n_store,
+ SCHEME_OBJECT * h1_r, SCHEME_OBJECT * h2_r,
+ unsigned long * n_words_r)
+{
+ unsigned long n1 = (trampoline_entry_size (n_entries));
+ unsigned long n2 = (1 + n1 + n_store);
+ (*h1_r) = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER, n2));
+ (*h2_r) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, n1));
+ (*n_words_r) = (1 + n2);
+}
+
+static bool
+fill_trampoline (SCHEME_OBJECT * block,
+ unsigned long index,
+ cc_entry_type_t * cet,
+ trampoline_type_t kind)
+{
+ insn_t * addr = (trampoline_entry_addr (block, index));
+ if (write_cc_entry_type (cet, addr))
+ return (true);
+ {
+ cc_entry_offset_t ceo;
+ (ceo.offset) = (addr - ((insn_t *) block));
+ (ceo.continued_p) = false;
+ if (write_cc_entry_offset ((&ceo), addr))
+ return (true);
+ }
+ return (store_trampoline_insns (addr, kind));
}
-SCHEME_OBJECT
-DEFUN (extract_variable_cache,
- (block, offset),
- SCHEME_OBJECT block AND
- long offset)
+SCHEME_OBJECT *
+trampoline_storage (SCHEME_OBJECT * block)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ return (block + 2 + (OBJECT_DATUM (block[1])));
}
\f
-SCHEME_OBJECT
-DEFUN (compiled_block_debugging_info,
- (block),
- SCHEME_OBJECT block)
+static long
+make_redirection_trampoline (SCHEME_OBJECT * slot,
+ trampoline_type_t kind,
+ SCHEME_OBJECT procedure)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ cc_entry_type_t cet;
+ make_cc_entry_type ((&cet), CET_TRAMPOLINE);
+ return (make_trampoline (slot, (&cet), kind, 1, procedure));
}
-SCHEME_OBJECT
-DEFUN (compiled_block_environment,
- (block),
- SCHEME_OBJECT block)
+static long
+make_apply_trampoline (SCHEME_OBJECT * slot,
+ trampoline_type_t kind,
+ SCHEME_OBJECT procedure,
+ unsigned long frame_size)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ cc_entry_type_t cet;
+ make_cc_entry_type ((&cet), CET_TRAMPOLINE);
+ return (make_trampoline (slot,
+ (&cet),
+ kind,
+ 2,
+ procedure,
+ (ULONG_TO_FIXNUM (frame_size))));
}
+\f
+/* Compiled-code breakpoints */
-long
-DEFUN (compiled_block_closure_p,
- (block),
- SCHEME_OBJECT block)
-{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
-}
+#ifdef HAVE_BKPT_SUPPORT
-SCHEME_OBJECT *
-DEFUN (compiled_entry_to_block_address,
- (entry),
- SCHEME_OBJECT entry)
+#define BKPT_PROCEED_FRAME_SIZE 3
+
+SCHEME_OBJECT
+bkpt_proceed (insn_t * ep, SCHEME_OBJECT handle, SCHEME_OBJECT state)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ if (! ((CC_ENTRY_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE)))
+ && ((CC_ENTRY_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) == ep)))
+ error_external_return ();
+ PUSH_REFLECTION (REFLECT_CODE_CC_BKPT);
+ stack_pointer = (STACK_LOC (-BKPT_PROCEED_FRAME_SIZE));
+ return (SHARP_F);
}
-long
-DEFUN (compiled_entry_to_block_offset,
- (entry),
- SCHEME_OBJECT entry)
+#else /* not HAVE_BKPT_SUPPORT */
+
+SCHEME_OBJECT
+bkpt_install (insn_t * ep)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ return (SHARP_F);
}
SCHEME_OBJECT
-DEFUN (compiled_entry_to_block,
- (entry),
- SCHEME_OBJECT entry)
+bkpt_closure_install (insn_t * ep)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ return (SHARP_F);
}
-\f
void
-DEFUN (compiled_entry_type,
- (entry, buffer),
- SCHEME_OBJECT entry AND long *buffer)
+bkpt_remove (insn_t * ep, SCHEME_OBJECT handle)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ error_external_return ();
}
-long
-DEFUN (compiled_entry_closure_p,
- (entry),
- SCHEME_OBJECT entry)
+bool
+bkpt_p (insn_t * ep)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ return (false);
}
SCHEME_OBJECT
-DEFUN (compiled_closure_to_entry, (entry), SCHEME_OBJECT entry)
+bkpt_proceed (insn_t * ep, SCHEME_OBJECT handle, SCHEME_OBJECT state)
{
- Microcode_Termination (TERM_COMPILER_DEATH);
- /*NOTREACHED*/
+ error_external_return ();
+ return (UNSPECIFIC);
}
-void
-DEFUN (declare_compiled_code_block, (block), SCHEME_OBJECT block)
+long
+do_bkpt_proceed (insn_t ** addr_r)
{
- return;
+ return (ERR_EXTERNAL_RETURN);
}
-#define LOSING_RETURN_ADDRESS(name) \
-extern long EXFUN (name, (void)); \
-long \
-DEFUN_VOID (name) \
-{ \
- Microcode_Termination (TERM_COMPILER_DEATH); \
- /*NOTREACHED*/ \
-}
-
-LOSING_RETURN_ADDRESS (comp_interrupt_restart)
-LOSING_RETURN_ADDRESS (comp_lookup_apply_restart)
-LOSING_RETURN_ADDRESS (comp_reference_restart)
-LOSING_RETURN_ADDRESS (comp_access_restart)
-LOSING_RETURN_ADDRESS (comp_unassigned_p_restart)
-LOSING_RETURN_ADDRESS (comp_unbound_p_restart)
-LOSING_RETURN_ADDRESS (comp_assignment_restart)
-LOSING_RETURN_ADDRESS (comp_definition_restart)
-LOSING_RETURN_ADDRESS (comp_safe_reference_restart)
-LOSING_RETURN_ADDRESS (comp_lookup_trap_restart)
-LOSING_RETURN_ADDRESS (comp_assignment_trap_restart)
-LOSING_RETURN_ADDRESS (comp_op_lookup_trap_restart)
-LOSING_RETURN_ADDRESS (comp_cache_lookup_apply_restart)
-LOSING_RETURN_ADDRESS (comp_safe_lookup_trap_restart)
-LOSING_RETURN_ADDRESS (comp_unassigned_p_trap_restart)
-LOSING_RETURN_ADDRESS (comp_link_caches_restart)
-LOSING_RETURN_ADDRESS (comp_error_restart)
+#endif /* not HAVE_BKPT_SUPPORT */
\f
-/* NOP entry points */
-
-void
-DEFUN (compiler_reset, (new_block), SCHEME_OBJECT new_block)
+DEFINE_SCHEME_UTILITY_2 (comutil_compiled_code_bkpt, entry_addr, state)
{
- extern void EXFUN (compiler_reset_error, (void));
+ DECLARE_UTILITY_ARG (insn_t *, entry_addr);
+ DECLARE_UTILITY_ARG (void *, state);
+ SCHEME_OBJECT entry = (MAKE_CC_ENTRY (entry_addr));
+ cc_entry_type_t cet;
+ SCHEME_OBJECT to_save;
+ SCHEME_OBJECT stack_ptr;
- if (new_block != SHARP_F)
- compiler_reset_error ();
- return;
-}
+ /* Potential bug: This does not preserve the environment for IC
+ procedures. There is no way to tell that we have an IC procedure
+ in our hands. It is not safe to preserve it in general because
+ the contents of the register may be stale (predate the last GC).
+ However, the compiler no longer generates IC procedures, and will
+ probably never do it again. */
-void
-DEFUN (compiler_initialize, (fasl_p), long fasl_p)
-{
- (Registers[REGBLOCK_PRIMITIVE]) = SHARP_F;
- compiler_processor_type = 0;
- compiler_interface_version = 0;
- compiler_utilities = SHARP_F;
- return_to_interpreter =
- (MAKE_OBJECT (TC_RETURN_CODE, RC_POP_FROM_COMPILED_CODE));
- return;
-}
+ if (read_cc_entry_type ((&cet), entry_addr))
+ to_save = SHARP_F;
+ else
+ switch (cet.marker)
+ {
+ case CET_CONTINUATION:
+ to_save = GET_VAL;
+ break;
-/* Identity procedure */
+ case CET_INTERNAL_CONTINUATION:
+ to_save = (MAKE_CC_STACK_ENV ((SCHEME_OBJECT *) state));
+ break;
-long
-DEFUN (coerce_to_compiled,
- (object, arity, location),
- SCHEME_OBJECT object AND long arity AND SCHEME_OBJECT *location)
-{
- *location = object;
- return (PRIM_DONE);
-}
+ case CET_RETURN_TO_INTERPRETER:
+ to_save = GET_VAL;
+ break;
-extern char * EXFUN (utility_index_to_name, (int));
-extern void EXFUN (declare_builtin, (unsigned long));
-extern char * EXFUN (builtin_index_to_name, (int));
-extern int EXFUN (pc_to_utility_index, (unsigned long));
-extern int EXFUN (pc_to_builtin_index, (unsigned long));
+ case CET_CLOSURE:
+ to_save = (MAKE_CC_ENTRY ((insn_t *) state));
+ break;
-char *
-DEFUN (utility_index_to_name, (index), int index)
-{
- return ((char *) NULL);
-}
+ default:
+ to_save = SHARP_F;
+ break;
+ }
-void
-DEFUN (declare_builtin, (builtin), unsigned long builtin)
-{
- return;
+ STACK_PUSH (entry);
+ stack_ptr = (MAKE_CC_STACK_ENV (stack_pointer));
+ STACK_PUSH (to_save);
+ STACK_PUSH (stack_ptr);
+ STACK_PUSH (entry);
+ TAIL_CALL_2 (comutil_apply,
+ (VECTOR_REF (fixed_objects, CC_BKPT_PROCEDURE)),
+ 4);
}
-char *
-DEFUN (builtin_index_to_name, (index), int index)
+DEFINE_SCHEME_UTILITY_1 (comutil_compiled_closure_bkpt, entry_addr)
{
- return ((char *) NULL);
-}
+ DECLARE_UTILITY_ARG (insn_t *, entry_addr);
+ SCHEME_OBJECT entry = (MAKE_CC_ENTRY (entry_addr));
+ SCHEME_OBJECT stack_ptr;
-int
-DEFUN (pc_to_utility_index, (pc), unsigned long pc)
+ STACK_PUSH (entry);
+ stack_ptr = (MAKE_CC_STACK_ENV (stack_pointer));
+ STACK_PUSH (SHARP_F);
+ STACK_PUSH (stack_ptr);
+ STACK_PUSH (entry);
+ TAIL_CALL_2 (comutil_apply,
+ (VECTOR_REF (fixed_objects, CC_BKPT_PROCEDURE)),
+ 4);
+}
+\f
+/* Utility table used by the assembly language interface to invoke the
+ SCHEME_UTILITY procedures that appear in this file.
+
+ Important: Do NOT reorder this table without changing the indices
+ defined on the following page and the corresponding table in the
+ compiler. */
+
+utility_proc_t * utility_table [] =
+{
+ comutil_return_to_interpreter, /* 0x0 */
+ comutil_operator_apply_trap, /* 0x1 */
+ comutil_operator_apply_trap, /* 0x2 */
+ comutil_operator_apply_trap, /* 0x3 */
+ comutil_operator_apply_trap, /* 0x4 */
+ comutil_operator_lexpr_trap, /* 0x5 */
+ comutil_operator_primitive_trap, /* 0x6 */
+ comutil_operator_lookup_trap, /* 0x7 */
+ comutil_operator_1_0_trap, /* 0x8 */
+ comutil_operator_2_1_trap, /* 0x9 */
+ comutil_operator_2_0_trap, /* 0xa */
+ comutil_operator_3_2_trap, /* 0xb */
+ comutil_operator_3_1_trap, /* 0xc */
+ comutil_operator_3_0_trap, /* 0xd */
+ comutil_operator_4_3_trap, /* 0xe */
+ comutil_operator_4_2_trap, /* 0xf */
+ comutil_operator_4_1_trap, /* 0x10 */
+ comutil_operator_4_0_trap, /* 0x11 */
+ comutil_primitive_apply, /* 0x12 */
+ comutil_primitive_lexpr_apply, /* 0x13 */
+ comutil_apply, /* 0x14 */
+ comutil_error, /* 0x15 */
+ comutil_lexpr_apply, /* 0x16 */
+ comutil_link, /* 0x17 */
+ comutil_interrupt_closure, /* 0x18 */
+ comutil_interrupt_dlink, /* 0x19 */
+ comutil_interrupt_procedure, /* 0x1a */
+ comutil_interrupt_continuation, /* 0x1b */
+ comutil_interrupt_ic_procedure, /* 0x1c */
+ comutil_assignment_trap, /* 0x1d */
+ comutil_cache_lookup_apply, /* 0x1e */
+ comutil_lookup_trap, /* 0x1f */
+ comutil_safe_lookup_trap, /* 0x20 */
+ comutil_unassigned_p_trap, /* 0x21 */
+ comutil_decrement, /* 0x22 */
+ comutil_divide, /* 0x23 */
+ comutil_equal, /* 0x24 */
+ comutil_greater, /* 0x25 */
+ comutil_increment, /* 0x26 */
+ comutil_less, /* 0x27 */
+ comutil_minus, /* 0x28 */
+ comutil_multiply, /* 0x29 */
+ comutil_negative, /* 0x2a */
+ comutil_plus, /* 0x2b */
+ comutil_positive, /* 0x2c */
+ comutil_zero, /* 0x2d */
+ 0, /* 0x2e */
+ 0, /* 0x2f */
+ 0, /* 0x30 */
+ 0, /* 0x31 */
+ 0, /* 0x32 */
+ 0, /* 0x33 */
+ 0, /* 0x34 */
+ 0, /* 0x35 */
+ comutil_primitive_error, /* 0x36 */
+ comutil_quotient, /* 0x37 */
+ comutil_remainder, /* 0x38 */
+ comutil_modulo, /* 0x39 */
+ comutil_reflect_to_interface, /* 0x3a */
+ comutil_interrupt_continuation_2, /* 0x3b */
+ comutil_compiled_code_bkpt, /* 0x3c */
+ comutil_compiled_closure_bkpt /* 0x3d */
+};
+
+unsigned long max_trampoline
+ = ((sizeof (utility_table)) / (sizeof (utility_proc_t *)));
+\f
+/* Support for trap handling. */
+
+const char *
+utility_index_to_name (unsigned int index)
{
- return (-1);
+ return (0);
}
int
-DEFUN (pc_to_builtin_index, (pc), unsigned long pc)
+pc_to_utility_index (unsigned long pc)
{
return (-1);
}
-\f
-SCHEME_OBJECT
-DEFUN (bkpt_install, (ep), PTR ep)
-{
- return (SHARP_F);
-}
-SCHEME_OBJECT
-DEFUN (bkpt_closure_install, (ep), PTR ep)
-{
- return (SHARP_F);
-}
+static unsigned int n_builtins = 0;
+static unsigned int s_builtins = 0;
+static unsigned long * builtins = 0;
+static const char ** builtin_names = 0;
void
-DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle)
+declare_builtin (unsigned long builtin, const char * name)
{
- error_external_return ();
+ if (n_builtins == s_builtins)
+ {
+ if (s_builtins == 0)
+ {
+ s_builtins = 30;
+ builtins = (malloc (s_builtins * (sizeof (unsigned long))));
+ builtin_names = (malloc (s_builtins * (sizeof (char *))));
+ }
+ else
+ {
+ s_builtins += s_builtins;
+ builtins
+ = (realloc (builtins, (s_builtins * (sizeof (unsigned long)))));
+ builtin_names
+ = (realloc (builtin_names, (s_builtins * (sizeof (char *)))));
+ }
+ if ((builtins == 0) || (builtin_names == 0))
+ {
+ outf_fatal ("declare_builtin: malloc/realloc failed (size = %d).\n",
+ s_builtins);
+ termination_init_error ();
+ }
+ }
+ {
+ unsigned int low = 0;
+ unsigned int high = n_builtins;
+ while (1)
+ {
+ if (low < high)
+ {
+ unsigned int middle = ((low + high) / 2);
+ if (builtin < (builtins[middle]))
+ high = middle;
+ else if (builtin > (builtins[middle]))
+ low = (middle + 1);
+ else
+ {
+ (builtin_names[middle]) = name;
+ return;
+ }
+ }
+ else
+ {
+ unsigned int scan = n_builtins;
+ while (low < scan)
+ {
+ (builtins [scan]) = (builtins [scan - 1]);
+ (builtin_names [scan]) = (builtin_names [scan - 1]);
+ scan -= 1;
+ }
+ (builtins [low]) = builtin;
+ (builtin_names [low]) = name;
+ return;
+ }
+ }
+ }
}
-Boolean
-DEFUN (bkpt_p, (ep), PTR ep)
+const char *
+builtin_index_to_name (unsigned int index)
{
- return (SHARP_F);
+ return ((index < n_builtins) ? (builtin_names[index]) : 0);
}
-SCHEME_OBJECT
-DEFUN (bkpt_proceed, (ep, handle, state),
- PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
+int
+pc_to_builtin_index (unsigned long pc)
{
- error_external_return ();
+ if (! ((builtins != 0)
+ && (pc >= (builtins[0]))
+ && (pc < (builtins [(n_builtins - 1)]))))
+ return (-1);
+ {
+ unsigned int low = 0;
+ unsigned int high = (n_builtins - 1);
+ while ((low + 1) < high)
+ {
+ unsigned int middle = ((low + high) / 2);
+ if (pc < (builtins[middle]))
+ high = middle;
+ else if (pc > (builtins[middle]))
+ low = middle;
+ else
+ return (middle);
+ }
+ return ((pc == (builtins[high])) ? high : low);
+ }
}
-
-#endif /* HAS_COMPILER_SUPPORT */
\f
#ifdef __WIN32__
#include "ntscmlib.h"
extern unsigned long * win32_catatonia_block;
-extern void EXFUN (win32_allocate_registers, (void));
-extern void EXFUN (win32_allocate_registers, (void));
#ifndef REGBLOCK_LENGTH
# define REGBLOCK_LENGTH REGBLOCK_MINIMUM_LENGTH
typedef struct register_storage
{
/* The following must be allocated consecutively */
- unsigned long catatonia_block[3];
-#if (COMPILER_PROCESSOR_TYPE == COMPILER_IA32_TYPE)
- void * Regstart[32]; /* Negative byte offsets from &Registers[0] */
-#endif
+ unsigned long catatonia_block [3];
+ void * Regstart [32]; /* Negative byte offsets from &Registers[0] */
SCHEME_OBJECT Registers [REGBLOCK_LENGTH];
} REGMEM;
-SCHEME_OBJECT * RegistersPtr = ((SCHEME_OBJECT *) NULL);
-unsigned long * win32_catatonia_block = ((unsigned long *) NULL);
+unsigned long * win32_catatonia_block = 0;
static REGMEM regmem;
void
-DEFUN_VOID (win32_allocate_registers)
+win32_allocate_registers (void)
{
- REGMEM * mem = & regmem;
-
- win32_catatonia_block = ((unsigned long *) &mem->catatonia_block[0]);
- RegistersPtr = mem->Registers;
- if (! (win32_system_utilities.lock_memory_area (mem, (sizeof (REGMEM)))))
- {
- outf_error ("Unable to lock registers\n");
- outf_flush_error ();
- }
- return;
+ win32_catatonia_block = (regmem.catatonia_block);
+ Registers = (regmem.Registers);
+ if (!win32_system_utilities.lock_memory_area ((®mem), (sizeof (regmem))))
+ {
+ outf_error ("Unable to lock registers\n");
+ outf_flush_error ();
+ }
}
void
-DEFUN_VOID (win32_deallocate_registers)
+win32_deallocate_registers (void)
{
- win32_system_utilities.unlock_memory_area (®mem, (sizeof (REGMEM)));
- return;
+ win32_system_utilities.unlock_memory_area ((®mem), (sizeof (regmem)));
}
#endif /* __WIN32__ */
/* -*-C-*-
-$Id: cmpint.h,v 10.14 2007/01/05 21:19:25 cph Exp $
+$Id: cmpint.h,v 10.15 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* Macros for the interface between compiled code and interpreted code. */
-\f
-/* Stack Gap Operations: */
+/* Compiled-code interface */
-/* With_Stack_Gap opens a gap Gap_Size wide Gap_Position cells above the
- * top of the stack. Code must push Gap_Size objects. It executes Code
- * with the stack pointer placed so that these objects will fill the gap.
- */
+#ifndef SCM_CMPINT_H
+#define SCM_CMPINT_H 1
-#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \
-{ \
- long size_to_move = (Gap_Position); \
- SCHEME_OBJECT * Destination = (STACK_LOC (- (Gap_Size))); \
- SCHEME_OBJECT * Saved_Destination = Destination; \
- while ((--size_to_move) >= 0) \
- (STACK_LOCATIVE_POP (Destination)) = (STACK_POP ()); \
- Code; \
- sp_register = Saved_Destination; \
-}
-
-/* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the
- * top of the stack. The contents of the gap are lost.
- */
+#include "config.h"
+#include "object.h"
-#define Close_Stack_Gap(Gap_Size, Gap_Position, extra_code) \
-{ \
- long size_to_move; \
- SCHEME_OBJECT *Source; \
- \
- size_to_move = (Gap_Position); \
- Source = (STACK_LOC (size_to_move)); \
- sp_register = (STACK_LOC ((Gap_Size) + size_to_move)); \
- extra_code; \
- while (--size_to_move >= 0) \
- { \
- STACK_PUSH (STACK_LOCATIVE_PUSH (Source)); \
- } \
-}
-\f
-/* Going from interpreted code to compiled code */
+#define COMPILER_INTERFACE_VERSION 3
-/* Tail recursion is handled as follows:
- if the return code is `reenter_compiled_code', it is discarded,
- and the two contiguous interpreter segments on the stack are
- merged.
- */
+typedef struct cc_entry_type_s cc_entry_type_t;
+typedef struct cc_entry_offset_s cc_entry_offset_t;
-/* Apply interface:
- calling a compiled procedure with a frame nslots long.
- */
+#include "cmpintmd.h"
-#define apply_compiled_setup(nslots) \
-{ \
- long frame_size; \
- \
- frame_size = (nslots); \
- if (STACK_REF(frame_size + CONTINUATION_RETURN_CODE) == \
- (MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
- { \
- /* Merge compiled code segments on the stack. */ \
- Close_Stack_Gap (CONTINUATION_SIZE, \
- frame_size, \
- { \
- long segment_size = \
- (OBJECT_DATUM \
- (STACK_REF \
- (CONTINUATION_EXPRESSION - \
- CONTINUATION_SIZE))); \
- last_return_code = (STACK_LOC (segment_size)); \
- }); \
- /* Undo the subproblem rotation. */ \
- Compiler_End_Subproblem(); \
- } \
- else \
- { \
- /* Make a new compiled code segment which includes this frame. */ \
- /* History need not be hacked here. */ \
- With_Stack_Gap(1, \
- frame_size, \
- { \
- last_return_code = (STACK_LOC (0)); \
- STACK_PUSH (return_to_interpreter); \
- }); \
- } \
-}
+#ifdef NO_CC_SUPPORT_P
+# undef CC_SUPPORT_P
+#else
+# define CC_SUPPORT_P 1
\f
-/* Eval interface:
- executing a compiled expression.
- */
+/* The following code handles compiled entry points, where the
+ addresses point to the "middle" of the code vector. From the entry
+ address, the offset word can be extracted, and this offset allows
+ us to find the beginning of the block, so it can be copied as a
+ whole. The broken heart for the whole block lives in its usual
+ place (first word in the vector).
+
+ The offset word contains an encoding of the offset and an encoding
+ of whether the resulting pointer points to the beginning of the
+ block or is another entry, so the process may have to be repeated. */
+
+typedef enum
+{
+ CET_PROCEDURE,
+ CET_CONTINUATION,
+ CET_EXPRESSION,
+ CET_INTERNAL_PROCEDURE,
+ CET_INTERNAL_CONTINUATION,
+ CET_TRAMPOLINE,
+ CET_RETURN_TO_INTERPRETER,
+ CET_CLOSURE
+} cc_entry_type_marker_t;
+
+struct cc_entry_type_s
+{
+ cc_entry_type_marker_t marker;
+ union
+ {
+ struct
+ {
+ unsigned int n_required;
+ unsigned int n_optional;
+ bool rest_p;
+ } for_procedure;
+ struct
+ {
+ /* This number is in insn_t units. A value of zero means
+ that the offset is unknown. */
+ unsigned long offset;
+ } for_continuation;
+ } args;
+};
+
+extern void make_compiled_procedure_type
+ (cc_entry_type_t *, unsigned int, unsigned int, bool);
+extern void make_compiled_continuation_type (cc_entry_type_t *, unsigned long);
+extern void make_cc_entry_type (cc_entry_type_t *, cc_entry_type_marker_t);
+\f
+extern bool read_cc_entry_type (cc_entry_type_t *, insn_t *);
+extern bool write_cc_entry_type (cc_entry_type_t *, insn_t *);
+
+extern bool decode_old_style_format_word (cc_entry_type_t *, unsigned short);
+extern bool encode_old_style_format_word (cc_entry_type_t *, unsigned short *);
+
+/* If continued_p is false, then offset is the distance in insn_t
+ units between the entry and the CC block. Otherwise, offset is the
+ distance in insn_t units between this entry and a preceding one.
+ */
+struct cc_entry_offset_s
+{
+ unsigned long offset;
+ bool continued_p;
+};
+
+extern bool read_cc_entry_offset (cc_entry_offset_t *, insn_t *);
+extern bool write_cc_entry_offset (cc_entry_offset_t *, insn_t *);
+
+#define CC_ENTRY_ADDRESS(obj) ((insn_t *) (OBJECT_ADDRESS (obj)))
+#define MAKE_CC_ENTRY(addr) \
+ (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (addr))))
+
+#define CC_ENTRY_NEW_ADDRESS(entry, address) \
+ (OBJECT_NEW_ADDRESS ((entry), ((insn_t *) (address))))
+
+#define CC_ENTRY_NEW_BLOCK(entry, new_block, old_block) \
+ (CC_ENTRY_NEW_ADDRESS ((entry), \
+ (((insn_t *) (new_block)) \
+ + ((CC_ENTRY_ADDRESS (entry)) \
+ - ((insn_t *) (old_block))))))
+
+#define MAKE_CC_BLOCK(address) \
+ (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (address)))
+
+#define MAKE_CC_STACK_ENV(address) \
+ (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, (address)))
+
+#define CC_BLOCK_LENGTH(block) (CC_BLOCK_ADDR_LENGTH (OBJECT_ADDRESS (block)))
+#define CC_BLOCK_END(block) (CC_BLOCK_ADDR_END (OBJECT_ADDRESS (block)))
+#define CC_BLOCK_ADDR_LENGTH(addr) ((OBJECT_DATUM (*addr)) + 1)
+#define CC_BLOCK_ADDR_END(addr) ((addr) + (CC_BLOCK_ADDR_LENGTH (addr)))
+
+#define CC_ENTRY_P(object) ((OBJECT_TYPE (object)) == TC_COMPILED_ENTRY)
+#define CC_BLOCK_P(object) ((OBJECT_TYPE (object)) == TC_COMPILED_CODE_BLOCK)
+#define CC_STACK_ENV_P(object) ((OBJECT_TYPE (object)) == TC_STACK_ENVIRONMENT)
+
+extern unsigned long cc_entry_to_block_offset (SCHEME_OBJECT);
+extern SCHEME_OBJECT cc_entry_to_block (SCHEME_OBJECT);
+extern SCHEME_OBJECT * cc_entry_to_block_address (SCHEME_OBJECT);
+extern SCHEME_OBJECT * cc_entry_address_to_block_address (insn_t *);
+extern int plausible_cc_block_p (SCHEME_OBJECT *);
+\f
+/* Linkage sections
+
+ Linkage sections implement free-variable references in compiled
+ code. They are built to be very fast, and are customized to
+ particular uses of the free variables.
+
+ If a compiled-code block has linkage sections, they appear at the
+ very beginning of the block's constants area (i.e. immediately
+ following the non-marked code segment). There are two basic kinds
+ of sections: (1) a reference section is used to read or write a
+ variable's value; and (2) an execution section is used to call a
+ variable's value.
+
+ Each linkage section has a header word, with type
+ TC_LINKAGE_SECTION. The bottom 16 bits of the header word's datum
+ contains the number of words in the rest of the linkage section
+ (i.e. its length, as if it were a vector). The bits above that
+ contain the linkage section's type, which must be one of the values
+ listed below.
+
+ Prior to linking, the header word has type TC_FIXNUM. Each entry
+ in a reference section is a symbol, which is the name of the free
+ variable being referred to. Each entry in an execution section has
+ two words: (1) a non-negative fixnum, which is the number of
+ arguments to be passed to the procedure; and (2) a symbol, which is
+ the name of the variable.
+
+ After linking, the header word has type TC_LINKAGE_SECTION. Each
+ entry in a reference section is the address (SCHEME_OBJECT*) of a
+ TC_HUNK3 object. Each entry in an execution section is an
+ architecture-specific instruction sequence that jumps to the called
+ procedure (a "UUO link"). */
+
+typedef enum
+{
+ LINKAGE_SECTION_TYPE_OPERATOR,
+ LINKAGE_SECTION_TYPE_REFERENCE,
+ LINKAGE_SECTION_TYPE_ASSIGNMENT,
+ LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR,
+ N_LINKAGE_SECTION_TYPES
+} linkage_section_type_t;
+
+extern linkage_section_type_t linkage_section_type (SCHEME_OBJECT);
+extern unsigned long linkage_section_count (SCHEME_OBJECT);
+extern SCHEME_OBJECT make_linkage_section_marker
+ (linkage_section_type_t, unsigned long);
+
+extern long make_uuo_link
+ (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+extern long coerce_to_compiled (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT *);
+extern SCHEME_OBJECT read_uuo_link (SCHEME_OBJECT, unsigned long);
+
+extern SCHEME_OBJECT read_uuo_symbol (SCHEME_OBJECT *);
+extern insn_t * read_uuo_target_no_reloc (SCHEME_OBJECT *);
+extern void write_uuo_target (insn_t *, SCHEME_OBJECT *);
+
+extern unsigned int read_uuo_frame_size (SCHEME_OBJECT *);
+
+extern void write_variable_cache (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+\f
+/* Compiled closures
+
+ A manifest closure header is followed by a (positive) count N,
+ which is followed by N closure entries. Each entry consists of a
+ GC offset and a type followed by the machine code for the closure
+ (typically a call-like instruction). The entries are tightly
+ packed so that the end address of one entry is the start address of
+ the next. After the end address of the last entry there is
+ optional padding, followed by the closure's marked objects.
+
+ When EMBEDDED_CLOSURE_ADDRS_P is defined, the target address of a
+ closure is embedded in the closure's code, and must be specially
+ managed by the garbage collector. When undefined, the targets are
+ stored in the marked objects section of the closure, and so need no
+ special treatment.
+
+ When EMBEDDED_CLOSURE_ADDRS_P is defined, the following macros are
+ used to read and write closure targets.
+
+ READ_COMPILED_CLOSURE_TARGET(start, ref) returns the target of
+ 'start' as a SCHEME_OBJECT, using 'ref' as the relocation
+ reference. */
+
+/* Given the address of the word past the manifest closure header,
+ returns the number of closure entries in the block. The returned
+ value must be positive. */
+extern unsigned long compiled_closure_count (SCHEME_OBJECT *);
+
+/* Given the address of the word past the manifest closure header,
+ returns the address of the first closure entry in the block. */
+extern insn_t * compiled_closure_start (SCHEME_OBJECT *);
+
+/* Given the address of the word past the manifest closure header,
+ returns the address of the first marked object. */
+extern SCHEME_OBJECT * compiled_closure_objects (SCHEME_OBJECT *);
+
+/* Given the address of a closure entry, returns the invocation
+ address for the corresponding closure. */
+extern insn_t * compiled_closure_entry (insn_t *);
+
+/* Given the address of a closure entry, returns the address of the
+ next closure entry. (Which is also the end address of the given
+ closure entry.) */
+extern insn_t * compiled_closure_next (insn_t *);
+
+/* Given the address of the end of the last closure entry, returns the
+ address of the first marked object. */
+extern SCHEME_OBJECT * skip_compiled_closure_padding (insn_t *);
+
+/* Given the address of a closure entry, returns the compiled-code
+ entry that this closure invokes. */
+extern SCHEME_OBJECT compiled_closure_entry_to_target (insn_t *);
+
+/* Given a compiled-code entry point and the address of a closure
+ entry, modifies the closure to invoke the entry point. */
+extern void write_compiled_closure_target (insn_t *, insn_t *);
+
+/* Given a compiled-code block, returns true iff it is a closure's
+ block. */
+extern bool cc_block_closure_p (SCHEME_OBJECT);
+
+/* Given a compiled-code entry, returns true iff it is a closure. */
+extern bool cc_entry_closure_p (SCHEME_OBJECT);
+
+/* Given a compiled-code closure, returns the compiled-code entry that
+ it calls. */
+extern SCHEME_OBJECT cc_closure_to_entry (SCHEME_OBJECT);
+\f
+/* Trampolines
-#define execute_compiled_setup() \
-{ \
- if (STACK_REF(CONTINUATION_RETURN_CODE) == \
- (MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
- { \
- /* Merge compiled code segments on the stack. */ \
- long segment_size; \
- \
- Restore_Cont(); \
- segment_size = OBJECT_DATUM (exp_register); \
- last_return_code = (STACK_LOC (segment_size)); \
- /* Undo the subproblem rotation. */ \
- Compiler_End_Subproblem(); \
- } \
- else \
- { \
- /* Make a new compiled code segment on the stack. */ \
- /* History need not be hacked here. */ \
- last_return_code = (STACK_LOC (0)); \
- STACK_PUSH (return_to_interpreter); \
- } \
-}
-
-/* Pop return interface:
- Returning to compiled code from the interpreter.
- */
+ Trampolines are "closures" that call code in the compiled-code
+ interface rather than compiled code. They have an
+ architecture-specific calling sequence and a marked storage area.
-#define compiled_code_restart() \
-{ \
- long segment_size = OBJECT_DATUM (exp_register); \
- last_return_code = (STACK_LOC (segment_size)); \
- /* Undo the subproblem rotation. */ \
- Compiler_End_Subproblem(); \
-}
-\f
-/* Going from compiled code to interpreted code */
+ The architecture description must define TRAMPOLINE_ENTRY_SIZE to
+ be the number of words occupied by the instruction sequence,
+ including the compiled-code entry header. The instruction sequence
+ must be padded, if necessary, to use an integral number of words.
-/* Tail recursion is handled in the following way:
- if the return address is `return_to_interpreter', it is discarded,
- and the two contiguous interpreter segments on the stack are
- merged.
- */
+ Here is a diagram of a trampoline on a 32-bit machine:
-/* Apply interface:
- calling an interpreted procedure (or unsafe primitive)
- with a frame nslots long.
- */
+ 0x00 TC_FIXNUM | 2 + trampoline_entry_size() + n
+ 0x04 TC_MANIFEST_NM_VECTOR | trampoline_entry_size() == k
+ 0x08 trampoline entry (k words)
+ 0x08+k*4 trampoline storage (n words)
-#define compiler_apply_procedure(nslots) \
-{ \
- long frame_size = (nslots); \
- if ((STACK_REF (frame_size)) == return_to_interpreter) \
- { \
- Close_Stack_Gap(1, frame_size, {}); \
- /* Set up the current rib. */ \
- Compiler_New_Reduction (); \
- } \
- else \
- { /* Make a new interpreter segment which includes this frame. */ \
- With_Stack_Gap \
- (CONTINUATION_SIZE, \
- frame_size, \
- { \
- long segment_size = \
- (STACK_LOCATIVE_DIFFERENCE \
- (last_return_code, (STACK_LOC (0)))); \
- exp_register = (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
- Store_Return (RC_REENTER_COMPILED_CODE); \
- Save_Cont (); \
- }); \
- /* Rotate history to a new subproblem. */ \
- Compiler_New_Subproblem (); \
- } \
-}
-
-/* Pop Return interface:
- returning to the interpreter from compiled code.
- Nothing needs to be done at this time.
*/
-#define compiled_code_done()
-\f
-/* Various handlers for backing out of compiled code. */
-
-/* Backing out of apply. */
-
-#define apply_compiled_backout() \
-{ \
- compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \
- OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));\
-}
-
-/* Backing out of eval. */
-
-#define execute_compiled_backout() \
-{ \
- if ((STACK_REF (0)) == return_to_interpreter) \
- { \
- /* Set up the current rib. */ \
- Compiler_New_Reduction (); \
- } \
- else \
- { \
- long segment_size = \
- (STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0)))); \
- exp_register = (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
- Store_Return (RC_REENTER_COMPILED_CODE); \
- Save_Cont (); \
- /* Rotate history to a new subproblem. */ \
- Compiler_New_Subproblem (); \
- } \
-}
-
-/* Backing out because of special errors or interrupts.
- The microcode has already setup a return code with a #F.
- No tail recursion in this case.
- ***
- Is the history manipulation correct?
- Does Microcode_Error do something special?
- ***
- */
+/* Given the number of trampoline entries, returns the number of words
+ needed to hold the instruction sequences for those entries. */
+extern unsigned long trampoline_entry_size (unsigned long);
+
+/* Given the address of a trampoline block and an entry index, returns
+ the address of the specified entry point. */
+extern insn_t * trampoline_entry_addr (SCHEME_OBJECT *, unsigned long);
+
+/* Given the address of a trampoline entry and the code for the
+ trampoline to be invoked, stores the appropriate instruction
+ sequence in the trampoline. */
+extern bool store_trampoline_insns (insn_t *, byte_t);
+
+/* Give the address of a trampoline block, returns a pointer to the
+ start of the trampoline's storage area. */
+extern SCHEME_OBJECT * trampoline_storage (SCHEME_OBJECT *);
+
+#ifndef UTILITY_RESULT_DEFINED
+#ifdef CMPINT_USE_STRUCS
+
+typedef struct
+{
+ void * interface_dispatch;
+ union
+ {
+ long code_to_interpreter;
+ insn_t * entry_point;
+ } extra;
+} utility_result_t;
-#define compiled_error_backout() \
-{ \
- long segment_size; \
- \
- Restore_Cont(); \
- segment_size = \
- (STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0)))); \
- exp_register = (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
- /* The Store_Return is a NOP, the Save_Cont is done by the code \
- that follows. */ \
- /* Store_Return (OBJECT_DATUM (ret_register)); */ \
- /* Save_Cont (); */ \
- Compiler_New_Subproblem (); \
-}
-
-extern long EXFUN (apply_compiled_procedure, (void));
-extern long EXFUN (comp_access_restart, (void));
-extern long EXFUN (comp_assignment_restart, (void));
-extern long EXFUN (comp_assignment_trap_restart, (void));
-extern long EXFUN (comp_cache_lookup_apply_restart, (void));
-extern long EXFUN (comp_definition_restart, (void));
-extern long EXFUN (comp_error_restart, (void));
-extern long EXFUN (comp_interrupt_restart, (void));
-extern long EXFUN (comp_link_caches_restart, (void));
-extern long EXFUN (comp_lookup_apply_restart, (void));
-extern long EXFUN (comp_lookup_trap_restart, (void));
-extern long EXFUN (comp_op_lookup_trap_restart, (void));
-extern long EXFUN (comp_reference_restart, (void));
-extern long EXFUN (comp_safe_lookup_trap_restart, (void));
-extern long EXFUN (comp_safe_reference_restart, (void));
-extern long EXFUN (comp_unassigned_p_restart, (void));
-extern long EXFUN (comp_unassigned_p_trap_restart, (void));
-extern long EXFUN (comp_unbound_p_restart, (void));
-extern long EXFUN (enter_compiled_expression, (void));
-extern long EXFUN (return_to_compiled_code, (void));
-
-extern SCHEME_OBJECT * EXFUN
- (compiled_entry_to_block_address, (SCHEME_OBJECT));
-
-extern void EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));
+#else
+
+typedef insn_t * utility_result_t;
+extern long C_return_value;
+
+#endif
+#endif
+
+typedef void utility_proc_t
+ (utility_result_t *, unsigned long, unsigned long, unsigned long,
+ unsigned long);
+extern utility_proc_t * utility_table [];
+
+#ifndef FLUSH_I_CACHE
+# define FLUSH_I_CACHE() do {} while (false)
+#endif
+
+#if !defined(PUSH_D_CACHE_REGION) && defined(FLUSH_I_CACHE_REGION)
+# define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords)
+#endif
+\f
+extern unsigned int compiler_interface_version;
+extern cc_arch_t compiler_processor_type;
+extern unsigned long max_trampoline;
+
+extern SCHEME_OBJECT compiler_utilities;
+extern SCHEME_OBJECT return_to_interpreter;
+extern SCHEME_OBJECT reflect_to_interface;
+
+extern SCHEME_OBJECT cc_block_debugging_info (SCHEME_OBJECT);
+extern SCHEME_OBJECT cc_block_environment (SCHEME_OBJECT);
+
+extern long enter_compiled_expression (void);
+extern void guarantee_cc_return (unsigned long);
+extern void guarantee_interp_return (void);
+extern long apply_compiled_procedure (void);
+extern long return_to_compiled_code (void);
+
+extern long apply_compiled_from_primitive (unsigned long, SCHEME_OBJECT);
+extern void compiled_with_interrupt_mask
+ (unsigned long, SCHEME_OBJECT, unsigned long);
+extern void compiled_with_stack_marker (SCHEME_OBJECT);
+
+extern void compiler_initialize (bool);
+extern void compiler_reset (SCHEME_OBJECT);
+
+extern void declare_compiled_code_block (SCHEME_OBJECT);
+
+extern void compiler_interrupt_common
+ (utility_result_t *, insn_t *, SCHEME_OBJECT);
+
+extern long comp_link_caches_restart (void);
+extern long comp_op_lookup_trap_restart (void);
+extern long comp_interrupt_restart (void);
+extern long comp_assignment_trap_restart (void);
+extern long comp_cache_lookup_apply_restart (void);
+extern long comp_lookup_trap_restart (void);
+extern long comp_safe_lookup_trap_restart (void);
+extern long comp_unassigned_p_trap_restart (void);
+extern long comp_error_restart (void);
+
+extern SCHEME_OBJECT bkpt_install (insn_t *);
+extern SCHEME_OBJECT bkpt_closure_install (insn_t *);
+extern bool bkpt_p (insn_t *);
+extern SCHEME_OBJECT bkpt_proceed (insn_t *, SCHEME_OBJECT, SCHEME_OBJECT);
+extern long do_bkpt_proceed (insn_t **);
+extern void bkpt_remove (insn_t *, SCHEME_OBJECT);
+
+extern int pc_to_utility_index (unsigned long);
+extern const char * utility_index_to_name (unsigned int);
+extern int pc_to_builtin_index (unsigned long);
+extern const char * builtin_index_to_name (unsigned int);
+extern void declare_builtin (unsigned long, const char *);
+\f
+extern utility_proc_t comutil_return_to_interpreter;
+extern utility_proc_t comutil_operator_apply_trap;
+extern utility_proc_t comutil_operator_arity_trap;
+extern utility_proc_t comutil_operator_entity_trap;
+extern utility_proc_t comutil_operator_interpreted_trap;
+extern utility_proc_t comutil_operator_lexpr_trap;
+extern utility_proc_t comutil_operator_primitive_trap;
+extern utility_proc_t comutil_operator_lookup_trap;
+extern utility_proc_t comutil_operator_1_0_trap;
+extern utility_proc_t comutil_operator_2_1_trap;
+extern utility_proc_t comutil_operator_2_0_trap;
+extern utility_proc_t comutil_operator_3_2_trap;
+extern utility_proc_t comutil_operator_3_1_trap;
+extern utility_proc_t comutil_operator_3_0_trap;
+extern utility_proc_t comutil_operator_4_3_trap;
+extern utility_proc_t comutil_operator_4_2_trap;
+extern utility_proc_t comutil_operator_4_1_trap;
+extern utility_proc_t comutil_operator_4_0_trap;
+extern utility_proc_t comutil_primitive_apply;
+extern utility_proc_t comutil_primitive_lexpr_apply;
+extern utility_proc_t comutil_apply;
+extern utility_proc_t comutil_error;
+extern utility_proc_t comutil_lexpr_apply;
+extern utility_proc_t comutil_link;
+extern utility_proc_t comutil_interrupt_closure;
+extern utility_proc_t comutil_interrupt_dlink;
+extern utility_proc_t comutil_interrupt_procedure;
+extern utility_proc_t comutil_interrupt_continuation;
+extern utility_proc_t comutil_interrupt_ic_procedure;
+extern utility_proc_t comutil_assignment_trap;
+extern utility_proc_t comutil_cache_lookup_apply;
+extern utility_proc_t comutil_lookup_trap;
+extern utility_proc_t comutil_safe_lookup_trap;
+extern utility_proc_t comutil_unassigned_p_trap;
+extern utility_proc_t comutil_decrement;
+extern utility_proc_t comutil_divide;
+extern utility_proc_t comutil_equal;
+extern utility_proc_t comutil_greater;
+extern utility_proc_t comutil_increment;
+extern utility_proc_t comutil_less;
+extern utility_proc_t comutil_minus;
+extern utility_proc_t comutil_multiply;
+extern utility_proc_t comutil_negative;
+extern utility_proc_t comutil_plus;
+extern utility_proc_t comutil_positive;
+extern utility_proc_t comutil_zero;
+extern utility_proc_t comutil_primitive_error;
+extern utility_proc_t comutil_quotient;
+extern utility_proc_t comutil_remainder;
+extern utility_proc_t comutil_modulo;
+extern utility_proc_t comutil_reflect_to_interface;
+extern utility_proc_t comutil_interrupt_continuation_2;
+extern utility_proc_t comutil_compiled_code_bkpt;
+extern utility_proc_t comutil_compiled_closure_bkpt;
+
+#endif /* !NO_CC_SUPPORT_P */
+#endif /* !SCM_CMPINT_H */
/* -*- C -*-
-$Id: alpha.h,v 1.8 2007/01/05 21:19:26 cph Exp $
+$Id: alpha.h,v 1.9 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1992, 1993 Digital Equipment Corporation (D.E.C.)
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
* Specialized for the Alpha
*/
-#ifndef CMPINTMD_H_INCLUDED
-#define CMPINTMD_H_INCLUDED
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED
-#include "cmptype.h"
\f
/* Machine parameters to be set by the user. */
/* Processor type. Choose a number from the above list, or allocate your own.
*/
-#define COMPILER_PROCESSOR_TYPE COMPILER_ALPHA_TYPE
+#define COMPILER_PROCESSOR_TYPE COMPILER_ALPHA_TYPE
/* Size (in long words) of the contents of a floating point register if
different from a double. For example, an MC68881 saves registers
*/
typedef unsigned short format_word; /* 16 bits */
-
-/* PC alignment constraint.
- Change PC_ZERO_BITS to be how many low order bits of the pc are
- guaranteed to be 0 always because of PC alignment constraints.
-*/
-
-#define PC_ZERO_BITS 2
\f
/* Utilities for manipulating absolute subroutine calls.
On the ALPHA this is done with either
#define STORE_ABSOLUTE_ADDRESS(entry_point, address) \
alpha_store_absolute_address (((void *) entry_point), ((void *) address))
-extern void EXFUN(alpha_store_absolute_address, (void *, void *));
+extern void alpha_store_absolute_address(void *, void *);
#define opJMP 0x1A
#define fnJMP 0x00
#define JMP(linkage, dest, displacement) \
((opJMP << 26) | ((linkage) << 21) | \
((dest) << 16) | (fnJMP << 14) | \
- (((displacement)>>PC_ZERO_BITS) & ((1<<14)-1)))
+ (((displacement)>>2) & ((1<<14)-1)))
/* Compiled Code Register Conventions */
/* This must match the compiler and cmpaux-alpha.m4 */
#ifdef IN_CMPINT_C
#define PC_FIELD_SIZE 21
-#define MAX_PC_DISPLACEMENT (1<<(PC_FIELD_SIZE+PC_ZERO_BITS-1))
+#define MAX_PC_DISPLACEMENT (1<<22)
#define MIN_PC_DISPLACEMENT (-MAX_PC_DISPLACEMENT)
#define opBR 0x30
void
-DEFUN (alpha_store_absolute_address, (entry_point, address),
- void *entry_point AND void *address)
+alpha_store_absolute_address (void *entry_point, void *address)
{
extern void scheme_closure_hook (void);
int *Instruction_Address = (int *) address;
(offset >= MIN_PC_DISPLACEMENT))
*Instruction_Address =
(opBR << 26) | (COMP_REG_LINKAGE << 21) |
- ((offset>>
PC_ZERO_BITS) & ((1L<<PC_FIELD_SIZE)-1));
+ ((offset>>
2) & ((1L<<PC_FIELD_SIZE)-1));
else
*Instruction_Address =
JMP(COMP_REG_LINKAGE, COMP_REG_LONGJUMP,
LDQ MEMTOP,0(BLOCK) -- Fill MemTop register
BIS CC_ENTRY_TYPE,temp,temp -- put tag on closure object
STQ temp,0(SP) -- save closure on top of stack
- BEQ temp2,Interrupt -- possible interrupt ...
+ BEQ temp2,Interrupt -- possible interrupt ...
Code sequence 4 (test for interrupts):
*Note*: In most machines code sequence 3 and 4 are the same and are
processor might have old copies of.
*/
-extern long EXFUN(Synchronize_Caches, (void));
-extern void EXFUN(Flush_I_Cache, (void));
+extern long Synchronize_Caches(void);
+extern void Flush_I_Cache(void);
#if 1
#define FLUSH_I_CACHE() ((void) Synchronize_Caches())
/* This flushes a region of the I-cache.
It is used after updating an execute cache while running.
Not needed during GC because FLUSH_I_CACHE will be used.
- */
+ */
#define FLUSH_I_CACHE_REGION(address, nwords) FLUSH_I_CACHE()
#define PUSH_D_CACHE_REGION(address, nwords) FLUSH_I_CACHE()
#define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC)
-#define ASM_RESET_HOOK() interface_initialize((PTR) &utility_table[0])
+#define ASM_RESET_HOOK() interface_initialize((void *) &utility_table[0])
#define REGBLOCK_EXTRA_SIZE 8 /* See lapgen.scm */
#define COMPILER_REGBLOCK_N_FIXED 16
#define REGBLOCK_ALLOCATE_CLOSURE REGBLOCK_FIRST_EXTRA+3
#define REGBLOCK_DIVQ REGBLOCK_FIRST_EXTRA+4
#define REGBLOCK_REMQ REGBLOCK_FIRST_EXTRA+5
+#define COMPILER_REGBLOCK_N_TEMPS 256
void *
-DEFUN (alpha_heap_malloc, (Size), long Size)
+alpha_heap_malloc (long Size)
{ int pagesize;
caddr_t Heap_Start_Page;
void *Area;
return (void *) Heap_Start_Page;
}
-/* ASSUMPTION: Direct mapped first level cache, with
+/* ASSUMPTION: Direct mapped first level cache, with
shared secondary caches. Sizes in bytes.
*/
#define DCACHE_SIZE (8*1024)
#define WRITE_BUFFER_SIZE (4*DCACHE_LINE_SIZE)
long
-DEFUN_VOID (Synchronize_Caches)
+Synchronize_Caches (void)
{ long Foo=0;
Flush_I_Cache();
{ static volatile long Fake_Out[WRITE_BUFFER_SIZE/(sizeof (long))];
volatile long *Ptr, *End, i=0;
-
+
for (End = &(Fake_Out[WRITE_BUFFER_SIZE/(sizeof (long))]),
Ptr = &(Fake_Out[0]);
Ptr < End;
#if 0
{ static volatile long Fake_Out[DCACHE_SIZE/(sizeof (long))];
volatile long *Ptr, *End;
-
+
for (End = &(Fake_Out[DCACHE_SIZE/(sizeof (long))]),
Ptr = &(Fake_Out[0]);
Ptr < End;
return Foo;
}
-extern char *EXFUN(allocate_closure, (long, char *));
+extern char *allocate_closure(long, char *);
static void
-DEFUN (interface_initialize, (table),
- PTR table)
+interface_initialize (void * table)
{ extern void __divq();
extern void __remq();
Registers[REGBLOCK_ADDRESS_OF_STACK_POINTER] =
- ((SCHEME_OBJECT) &sp_register);
+ ((SCHEME_OBJECT) &stack_pointer);
Registers[REGBLOCK_ADDRESS_OF_FREE] =
((SCHEME_OBJECT) &Free);
Registers[REGBLOCK_ADDRESS_OF_UTILITY_TABLE] =
static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
static long last_chunk_size;
-#define REGBLOCK_CLOSURE_LIMIT REGBLOCK_CLOSURE_SPACE
-
char *
-DEFUN (allocate_closure, (size, this_block),
- long size AND char *this_block)
+allocate_closure (long size, char *this_block)
/* size in Scheme objects of the block we need to allocate.
this_block is a pointer to the first entry point in the block we
didn't manage to allocate.
free_closure = (SCHEME_OBJECT *)
(this_block-CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT);
- limit = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_LIMIT]);
+ limit = GET_CLOSURE_SPACE;
space = limit - free_closure;
if (size > space)
{ SCHEME_OBJECT *ptr;
*/
}
free_closure = Free;
- if ((size <= closure_chunk) && (!(GC_Check (closure_chunk))))
+ if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk)))
{ limit = (free_closure + closure_chunk);
}
else
- { if (GC_Check (size))
- { if ((Heap_Top - Free) < size)
+ { if (GC_NEEDED_P (size))
+ { if ((heap_end - Free) < size)
{ /* No way to back out -- die. */
fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
Microcode_Termination (TERM_NO_SPACE);
/* NOTREACHED */
}
- Request_GC (0);
+ REQUEST_GC (0);
}
else if (size <= closure_chunk)
- { Request_GC (0);
+ { REQUEST_GC (0);
}
limit = (free_closure + size);
}
wptr += 1;
}
PUSH_D_CACHE_REGION (free_closure, last_chunk_size);
- Registers[REGBLOCK_CLOSURE_LIMIT] = (SCHEME_OBJECT) limit;
+ SET_CLOSURE_SPACE (limit);
}
- Registers[REGBLOCK_CLOSURE_FREE] = (SCHEME_OBJECT) (free_closure+size);
+ SET_CLOSURE_FREE (free_closure + size);
return (((char *) free_closure)+CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT);
}
#endif /* IN_CMPINT_C */
#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-#if (PC_ZERO_BITS == 0)
-/* Instructions aligned on byte boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) >> 1)
-#endif
-
-#if (PC_ZERO_BITS == 1)
-/* Instructions aligned on word (16 bit) boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- (CLEAR_LOW_BIT(offset_word))
-#endif
-
-#if (PC_ZERO_BITS >= 2)
-/* Should be OK for =2, but bets are off for >2 because of problems
- mentioned earlier!
-*/
-#define SHIFT_AMOUNT (PC_ZERO_BITS - 1)
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT))
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
-#endif
+#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1)
+#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1)
#define MAKE_OFFSET_WORD(entry, block, continue) \
((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-#endif /* CMPINTMD_H_INCLUDED */
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
/* -*-C-*-
-$Id: locks.h,v 9.30 2007/01/05 21:19:25 cph Exp $
+$Id: c-config.h,v 1.2 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* Contains everything needed to lock and unlock parts of
- the heap, pure/constant space and the like.
- It also contains intercommunication stuff as well. */
+#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED
+#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1
-typedef long *Lock_Handle; /* Address of lock word */
-#define CONTENTION_DELAY 10 /* For "slow" locks, back off */
-#define Lock_Cell(Cell) NULL /* Start lock */
-#define Unlock_Cell(Cell) /* End lock */
-#define Initialize_Heap_Locks() /* Clear at start up */
-#define Do_Store_No_Lock(To, F) *(To) = F
-#define Sleep(How_Long) { } /* Delay for locks, etc. */
+#define COMPILER_PROCESSOR_TYPE COMPILER_C_TYPE
+#define CC_IS_C 1
+#define CC_IS_GENERIC 1
+#define NO_HEAP_IN_LOW_MEMORY 1
-#define LOCK_FIRST(cell1, cell2) (cell1 < cell2)
+#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */
--- /dev/null
+/* -*-C-*-
+
+$Id: c.c,v 1.2 2007/04/22 16:31:24 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Compiled code interface for C "native" code. */
+
+#include "cmpint.h"
+#include "extern.h"
+#include "errors.h"
+
+bool
+read_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+ uint32_t n = ((uint32_t) (address[-1]));
+ return (decode_old_style_format_word (cet, (n & 0x0000FFFF)));
+}
+
+bool
+write_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+ uint16_t m;
+ if (!encode_old_style_format_word (cet, (&m)))
+ {
+ uint32_t n = ((uint32_t) (address[-1]));
+ (address[-1]) = ((insn_t) ((n & 0xFFFF0000) | m));
+ return (false);
+ }
+ return (true);
+}
+
+bool
+read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+ uint32_t n = ((uint32_t) (address[-1]));
+ uint16_t m = (n >> 16);
+ (ceo->offset) = (m >> 1);
+ (ceo->continued_p) = ((m & 1) == 1);
+ return (false);
+}
+
+bool
+write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+ if ((ceo->offset) < 0x4000)
+ {
+ uint16_t m = (((ceo->offset) << 1) | ((ceo->continued_p) ? 1 : 0));
+ uint32_t n = ((uint32_t) (address[-1]));
+ (address[-1]) = ((insn_t) ((n & 0x0000FFFF) | (m << 16)));
+ return (false);
+ }
+ return (true);
+}
+\f
+insn_t *
+read_compiled_closure_target (insn_t * start)
+{
+ return ((insn_t *) (start [CC_ENTRY_HEADER_SIZE + 1]));
+}
+
+void
+write_compiled_closure_target (insn_t * target, insn_t * start)
+{
+ (start [CC_ENTRY_HEADER_SIZE + 1]) = ((insn_t) target);
+}
+
+SCHEME_OBJECT
+compiled_closure_entry_to_target (insn_t * entry)
+{
+ return (MAKE_CC_ENTRY ((insn_t *) (entry[1])));
+}
+
+unsigned long
+compiled_closure_count (SCHEME_OBJECT * block)
+{
+ uint32_t n = ((uint32_t) (*block));
+ return (((n & 0xFFFF0000) == 0) ? (n & 0x0000FFFF) : 1);
+}
+
+insn_t *
+compiled_closure_start (SCHEME_OBJECT * block)
+{
+ uint32_t n = ((uint32_t) (*block));
+ return (block + (((n & 0xFFFF0000) == 0) ? 1 : 0));
+}
+
+insn_t *
+compiled_closure_entry (insn_t * start)
+{
+ return (start + CC_ENTRY_HEADER_SIZE);
+}
+
+insn_t *
+compiled_closure_next (insn_t * start)
+{
+ return (start + CC_ENTRY_HEADER_SIZE + 2);
+}
+
+SCHEME_OBJECT *
+skip_compiled_closure_padding (insn_t * start)
+{
+ return ((SCHEME_OBJECT *) start);
+}
+\f
+SCHEME_OBJECT
+read_uuo_symbol (SCHEME_OBJECT * saddr)
+{
+ return (saddr[0]);
+}
+
+unsigned int
+read_uuo_frame_size (SCHEME_OBJECT * saddr)
+{
+ return ((unsigned int) (saddr[1]));
+}
+
+insn_t *
+read_uuo_target (SCHEME_OBJECT * saddr)
+{
+ return ((insn_t *) (saddr[0]));
+}
+
+insn_t *
+read_uuo_target_no_reloc (SCHEME_OBJECT * saddr)
+{
+ return ((insn_t *) (saddr[0]));
+}
+
+void
+write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr)
+{
+ (saddr[0]) = ((SCHEME_OBJECT) target);
+}
+
+unsigned long
+trampoline_entry_size (unsigned long n_entries)
+{
+ return (n_entries * 2);
+}
+
+insn_t *
+trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index)
+{
+ return (((insn_t *) (block + 2 + (index * 2))) + CC_ENTRY_HEADER_SIZE);
+}
/* -*-C-*-
-$Id: c.h,v 1.12 2007/01/05 21:19:26 cph Exp $
+$Id: c.h,v 1.13 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#ifndef CMPINTMD_H_INCLUDED
-#define CMPINTMD_H_INCLUDED
+/* Compiled code interface macros for C "native" code. */
+
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
+
+/*
+
+Structure of code block (prior to link):
+
++-----+-------------------------+
+| MV | length |
++-----+-------------------------+
+| NMV | 2N |
++-----+-------------------------+
+| format/offset1 |
++-------------------------------+
+| index1 |
++-------------------------------+
+. .
+. .
++-------------------------------+
+| format/offsetN |
++-------------------------------+
+| indexN |
++-----+---------+---------------+
+| FIX | UUO | 2M | (not TC_LINKAGE_SECTION)
++-----+---------+---------------+
+| name1 |
++-------------------------------+
+| nargs1 |
++-------------------------------+
+. .
+. .
++-------------------------------+
+| nameM |
++-------------------------------+
+| nargsM |
++-----+---------+---------------+
+| FIX | REFS | L | (not TC_LINKAGE_SECTION)
++-----+---------+---------------+
+| name1 |
++-------------------------------+
+. .
+. .
++-------------------------------+
+| nameL |
++-----+---------+---------------+
+| FIX | ASNS | K | (not TC_LINKAGE_SECTION)
++-----+---------+---------------+
+| name1 |
++-------------------------------+
+. .
+. .
++-------------------------------+
+| nameK |
++-----+---------+---------------+
+| FIX | GUUO | 2J | (not TC_LINKAGE_SECTION)
++-----+---------+---------------+
+| name1 |
++-------------------------------+
+| nargs1 |
++-------------------------------+
+. .
+. .
++-------------------------------+
+| nameJ |
++-------------------------------+
+| nargsJ |
++-------------------------------+
+| const1 |
++-------------------------------+
+. .
+. .
++-------------------------------+
+| constI |
++-------------------------------+
+
+length = 2N + 2M + L + K + 2J + I + p(M) + p(L) + p(K) + p(J) + 1
+ where p(x) = ((x > 0) ? 1 : 0)
+
+format/offset is raw integer, of which only LS 32 bits are used:
+
+ 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1
+ 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
+ +-----------------------------+-+---------------+---------------+
+ | offset |C| fmthigh | fmtlow |
+ +-----------------------------+-+---------------+---------------+
+
+offset field is in insn_t units.
+
+The indexes refer to entries in the compiled_entries array.
-#include "limits.h"
-#include "cmptype.h"
-\f
-#define COMPILER_PROCESSOR_TYPE COMPILER_LOSING_C_TYPE
-
-#ifndef NATIVE_CODE_IS_C
-#define NATIVE_CODE_IS_C
-#endif
-
-#define WRITE_LABEL_DESCRIPTOR(entry,kind,offset) do \
-{ \
- SCHEME_OBJECT * _ent = ((SCHEME_OBJECT *) (entry)); \
- \
- COMPILED_ENTRY_FORMAT_WORD (_ent) = (kind); \
- COMPILED_ENTRY_OFFSET_WORD (_ent) = \
- (WORD_OFFSET_TO_OFFSET_WORD (offset)); \
-} while (0)
-
-#define CC_BLOCK_DISTANCE(block,entry) \
- (((SCHEME_OBJECT *) (entry)) - ((SCHEME_OBJECT *) (block)))
-
-typedef unsigned short format_word;
-
-extern int pc_zero_bits;
-
-#define PC_ZERO_BITS pc_zero_bits
-
-/* arbitrary */
-#define ENTRY_PREFIX_LENGTH 2
-
-#define ADJUST_CLOSURE_AT_CALL(entry_point, location) do { } while (0)
-
-#define COMPILED_CLOSURE_ENTRY_SIZE ((sizeof (SCHEME_OBJECT)) * 3)
-
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(output,location) do \
-{ \
- (output) = (((SCHEME_OBJECT *) (location))[1]); \
-} while (0)
-
-#define STORE_CLOSURE_ENTRY_ADDRESS(input,location) do \
-{ \
- ((SCHEME_OBJECT *) (location))[1] = ((SCHEME_OBJECT) (input)); \
-} while (0)
-
-#define MANIFEST_CLOSURE_COUNT(scan) \
-(((COMPILED_ENTRY_OFFSET_WORD (((SCHEME_OBJECT *) (scan)) + 1)) == 0) \
- ? (COMPILED_ENTRY_FORMAT_WORD (((SCHEME_OBJECT *) (scan)) + 1)) \
- : 1)
-
-#define FIRST_MANIFEST_CLOSURE_ENTRY(scan) \
-(((COMPILED_ENTRY_OFFSET_WORD (((SCHEME_OBJECT *) (scan)) + 1)) == 0) \
- ? ((char *) (((SCHEME_OBJECT *) (scan)) + 2)) \
- : ((char *) (((SCHEME_OBJECT *) (scan)) + 1)))
-\f
-/* Trampolines are implemented as tiny compiled code blocks that
- invoke the constant C procedure indexed by the number 0.
- */
-
-#define TRAMPOLINE_ENTRY_SIZE 2 /* Words */
-
-#define TRAMPOLINE_BLOCK_TO_ENTRY 3
-
-#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
- (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
-
-#define TRAMPOLINE_STORAGE(tramp_entry) \
- ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
-
-/* This depends on knowledge that the trampoline block is the first
- compiled code block.
- */
-
-#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \
-{ \
- ((SCHEME_OBJECT *) (entry_address))[0] = ((SCHEME_OBJECT) (index)); \
-} while (0)
-
-/* An execute cache contains a compiled entry for the callee,
- and a number of arguments (+ 1).
- */
-
-#define EXECUTE_CACHE_ENTRY_SIZE 2
-
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) do \
-{ \
- (target) = ((long) (((SCHEME_OBJECT *) (address))[1])); \
-} while (0)
-
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) do \
-{ \
- (target) = (((SCHEME_OBJECT *) (address))[0]); \
-} while (0)
-
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) do \
-{ \
- (target) = (((SCHEME_OBJECT *) (address)) [0]); \
-} while (0)
-
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) do \
-{ \
- ((SCHEME_OBJECT *) (address))[0] = ((SCHEME_OBJECT) (entry)); \
-} while (0)
-
-#define STORE_EXECUTE_CACHE_CODE(address) do { } while (0)
-
-extern void EXFUN (interface_initialize, (void));
-
-#define ASM_RESET_HOOK() interface_initialize ()
-\f
-/* Derived parameters and macros.
-
- These macros expect the above definitions to be meaningful.
- If they are not, the macros below may have to be changed as well.
- */
-
-#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1])
-#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2])
-
-/* The next one assumes 2's complement integers....*/
-#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
-#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-
-#define WORD_OFFSET_TO_OFFSET_WORD(words) ((words) << 1)
-
-#define BYTE_OFFSET_TO_OFFSET_WORD(bytes) \
- WORD_OFFSET_TO_OFFSET_WORD ((bytes) / (sizeof (SCHEME_OBJECT)))
-
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((sizeof (SCHEME_OBJECT)) * ((CLEAR_LOW_BIT (offset_word)) >> 1))
-
-#define MAKE_OFFSET_WORD(entry, block, continue) \
- ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
- ((char *) (block)))) | \
- ((continue) ? 1 : 0))
-
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 1)
+*/
\f
-/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
- a format word and a gc offset word. See the early part of the
- TRAMPOLINE picture, above.
- */
-
-#define CC_BLOCK_FIRST_ENTRY_OFFSET \
- (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
-
-/* Format words */
-
-#define FORMAT_BYTE_EXPR 0xFF
-#define FORMAT_BYTE_COMPLR 0xFE
-#define FORMAT_BYTE_CMPINT 0xFD
-#define FORMAT_BYTE_DLINK 0xFC
-#define FORMAT_BYTE_RETURN 0xFB
-
-#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
-#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
-#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
-
-/* This assumes that a format word is at least 16 bits,
- and the low order field is always 8 bits.
- */
+#define ASM_RESET_HOOK initialize_C_interface
-#define MAKE_FORMAT_WORD(field1, field2) \
- (((field1) << 8) | ((field2) & 0xff))
+typedef SCHEME_OBJECT insn_t;
-#define SIGN_EXTEND_FIELD(field, size) \
- (((field) & ((1 << (size)) - 1)) | \
- ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
- ((-1) << (size))))
+/* Number of insn_t units preceding entry address in which header
+ (type and offset info) is stored. */
+#define CC_ENTRY_HEADER_SIZE 1
-#define FORMAT_WORD_LOW_BYTE(word) \
- (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8))
+/* Number of insn_t units preceding entry header in which GC trap
+ instructions are stored. */
+#define CC_ENTRY_GC_TRAP_SIZE 0
-#define FORMAT_WORD_HIGH_BYTE(word) \
- (SIGN_EXTEND_FIELD \
- ((((unsigned long) (word)) >> 8), \
- (((sizeof (format_word)) * CHAR_BIT) - 8)))
+/* Size of execution cache in SCHEME_OBJECTS. */
+#define UUO_LINK_SIZE 2
+#define READ_UUO_TARGET(a, r) read_uuo_target (a)
-#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
- (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
+#undef CMPINT_USE_STRUCS
-#define COMPILED_ENTRY_FORMAT_LOW(addr) \
- (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
+#define EMBEDDED_CLOSURE_ADDRS_P 1
+#define READ_COMPILED_CLOSURE_TARGET(a, r) (read_compiled_closure_target (a))
-#define FORMAT_BYTE_FRAMEMAX 0x7f
+extern void initialize_C_interface (void);
+extern insn_t * read_uuo_target (SCHEME_OBJECT *);
+extern insn_t * read_compiled_closure_target (insn_t *);
-#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
-#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
+extern unsigned long c_code_table_export_length (unsigned long *);
+extern void export_c_code_table (SCHEME_OBJECT *);
+extern bool import_c_code_table (SCHEME_OBJECT *, unsigned long);
-#endif /* CMPINTMD_H_INCLUDED */
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
/* -*-C-*-
-$Id: hppa.h,v 1.56 2007/01/05 21:19:26 cph Exp $
+$Id: hppa.h,v 1.57 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/*
- *
- * Compiled code interface macros.
- *
- * See cmpint.txt for a description of these fields.
- *
- * Specialized for the HP Precision Architecture (Spectrum)
- */
+/* Compiled code interface macros, specialized for the HP Precision
+ Architecture. */
-#ifndef CMPINTMD_H_INCLUDED
-#define CMPINTMD_H_INCLUDED
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
-#include "cmptype.h"
#include "hppacach.h"
-\f
+
/* Machine parameters to be set by the user. */
/* Until cmpaux-hppa.m4 is updated. */
#define CMPINT_USE_STRUCS
-/* Processor type. Choose a number from the above list, or allocate your own. */
+/* Processor type. Choose a number from the above list, or allocate
+ your own. */
-#define COMPILER_PROCESSOR_TYPE COMPILER_SPECTRUM_TYPE
+#define COMPILER_PROCESSOR_TYPE COMPILER_SPECTRUM_TYPE
/* Size (in long words) of the contents of a floating point register if
different from a double. For example, an MC68881 saves registers
in 96 bit (3 longword) blocks.
Default is fine for PA.
- define COMPILER_TEMP_SIZE 3
-*/
+ define COMPILER_TEMP_SIZE 3
+ */
+
+#define COMPILER_REGBLOCK_N_TEMPS 256
/* Descriptor size.
This is the size of the offset field, and of the format field.
- This definition probably does not need to be changed.
- */
+ This definition probably does not need to be changed. */
typedef unsigned short format_word;
-/* PC alignment constraint.
- Change PC_ZERO_BITS to be how many low order bits of the pc are
- guaranteed to be 0 always because of PC alignment constraints.
-*/
-
-#define PC_ZERO_BITS 2
+typedef unsigned long insn_t;
/* C function pointers are pairs of instruction addreses and data segment
- pointers. We don't want that for the assembly language entry points.
- */
+ pointers. We don't want that for the assembly language entry points. */
-#define C_FUNC_PTR_IS_CLOSURE
+#define C_FUNC_PTR_IS_CLOSURE 1
#ifndef C_FUNC_PTR_IS_CLOSURE
# define interface_to_C ep_interface_to_C
\f
/* Utilities for manipulating absolute subroutine calls.
On the PA the absolute address is "smeared out" over two
- instructions, an LDIL and a BLE instruction.
- */
+ instructions, an LDIL and a BLE instruction. */
-extern unsigned long
- EXFUN (hppa_extract_absolute_address, (unsigned long *));
+extern unsigned long hppa_extract_absolute_address (unsigned long *);
-extern void
- EXFUN (hppa_store_absolute_address,
- (unsigned long *, unsigned long, unsigned long));
+extern void hppa_store_absolute_address
+ (unsigned long *, unsigned long, unsigned long);
#define EXTRACT_ABSOLUTE_ADDRESS(target, address) \
{ \
#define TRAMPOLINE_STORAGE(tramp_entry) \
((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
+ (2 + TRAMPOLINE_ENTRY_SIZE))
#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \
{ \
extern void \
- EXFUN (cache_flush_region, (PTR, long, unsigned int)); \
+ cache_flush_region (void *, long, unsigned int); \
\
unsigned long *PC; \
\
#define FLUSH_I_CACHE() do \
{ \
- extern void \
- EXFUN (flush_i_cache, (void)); \
- \
+ extern void flush_i_cache (void); \
flush_i_cache (); \
} while (0)
/* This flushes a region of the I-cache.
It is used after updating an execute cache while running.
Not needed during GC because FLUSH_I_CACHE will be used.
- */
+ */
#define FLUSH_I_CACHE_REGION(address, nwords) do \
{ \
- extern void \
- EXFUN (cache_flush_region, (PTR, long, unsigned int)); \
- \
- cache_flush_region (((PTR) (address)), ((long) (nwords)), \
+ extern void cache_flush_region, (void *, long, unsigned int); \
+ cache_flush_region (((void *) (address)), ((long) (nwords)), \
(D_CACHE | I_CACHE)); \
} while (0)
/* This pushes a region of the D-cache back to memory.
It is (typically) used after loading (and relocating) a piece of code
into memory.
- */
+ */
#define PUSH_D_CACHE_REGION(address, nwords) do \
{ \
- extern void \
- EXFUN (push_d_cache_region, (PTR, unsigned long)); \
- \
- push_d_cache_region (((PTR) (address)), \
+ extern void push_d_cache_region (void *, unsigned long); \
+ push_d_cache_region (((void *) (address)), \
((unsigned long) (nwords))); \
} while (0)
-extern void EXFUN (hppa_update_primitive_table, (int, int));
-extern Boolean EXFUN (hppa_grow_primitive_table, (int));
+extern void hppa_update_primitive_table (int, int);
+extern bool hppa_grow_primitive_table (int);
#define UPDATE_PRIMITIVE_TABLE_HOOK hppa_update_primitive_table
#define GROW_PRIMITIVE_TABLE_HOOK hppa_grow_primitive_table
#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-#if (PC_ZERO_BITS == 0)
-/* Instructions aligned on byte boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) >> 1)
-#endif
-
-#if (PC_ZERO_BITS == 1)
-/* Instructions aligned on word (16 bit) boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- (CLEAR_LOW_BIT(offset_word))
-#endif
-
-#if (PC_ZERO_BITS >= 2)
-/* Should be OK for =2, but bets are off for >2 because of problems
- mentioned earlier!
-*/
-#define SHIFT_AMOUNT (PC_ZERO_BITS - 1)
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT))
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
-#endif
+#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1)
+#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1)
#define MAKE_OFFSET_WORD(entry, block, continue) \
((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
((char *) (block)))) | \
((continue) ? 1 : 0))
-#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 1)
-#endif
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 2)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 2)
-#endif
-
-#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
((count) / EXECUTE_CACHE_ENTRY_SIZE)
#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
((entries) * EXECUTE_CACHE_ENTRY_SIZE)
-#endif
\f
/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
a format word and a gc offset word. See the early part of the
};
long
-DEFUN (assemble_17, (inst), union branch_inst inst)
+assemble_17 (union branch_inst inst)
{
union assemble_17_u off;
}
long
-DEFUN (assemble_12, (inst), union branch_inst inst)
+assemble_12 (union branch_inst inst)
{
union assemble_12_u off;
static unsigned long hppa_closure_hook = 0;
static unsigned long
-DEFUN (C_closure_entry_point, (C_closure), unsigned long C_closure)
+C_closure_entry_point (unsigned long C_closure)
{
if ((C_closure & 0x3) != 0x2)
return (C_closure);
0x30, 0x31, 0x32, 0x33, 0x38, 0x39, 0x3a
};
-static Boolean
+static bool
branch_opcode_table[64];
static unsigned long
#define FAHRENHEIT 451
static void
-DEFUN_VOID (bkpt_init)
+bkpt_init (void)
{
int i, this_size, max_size;
union branch_inst instr;
- extern void EXFUN (bkpt_normal_proceed, (void));
- extern void EXFUN (bkpt_plus_proceed, (void));
- extern void EXFUN (bkpt_minus_proceed_start, (void));
- extern void EXFUN (bkpt_minus_proceed, (void));
- extern void EXFUN (bkpt_closure_proceed, (void));
- extern void EXFUN (bkpt_closure_proceed_end, (void));
+ extern void bkpt_normal_proceed (void);
+ extern void bkpt_plus_proceed (void);
+ extern void bkpt_minus_proceed_start (void);
+ extern void bkpt_minus_proceed (void);
+ extern void bkpt_closure_proceed (void);
+ extern void bkpt_closure_proceed_end (void);
for (i = 0;
- i < ((sizeof (branch_opcode_table)) / (sizeof (Boolean)));
+ i < ((sizeof (branch_opcode_table)) / (sizeof (bool)));
i++)
branch_opcode_table[i] = FALSE;
this_size = (bkpt_minus_proceed_thunk_start - bkpt_plus_proceed_thunk);
if (this_size > max_size)
max_size = this_size;
-
+
bkpt_proceed_buffer = ((unsigned long *)
(malloc (max_size * (sizeof (unsigned long)))));
if (bkpt_proceed_buffer == ((unsigned long *) NULL))
#define BKPT_KIND_BLE_INST 4
#define BKPT_KIND_CLOSURE_ENTRY 5
-extern void EXFUN (cache_flush_region, (PTR, long, unsigned int));
+extern void cache_flush_region (void *, long, unsigned int);
static SCHEME_OBJECT
-DEFUN (alloc_bkpt_handle, (kind, first_instr, entry_point),
- int kind AND unsigned long first_instr AND PTR entry_point)
+alloc_bkpt_handle (int kind, unsigned long first_instr, void * entry_point)
{
SCHEME_OBJECT * handle;
Primitive_GC_If_Needed (5);
handle[2] = ((SCHEME_OBJECT) (FIXNUM_ZERO + kind));
handle[3] = ((SCHEME_OBJECT) first_instr);
handle[4] = (ENTRY_TO_OBJECT (entry_point));
-
+
return (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, handle));
}
SCHEME_OBJECT
-DEFUN (bkpt_install, (entry_point), PTR entry_point)
+bkpt_install (void * entry_point)
{
unsigned long kind;
SCHEME_OBJECT handle;
if ((COMPILED_ENTRY_FORMAT_WORD (entry_point)) == FORMAT_WORD_CLOSURE)
{
- /* This assumes that the first instruction is normal */
+ /* This assumes that the first instruction is normal */
kind = BKPT_KIND_CLOSURE_ENTRY;
new_instr = closure_entry_bkpt_instruction;
}
handle = (alloc_bkpt_handle (kind, first_instr, entry_point));
(* ((unsigned long *) entry_point)) = new_instr;
- cache_flush_region (((PTR) entry_point), 1, (D_CACHE | I_CACHE));
+ cache_flush_region (((void *) entry_point), 1, (D_CACHE | I_CACHE));
return (handle);
}
SCHEME_OBJECT
-DEFUN (bkpt_closure_install, (entry_point), PTR entry_point)
+bkpt_closure_install (void * entry_point)
{
unsigned long * instrs = ((unsigned long *) entry_point);
SCHEME_OBJECT handle;
handle = (alloc_bkpt_handle (BKPT_KIND_CLOSURE, instrs[2], entry_point));
instrs[2] = closure_bkpt_instruction;
- cache_flush_region (((PTR) &instrs[2]), 1, (D_CACHE | I_CACHE));
+ cache_flush_region (((void *) &instrs[2]), 1, (D_CACHE | I_CACHE));
return (handle);
}
-\f
+
void
-DEFUN (bkpt_remove, (entry_point, handle),
- PTR entry_point AND SCHEME_OBJECT handle)
+bkpt_remove (void * entry_point, SCHEME_OBJECT handle)
{
int offset;
unsigned long * instrs = ((unsigned long *) entry_point);
else
error_external_return ();
- instrs[offset] = ((unsigned long) (FAST_MEMORY_REF (handle, 3)));
- cache_flush_region (((PTR) &instrs[offset]), 1, (D_CACHE | I_CACHE));
+ instrs[offset] = ((unsigned long) (MEMORY_REF (handle, 3)));
+ cache_flush_region (((void *) &instrs[offset]), 1, (D_CACHE | I_CACHE));
return;
}
-Boolean
-DEFUN (bkpt_p, (entry_point), PTR entry_point)
+bool
+bkpt_p (void * entry_point)
{
unsigned long * instrs = ((unsigned long *) entry_point);
|| (instrs[0] == closure_entry_bkpt_instruction)
|| (instrs[2] == closure_bkpt_instruction));
}
-
-Boolean
-DEFUN (do_bkpt_proceed, (value), unsigned long * value)
+\f
+long
+do_bkpt_proceed (insn_t ** addr_r)
{
- unsigned long * buffer = ((unsigned long *) bkpt_proceed_buffer);
+ insn_t * buffer = bkpt_proceed_buffer;
SCHEME_OBJECT ep = (STACK_POP ());
SCHEME_OBJECT handle = (STACK_POP ());
SCHEME_OBJECT state = (STACK_POP ());
STACK_POP (); /* Pop duplicate entry point. */
- switch (OBJECT_DATUM (FAST_MEMORY_REF (handle, 2)))
- {
- case BKPT_KIND_CLOSURE:
+ switch (OBJECT_DATUM (MEMORY_REF (handle, 2)))
{
- int i, len;
- unsigned long * clos_entry
- = (OBJECT_ADDRESS (FAST_MEMORY_REF (handle, 4)));
- SCHEME_OBJECT real_entry_point;
-
- EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry_point, clos_entry);
- len = (bkpt_closure_proceed_thunk_end - bkpt_closure_proceed_thunk);
- for (i = 0; i < (len - 2); i++)
- buffer[i] = bkpt_closure_proceed_thunk[i];
- cache_flush_region (((PTR) buffer), (len - 2), (D_CACHE | I_CACHE));
-
- buffer[len - 2] = ((unsigned long) clos_entry);
- buffer[len - 1] = real_entry_point;
-
- val_register = SHARP_F;
- * value = ((unsigned long) buffer);
- return (TRUE);
- }
-\f
+ case BKPT_KIND_CLOSURE:
+ {
+ int i, len;
+ unsigned long * clos_entry
+ = (OBJECT_ADDRESS (MEMORY_REF (handle, 4)));
+ SCHEME_OBJECT real_entry_point;
+
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry_point, clos_entry);
+ len = (bkpt_closure_proceed_thunk_end - bkpt_closure_proceed_thunk);
+ for (i = 0; i < (len - 2); i++)
+ buffer[i] = bkpt_closure_proceed_thunk[i];
+ cache_flush_region (((void *) buffer), (len - 2), (D_CACHE | I_CACHE));
+
+ buffer[len - 2] = ((unsigned long) clos_entry);
+ buffer[len - 1] = real_entry_point;
+
+ SET_VAL (SHARP_F);
+ (*addr_r) = buffer;
+ return (PRIM_DONE);
+ }
+
case BKPT_KIND_NORMAL:
- {
- int i, len;
+ {
+ int i, len;
- len = (bkpt_plus_proceed_thunk - bkpt_normal_proceed_thunk);
- for (i = 0; i < (len - 2); i++)
- buffer[i] = bkpt_normal_proceed_thunk[i];
- buffer[len - 2] = ((unsigned long) (FAST_MEMORY_REF (handle, 3)));
+ len = (bkpt_plus_proceed_thunk - bkpt_normal_proceed_thunk);
+ for (i = 0; i < (len - 2); i++)
+ buffer[i] = bkpt_normal_proceed_thunk[i];
+ buffer[len - 2] = ((unsigned long) (MEMORY_REF (handle, 3)));
- cache_flush_region (((PTR) buffer), (len - 1), (D_CACHE | I_CACHE));
- buffer[len - 1] = (((unsigned long) (OBJECT_ADDRESS (ep))) + 4);
+ cache_flush_region (((void *) buffer), (len - 1), (D_CACHE | I_CACHE));
+ buffer[len - 1] = (((unsigned long) (OBJECT_ADDRESS (ep))) + 4);
- val_register = state;
- * value = ((unsigned long) buffer);
- return (TRUE);
- }
+ SET_VAL (state);
+ (*addr_r) = buffer;
+ return (PRIM_DONE);
+ }
case BKPT_KIND_CLOSURE_ENTRY:
- {
- STACK_PUSH (state); /* closure object */
- * value = ((unsigned long) ((OBJECT_ADDRESS (ep)) + 2));
- return (TRUE);
- }
+ {
+ STACK_PUSH (state); /* closure object */
+ (*addr_r) = ((CC_ENTRY_ADDRESS (ep)) + 2);
+ return (PRIM_DONE);
+ }
case BKPT_KIND_BL_INST:
case BKPT_KIND_BLE_INST:
default:
STACK_PUSH (ep);
- * value = ((unsigned long) ERR_EXTERNAL_RETURN);
- return (FALSE);
+ return (ERR_EXTERNAL_RETURN);
case BKPT_KIND_PC_REL_BRANCH:
- {
- long offset;
- int i, len, clobber;
- union branch_inst new, old;
- unsigned long * instrs = ((unsigned long *) (OBJECT_ADDRESS (ep)));
- unsigned long * block;
-
- old.inst = ((unsigned long) (FAST_MEMORY_REF (handle, 3)));
- offset = (assemble_12 (old));
- if (offset >= 0)
{
- block = bkpt_plus_proceed_thunk;
- len = (bkpt_minus_proceed_thunk_start - block);
- clobber = 0;
- }
- else
- {
- block = bkpt_minus_proceed_thunk_start;
- len = (bkpt_closure_proceed_thunk - block);
- clobber = (bkpt_minus_proceed_thunk - block);
+ long offset;
+ int i, len, clobber;
+ union branch_inst new, old;
+ insn_t * instrs = (CC_ENTRY_ADDRESS (ep));
+ unsigned long * block;
+
+ old.inst = ((unsigned long) (MEMORY_REF (handle, 3)));
+ offset = (assemble_12 (old));
+ if (offset >= 0)
+ {
+ block = bkpt_plus_proceed_thunk;
+ len = (bkpt_minus_proceed_thunk_start - block);
+ clobber = 0;
+ }
+ else
+ {
+ block = bkpt_minus_proceed_thunk_start;
+ len = (bkpt_closure_proceed_thunk - block);
+ clobber = (bkpt_minus_proceed_thunk - block);
+ }
+
+ for (i = 0; i < (len - 2); i++)
+ buffer[i] = block[i];
+
+ new.inst = buffer[clobber];
+ old.inst = ((unsigned long) (MEMORY_REF (handle, 3)));
+ old.fields.w2b = new.fields.w2b;
+ old.fields.w2a = new.fields.w2a;
+ old.fields.w0 = new.fields.w0;
+ buffer[clobber] = old.inst;
+ buffer[clobber + 1] = instrs[1];
+ cache_flush_region (((void *) buffer), (len - 2), (D_CACHE | I_CACHE));
+
+ buffer[len - 2] = (((unsigned long) instrs) + 8);
+ buffer[len - 1] = ((((unsigned long) instrs) + 8)
+ + offset);
+
+ SET_VAL (state);
+ (*addr_r) = (buffer + clobber);
+ return (PRIM_DONE);
}
-
- for (i = 0; i < (len - 2); i++)
- buffer[i] = block[i];
-
- new.inst = buffer[clobber];
- old.inst = ((unsigned long) (FAST_MEMORY_REF (handle, 3)));
- old.fields.w2b = new.fields.w2b;
- old.fields.w2a = new.fields.w2a;
- old.fields.w0 = new.fields.w0;
- buffer[clobber] = old.inst;
- buffer[clobber + 1] = instrs[1];
- cache_flush_region (((PTR) buffer), (len - 2), (D_CACHE | I_CACHE));
-
- buffer[len - 2] = (((unsigned long) instrs) + 8);
- buffer[len - 1] = ((((unsigned long) instrs) + 8)
- + offset);
-
- val_register = state;
- * value = ((unsigned long) &buffer[clobber]);
- return (TRUE);
}
- }
}
\f
static void
-DEFUN (transform_procedure_entries, (len, otable, ntable),
- long len AND PTR * otable AND PTR * ntable)
+transform_procedure_entries (long len, void ** otable, void ** ntable)
{
long counter;
-
+
for (counter = 0; counter < len; counter++)
ntable[counter] =
- ((PTR) (C_closure_entry_point ((unsigned long) (otable [counter]))));
+ ((void *) (C_closure_entry_point ((unsigned long) (otable [counter]))));
return;
-}
+}
-static PTR *
-DEFUN (transform_procedure_table, (table_length, old_table),
- long table_length AND PTR * old_table)
+static void **
+transform_procedure_table (long table_length, void ** old_table)
{
- PTR * new_table;
+ void ** new_table;
- new_table = ((PTR *) (malloc (table_length * (sizeof (PTR)))));
- if (new_table == ((PTR *) NULL))
+ new_table = ((void **) (malloc (table_length * (sizeof (void *)))));
+ if (new_table == ((void **) NULL))
{
outf_fatal ("transform_procedure_table: malloc (%d) failed.\n",
- (table_length * (sizeof (PTR))));
+ (table_length * (sizeof (void *))));
exit (1);
}
transform_procedure_entries (table_length, old_table, new_table);
#endif
void
-DEFUN_VOID (change_vm_protection)
+change_vm_protection (void)
{
#if 0
/* Thought I needed this under _BSD4_3 */
unsigned long size;
heap_start_page = (((unsigned long) Heap) & (pagesize - 1));
- size = (((((unsigned long) Highest_Allocated_Address) + (pagesize - 1))
- & (pagesize - 1))
+ size = (((memory_block_end + (pagesize - 1)) & (pagesize - 1))
- heap_start_page);
if ((mprotect (((caddr_t) heap_start_page), size, VM_PROT_SCHEME))
== -1)
termination_init_error ();
}
#endif
- return;
}
\f
#include "option.h"
static struct pdc_cache_dump cache_info;
static void
-DEFUN_VOID (flush_i_cache_initialize)
+flush_i_cache_initialize (void)
{
- extern char * EXFUN (getenv, (const char *));
- CONST char * models_filename =
- (search_path_for_file (0, MODELS_FILENAME, 1, 1));
+ const char * models_filename =
+ (search_path_for_file (0, MODELS_FILENAME, true, true));
char * model;
model = (getenv ("MITSCHEME_HPPA_MODEL"));
It also changes the VM protection of the heap, if necessary.
*/
-extern PTR * hppa_utility_table;
-extern PTR * hppa_primitive_table;
+extern void ** hppa_utility_table;
+extern void ** hppa_primitive_table;
-PTR * hppa_utility_table = ((PTR *) NULL);
+void ** hppa_utility_table = ((void **) NULL);
static void
-DEFUN (hppa_reset_hook, (utility_length, utility_table),
- long utility_length AND PTR * utility_table)
+hppa_reset_hook (long utility_length, void ** utility_table)
{
- extern void EXFUN (interface_initialize, (void));
- extern void EXFUN (cross_segment_call, (void));
+ extern void interface_initialize (void);
+ extern void cross_segment_call (void);
flush_i_cache_initialize ();
interface_initialize ();
#define ASM_RESET_HOOK() do \
{ \
bkpt_init (); \
- hppa_reset_hook (((sizeof (utility_table)) / (sizeof (PTR))), \
- ((PTR *) (&utility_table[0]))); \
+ hppa_reset_hook (((sizeof (utility_table)) / (sizeof (void *))), \
+ ((void **) (&utility_table[0]))); \
} while (0)
-PTR * hppa_primitive_table = ((PTR *) NULL);
+void ** hppa_primitive_table = ((void **) NULL);
void
-DEFUN (hppa_update_primitive_table, (low, high), int low AND int high)
+hppa_update_primitive_table (int low, int high)
{
transform_procedure_entries ((high - low),
- ((PTR *) (Primitive_Procedure_Table + low)),
+ ((void **) (Primitive_Procedure_Table + low)),
(hppa_primitive_table + low));
return;
}
-Boolean
-DEFUN (hppa_grow_primitive_table, (new_size), int new_size)
+bool
+hppa_grow_primitive_table (int new_size)
{
- PTR * new_table
- = ((PTR *) (realloc (hppa_primitive_table, (new_size * (sizeof (PTR))))));
- if (new_table != ((PTR *) NULL))
+ void ** new_table
+ = ((void **)
+ (realloc (hppa_primitive_table, (new_size * (sizeof (void *))))));
+ if (new_table != ((void **) NULL))
hppa_primitive_table = new_table;
- return (new_table != ((PTR *) NULL));
+ return (new_table != ((void **) NULL));
}
\f
/*
*/
unsigned long
-DEFUN (hppa_extract_absolute_address, (addr), unsigned long * addr)
+hppa_extract_absolute_address (unsigned long * addr)
{
union short_pointer result;
union branch_inst ble;
}
void
-DEFUN (hppa_store_absolute_address, (addr, sourcev, nullify_p),
- unsigned long * addr AND unsigned long sourcev
- AND unsigned long nullify_p)
+hppa_store_absolute_address (unsigned long * addr, unsigned long sourcev,
+ unsigned long nullify_p)
{
union short_pointer source;
union ldil_inst ldil;
*/
extern void
- EXFUN (flush_i_cache, (void)),
- EXFUN (push_d_cache_region, (PTR, unsigned long));
+ flush_i_cache (void),
+ push_d_cache_region (void *, unsigned long);
void
-DEFUN_VOID (flush_i_cache)
+flush_i_cache (void)
{
extern void
- EXFUN (cache_flush_all, (unsigned int, struct pdc_cache_result *));
+ cache_flush_all (unsigned int, struct pdc_cache_result *);
struct pdc_cache_result * cache_desc;
-
+
cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format));
/* The call can be interrupted in the middle of a set, so do it twice.
}
void
-DEFUN (push_d_cache_region, (start_address, block_size),
- PTR start_address AND unsigned long block_size)
+push_d_cache_region (void * start_address, unsigned long block_size)
{
extern void
- EXFUN (cache_flush_region, (PTR, long, unsigned int));
+ cache_flush_region (void *, long, unsigned int);
struct pdc_cache_result * cache_desc;
-
+
cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format));
/* Note that the first and last words are also flushed from the I-cache
{
cache_flush_region (start_address, block_size, D_CACHE);
cache_flush_region (start_address, 1, I_CACHE);
- cache_flush_region (((PTR)
+ cache_flush_region (((void *)
(((unsigned long *) start_address)
+ (block_size - 1))),
1,
#endif /* IN_CMPINT_C */
-#endif /* CMPINTMD_H_INCLUDED */
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
-#| -*-Scheme-*-
+/* -*-C-*-
-$Id: files-gc-std.scm,v 1.6 2007/01/05 21:19:26 cph Exp $
+$Id: i386-config.h,v 1.2 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.
-|#
+*/
-;;;; C files for standard garbage collector.
+#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED
+#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1
-"fasdump"
-"gcloop"
-"memmag"
-"purify"
-"wabbit"
+#define COMPILER_PROCESSOR_TYPE COMPILER_IA32_TYPE
+#define CC_IS_NATIVE 1
+
+#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */
--- /dev/null
+/* -*-C-*-
+
+$Id: i386.c,v 1.2 2007/04/22 16:31:24 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Compiled code interface for Intel IA-32. */
+
+#include "cmpint.h"
+#include "extern.h"
+#include "outf.h"
+#include "errors.h"
+
+extern void * tospace_to_newspace (void *);
+\f
+bool
+read_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+ return (decode_old_style_format_word (cet, (((uint16_t *) address) [-2])));
+}
+
+bool
+write_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+ return (encode_old_style_format_word (cet, ((uint16_t *) address) - 2));
+}
+
+bool
+read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+ uint16_t n = (((uint16_t *) address) [-1]);
+ (ceo->offset) = (n >> 1);
+ (ceo->continued_p) = ((n & 1) != 0);
+ return (false);
+}
+
+bool
+write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+ if (! ((ceo->offset) < 0x4000))
+ return (true);
+ (((uint16_t *) address) [-1])
+ = (((ceo->offset) << 1) | ((ceo->continued_p) ? 1 : 0));
+ return (false);
+}
+\f
+/* Compiled closures */
+
+void
+start_closure_relocation (SCHEME_OBJECT * scan, reloc_ref_t * ref)
+{
+ (ref->old_addr) = (CC_ENTRY_ADDRESS (* ((CC_BLOCK_ADDR_END (scan)) - 1)));
+ (ref->new_addr)
+ = (tospace_to_newspace
+ (compiled_closure_entry (compiled_closure_start (scan + 1))));
+}
+
+insn_t *
+read_compiled_closure_target (insn_t * start, reloc_ref_t * ref)
+{
+ insn_t * addr = (start + CC_ENTRY_HEADER_SIZE + 1);
+ return (((((insn_t *) (tospace_to_newspace (addr + 4)))
+ - (ref->new_addr))
+ + (ref->old_addr))
+ + (* ((long *) addr)));
+}
+
+void
+write_compiled_closure_target (insn_t * target, insn_t * start)
+{
+ insn_t * addr = (start + CC_ENTRY_HEADER_SIZE + 1);
+ (* ((long *) addr))
+ = (target - ((insn_t *) (tospace_to_newspace (addr + 4))));
+}
+
+#define SINGLE_CLOSURE_OFFSET \
+ (((sizeof (SCHEME_OBJECT)) + CC_ENTRY_HEADER_SIZE) << 1)
+
+unsigned long
+compiled_closure_count (SCHEME_OBJECT * block)
+{
+ unsigned short * addr = ((unsigned short *) block);
+ return (((addr[1]) == SINGLE_CLOSURE_OFFSET) ? 1 : (addr[0]));
+}
+
+insn_t *
+compiled_closure_start (SCHEME_OBJECT * block)
+{
+ unsigned short * addr = ((unsigned short *) block);
+ return
+ (((insn_t *) block)
+ + (((addr[1]) == SINGLE_CLOSURE_OFFSET)
+ ? 0
+ : CC_ENTRY_HEADER_SIZE));
+}
+
+insn_t *
+compiled_closure_entry (insn_t * start)
+{
+ return (start + CC_ENTRY_HEADER_SIZE);
+}
+
+insn_t *
+compiled_closure_next (insn_t * start)
+{
+ return (start + CC_ENTRY_HEADER_SIZE + 6);
+}
+
+SCHEME_OBJECT *
+skip_compiled_closure_padding (insn_t * start)
+{
+ return
+ ((SCHEME_OBJECT *)
+ ((((unsigned long) start) + ((sizeof (SCHEME_OBJECT)) - 1))
+ &~ ((sizeof (SCHEME_OBJECT)) - 1)));
+}
+
+SCHEME_OBJECT
+compiled_closure_entry_to_target (insn_t * entry)
+{
+ insn_t * addr = (entry + 1);
+ return (MAKE_CC_ENTRY ((addr + 4) + (* ((long *) addr))));
+}
+\f
+/* Execution caches (UUO links)
+
+ An execution cache is a region of memory that lives in the
+ constants section of a compiled-code block. It is an indirection
+ for calling external procedures that allows the linker to control
+ the calling process without having to find and change all the
+ places in the compiled code that refer to it.
+
+ Prior to linking, the execution cache has two pieces of
+ information: (1) the name of the procedure being called (a symbol),
+ and (2) the number of arguments that will be passed to the
+ procedure. */
+
+SCHEME_OBJECT
+read_uuo_symbol (SCHEME_OBJECT * saddr)
+{
+ return (saddr[1]);
+}
+
+unsigned int
+read_uuo_frame_size (SCHEME_OBJECT * saddr)
+{
+ return (* ((unsigned short *) saddr));
+}
+
+void
+start_operator_relocation (SCHEME_OBJECT * saddr, reloc_ref_t * ref)
+{
+ insn_t * nsaddr = (tospace_to_newspace (saddr));
+ (ref->old_addr) = (* ((insn_t **) saddr));
+ (ref->new_addr) = nsaddr;
+ (* ((insn_t **) saddr)) = nsaddr;
+}
+
+insn_t *
+read_uuo_target (SCHEME_OBJECT * saddr, reloc_ref_t * ref)
+{
+ insn_t * addr = (((insn_t *) saddr) + 4);
+ insn_t * base = (tospace_to_newspace (addr + 4));
+ return (((ref == 0)
+ ? base
+ : ((base - (ref->new_addr)) + (ref->old_addr)))
+ + (* ((long *) addr)));
+}
+
+insn_t *
+read_uuo_target_no_reloc (SCHEME_OBJECT * saddr)
+{
+ return (read_uuo_target (saddr, 0));
+}
+
+void
+write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr)
+{
+ insn_t * addr = (((insn_t *) saddr) + 3);
+ (*addr++) = 0xE9; /* JMP rel32 */
+ (* ((long *) addr))
+ = (target - ((insn_t *) (tospace_to_newspace (addr + 4))));
+}
+\f
+#define TRAMPOLINE_ENTRY_SIZE 3
+
+#define ESI_TRAMPOLINE_TO_INTERFACE_OFFSET \
+ ((COMPILER_REGBLOCK_N_FIXED + (2 * COMPILER_HOOK_SIZE)) \
+ * SIZEOF_SCHEME_OBJECT)
+
+unsigned long
+trampoline_entry_size (unsigned long n_entries)
+{
+ return (n_entries * TRAMPOLINE_ENTRY_SIZE);
+}
+
+insn_t *
+trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index)
+{
+ return (((insn_t *) (block + 2 + (index * TRAMPOLINE_ENTRY_SIZE)))
+ + CC_ENTRY_HEADER_SIZE);
+}
+
+bool
+store_trampoline_insns (insn_t * entry, byte_t code)
+{
+ (*entry++) = 0xB0; /* MOV AL,code */
+ (*entry++) = code;
+ (*entry++) = 0xFF; /* CALL /2 disp32(ESI) */
+ (*entry++) = 0x96;
+ (* ((unsigned long *) entry)) = ESI_TRAMPOLINE_TO_INTERFACE_OFFSET;
+ IA32_CACHE_SYNCHRONIZE ();
+ return (false);
+}
+\f
+#ifdef _MACH_UNIX
+# include <mach.h>
+# define VM_PROT_SCHEME (VM_PROT_READ | VM_PROT_WRITE | VM_PROT_EXECUTE)
+#endif
+
+#define SETUP_REGISTER(hook) do \
+{ \
+ (* ((unsigned long *) (esi_value + offset))) \
+ = ((unsigned long) (hook)); \
+ offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
+ declare_builtin (((unsigned long) hook), #hook); \
+} while (0)
+
+void
+i386_reset_hook (void)
+{
+ unsigned int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT)));
+ unsigned char * esi_value = ((unsigned char *) Registers);
+ bool fp_support_present = (i386_interface_initialize ());
+
+ /* These must match machines/i386/lapgen.scm */
+
+ SETUP_REGISTER (asm_scheme_to_interface); /* 0 */
+ SETUP_REGISTER (asm_scheme_to_interface_call); /* 1 */
+
+ if (offset != ESI_TRAMPOLINE_TO_INTERFACE_OFFSET)
+ {
+ outf_fatal ("\ni386_reset_hook: ESI_TRAMPOLINE_TO_INTERFACE_OFFSET\n");
+ Microcode_Termination (TERM_EXIT);
+ }
+ SETUP_REGISTER (asm_trampoline_to_interface); /* 2 */
+
+ SETUP_REGISTER (asm_interrupt_procedure); /* 3 */
+ SETUP_REGISTER (asm_interrupt_continuation); /* 4 */
+ SETUP_REGISTER (asm_interrupt_closure); /* 5 */
+ SETUP_REGISTER (asm_interrupt_dlink); /* 6 */
+ SETUP_REGISTER (asm_primitive_apply); /* 7 */
+ SETUP_REGISTER (asm_primitive_lexpr_apply); /* 8 */
+ SETUP_REGISTER (asm_assignment_trap); /* 9 */
+ SETUP_REGISTER (asm_reference_trap); /* 10 */
+ SETUP_REGISTER (asm_safe_reference_trap); /* 11 */
+ SETUP_REGISTER (asm_link); /* 12 */
+ SETUP_REGISTER (asm_error); /* 13 */
+ SETUP_REGISTER (asm_primitive_error); /* 14 */
+ SETUP_REGISTER (asm_short_primitive_apply); /* 15 */
+
+ /* No more room for positive offsets without going to 32-bit
+ offsets! */
+
+ /* This is a hack to make all the hooks be addressable with byte
+ offsets (instead of longword offsets). The register block
+ extends to negative offsets as well, so all the following hooks
+ are accessed with negative offsets, and all fit in a byte. */
+
+ offset = -128;
+ if (fp_support_present)
+ {
+ SETUP_REGISTER (asm_generic_add); /* -32 */
+ SETUP_REGISTER (asm_generic_subtract); /* -31 */
+ SETUP_REGISTER (asm_generic_multiply); /* -30 */
+ SETUP_REGISTER (asm_generic_divide); /* -29 */
+ SETUP_REGISTER (asm_generic_equal); /* -28 */
+ SETUP_REGISTER (asm_generic_less); /* -27 */
+ SETUP_REGISTER (asm_generic_greater); /* -26 */
+ SETUP_REGISTER (asm_generic_increment); /* -25 */
+ SETUP_REGISTER (asm_generic_decrement); /* -24 */
+ SETUP_REGISTER (asm_generic_zero); /* -23 */
+ SETUP_REGISTER (asm_generic_positive); /* -22 */
+ SETUP_REGISTER (asm_generic_negative); /* -21 */
+ SETUP_REGISTER (asm_generic_quotient); /* -20 */
+ SETUP_REGISTER (asm_generic_remainder); /* -19 */
+ SETUP_REGISTER (asm_generic_modulo); /* -18 */
+ }
+ else
+ {
+ SETUP_REGISTER (asm_nofp_add); /* -32 */
+ SETUP_REGISTER (asm_nofp_subtract); /* -31 */
+ SETUP_REGISTER (asm_nofp_multiply); /* -30 */
+ SETUP_REGISTER (asm_nofp_divide); /* -29 */
+ SETUP_REGISTER (asm_nofp_equal); /* -28 */
+ SETUP_REGISTER (asm_nofp_less); /* -27 */
+ SETUP_REGISTER (asm_nofp_greater); /* -26 */
+ SETUP_REGISTER (asm_nofp_increment); /* -25 */
+ SETUP_REGISTER (asm_nofp_decrement); /* -24 */
+ SETUP_REGISTER (asm_nofp_zero); /* -23 */
+ SETUP_REGISTER (asm_nofp_positive); /* -22 */
+ SETUP_REGISTER (asm_nofp_negative); /* -21 */
+ SETUP_REGISTER (asm_nofp_quotient); /* -20 */
+ SETUP_REGISTER (asm_nofp_remainder); /* -19 */
+ SETUP_REGISTER (asm_nofp_modulo); /* -18 */
+ }
+
+ SETUP_REGISTER (asm_sc_apply); /* -17 */
+ SETUP_REGISTER (asm_sc_apply_size_1); /* -16 */
+ SETUP_REGISTER (asm_sc_apply_size_2); /* -15 */
+ SETUP_REGISTER (asm_sc_apply_size_3); /* -14 */
+ SETUP_REGISTER (asm_sc_apply_size_4); /* -13 */
+ SETUP_REGISTER (asm_sc_apply_size_5); /* -12 */
+ SETUP_REGISTER (asm_sc_apply_size_6); /* -11 */
+ SETUP_REGISTER (asm_sc_apply_size_7); /* -10 */
+ SETUP_REGISTER (asm_sc_apply_size_8); /* -9 */
+ SETUP_REGISTER (asm_interrupt_continuation_2); /* -8 */
+ if (ia32_cpuid_needed)
+ SETUP_REGISTER (asm_serialize_cache); /* -7 */
+ else
+ SETUP_REGISTER (asm_dont_serialize_cache); /* -7 */
+
+#ifdef _MACH_UNIX
+ {
+ vm_address_t addr;
+ vm_size_t size;
+ vm_prot_t prot;
+ vm_prot_t max_prot;
+ vm_inherit_t inheritance;
+ boolean_t shared;
+ port_t object;
+ vm_offset_t offset;
+
+ addr = ((vm_address_t) Heap);
+ if ((vm_region ((task_self ()), &addr, &size, &prot, &max_prot,
+ &inheritance, &shared, &object, &offset))
+ != KERN_SUCCESS)
+ {
+ outf_fatal ( "compiler_reset: vm_region() failed.\n");
+ Microcode_Termination (TERM_EXIT);
+ /*NOTREACHED*/
+ }
+ if ((prot & VM_PROT_SCHEME) != VM_PROT_SCHEME)
+ {
+ if ((max_prot & VM_PROT_SCHEME) != VM_PROT_SCHEME)
+ {
+ outf_fatal (
+ "compiler_reset: inadequate protection for Heap.\n");
+ outf_fatal ( "maximum = 0x%lx; desired = 0x%lx\n",
+ ((unsigned long) (max_prot & VM_PROT_SCHEME)),
+ ((unsigned long) VM_PROT_SCHEME));
+ Microcode_Termination (TERM_EXIT);
+ /*NOTREACHED*/
+ }
+ if ((vm_protect ((task_self ()), ((vm_address_t) Heap),
+ (((char *) constant_end) - ((char *) Heap)),
+ 0, VM_PROT_SCHEME))
+ != KERN_SUCCESS)
+ {
+ outf_fatal ("Unable to change protection for Heap.\n");
+ outf_fatal ("actual = 0x%lx; desired = 0x%lx\n",
+ ((unsigned long) (prot & VM_PROT_SCHEME)),
+ ((unsigned long) VM_PROT_SCHEME));
+ Microcode_Termination (TERM_EXIT);
+ /*NOTREACHED*/
+ }
+ }
+ }
+#endif /* _MACH_UNIX */
+}
/* -*-C-*-
-$Id: i386.h,v 1.39 2007/01/05 21:19:26 cph Exp $
+$Id: i386.h,v 1.40 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/*
- *
- * Compiled code interface macros.
- *
- * See cmpint.txt for a description of these fields.
- *
- * Specialized for the Intel 386 (and successors) architecture.
- */
-
-#ifndef SCM_CMPINTMD_H
-#define SCM_CMPINTMD_H
-
-#include "cmptype.h"
-\f
-/* Until cmpaux-i386.m4 is updated. */
-#define CMPINT_USE_STRUCS
-
-/* Hack for OS/2 calling-convention type: */
-
-#if defined(__OS2__) && (defined(__IBMC__) || defined(__WATCOMC__))
-# define ASM_ENTRY_POINT(name) (_System name)
-#else
-# if defined(__WIN32__) && defined(__WATCOMC__)
-# define ASM_ENTRY_POINT(name) (__cdecl name)
-# else
-# define ASM_ENTRY_POINT(name) name
-# endif
-#endif
-
-extern void EXFUN (ia32_cache_synchronize, (void));
-extern int ia32_cpuid_needed;
-
-#define IA32_CACHE_SYNCHRONIZE() \
-{ \
- if (ia32_cpuid_needed) \
- ia32_cache_synchronize (); \
-}
+/* Compiled code interface macros for Intel IA-32. */
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
+\f
/*
- Problems with i386 ISA (instruction set architecture)
+Problems with the IA-32 instruction set architecture
+====================================================
-<1> Code space is separate from data space. The only way to obtain a
-code space address is to do a CALL and use the return address on the
-stack.
+1. Code space is separate from data space. The only way to obtain a
+ code space address is to do a CALL and use the return address on
+ the stack.
Problem: References to the constants vector in compiled code.
Fix: Just as on RISC machines. Use CALL when necessary, and cache the
-result in the assembly language.
+ result in the assembly language.
-<2> Jumps are PC-relative. There are absolute jumps, assuming the PC
-is in a data location, or with immediate destinations that include a
-segment descriptor (16 bits). The short forms have a PC-relative
-offset defined with respect to the immediately following instruction.
+2. Jumps are PC-relative. There are absolute jumps, assuming the PC
+ is in a data location, or with immediate destinations that include
+ a segment descriptor (16 bits). The short forms have a PC-relative
+ offset defined with respect to the immediately following
+ instruction.
Problem: Closures and execute caches need their address in old space
-in order to be relocated correctly.
+ in order to be relocated correctly.
-Fix:
+Fix:
- For execute caches we can define a new linker field, called
+For execute caches we can define a new linker field, called
load-relocation-address which on every GC/relocation stores the new
address and the old contents into global variables and stores the new
address in the field. Alternatively the difference between the new
variable, and this can be used, together with the new address of each
cache, to find the old code.
- For closures the code that reads the header (manifest closure) can
-do the same.
+For closures the code that reads the header (manifest closure) can do
+the same.
-<3> The stack pointer register (ESP) cannot be used as the base in
-(base + displacement) addressing mode.
+3. The stack pointer register (ESP) cannot be used as the base in
+ (base + displacement) addressing mode.
Problem: Common operation in the compiler, which assumes direct access
-to the stack.
+ to the stack.
Fix: Use base + indexed mode, which allows specification of ESP as
-base and nullification of the index (by using ESP again).
-This is one byte longer than otherwise, but...
-\f
- Register assignments
+ base and nullification of the index (by using ESP again). This is
+ one byte longer than otherwise, but...
+
+
+Register assignments
+====================
EAX (0) Unassigned
ECX (1) Unassigned
"frame" register is typically used) because its most common use, (EBP)
(address syllable for memory memtop) takes more bytes than (ESI).
\f
- Encodings and layout of various control features:
+Encodings and layout of various control features
+================================================
Assumptions:
- The processor will be in 32-bit address and operand mode.
-Thus instructions use 32-bit operands, and displacements for
-addressing modes and jump instructions are all 32-bits by default.
+The processor will be in 32-bit address and operand mode. Thus
+instructions use 32-bit operands, and displacements for addressing
+modes and jump instructions are all 32 bits by default.
Offset Contents Encoding
4 32-bit offset
8 <next cache>
-Arity stays in place because the i386 is a little-endian architecture.
+Arity stays in place because the IA-32 is a little-endian architecture.
- Closure entry encoding:
*/
\f
-#define COMPILER_PROCESSOR_TYPE COMPILER_IA32_TYPE
-
-/* The i387 coprocessor and i486 use 80-bit extended format internally. */
-
-#define COMPILER_TEMP_SIZE 3
-
-typedef unsigned short format_word;
-
-/* i386 instructions can be aligned on any byte boundary. */
-
-#define PC_ZERO_BITS 0
+#define ASM_RESET_HOOK i386_reset_hook
+#define FPE_RESET_TRAPS i386_interface_initialize
-/* See the encodings above. */
+#define CMPINT_USE_STRUCS 1
-#define ENTRY_PREFIX_LENGTH 3
+/* These next definitions must agree with "cmpauxmd/i386.m4", which is
+ where the register block is allocated. */
+#define COMPILER_REGBLOCK_N_FIXED 16
+/* Big enough to hold 80-bit floating-point value: */
+#define COMPILER_TEMP_SIZE 3
+#define COMPILER_REGBLOCK_N_TEMPS 256
+#define COMPILER_REGBLOCK_N_HOOKS 80
+#define COMPILER_HOOK_SIZE 1
-# define COMPILED_CLOSURE_ENTRY_SIZE \
- ((2 * (sizeof (format_word))) + 6)
+#define COMPILER_REGBLOCK_EXTRA_SIZE \
+ (COMPILER_REGBLOCK_N_HOOKS * COMPILER_HOOK_SIZE)
-# define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
-do { \
- long magic_constant; \
- \
- magic_constant = (* ((long *) (((char *) (entry_point)) + 3))); \
- (location) = ((SCHEME_OBJECT) \
- ((((long) (OBJECT_ADDRESS (location))) + 5) + \
- magic_constant)); \
-} while (0)
-\f
-/* For the relocation of PC-relative JMP and CALL instructions.
- This is used during GC/relocation, when the displacement
- is incorrect, since it was computed with respect to the
- location in old space.
- */
+#define REGBLOCK_ALLOCATED_BY_INTERFACE true
-extern long i386_pc_displacement_relocation;
+typedef byte_t insn_t;
-#define EXTRACT_ADDRESS_FROM_DISPLACEMENT(var, instr_addr) do \
-{ \
- long displacement_address, new_displacement; \
- \
- displacement_address = (((long) (instr_addr)) + 1); \
- new_displacement = ((* ((long *) displacement_address)) \
- + i386_pc_displacement_relocation); \
- (* ((long *) displacement_address)) = new_displacement; \
- (var) = ((SCHEME_OBJECT) \
- ((ADDR_TO_SCHEME_ADDR (displacement_address + 4)) \
- + new_displacement)); \
-} while (0)
-
-#define STORE_DISPLACEMENT_FROM_ADDRESS(target, instr_address) do \
-{ \
- long displacement_address = (((long) (instr_address)) + 1); \
- (* ((long *) displacement_address)) = \
- (((long) (target)) \
- - (ADDR_TO_SCHEME_ADDR (displacement_address + 4))); \
-} while (0)
+/* Number of insn_t units preceding entry address in which header
+ (type and offset info) is stored. */
+#define CC_ENTRY_HEADER_SIZE (CC_ENTRY_TYPE_SIZE + CC_ENTRY_OFFSET_SIZE)
+#define CC_ENTRY_TYPE_SIZE 2
+#define CC_ENTRY_OFFSET_SIZE 2
-#define BCH_EXTRACT_ADDRESS_FROM_DISPLACEMENT(var, v_addr, p_addr) do \
-{ \
- long displacement_address, new_displacement; \
- \
- displacement_address = (((long) (p_addr)) + 1); \
- new_displacement = ((* ((long *) displacement_address)) \
- + i386_pc_displacement_relocation); \
- (* ((long *) displacement_address)) = new_displacement; \
- (var) = ((SCHEME_OBJECT) \
- ((ADDR_TO_SCHEME_ADDR (((long) (v_addr)) + 5)) \
- + new_displacement)); \
-} while (0)
-
-#define BCH_STORE_DISPLACEMENT_FROM_ADDRESS(target, v_addr, p_addr) do \
-{ \
- long displacement_address = (((long) (p_addr)) + 1); \
- (* ((long *) displacement_address)) \
- = (((long) (target)) \
- - (ADDR_TO_SCHEME_ADDR (((long) (v_addr)) + 5))); \
-} while (0)
-\f
-#define START_CLOSURE_RELOCATION(scan) do \
-{ \
- SCHEME_OBJECT * _block, * _old; \
- char * _new; \
- \
- _block = ((SCHEME_OBJECT *) (scan)); \
- _old = (OBJECT_ADDRESS (_block[(OBJECT_DATUM (*_block))])); \
- _new = ((char *) (FIRST_MANIFEST_CLOSURE_ENTRY (_block + 1))); \
- \
- i386_pc_displacement_relocation = (((long) _old) - ((long) _new)); \
-} while (0)
-
-#define END_CLOSURE_RELOCATION(scan) i386_pc_displacement_relocation = 0
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS EXTRACT_ADDRESS_FROM_DISPLACEMENT
-#define STORE_CLOSURE_ENTRY_ADDRESS STORE_DISPLACEMENT_FROM_ADDRESS
-
-#define BCH_START_CLOSURE_RELOCATION(scan) do \
-{ \
- SCHEME_OBJECT * _scan, * _block, _old_obj, * _old; \
- char * _new; \
- \
- _scan = ((SCHEME_OBJECT *) (scan)); \
- _block = ((SCHEME_OBJECT *) \
- (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_scan))); \
- READ_NEWSPACE_ADDRESS (_old_obj, \
- (_block + (OBJECT_DATUM (* _scan)))); \
- _old = (OBJECT_ADDRESS (_old_obj)); \
- _new = ((char *) (FIRST_MANIFEST_CLOSURE_ENTRY (_scan + 1))); \
- \
- i386_pc_displacement_relocation \
- = (((long) _old) \
- - ((long) (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_new)))); \
-} while (0)
-
-#define BCH_END_CLOSURE_RELOCATION END_CLOSURE_RELOCATION
-
-#define BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS(var, p_addr) do \
-{ \
- SCHEME_OBJECT * _p_addr, * _v_addr; \
- \
- _p_addr = ((SCHEME_OBJECT *) (p_addr)); \
- _v_addr = ((SCHEME_OBJECT *) \
- (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_p_addr))); \
- \
- BCH_EXTRACT_ADDRESS_FROM_DISPLACEMENT (var, _v_addr, _p_addr); \
-} while (0)
-
-#define BCH_STORE_CLOSURE_ENTRY_ADDRESS(target, p_addr) do \
-{ \
- SCHEME_OBJECT * _p_addr, * _v_addr; \
- \
- _p_addr = ((SCHEME_OBJECT *) (p_addr)); \
- _v_addr = ((SCHEME_OBJECT *) \
- (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_p_addr))); \
- \
- BCH_STORE_DISPLACEMENT_FROM_ADDRESS (target, _v_addr, _p_addr); \
-} while (0)
+/* Number of insn_t units preceding entry header in which GC trap
+ instructions are stored. */
+#define CC_ENTRY_GC_TRAP_SIZE 3
\f
-#define EXECUTE_CACHE_ENTRY_SIZE 2
+#define EMBEDDED_CLOSURE_ADDRS_P 1
-#define FIRST_OPERATOR_LINKAGE_OFFSET 2
-
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) do \
-{ \
- (target) = ((long) (* ((unsigned short *) (address)))); \
-} while (0)
+typedef struct
+{
+ insn_t * old_addr;
+ insn_t * new_addr;
+} reloc_ref_t;
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) do \
-{ \
- (target) = (* (((SCHEME_OBJECT *) (address)) + 1)); \
-} while (0)
+#define DECLARE_RELOCATION_REFERENCE(name) reloc_ref_t name
-/* This is used during GC/relocation.
- The displacement stored in the instruction refers to the old space
- location.
- */
+#define START_CLOSURE_RELOCATION(scan, ref) \
+ start_closure_relocation ((scan), (&ref))
-#define EXTRACT_OPERATOR_LINKAGE_ADDRESS(target, address) do \
+#define START_OPERATOR_RELOCATION(scan, ref) do \
{ \
- EXTRACT_ADDRESS_FROM_DISPLACEMENT (target, \
- (((long) (address)) + 3)); \
-} while (0)
+ start_operator_relocation ((scan), (&ref)); \
+ (scan) += 1; \
+} while (false)
-/* This is used when not relocating.
- The displacement refers to the current location of the instruction.
- */
+#define READ_COMPILED_CLOSURE_TARGET(a, r) \
+ read_compiled_closure_target ((a), (&r))
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(loc, cache_addr) do \
-{ \
- long displacement_address, displacement; \
- \
- displacement_address = (((long) (cache_addr)) + 4); \
- displacement = (* ((long *) displacement_address)); \
- (loc) = ((SCHEME_OBJECT) \
- ((displacement_address + 4) + displacement)); \
-} while (0)
-
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry_address) do \
-{ \
- STORE_DISPLACEMENT_FROM_ADDRESS (entry_address, \
- (((long) (address)) + 3)); \
-} while (0)
+/* Size of execution cache in SCHEME_OBJECTS. */
+#define UUO_LINK_SIZE 2
-#define STORE_EXECUTE_CACHE_CODE(address) do \
-{ \
- /* Store a <JMP rel32> opcode. */ \
- (* (((unsigned char *) (address)) + 3)) = 0xe9; \
-} while (0)
+#define UUO_WORDS_TO_COUNT(nw) (((nw) - 1) / UUO_LINK_SIZE)
+#define UUO_COUNT_TO_WORDS(nc) (((nc) * UUO_LINK_SIZE) + 1)
-#define START_OPERATOR_RELOCATION(scan) do \
-{ \
- SCHEME_OBJECT * _scan, * _old, _loc; \
- \
- _scan = (((SCHEME_OBJECT *) (scan)) + 1); \
- _old = ((SCHEME_OBJECT *) (* _scan)); \
- _loc = (ADDR_TO_SCHEME_ADDR (_scan)); \
- \
- (* _scan) = _loc; \
- i386_pc_displacement_relocation = (((long) _old) - ((long) _loc)); \
-} while (0)
-
-#define END_OPERATOR_RELOCATION(scan) i386_pc_displacement_relocation = 0
-\f
-#define BCH_START_OPERATOR_RELOCATION(scan) do \
-{ \
- SCHEME_OBJECT * _scan, * _old, _loc; \
- \
- _scan = (((SCHEME_OBJECT *) (scan)) + 1); \
- _old = ((SCHEME_OBJECT *) (* _scan)); \
- _loc = (ADDR_TO_SCHEME_ADDR \
- (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_scan))); \
- \
- * _scan = _loc; \
- i386_pc_displacement_relocation = (((long) _old) - ((long) _loc)); \
-} while (0)
-
-#define BCH_END_OPERATOR_RELOCATION END_OPERATOR_RELOCATION
-
-#define BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS(var, p_addr) do \
-{ \
- SCHEME_OBJECT * _p_addr, * _v_addr; \
- \
- _p_addr = ((SCHEME_OBJECT *) (((long) (p_addr)) + 3)); \
- _v_addr = ((SCHEME_OBJECT *) \
- (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_p_addr))); \
- \
- BCH_EXTRACT_ADDRESS_FROM_DISPLACEMENT (var, _v_addr, _p_addr); \
-} while (0)
-
-#define BCH_STORE_OPERATOR_LINKAGE_ADDRESS(e_addr, p_addr) do \
-{ \
- SCHEME_OBJECT * _p_addr, * _v_addr; \
- \
- _p_addr = ((SCHEME_OBJECT *) (((long) (p_addr)) + 3)); \
- _v_addr = ((SCHEME_OBJECT *) \
- (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_p_addr))); \
- \
- BCH_STORE_DISPLACEMENT_FROM_ADDRESS (e_addr, _v_addr, _p_addr); \
-} while (0)
-\f
-#define TRAMPOLINE_ENTRY_SIZE 3
-#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* MNV to MOV instr. */
-
-#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \
-{ \
- unsigned char *PC = ((unsigned char *) (entry_address)); \
- \
- *PC++ = 0xb0; /* MOV AL,byte */ \
- *PC++ = ((unsigned char) (index)); /* byte value */ \
- *PC++ = 0xff; /* CALL */ \
- *PC++ = 0x96; /* /2 disp32(ESI) */ \
- (* ((unsigned long *) PC)) = ESI_TRAMPOLINE_TO_INTERFACE_OFFSET; \
- IA32_CACHE_SYNCHRONIZE (); \
-} while (0)
-
-#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
- (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
-
-#define TRAMPOLINE_STORAGE(tramp_entry) \
- ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
-
-#define FLUSH_I_CACHE() do \
-{ \
- IA32_CACHE_SYNCHRONIZE (); \
-} while (0)
+#define READ_UUO_TARGET(a, r) read_uuo_target ((a), (&r))
-#define FLUSH_I_CACHE_REGION(address, nwords) do \
-{ \
- IA32_CACHE_SYNCHRONIZE (); \
-} while (0)
+#define FLUSH_I_CACHE() IA32_CACHE_SYNCHRONIZE ()
+#define FLUSH_I_CACHE_REGION(address, nwords) IA32_CACHE_SYNCHRONIZE ()
+#define PUSH_D_CACHE_REGION(address, nwords) IA32_CACHE_SYNCHRONIZE ()
-#define PUSH_D_CACHE_REGION(address, nwords) do \
+#define IA32_CACHE_SYNCHRONIZE() do \
{ \
- IA32_CACHE_SYNCHRONIZE (); \
-} while (0)
-
+ if (ia32_cpuid_needed) \
+ ia32_cache_synchronize (); \
+} while (false)
\f
-/* These must aggree with cmpaux-i386.m4!
- The register block is actually allocated there.
- */
-
-#define COMPILER_REGBLOCK_N_FIXED 16
-
-#define COMPILER_REGBLOCK_N_HOOKS 80
-
- /* A hook is the address (offset) of an assembly-language routine. */
-
-#define COMPILER_HOOK_SIZE 1
-
-#define COMPILER_REGBLOCK_EXTRA_SIZE \
- (COMPILER_REGBLOCK_N_HOOKS * COMPILER_HOOK_SIZE)
-
-#define REGBLOCK_ALLOCATED_BY_INTERFACE
-
-#define ESI_TRAMPOLINE_TO_INTERFACE_OFFSET \
- ((COMPILER_REGBLOCK_N_FIXED + (2 * COMPILER_HOOK_SIZE)) * \
- (sizeof (SCHEME_OBJECT)))
-
-#ifdef IN_CMPINT_C
-
-#ifdef _MACH_UNIX
-# include <mach.h>
-# define VM_PROT_SCHEME (VM_PROT_READ | VM_PROT_WRITE | VM_PROT_EXECUTE)
-#endif
-
-long i386_pc_displacement_relocation = 0;
-
-#define ASM_RESET_HOOK i386_reset_hook
-
-#ifndef HOOK_TO_SCHEME_OFFSET
-# define HOOK_TO_SCHEME_OFFSET(hook) ((unsigned long) (hook))
-#endif
-
-#ifdef HAVE_STDC
-# define STRINGIFY(x) #x
+#if defined(__OS2__) && (defined(__IBMC__) || defined(__WATCOMC__))
+# define ASM_ENTRY_POINT(name) (_System name)
+#elif defined(__WIN32__) && defined(__WATCOMC__)
+# define ASM_ENTRY_POINT(name) (__cdecl name)
#else
-# define STRINGIFY(x) "x"
-#endif
-
-#define SETUP_REGISTER(hook) do \
-{ \
- extern void hook (); \
- \
- (* ((unsigned long *) (esi_value + offset))) = \
- (HOOK_TO_SCHEME_OFFSET (hook)); \
- offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
- declare_builtin (((unsigned long) hook), (STRINGIFY (hook))); \
-} while (0)
-
-void
-DEFUN_VOID (i386_reset_hook)
-{
- extern int EXFUN (ASM_ENTRY_POINT(i386_interface_initialize), (void));
- extern void EXFUN (declare_builtin, (unsigned long, char *));
- int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT)));
- unsigned char * esi_value = ((unsigned char *) (&Registers[0]));
- int fp_support_present = (i386_interface_initialize ());
-
- /* These must match machines/i386/lapgen.scm */
-
- SETUP_REGISTER (asm_scheme_to_interface); /* 0 */
- SETUP_REGISTER (asm_scheme_to_interface_call); /* 1 */
-
- if (offset != ESI_TRAMPOLINE_TO_INTERFACE_OFFSET)
- {
- outf_fatal ("\ni386_reset_hook: ESI_TRAMPOLINE_TO_INTERFACE_OFFSET\n");
- Microcode_Termination (TERM_EXIT);
- }
- SETUP_REGISTER (asm_trampoline_to_interface); /* 2 */
-
- SETUP_REGISTER (asm_interrupt_procedure); /* 3 */
- SETUP_REGISTER (asm_interrupt_continuation); /* 4 */
- SETUP_REGISTER (asm_interrupt_closure); /* 5 */
- SETUP_REGISTER (asm_interrupt_dlink); /* 6 */
-\f
- SETUP_REGISTER (asm_primitive_apply); /* 7 */
- SETUP_REGISTER (asm_primitive_lexpr_apply); /* 8 */
- SETUP_REGISTER (asm_assignment_trap); /* 9 */
- SETUP_REGISTER (asm_reference_trap); /* 10 */
- SETUP_REGISTER (asm_safe_reference_trap); /* 11 */
- SETUP_REGISTER (asm_link); /* 12 */
- SETUP_REGISTER (asm_error); /* 13 */
- SETUP_REGISTER (asm_primitive_error); /* 14 */
- SETUP_REGISTER (asm_short_primitive_apply); /* 15 */
-
- /* No more room for positive offsets without going to 32-bit
- offsets!
- */
-
- /* This is a hack to make all the hooks be addressable
- with byte offsets (instead of longword offsets).
- The register block extends to negative offsets as well,
- so all the following hooks are accessed with negative
- offsets, and all fit in a byte.
- */
-
- offset = -128;
-
- if (fp_support_present != 0)
- {
- SETUP_REGISTER (asm_generic_add); /* -32 */
- SETUP_REGISTER (asm_generic_subtract); /* -31 */
- SETUP_REGISTER (asm_generic_multiply); /* -30 */
- SETUP_REGISTER (asm_generic_divide); /* -29 */
- SETUP_REGISTER (asm_generic_equal); /* -28 */
- SETUP_REGISTER (asm_generic_less); /* -27 */
- SETUP_REGISTER (asm_generic_greater); /* -26 */
- SETUP_REGISTER (asm_generic_increment); /* -25 */
- SETUP_REGISTER (asm_generic_decrement); /* -24 */
- SETUP_REGISTER (asm_generic_zero); /* -23 */
- SETUP_REGISTER (asm_generic_positive); /* -22 */
- SETUP_REGISTER (asm_generic_negative); /* -21 */
- SETUP_REGISTER (asm_generic_quotient); /* -20 */
- SETUP_REGISTER (asm_generic_remainder); /* -19 */
- SETUP_REGISTER (asm_generic_modulo); /* -18 */
- }
- else
- {
- SETUP_REGISTER (asm_nofp_add); /* -32 */
- SETUP_REGISTER (asm_nofp_subtract); /* -31 */
- SETUP_REGISTER (asm_nofp_multiply); /* -30 */
- SETUP_REGISTER (asm_nofp_divide); /* -29 */
- SETUP_REGISTER (asm_nofp_equal); /* -28 */
- SETUP_REGISTER (asm_nofp_less); /* -27 */
- SETUP_REGISTER (asm_nofp_greater); /* -26 */
- SETUP_REGISTER (asm_nofp_increment); /* -25 */
- SETUP_REGISTER (asm_nofp_decrement); /* -24 */
- SETUP_REGISTER (asm_nofp_zero); /* -23 */
- SETUP_REGISTER (asm_nofp_positive); /* -22 */
- SETUP_REGISTER (asm_nofp_negative); /* -21 */
- SETUP_REGISTER (asm_nofp_quotient); /* -20 */
- SETUP_REGISTER (asm_nofp_remainder); /* -19 */
- SETUP_REGISTER (asm_nofp_modulo); /* -18 */
- }
-
- SETUP_REGISTER (asm_sc_apply); /* -17 */
- SETUP_REGISTER (asm_sc_apply_size_1); /* -16 */
- SETUP_REGISTER (asm_sc_apply_size_2); /* -15 */
- SETUP_REGISTER (asm_sc_apply_size_3); /* -14 */
- SETUP_REGISTER (asm_sc_apply_size_4); /* -13 */
- SETUP_REGISTER (asm_sc_apply_size_5); /* -12 */
- SETUP_REGISTER (asm_sc_apply_size_6); /* -11 */
- SETUP_REGISTER (asm_sc_apply_size_7); /* -10 */
- SETUP_REGISTER (asm_sc_apply_size_8); /* -9 */
- SETUP_REGISTER (asm_interrupt_continuation_2); /* -8 */
- if (ia32_cpuid_needed)
- {
- SETUP_REGISTER (asm_serialize_cache); /* -7 */
- }
- else
- {
- SETUP_REGISTER (asm_dont_serialize_cache); /* -7 */
- }
-\f
-#ifdef _MACH_UNIX
- {
- vm_address_t addr;
- vm_size_t size;
- vm_prot_t prot;
- vm_prot_t max_prot;
- vm_inherit_t inheritance;
- boolean_t shared;
- port_t object;
- vm_offset_t offset;
-
- addr = ((vm_address_t) Heap);
- if ((vm_region ((task_self ()), &addr, &size, &prot, &max_prot,
- &inheritance, &shared, &object, &offset))
- != KERN_SUCCESS)
- {
- outf_fatal ( "compiler_reset: vm_region() failed.\n");
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- }
- if ((prot & VM_PROT_SCHEME) != VM_PROT_SCHEME)
- {
- if ((max_prot & VM_PROT_SCHEME) != VM_PROT_SCHEME)
- {
- outf_fatal (
- "compiler_reset: inadequate protection for Heap.\n");
- outf_fatal ( "maximum = 0x%lx; desired = 0x%lx\n",
- ((unsigned long) (max_prot & VM_PROT_SCHEME)),
- ((unsigned long) VM_PROT_SCHEME));
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- }
- if ((vm_protect ((task_self ()), ((vm_address_t) Heap),
- (((char *) Constant_Top) - ((char *) Heap)),
- 0, VM_PROT_SCHEME))
- != KERN_SUCCESS)
- {
- outf_fatal (
- "compiler_reset: unable to change protection for Heap.\n");
- outf_fatal ( "actual = 0x%lx; desired = 0x%lx\n",
- ((unsigned long) (prot & VM_PROT_SCHEME)),
- ((unsigned long) VM_PROT_SCHEME));
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- }
- }
- }
-#endif /* _MACH_UNIX */
-}
-
-#endif /* IN_CMPINT_C */
-\f
-/* Derived parameters and macros.
- These macros expect the above definitions to be meaningful.
- If they are not, the macros below may have to be changed as well.
- */
-
-#define COMPILED_ENTRY_OFFSET_WORD(entry) \
- (((format_word *) (entry))[-1])
-#define COMPILED_ENTRY_FORMAT_WORD(entry) \
- (((format_word *) (entry))[-2])
-
-/* The next one assumes 2's complement integers....*/
-#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
-#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-
-#if (PC_ZERO_BITS == 0)
-/* Instructions aligned on byte boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) >> 1)
-#endif
-
-#if (PC_ZERO_BITS == 1)
-/* Instructions aligned on word (16 bit) boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- (CLEAR_LOW_BIT(offset_word))
-#endif
-
-#if (PC_ZERO_BITS >= 2)
-/* Should be OK for =2, but bets are off for >2 because of problems
- mentioned earlier!
-*/
-#define SHIFT_AMOUNT (PC_ZERO_BITS - 1)
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT))
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
+# define ASM_ENTRY_POINT(name) name
#endif
-#define MAKE_OFFSET_WORD(entry, block, continue) \
- ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
- ((char *) (block)))) | \
- ((continue) ? 1 : 0))
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 1)
-#endif
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 2)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 2)
-#endif
-
-#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) / EXECUTE_CACHE_ENTRY_SIZE)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
-#endif
-\f
-/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
- a format word and a gc offset word. See the early part of the
- TRAMPOLINE picture, above.
- */
+extern int ASM_ENTRY_POINT (i386_interface_initialize) (void);
+
+extern void ASM_ENTRY_POINT (asm_assignment_trap) (void);
+extern void ASM_ENTRY_POINT (asm_dont_serialize_cache) (void);
+extern void ASM_ENTRY_POINT (asm_error) (void);
+extern void ASM_ENTRY_POINT (asm_generic_add) (void);
+extern void ASM_ENTRY_POINT (asm_generic_decrement) (void);
+extern void ASM_ENTRY_POINT (asm_generic_divide) (void);
+extern void ASM_ENTRY_POINT (asm_generic_equal) (void);
+extern void ASM_ENTRY_POINT (asm_generic_greater) (void);
+extern void ASM_ENTRY_POINT (asm_generic_increment) (void);
+extern void ASM_ENTRY_POINT (asm_generic_less) (void);
+extern void ASM_ENTRY_POINT (asm_generic_modulo) (void);
+extern void ASM_ENTRY_POINT (asm_generic_multiply) (void);
+extern void ASM_ENTRY_POINT (asm_generic_negative) (void);
+extern void ASM_ENTRY_POINT (asm_generic_positive) (void);
+extern void ASM_ENTRY_POINT (asm_generic_quotient) (void);
+extern void ASM_ENTRY_POINT (asm_generic_remainder) (void);
+extern void ASM_ENTRY_POINT (asm_generic_subtract) (void);
+extern void ASM_ENTRY_POINT (asm_generic_zero) (void);
+extern void ASM_ENTRY_POINT (asm_interrupt_closure) (void);
+extern void ASM_ENTRY_POINT (asm_interrupt_continuation) (void);
+extern void ASM_ENTRY_POINT (asm_interrupt_continuation_2) (void);
+extern void ASM_ENTRY_POINT (asm_interrupt_dlink) (void);
+extern void ASM_ENTRY_POINT (asm_interrupt_procedure) (void);
+extern void ASM_ENTRY_POINT (asm_link) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_add) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_decrement) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_divide) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_equal) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_greater) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_increment) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_less) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_modulo) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_multiply) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_negative) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_positive) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_quotient) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_remainder) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_subtract) (void);
+extern void ASM_ENTRY_POINT (asm_nofp_zero) (void);
+extern void ASM_ENTRY_POINT (asm_primitive_apply) (void);
+extern void ASM_ENTRY_POINT (asm_primitive_error) (void);
+extern void ASM_ENTRY_POINT (asm_primitive_lexpr_apply) (void);
+extern void ASM_ENTRY_POINT (asm_reference_trap) (void);
+extern void ASM_ENTRY_POINT (asm_safe_reference_trap) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply_size_1) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply_size_2) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply_size_3) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply_size_4) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply_size_5) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply_size_6) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply_size_7) (void);
+extern void ASM_ENTRY_POINT (asm_sc_apply_size_8) (void);
+extern void ASM_ENTRY_POINT (asm_scheme_to_interface) (void);
+extern void ASM_ENTRY_POINT (asm_scheme_to_interface_call) (void);
+extern void ASM_ENTRY_POINT (asm_serialize_cache) (void);
+extern void ASM_ENTRY_POINT (asm_short_primitive_apply) (void);
+extern void ASM_ENTRY_POINT (asm_trampoline_to_interface) (void);
+
+extern void ia32_cache_synchronize (void);
+extern void start_closure_relocation (SCHEME_OBJECT *, reloc_ref_t *);
+extern insn_t * read_compiled_closure_target (insn_t *, reloc_ref_t *);
+extern void start_operator_relocation (SCHEME_OBJECT *, reloc_ref_t *);
+extern insn_t * read_uuo_target (SCHEME_OBJECT *, reloc_ref_t *);
+extern void i386_reset_hook (void);
-#define CC_BLOCK_FIRST_ENTRY_OFFSET \
- (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
-
-/* Format words */
-
-#define FORMAT_BYTE_EXPR 0xFF
-#define FORMAT_BYTE_COMPLR 0xFE
-#define FORMAT_BYTE_CMPINT 0xFD
-#define FORMAT_BYTE_DLINK 0xFC
-#define FORMAT_BYTE_RETURN 0xFB
-
-#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
-#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
-#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
-
-/* This assumes that a format word is at least 16 bits,
- and the low order field is always 8 bits.
- */
-
-#define MAKE_FORMAT_WORD(field1, field2) \
- (((field1) << 8) | ((field2) & 0xff))
-
-#define SIGN_EXTEND_FIELD(field, size) \
- (((field) & ((1 << (size)) - 1)) | \
- ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
- ((-1) << (size))))
-
-#define FORMAT_WORD_LOW_BYTE(word) \
- (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8))
-
-#define FORMAT_WORD_HIGH_BYTE(word) \
- (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \
- (((sizeof (format_word)) * CHAR_BIT) - 8)))
-
-#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
- (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
-
-#define COMPILED_ENTRY_FORMAT_LOW(addr) \
- (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
-
-#define FORMAT_BYTE_FRAMEMAX 0x7f
-
-#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
-#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
+extern int ia32_cpuid_needed;
-#endif /* not SCM_CMPINTMD_H */
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
/* -*-C-*-
-$Id: mc68k.h,v 1.40 2007/01/05 21:19:26 cph Exp $
+$Id: mc68k.h,v 1.41 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
* Specialized for the Motorola 68K family.
*/
-#ifndef CMPINTMD_H_INCLUDED
-#define CMPINTMD_H_INCLUDED
-
-#include "cmptype.h"
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
\f
/* Machine parameters to be set by the user. */
typedef unsigned short format_word;
-/* PC alignment constraint.
- Change PC_ZERO_BITS to be how many low order bits of the pc are
- guaranteed to be 0 always because of PC alignment constraints.
-*/
-
-#define PC_ZERO_BITS 1
-
/* The length of the GC recovery code that precedes an entry.
On the 68K a "jsr n(a6)" instruction.
*/
#ifdef _NEXTOS
-extern void EXFUN (NeXT_cacheflush, (void));
+extern void NeXT_cacheflush (void);
# ifdef IN_CMPINT_C
*/
void
-DEFUN_VOID (NeXT_cacheflush)
+NeXT_cacheflush (void)
{
asm ("trap #2");
return;
# ifdef SWITZERLAND
-extern void EXFUN (swiss_cachectl, (int, void *, unsigned long));
+extern void swiss_cachectl (int, void *, unsigned long);
# define FLUSH_CACHE_INITIALIZE() swiss_cachectl_init_p = 0
swiss_cachectl_flush_p = 0;
void
-DEFUN (swiss_cachectl,
- (mode, base, count),
- int mode AND PTR base AND unsigned long count)
+swiss_cachectl (int mode, void * base, unsigned long count)
{
if (swiss_cachectl_init_p == 0)
{
int length;
char *string, *posn;
- extern char * EXFUN (strstr, (char *, char *));
- extern int EXFUN (getcontext, (char *, int));
+ extern char * strstr (char *, char *);
+ extern int getcontext (char *, int);
string = ((char *) Free);
length = (getcontext (string,
- ((MemTop - Free) * (sizeof (SCHEME_OBJECT)))));
+ ((heap_alloc_limit - Free)
+ * (sizeof (SCHEME_OBJECT)))));
swiss_cachectl_flush_p =
(((strstr (string, "HP-MC68040")) == ((char *) NULL)) ? 0 : 1);
swiss_cachectl_init_p = 1;
# endif /* SWITZERLAND */
extern void
- EXFUN (operate_on_cache_region, (int, char *, unsigned long));
+ operate_on_cache_region (int, char *, unsigned long);
# define SPLIT_CACHES
((char *) \
(((unsigned long *) base) + (len - 1))), \
1); \
-} while (0)
+} while (0)
# ifdef IN_CMPINT_C
-void
-DEFUN (operate_on_cache_region,
- (cachecmd, bptr, nwords),
- int cachecmd AND char * bptr AND unsigned long nwords)
+void
+operate_on_cache_region (int cachecmd, char * bptr, unsigned long nwords)
{
char * eptr;
unsigned long nbytes, quantum;
if (nwords == 0)
return;
-
+
nbytes = (nwords * (sizeof (long)));
eptr = (bptr + (nbytes - 1));
quantum = ((nbytes <= 0x40) ? 0x10 : 0x1000);
# endif /* IN_CMPINT_C */
# else /* S2DATA_WT */
-# define FLUSH_I_CACHE() NOP()
+# define FLUSH_I_CACHE() do {} while (0)
# endif /* S2DATA_WT */
#endif /* __hpux */
#ifndef FLUSH_CACHE_INITIALIZE
-# define FLUSH_CACHE_INITIALIZE() NOP()
+# define FLUSH_CACHE_INITIALIZE() do {} while (0)
#endif /* FLUSH_CACHE_INITIALIZE */
#ifndef FLUSH_I_CACHE_REGION
-# define FLUSH_I_CACHE_REGION(addr, nwords) NOP()
+# define FLUSH_I_CACHE_REGION(addr, nwords) do {} while (0)
#endif /* not FLUSH_I_CACHE_REGION */
#ifndef PUSH_D_CACHE_REGION
magic_constant)); \
} while (0)
-/* Manifest closure entry block size.
+/* Manifest closure entry block size.
Size in bytes of a compiled closure's header excluding the
TC_MANIFEST_CLOSURE header.
On the 68k, this is the format word and gc offset word and 6 bytes
- more for the jsr instruction.
+ more for the jsr instruction.
*/
# define COMPILED_CLOSURE_ENTRY_SIZE \
/* On the MC68040, closure entry points are aligned, so this is a NOP. */
-# define ADJUST_CLOSURE_AT_CALL(entry_point, location) NOP()
+# define ADJUST_CLOSURE_AT_CALL(entry_point, location) do {} while (0)
-/* Manifest closure entry block size.
+/* Manifest closure entry block size.
Size in bytes of a compiled closure's header excluding the
TC_MANIFEST_CLOSURE header.
"cmpint.c". */
#define COMPILER_REGBLOCK_N_FIXED 16
+#define COMPILER_REGBLOCK_N_TEMPS 256
#define COMPILER_REGBLOCK_START_HOOKS COMPILER_REGBLOCK_N_FIXED
#define COMPILER_REGBLOCK_N_HOOKS 80
#define SETUP_REGISTER(hook) do \
{ \
- extern void EXFUN (hook, (void)); \
+ extern void hook, (void); \
(* ((unsigned short *) (a6_value + offset))) = 0x4ef9; \
(* ((unsigned long *) \
(((unsigned short *) (a6_value + offset)) + 1))) = \
#endif
\f
void
-DEFUN_VOID (mc68k_reset_hook)
+mc68k_reset_hook (void)
{
- extern void EXFUN (interface_initialize, (void));
+ extern void interface_initialize (void);
unsigned char * a6_value = ((unsigned char *) (&Registers[0]));
int offset = (COMPILER_REGBLOCK_START_HOOKS * (sizeof (SCHEME_OBJECT)));
static long last_chunk_size;
SCHEME_OBJECT *
-DEFUN (allocate_closure, (size), long size)
+allocate_closure (long size)
{
long space;
SCHEME_OBJECT *result;
#else /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */
- space = ((long) (Registers[REGBLOCK_CLOSURE_SPACE]));
- result = ((SCHEME_OBJECT *) (Registers[REGBLOCK_CLOSURE_FREE]));
+ space = ((long) GET_CLOSURE_SPACE);
+ result = GET_CLOSURE_FREE;
if (size > space)
{
*/
}
- if ((size <= closure_chunk) && (!(GC_Check (closure_chunk))))
+ if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk)))
{
start = Free;
eptr = (start + closure_chunk);
}
else
{
- if (GC_Check (size))
+ if (GC_NEEDED_P (size))
{
- if ((Heap_Top - Free) < size)
+ if ((heap_end - Free) < size)
{
/* No way to back out -- die. */
Microcode_Termination (TERM_NO_SPACE);
/* NOTREACHED */
}
- Request_GC (0);
+ REQUEST_GC (0);
}
else if (size <= closure_chunk)
{
- Request_GC (0);
+ REQUEST_GC (0);
}
start = Free;
eptr = (start + size);
PUSH_D_CACHE_REGION (start, space);
}
- Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) (result + size));
- Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) (space - size));
+ SET_CLOSURE_FREE (result + size);
+ SET_CLOSURE_SPACE (space - size);
return (result);
#endif /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */
#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-#if (PC_ZERO_BITS == 0)
-/* Instructions aligned on byte boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) >> 1)
-#endif
-
-#if (PC_ZERO_BITS == 1)
/* Instructions aligned on word (16 bit) boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- (CLEAR_LOW_BIT(offset_word))
-#endif
-
-#if (PC_ZERO_BITS >= 2)
-/* Should be OK for =2, but bets are off for >2 because of problems
- mentioned earlier!
-*/
-#define SHIFT_AMOUNT (PC_ZERO_BITS - 1)
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT))
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
-#endif
+#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
+#define OFFSET_WORD_TO_BYTE_OFFSET(word) (CLEAR_LOW_BIT (word))
#define MAKE_OFFSET_WORD(entry, block, continue) \
((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-#endif /* CMPINTMD_H_INCLUDED */
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
/* -*-C-*-
-$Id: mips.h,v 1.27 2007/01/05 21:19:26 cph Exp $
+$Id: mips.h,v 1.28 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
* Specialized for the MIPS R2000/R3000
*/
-#ifndef CMPINTMD_H_INCLUDED
-#define CMPINTMD_H_INCLUDED
-
-#include "cmptype.h"
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
\f
#ifdef _IRIX
/* Processor type. Choose a number from the above list, or allocate your own. */
-#define COMPILER_PROCESSOR_TYPE COMPILER_MIPS_TYPE
+#define COMPILER_PROCESSOR_TYPE COMPILER_MIPS_TYPE
/* Size (in long words) of the contents of a floating point register if
different from a double. For example, an MC68881 saves registers
define COMPILER_TEMP_SIZE 3
*/
+#define COMPILER_REGBLOCK_N_TEMPS 256
+
/* Descriptor size.
This is the size of the offset field, and of the format field.
This definition probably does not need to be changed.
*/
typedef unsigned short format_word;
-
-/* PC alignment constraint.
- Change PC_ZERO_BITS to be how many low order bits of the pc are
- guaranteed to be 0 always because of PC alignment constraints.
-*/
-
-#define PC_ZERO_BITS 2
\f
/* Utilities for manipulating absolute subroutine calls.
On the MIPS this is done with:
SLT $at,$FREE,$MEMTOP
BEQ $at,$0,interrupt
LW $MEMTOP,REG_BLOCK
-
+
For a closure
LUI $at,FROB(TC_CLOSURE) ; temp <- closure tag
On the MIPS this is 2 format_words for the format word and gc
offset words, and 8 more bytes for 2 instructions.
-
+
The two instructions are
JAL destination
not always work, thus closures are allocated from a pre-initialized
pool where the entries have been initialized to contain
the following instructions.
-
+
JALR LINKAGE,CLOSURE_HOOK
ADDI LINKAGE,LINKAGE,-8
#define TRAMPOLINE_STORAGE(tramp_entry) \
((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
+ (2 + TRAMPOLINE_ENTRY_SIZE))
#define SPECIAL_OPCODE 000
#define ADDI_OPCODE 010
arguments in the lower 16 bits.
*/
-#define EXECUTE_CACHE_ENTRY_SIZE 2
+#define EXECUTE_CACHE_ENTRY_SIZE 2
/* Execute cache destructuring. */
#define FLUSH_I_CACHE() do \
{ \
- FLUSH_BOTH (Constant_Space, \
- (((unsigned long) Heap_Top) \
- - ((unsigned long) Constant_Space))); \
+ FLUSH_BOTH (constant_start, \
+ (((unsigned long) heap_end) \
+ - ((unsigned long) constant_start))); \
} while (0)
/* This flushes a region of the I-cache.
It is used after updating an execute cache while running.
Not needed during GC because FLUSH_I_CACHE will be used.
- */
+ */
#define FLUSH_I_CACHE_REGION(address, nwords) do \
{ \
{ \
unsigned long _addr = ((unsigned long) (address)); \
unsigned long _nbytes = ((sizeof (long)) * (nwords)); \
- cacheflush (((PTR) _addr), _nbytes, DCACHE); \
- cacheflush (((PTR) _addr), 1, ICACHE); \
- cacheflush (((PTR) (_addr + (_nbytes - 1))), 1, ICACHE); \
+ cacheflush (((void *) _addr), _nbytes, DCACHE); \
+ cacheflush (((void *) _addr), 1, ICACHE); \
+ cacheflush (((void *) (_addr + (_nbytes - 1))), 1, ICACHE); \
} while (0)
#endif /* not USE_MPROTECT_CACHE_FLUSH */
#ifdef IN_CMPINT_C
static void
-DEFUN_VOID (interface_initialize_C)
+interface_initialize_C (void)
{
- extern void EXFUN (interface_initialize, (void));
+ extern void interface_initialize (void);
/* Prevent the OS from "fixing" unaligned accesses.
Within Scheme, they are a BUG, and should fault.
static unsigned long mprotect_size;
static void
-DEFUN (call_mprotect_1, (start, size), void * start AND unsigned long size)
+call_mprotect_1 (void * start, unsigned long size)
{
if ((mprotect (start, size, VM_PROT_SCHEME)) != 0)
{
#ifdef USE_MPROTECT_CACHE_FLUSH
void
-DEFUN (call_mprotect, (start, size), void * start AND unsigned long size)
+call_mprotect (void * start, unsigned long size)
{
unsigned long pagesize = (getpagesize ());
unsigned long istart = ((unsigned long) start);
#endif /* USE_MPROTECT_CACHE_FLUSH */
void *
-DEFUN (irix_heap_malloc, (size), long size)
+irix_heap_malloc (long size)
{
int pagesize = (getpagesize ());
void * area = (malloc (size + pagesize));
static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
-#define REGBLOCK_CLOSURE_LIMIT REGBLOCK_CLOSURE_SPACE
-
/* The apparently random instances of the number 3 below arise from
the convention that free_closure always points to a JAL instruction
with (at least) 3 unused words preceding it.
In this way, if there is enough space, we can use free_closure
as the address of a new uni- or multi-closure.
-
+
The code below (in the initialization loop) depends on knowing that
CLOSURE_ENTRY_WORDS is 3.
-
+
Random hack: ADDI instructions look like TC_TRUE objects, thus of the
pre-initialized words, only the JALR looks like a pointer object
(an SCODE-QUOTE). Since there is exactly one JALR of waste between
/* size in Scheme objects of the block we need to allocate. */
void
-DEFUN (allocate_closure, (size), long size)
+allocate_closure (long size)
{
long space;
SCHEME_OBJECT * free_closure, * limit;
- free_closure = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_FREE]);
- limit = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_LIMIT]);
+ free_closure = GET_CLOSURE_FREE;
+ limit = GET_CLOSURE_SPACE;
space = ((limit - free_closure) + 3);
/* Bump up to a multiple of CLOSURE_ENTRY_WORDS.
/* Make the heap be parseable forward by protecting the waste
in the last chunk.
*/
-
+
if ((space > 0) && (free_closure != ((SCHEME_OBJECT *) NULL)))
free_closure[-3] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (space - 1)));
free_closure = Free;
- if ((size <= closure_chunk) && (!(GC_Check (closure_chunk))))
+ if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk)))
limit = (free_closure + closure_chunk);
else
{
- if (GC_Check (size))
+ if (GC_NEEDED_P (size))
{
- if ((Heap_Top - Free) < size)
+ if ((heap_end - Free) < size)
{
/* No way to back out -- die. */
fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
Microcode_Termination (TERM_NO_SPACE);
/* NOTREACHED */
}
- Request_GC (0);
+ REQUEST_GC (0);
}
else if (size <= closure_chunk)
- Request_GC (0);
+ REQUEST_GC (0);
limit = (free_closure + size);
}
Free = limit;
*ptr++ = SHARP_F;
}
PUSH_D_CACHE_REGION (free_closure, chunk_size);
- Registers[REGBLOCK_CLOSURE_LIMIT] = ((SCHEME_OBJECT) limit);
- Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) (free_closure + 3));
+ SET_CLOSURE_SPACE (limit);
+ SET_CLOSURE_FREE (free_closure + 3);
}
- return;
}
#endif /* IN_CMPINT_C */
#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-#if (PC_ZERO_BITS == 0)
-/* Instructions aligned on byte boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) >> 1)
-#endif
-
-#if (PC_ZERO_BITS == 1)
-/* Instructions aligned on word (16 bit) boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- (CLEAR_LOW_BIT(offset_word))
-#endif
-
-#if (PC_ZERO_BITS >= 2)
-/* Should be OK for =2, but bets are off for >2 because of problems
- mentioned earlier!
-*/
-#define SHIFT_AMOUNT (PC_ZERO_BITS - 1)
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT))
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
-#endif
+#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1)
+#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1)
#define MAKE_OFFSET_WORD(entry, block, continue) \
((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
((char *) (block)))) | \
((continue) ? 1 : 0))
-#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
((count) >> 1)
#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
((entries) << 1)
-#endif
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 2)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 2)
-#endif
-
-#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) / EXECUTE_CACHE_ENTRY_SIZE)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
-#endif
\f
/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
a format word and a gc offset word. See the early part of the
#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-#endif /* CMPINTMD_H_INCLUDED */
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
/* -*-C-*-
-$Id: starbasx.c,v 1.10 2007/01/05 21:19:25 cph Exp $
+$Id: none-config.h,v 1.2 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* Starbase/X11 interface */
-
-#include "scheme.h"
-#include "prims.h"
-#include "x11.h"
-#include <starbase.c.h>
-
-DEFINE_PRIMITIVE ("X11-WINDOW-STARBASE-FILENAME", Prim_x11_window_starbase_filename, 1, 1,
- "Given a window, returns the name of a file which can be opened\n\
-as a Starbase graphics device.")
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- char * starbase_filename =
- (make_X11_gopen_string ((XW_DISPLAY (xw)), (XW_WINDOW (xw))));
- PRIMITIVE_RETURN
- ((starbase_filename == 0)
- ? SHARP_F
- : (char_pointer_to_string (starbase_filename)));
- }
-}
+#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED
+#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1
+
+#define COMPILER_PROCESSOR_TYPE COMPILER_NONE_TYPE
+#define NO_CC_SUPPORT_P 1
+
+#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */
-#| -*-Scheme-*-
+/* -*-C-*-
-$Id: files-gc-bch.scm,v 1.6 2007/01/05 21:19:26 cph Exp $
+$Id: none.c,v 1.2 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.
-|#
+*/
-;;;; C files for one-heap garbage-collector.
-
-"bchdmp"
-"bchgcl"
-"bchmmg"
-"bchpur"
-"bchutl"
+/* Compiled code interface stub. */
--- /dev/null
+/* -*-C-*-
+
+$Id: none.h,v 1.2 2007/04/22 16:31:24 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Compiled code interface stub. */
+
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
+
+typedef byte_t insn_t;
+
+#define compiler_interface_version (0UL)
+#define compiler_processor_type COMPILER_PROCESSOR_TYPE
+#define compiler_utilities SHARP_F
+
+#define return_to_interpreter SHARP_F
+#define reflect_to_interface SHARP_F
+
+#define compiler_initialize(faslp) do {} while (false)
+#define guarantee_interp_return() do {} while (false)
+
+#define CC_ENTRY_P(object) (false)
+
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
--- /dev/null
+/* -*-C-*-
+
+$Id: svm1-config.h,v 1.2 2007/04/22 16:31:24 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED
+#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1
+
+#define COMPILER_PROCESSOR_TYPE COMPILER_SVM_TYPE
+#define CC_IS_SVM 1
+#define CC_IS_GENERIC 1
+
+#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */
--- /dev/null
+/* -*-C-*-
+
+$Id: svm1.c,v 1.2 2007/04/22 16:31:24 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Compiled code interface for SVM v1. */
+
+#include "cmpint.h"
+#include "extern.h"
+#include "errors.h"
+#include "svm1-defns.h"
+
+static unsigned int cc_entry_reference_offset (insn_t *);
+\f
+bool
+read_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+ unsigned int n
+ = ((((unsigned int) (address[-3])) << 8)
+ | ((unsigned int) (address[-4])));
+ if (n < 0x8000)
+ make_compiled_procedure_type
+ (cet,
+ (n & 0x007F),
+ ((n & 0x3F80) >> 7),
+ ((n & 0x4000) != 0));
+ else if (n < 0xFFF8)
+ make_compiled_continuation_type (cet, (n - 0x8000));
+ else
+ switch (n - 0xFFF8)
+ {
+ case 7:
+ make_cc_entry_type (cet, CET_EXPRESSION);
+ break;
+
+ case 6:
+ make_cc_entry_type (cet, CET_INTERNAL_PROCEDURE);
+ break;
+
+ case 5:
+ make_cc_entry_type (cet, CET_INTERNAL_CONTINUATION);
+ break;
+
+ case 4:
+ make_cc_entry_type (cet, CET_TRAMPOLINE);
+ break;
+
+ case 3:
+ make_cc_entry_type (cet, CET_RETURN_TO_INTERPRETER);
+ break;
+
+ case 2:
+ make_cc_entry_type (cet, CET_CLOSURE);
+ break;
+
+ default:
+ return (true);
+ }
+ return (false);
+}
+\f
+bool
+write_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+ unsigned int n;
+
+ switch (cet->marker)
+ {
+ case CET_PROCEDURE:
+ if (! (((cet->args.for_procedure.n_required) < 0x80)
+ && ((cet->args.for_procedure.n_optional) < 0x80)))
+ return (true);
+ n = ((cet->args.for_procedure.n_required)
+ | ((cet->args.for_procedure.n_optional) << 7)
+ | ((cet->args.for_procedure.rest_p) ? 0x4000 : 0));
+ break;
+
+ case CET_CONTINUATION:
+ if (! ((cet->args.for_continuation.offset) < 0x7FF8))
+ return (true);
+ n = ((cet->args.for_continuation.offset) + 0x8000);
+ break;
+
+ case CET_EXPRESSION:
+ n = (0xFFF8 + 7);
+ break;
+
+ case CET_INTERNAL_PROCEDURE:
+ n = (0xFFF8 + 6);
+ break;
+
+ case CET_INTERNAL_CONTINUATION:
+ n = (0xFFF8 + 5);
+ break;
+
+ case CET_TRAMPOLINE:
+ n = (0xFFF8 + 4);
+ break;
+
+ case CET_RETURN_TO_INTERPRETER:
+ n = (0xFFF8 + 3);
+ break;
+
+ case CET_CLOSURE:
+ n = (0xFFF8 + 2);
+ break;
+
+ default:
+ return (true);
+ }
+ (address[-4]) = (n & 0x00FF);
+ (address[-3]) = (n >> 8);
+ return (false);
+}
+\f
+/* The offset is encoded as two bytes. It's relative to its own
+ address, _not_ relative to the entry address. In the case of a
+ closure, the offset points to the start of the first entry in the
+ block. For other entry types, it points to the first non-marked
+ word in the block. */
+
+bool
+read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+ unsigned int n
+ = ((((unsigned int) (address[-1])) << 8)
+ | ((unsigned int) (address[-2])));
+ if (n < 0x8000)
+ {
+ (ceo->offset) = (n + (cc_entry_reference_offset (address)));
+ (ceo->continued_p) = false;
+ }
+ else
+ {
+ (ceo->offset) = (n - 0x8000);
+ (ceo->continued_p) = true;
+ }
+ return (false);
+}
+
+bool
+write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+ unsigned long offset = (ceo->offset);
+ if (ceo->continued_p)
+ {
+ offset -= (cc_entry_reference_offset (address));
+ if (! (offset < 0x8000))
+ return (true);
+ }
+ else
+ {
+ if (! (offset < 0x8000))
+ return (true);
+ offset += 0x8000;
+ }
+ (address[-2]) = (offset & 0x00FF);
+ (address[-1]) = (offset >> 8);
+ return (false);
+}
+
+static unsigned int
+cc_entry_reference_offset (insn_t * address)
+{
+ cc_entry_type_t cet;
+#ifdef ENABLE_DEBUGGING_TOOLS
+ bool ok_p = (read_cc_entry_type ((&cet), address));
+ assert (ok_p);
+#else
+ read_cc_entry_type ((&cet), address);
+#endif
+ return
+ (CC_ENTRY_OFFSET_SIZE
+ + (((cet.marker) == CET_CLOSURE)
+ ? ((sizeof (SCHEME_OBJECT)) + 2)
+ : (2 * (sizeof (SCHEME_OBJECT)))));
+}
+\f
+/* Compiled closures
+
+ A compiled-closure block starts with a single GC header
+ (TC_MANIFEST_CLOSURE), followed by a 2-byte positive count,
+ followed by the closure entries (as specified by the count). For
+ example, on a 32-bit machine with count == 2 and 4 value cells:
+
+ 0x00 TC_MANIFEST_CLOSURE | n_words == 10
+ 0x04 (count - 1) == 1
+
+ 0x06 type == CET_CLOSURE
+ 0x08 (offset - 6) == 2
+ 0x0A SVM1_INST_ICALL_U8
+ 0x0B offset == 8
+
+ 0x0C type == CET_CLOSURE
+ 0x0E (offset - 6) == 8
+ 0x10 SVM1_INST_ICALL_U8
+ 0x11 offset == 6
+
+ 0x12 2 padding bytes
+
+ 0x14 code entry 0
+ 0x18 code entry 1
+
+ 0x1C value cell 0
+ 0x20 value cell 1
+ 0x24 value cell 2
+ 0x28 value cell 3
+
+ */
+
+unsigned long
+compiled_closure_count (SCHEME_OBJECT * block)
+{
+ return
+ (((((unsigned long) (((byte_t *) block) [1])) << 8)
+ | ((unsigned long) (((byte_t *) block) [0])))
+ + 1);
+}
+
+insn_t *
+compiled_closure_start (SCHEME_OBJECT * block)
+{
+ return (((insn_t *) block) + 2);
+}
+
+insn_t *
+compiled_closure_entry (insn_t * start)
+{
+ return (start + CC_ENTRY_HEADER_SIZE);
+}
+\f
+insn_t *
+compiled_closure_next (insn_t * start)
+{
+ insn_t * entry = (compiled_closure_entry (start));
+ switch (*entry)
+ {
+ case SVM1_INST_ICALL_U8: return (entry + 2);
+ case SVM1_INST_ICALL_U16: return (entry + 3);
+ case SVM1_INST_ICALL_U32: return (entry + 5);
+ default:
+ Microcode_Termination (TERM_COMPILER_DEATH);
+ return (0);
+ }
+}
+
+SCHEME_OBJECT *
+skip_compiled_closure_padding (insn_t * start)
+{
+ return
+ ((SCHEME_OBJECT *)
+ ((((unsigned long) start) + ((sizeof (SCHEME_OBJECT)) - 1))
+ &~ ((sizeof (SCHEME_OBJECT)) - 1)));
+}
+
+SCHEME_OBJECT
+compiled_closure_entry_to_target (insn_t * entry)
+{
+ unsigned long offset;
+ switch (entry[0])
+ {
+ case SVM1_INST_ICALL_U8:
+ offset = (((unsigned long) (entry[1])) + 2);
+ break;
+
+ case SVM1_INST_ICALL_U16:
+ offset
+ = (((((unsigned long) (entry[2])) << 8)
+ | ((unsigned long) (entry[1])))
+ + 3);
+ break;
+
+ case SVM1_INST_ICALL_U32:
+ offset
+ = (((((unsigned long) (entry[4])) << 24)
+ | (((unsigned long) (entry[3])) << 16)
+ | (((unsigned long) (entry[2])) << 8)
+ | ((unsigned long) (entry[1])))
+ + 5);
+ break;
+
+ default:
+ Microcode_Termination (TERM_COMPILER_DEATH);
+ return (0);
+ }
+ return (* ((SCHEME_OBJECT *) (entry + offset)));
+}
+\f
+/* Execution caches (UUO links)
+
+ An execution cache is a region of memory that lives in the
+ constants section of a compiled-code block. It is an indirection
+ for calling external procedures that allows the linker to control
+ the calling process without having to find and change all the
+ places in the compiled code that refer to it.
+
+ Prior to linking, the execution cache has two pieces of
+ information: (1) the name of the procedure being called (a symbol),
+ and (2) the number of arguments that will be passed to the
+ procedure. It is laid out in memory like this (on a 32-bit
+ machine):
+
+ 0x00 n-args encoded as fixnum
+ 0x04 name encoded as symbol
+
+ After linking, the cache is changed as follows:
+
+ 0x00 n-args
+ 0x02 SVM1_INST_IJUMP_U8
+ 0x03 offset = 0
+ 0x04 32-bit address
+
+ On a 64-bit machine, the post-linking layout is:
+
+ 0x00 n-args
+ 0x02 4 padding bytes
+ 0x06 SVM1_INST_IJUMP_U8
+ 0x07 offset = 0
+ 0x08 64-bit address
+
+ */
+
+unsigned int
+read_uuo_frame_size (SCHEME_OBJECT * saddr)
+{
+ insn_t * address = ((insn_t *) saddr);
+ return
+ ((((unsigned int) (address[1])) << 8)
+ | ((unsigned int) (address[0])));
+}
+\f
+insn_t *
+read_uuo_target (SCHEME_OBJECT * saddr)
+{
+ insn_t * addr = ((insn_t *) (saddr + 2));
+ insn_t * end = ((insn_t *) (saddr + 1));
+ unsigned long eaddr = 0;
+
+ while (true)
+ {
+ eaddr |= (*--addr);
+ if (addr == end)
+ return (eaddr);
+ eaddr <<= 8;
+ }
+}
+
+insn_t *
+read_uuo_target_no_reloc (SCHEME_OBJECT * saddr)
+{
+ return (read_uuo_target (saddr));
+}
+
+void
+write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr)
+{
+ unsigned long eaddr = ((unsigned long) target);
+ unsigned long frame_size = (OBJECT_DATUM (saddr[0]));
+ insn_t * addr = ((insn_t *) saddr);
+ insn_t * end = ((insn_t *) (saddr + 1));
+
+ (*addr++) = (frame_size & 0x00FF);
+ (*addr++) = ((frame_size & 0xFF00) >> 8);
+ while (addr < (end - 2))
+ (*addr++) = 0;
+ (*addr++) = SVM1_INST_IJUMP_U8;
+ (*addr++) = 0;
+
+ end = ((insn_t *) (saddr + 2));
+ while (true)
+ {
+ (*addr++) = (eaddr & 0xFF);
+ if (addr == end)
+ break;
+ eaddr >>= 8;
+ }
+}
+
+unsigned long
+trampoline_entry_size (unsigned long n_entries)
+{
+ return (BYTES_TO_WORDS (n_entries * (CC_ENTRY_HEADER_SIZE + 2)));
+}
+
+insn_t *
+trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index)
+{
+ return (((insn_t *) (block + 2))
+ + (index * (CC_ENTRY_HEADER_SIZE + 2))
+ + CC_ENTRY_HEADER_SIZE);
+}
+
+bool
+store_trampoline_insns (insn_t * entry, byte_t code)
+{
+ (entry[0]) = SVM1_INST_TRAP_TRAP_0;
+ (entry[1]) = code;
+ return (false);
+}
--- /dev/null
+/* -*-C-*-
+
+$Id: svm1.h,v 1.2 2007/04/22 16:31:24 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Compiled code interface macros for SVM v1. */
+
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
+
+#define ASM_RESET_HOOK initialize_svm1
+
+#define COMPILER_REGBLOCK_N_FIXED 512
+
+typedef byte_t insn_t;
+
+/* Number of insn_t units preceding entry address in which header
+ (type and offset info) is stored. */
+#define CC_ENTRY_HEADER_SIZE (CC_ENTRY_TYPE_SIZE + CC_ENTRY_OFFSET_SIZE)
+#define CC_ENTRY_TYPE_SIZE 2
+#define CC_ENTRY_OFFSET_SIZE 2
+
+/* Number of insn_t units preceding entry header in which GC trap
+ instructions are stored. */
+#define CC_ENTRY_GC_TRAP_SIZE 0
+
+/* Size of execution cache in SCHEME_OBJECTS. */
+#define UUO_LINK_SIZE 2
+#define READ_UUO_TARGET(a, r) read_uuo_target (a)
+
+#define UTILITY_RESULT_DEFINED 1
+
+typedef struct
+{
+ bool scheme_p;
+ union { long interpreter_code; insn_t * new_pc; } arg;
+} utility_result_t;
+
+#define RETURN_TO_C(code) do \
+{ \
+ (DSU_result->scheme_p) = false; \
+ ((DSU_result->arg) . interpreter_code) = (code); \
+ return; \
+} while (false)
+
+#define RETURN_TO_SCHEME(ep) do \
+{ \
+ (DSU_result->scheme_p) = true; \
+ ((DSU_result->arg) . new_pc) = (ep); \
+ return; \
+} while (false)
+
+#define ENTER_SCHEME(ep) return (C_to_interface (ep))
+
+extern long C_to_interface (void *);
+extern void initialize_svm1 (void);
+extern insn_t * read_uuo_target (SCHEME_OBJECT *);
+
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
/* -*-C-*-
-$Id: vax.h,v 1.13 2007/01/05 21:19:26 cph Exp $
+$Id: vax.h,v 1.14 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
* Specialized for the Vax architecture.
*/
-#ifndef CMPNTMD_H_INCLUDED
-#define CMPNTMD_H_INCLUDED
-
-#include "cmptype.h"
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
\f
/* Machine parameters to be set by the user. */
/* Processor type. Choose a number from the above list, or allocate your own. */
-#define COMPILER_PROCESSOR_TYPE COMPILER_VAX_TYPE
+#define COMPILER_PROCESSOR_TYPE COMPILER_VAX_TYPE
/* Size (in long words) of the contents of a floating point register if
different from a double. Default is fine.
*/
typedef unsigned short format_word;
-
-/* PC alignment constraint.
- Change PC_ZERO_BITS to be how many low order bits of the pc are
- guaranteed to be 0 always because of PC alignment constraints.
-*/
-
-#define PC_ZERO_BITS 0
\f
/* The length of the GC recovery code that precedes an entry.
On the Vax a "movl s^code,r0; jsb b^n(r10)" sequence.
magic_constant)); \
} while (0)
-/* Manifest closure entry block size.
+/* Manifest closure entry block size.
Size in bytes of a compiled closure's header excluding the
TC_MANIFEST_CLOSURE header.
On the Vax, this is the format word and gc offset word and 6 bytes
- more for the jsb instruction.
+ more for the jsb instruction.
*/
#define COMPILED_CLOSURE_ENTRY_SIZE \
contains the callee's name instead of the jump code.
*/
-#define EXECUTE_CACHE_ENTRY_SIZE 2
+#define EXECUTE_CACHE_ENTRY_SIZE 2
/* Execute cache destructuring. */
*/
#define COMPILER_REGBLOCK_N_FIXED 16
+#define COMPILER_REGBLOCK_N_TEMPS 256
#define COMPILER_REGBLOCK_N_HOOKS 40
#define COMPILER_HOOK_SIZE 2 /* jsb @& + pad */
#define SETUP_REGISTER(hook) \
{ \
- extern void EXFUN (hook, (void)); \
+ extern void hook (void); \
(* ((unsigned short *) (r10_value + offset))) = \
((unsigned short) 0x9f17); \
(* ((unsigned long *) \
#endif
void
-DEFUN_VOID (vax_reset_hook)
+vax_reset_hook (void)
{
unsigned char * r10_value = ((unsigned char *) (&Registers[0]));
int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT)));
#define TRAMPOLINE_STORAGE(tramp_entry) \
((((SCHEME_OBJECT *) tramp_entry) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
+ (2 + TRAMPOLINE_ENTRY_SIZE))
#define STORE_TRAMPOLINE_ENTRY(entry_address, code) \
{ \
#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-#if (PC_ZERO_BITS == 0)
/* Instructions aligned on byte boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) >> 1)
-#endif
-
-#if (PC_ZERO_BITS == 1)
-/* Instructions aligned on word (16 bit) boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- (CLEAR_LOW_BIT(offset_word))
-#endif
-
-#if (PC_ZERO_BITS >= 2)
-/* Should be OK for =2, but bets are off for >2 because of problems
- mentioned earlier!
-*/
-#define SHIFT_AMOUNT (PC_ZERO_BITS - 1)
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT))
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
-#endif
+#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
+#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) >> 1)
#define MAKE_OFFSET_WORD(entry, block, continue) \
((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
((char *) (block)))) | \
((continue) ? 1 : 0))
-#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 1)
-#endif
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 2)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 2)
-#endif
-
-#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) / EXECUTE_CACHE_ENTRY_SIZE)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
-#endif
+#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) ((count) >> 1)
+#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) ((entries) << 1)
\f
/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
a format word and a gc offset word. See the early part of the
#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-#endif /* CMPNTMD_H_INCLUDED */
+#endif /* !SCM_CMPINTMD_H_INCLUDED */
+++ /dev/null
-/* -*-C-*-
-
-$Id: cmptype.h,v 1.8 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Processor type definitions */
-
-#ifndef SCM_CMPTYPE_H
-#define SCM_CMPTYPE_H 1
-
-/* This file contains the associations between processor numbers and
- their descriptions. This file should only be modified by the
- Scheme project at MIT, to avoid conflicts.
-
- These numbers are the numbers stored in Scheme images (bands) so
- that the microcode can detect whether the compiled code in the band
- is compatible with it.
-
- These _are not_ the same numbers as the PROC_TYPE_XXX used to
- configure the microcode under Unix (cf.h)---they probably should
- be.
-
-
-Number Description
-______ ___________
-
-0 No compiled code support
-
-1 Motorola MC68020 with MC68881 floating point coprocessor,
- or MC68030 (not MC68040).
- Examples: HP series 9000 models 320, 350, 370, 375
- Sun models 340, 360
-
-2 DEC Vax
- Examples: Vax-11 750
- MicroVax II
- VaxStation 3100
-
-3 HP Precision architecture (version 1.0 and later).
- Examples: HP series 9000 models 850, 835, 720, 750, 710, 877.
-
-4 MIPS R2000/R3000 with cache line <= 16 bytes.
- Examples: DecStation 3100, 2100, 5000/200.
- Sony News 3250
-
-5 Motorola MC68020-MC68040
- Examples: HP series 9000 models 320-380, models 400+
- All Next computers (up to Aug. 1992).
-
-6 Sun Sparc
- Examples: Sun 4, SparcStation 2, IPC, ELC.
- Solbourne ?
-
-7 IBM POWER and POWER/PC architecture.
- Examples: IBM RS6000 model 560.
-
-8 Motorola 88000 architecture (88100 and 88110).
- Examples: ?
-
-9 Intel IA-32 architecture.
- Examples: IBM PC AT clones with 386+ processors.
-
-10 DEC Alpha architecture
- Examples: DEC AXP 500
-
-11 MIPS R200-R4000 (32 bit) with arbitrary cache line size.
- Examples: DecStation 2100, 3100, 5000/200, 5000/240
- Sony News 3250
- Silicon Graphics Predator, Indigo, and Crimson
-
-12 Virtual C processor.
- The Scheme compiler produces C to be compiled by the
- same C compiler as the microcode.
-
-13 Scheme Virtual Machine
- The compiler produces code for a virtual machine that is
- written in C and embedded in the microcode.
-
-*/
-
-#define COMPILER_NONE_TYPE 0
-#define COMPILER_MC68020_TYPE 1
-#define COMPILER_VAX_TYPE 2
-#define COMPILER_SPECTRUM_TYPE 3
-#define COMPILER_OLD_MIPS_TYPE 4
-#define COMPILER_MC68040_TYPE 5
-#define COMPILER_SPARC_TYPE 6
-#define COMPILER_RS6000_TYPE 7
-#define COMPILER_MC88K_TYPE 8
-#define COMPILER_IA32_TYPE 9
-#define COMPILER_ALPHA_TYPE 10
-#define COMPILER_MIPS_TYPE 11
-#define COMPILER_LOSING_C_TYPE 12
-#define COMPILER_SVM_TYPE 13
-
-#endif /* SCM_CMPTYPE_H */
/* -*-C-*-
+$Id: comlin.c,v 1.15 2007/04/22 16:31:22 cph Exp $
+
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007 Massachusetts Institute of Technology
*/
-/* $Id: comlin.c,v 1.14 2007/01/05 21:19:25 cph Exp $
- *
- * This file contains the scheme command parser.
- *
- */
+/* The scheme command parser. */
\f
#include <stdio.h>
#ifndef toupper
-#include <ctype.h>
+# include <ctype.h>
#endif
#include "comlin.h"
/* Some string utilities */
char *
-DEFUN (remove_initial_substring, (sub, str),
- register char * sub
- AND register char * str)
+remove_initial_substring (char * sub, char * str)
{
for ( ; *sub != '\0'; sub++, str++)
- {
- if (*sub != *str)
{
- return ((char *) NULL);
+ if (*sub != *str)
+ return (0);
}
- }
return (str);
}
-boolean
-DEFUN (STREQUAL, (s1, s2),
- register char * s1
- AND register char * s2)
+bool
+STREQUAL (char * s1, char * s2)
{
for ( ; *s1 != '\0'; s1++, s2++)
- {
- if (toupper(*s1) != toupper(*s2))
{
- return (false);
+ if (toupper(*s1) != toupper(*s2))
+ return (false);
}
- }
return (*s2 == '\0');
}
\f
/* Usage information */
void
-DEFUN (print_usage_and_exit, (options, val),
- struct keyword_struct * options
- AND int val)
+print_usage_and_exit (struct keyword_struct * options, int val)
{
- register int i;
+ int i;
fprintf(stderr, "usage: %s", program_name);
if ((options[0].type_tag) == LAST_KYWRD)
- {
- fprintf(stderr, "\n");
- exit(val);
- }
+ {
+ fprintf(stderr, "\n");
+ exit(val);
+ }
fprintf(stderr, " [args]\n");
fprintf(stderr, " where args are as follows:\n");
for (i = 0;
((options[i].type_tag) != LAST_KYWRD);
i++)
- {
- switch (options[i].type_tag)
{
- case BOOLEAN_KYWRD:
- fprintf(stderr, " %s={true,false}\n",
- options[i].keyword);
- break;
+ switch (options[i].type_tag)
+ {
+ case BOOLEAN_KYWRD:
+ fprintf(stderr, " %s={true,false}\n",
+ options[i].keyword);
+ break;
- case INT_KYWRD:
- case DOUBLE_KYWRD:
- fprintf(stderr, " %s=%s\n",
- options[i].keyword, options[i].format);
- break;
+ case INT_KYWRD:
+ case DOUBLE_KYWRD:
+ fprintf(stderr, " %s=%s\n",
+ options[i].keyword, options[i].format);
+ break;
- case STRING_KYWRD:
- fprintf(stderr, " %s=%%s\n",
- options[i].keyword);
- break;
+ case STRING_KYWRD:
+ fprintf(stderr, " %s=%%s\n",
+ options[i].keyword);
+ break;
+ }
}
- }
exit(val);
}
\f
void
-DEFUN (supply, (options, j),
- struct keyword_struct * options
- AND int j)
+supply (struct keyword_struct * options, int j)
{
- if (options[j].supplied_p != ((boolean *) NULL))
+ if (options[j].supplied_p != 0)
{
if (*(options[j].supplied_p))
{
\f
char * program_name;
-/* This parser assumes that no keyword is an initial
- substring of another.
- */
+/* This parser assumes that no keyword is an initial substring of
+ another. */
void
-DEFUN (parse_keywords,
- (argc, argv, options, allow_others_p),
- int argc
- AND char **argv
- AND struct keyword_struct * options
- AND boolean allow_others_p)
+parse_keywords (int argc,
+ char **argv,
+ struct keyword_struct * options,
+ bool allow_others_p)
{
- register int i, j, length;
- char *argument;
+ int i, j, length;
+ char * argument;
program_name = argv[0];
argv += 1;
((options[length].type_tag) != LAST_KYWRD);
length++)
{
- if (options[length].supplied_p != ((boolean *) NULL))
+ if (options[length].supplied_p != 0)
{
*(options[length].supplied_p) = false;
}
-\f
+
switch (options[length].type_tag)
{
case BOOLEAN_KYWRD:
exit(1);
}
}
-\f
+
for (i = 0; i < argc; i++)
{
for (j = 0; j < length; j++)
case BOOLEAN_KYWRD:
{
- boolean value = false;
+ bool value = false;
if (*argument != '\0')
{
"parse_keywords: unrecognized parameter: %s\n",
argv[i]);
print_usage_and_exit(&options[0], 1);
+ /*NOTREACHED*/
+ value = false;
}
else
{
"parse_keywords: Invalid boolean value: %s\n",
argv[i]);
print_usage_and_exit(&options[0], 1);
+ /*NOTREACHED*/
+ value = false;
}
}
}
*(BOOLEAN_LVALUE(options[j])) = value;
break;
}
-\f
+
case INT_KYWRD:
if (*argument != '=')
{
supply(options, j);
sscanf(&argument[1], options[j].format, DOUBLE_LVALUE(options[j]));
break;
-\f
+
case STRING_KYWRD:
if (*argument != '=')
{
print_usage_and_exit(&options[0], 1);
}
}
- return;
}
/* -*-C-*-
+$Id: comlin.h,v 1.12 2007/04/22 16:31:22 cph Exp $
+
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007 Massachusetts Institute of Technology
*/
-/* $Id: comlin.h,v 1.11 2007/01/05 21:19:25 cph Exp $
- *
- * This file contains definitions for the scheme command parser.
- *
- */
+/* The scheme command parser. */
\f
#ifndef COMLIN_H_INCLUDED
#define COMLIN_H_INCLUDED
-#include "ansidecl.h"
-
#ifndef boolean
# define boolean int
#endif
{
int type_tag;
string keyword;
- long *data;
+ void *data;
string format;
boolean *supplied_p;
};
-#define KEYWORD(str, var, type, format, sup) \
-{ \
- type, \
- ((string) str), \
- ((long *) var), \
- format, \
- sup \
-}
+#define KEYWORD(str, var, type, format, sup) { type, str, var, format, sup }
-#define END_KEYWORD() KEYWORD("", NULL, LAST_KYWRD, NULL, NULL)
+#define END_KEYWORD() KEYWORD ("", 0, LAST_KYWRD, 0, 0)
/* Fake boolean and string formats */
-#define BFRMT ((string) NULL)
-#define SFRMT ((string) NULL)
+#define BFRMT (0)
+#define SFRMT (0)
/* Exports */
-extern char *program_name;
+extern char * program_name;
-extern void EXFUN (parse_keywords,
- (int, char **, struct keyword_struct *, boolean));
+extern void parse_keywords (int, char **, struct keyword_struct *, boolean);
#endif /* COMLIN_H_INCLUDED */
/* -*-C-*-
-$Id: comutl.c,v 1.37 2007/01/12 03:45:55 cph Exp $
+$Id: comutl.c,v 1.38 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
-extern SCHEME_OBJECT
- * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT));
-
-extern long
- EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT)),
- EXFUN (coerce_to_compiled, (SCHEME_OBJECT, long, SCHEME_OBJECT *));
-
-extern void EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));
-\f
-DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block, 1, 1,
- "Given a compiled code address, return its compiled code block.")
+DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block,
+ 1, 1, "(ADDRESS)\n\
+Given a compiled-code entry ADDRESS, return its block.")
{
PRIMITIVE_HEADER (1);
-
- CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
- PRIMITIVE_RETURN
- (MAKE_POINTER_OBJECT
- (TC_COMPILED_CODE_BLOCK,
- (compiled_entry_to_block_address (ARG_REF (1)))));
+ CHECK_ARG (1, CC_ENTRY_P);
+ PRIMITIVE_RETURN (cc_entry_to_block (ARG_REF (1)));
}
-DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET", Prim_comp_code_address_offset, 1, 1,
- "Given a compiled code address, return its offset into its block.")
+DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET",
+ Prim_comp_code_address_offset, 1, 1, "(ADDRESS)\n\
+Given a compiled-code entry ADDRESS, return its offset into its block.")
{
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
- PRIMITIVE_RETURN
- (LONG_TO_FIXNUM (compiled_entry_to_block_offset (ARG_REF (1))));
+ CHECK_ARG (1, CC_ENTRY_P);
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (cc_entry_to_block_offset (ARG_REF (1))));
}
-#ifndef USE_STACKLETS
-
DEFINE_PRIMITIVE ("STACK-TOP-ADDRESS", Prim_stack_top_address, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (long_to_integer ((long) (ADDRESS_TO_DATUM (Stack_Top))));
+ PRIMITIVE_RETURN (ulong_to_integer (ADDRESS_TO_DATUM (STACK_BOTTOM)));
}
DEFINE_PRIMITIVE ("STACK-ADDRESS-OFFSET", Prim_stack_address_offset, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STACK_ADDRESS_P);
- PRIMITIVE_RETURN
- (long_to_integer
- (STACK_LOCATIVE_DIFFERENCE ((Stack_Top),
- (OBJECT_ADDRESS (ARG_REF (1))))));
+ CHECK_ARG (1, CC_STACK_ENV_P);
+ {
+ SCHEME_OBJECT * address = (OBJECT_ADDRESS (ARG_REF (1)));
+ if (!ADDRESS_IN_STACK_P (address))
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN
+ (ulong_to_integer (SP_TO_N_PUSHED (address, stack_start, stack_end)));
+ }
}
-
-#endif /* USE_STACKLETS */
-
-DEFINE_PRIMITIVE ("COMPILED-ENTRY-KIND", Prim_compiled_entry_type, 1, 1, 0)
+\f
+DEFINE_PRIMITIVE ("COMPILED-ENTRY-KIND", Prim_compiled_entry_kind, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+ CHECK_ARG (1, CC_ENTRY_P);
{
- long results [3];
- compiled_entry_type ((ARG_REF (1)), results);
+ cc_entry_type_t cet;
+ unsigned long kind = 4;
+ unsigned long field1 = 0;
+ long field2 = 0;
+
+ if (!read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (ARG_REF (1)))))
+ switch (cet.marker)
+ {
+ case CET_PROCEDURE:
+ kind = 0;
+ field1 = (1 + (cet.args.for_procedure.n_required));
+ field2 = (field1 + (cet.args.for_procedure.n_optional));
+ if (cet.args.for_procedure.rest_p)
+ field2 = (- (field2 + 1));
+ break;
+
+ case CET_CONTINUATION:
+ kind = 1;
+ field1 = 0;
+ field2 = (cet.args.for_continuation.offset);
+ break;
+
+ case CET_EXPRESSION:
+ kind = 2;
+ field1 = 0;
+ field2 = 0;
+ break;
+
+ case CET_INTERNAL_CONTINUATION:
+ kind = 1;
+ field1 = 1;
+ field2 = (-1);
+ break;
+
+ case CET_INTERNAL_PROCEDURE:
+ case CET_TRAMPOLINE:
+ kind = 3;
+ field1 = 1;
+ field2 = 0;
+ break;
+
+ case CET_RETURN_TO_INTERPRETER:
+ kind = 1;
+ field1 = 2;
+ field2 = ((ARG_REF (1)) != return_to_interpreter);
+ break;
+
+ case CET_CLOSURE:
+ kind = 3;
+ field1 = 0;
+ field2 = 0;
+ break;
+ }
PRIMITIVE_RETURN
- (hunk3_cons ((LONG_TO_FIXNUM (results [0])),
- (LONG_TO_FIXNUM (results [1])),
- (LONG_TO_FIXNUM (results [2]))));
+ (hunk3_cons ((ULONG_TO_FIXNUM (kind)),
+ (ULONG_TO_FIXNUM (field1)),
+ (LONG_TO_FIXNUM (field2))));
}
}
\f
-DEFINE_PRIMITIVE ("COERCE-TO-COMPILED-PROCEDURE", Prim_coerce_to_closure, 2, 2, 0)
+DEFINE_PRIMITIVE ("COERCE-TO-COMPILED-PROCEDURE", Prim_coerce_to_closure, 2, 2,
+ 0)
{
- SCHEME_OBJECT temp;
- long result;
- PRIMITIVE_HEADER(2);
- result = (coerce_to_compiled ((ARG_REF (1)), (arg_integer (2)), &temp));
- switch(result)
+ PRIMITIVE_HEADER (2);
{
- case PRIM_DONE:
- PRIMITIVE_RETURN(temp);
-
- case PRIM_INTERRUPT:
- Primitive_GC(10);
- /*NOTREACHED*/
-
- default:
- error_bad_range_arg (2);
- /*NOTREACHED*/
- return (0);
+ SCHEME_OBJECT temp;
+ long result
+ = (coerce_to_compiled ((ARG_REF (1)), (arg_ulong_integer (2)), (&temp)));
+ switch (result)
+ {
+ case PRIM_DONE:
+ break;
+
+ case PRIM_INTERRUPT:
+ Primitive_GC (10);
+ /*NOTREACHED*/
+ break;
+
+ default:
+ error_bad_range_arg (2);
+ /*NOTREACHED*/
+ break;
+ }
+ PRIMITIVE_RETURN (temp);
}
}
-DEFINE_PRIMITIVE ("COMPILED-CLOSURE->ENTRY", Prim_compiled_closure_to_entry, 1, 1,
+DEFINE_PRIMITIVE ("COMPILED-CLOSURE->ENTRY", Prim_cc_closure_to_entry, 1, 1,
"Given a compiled closure, return the entry point which it invokes.")
{
- long entry_type [3];
- SCHEME_OBJECT closure;
- extern long EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT));
- extern SCHEME_OBJECT EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT));
PRIMITIVE_HEADER (1);
-
- CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
- closure = (ARG_REF (1));
- compiled_entry_type (closure, (& (entry_type [0])));
- if (! (((entry_type [0]) == 0) && (compiled_entry_closure_p (closure))))
+ CHECK_ARG (1, CC_ENTRY_P);
+ if (!cc_entry_closure_p (ARG_REF (1)))
error_bad_range_arg (1);
- PRIMITIVE_RETURN (compiled_closure_to_entry (closure));
+ PRIMITIVE_RETURN (cc_closure_to_entry (ARG_REF (1)));
}
-\f
-DEFINE_PRIMITIVE ("UTILITY-INDEX->NAME", Prim_utility_index_to_name, 1, 1,
- "Given an integer, return the name of the corresponding compiled code utility.")
+
+DEFINE_PRIMITIVE ("UTILITY-INDEX->NAME", Prim_utility_index_to_name, 1, 1, 0)
{
- extern char * EXFUN (utility_index_to_name, (int));
- char * result;
PRIMITIVE_HEADER (1);
-
- result = (utility_index_to_name (arg_integer (1)));
- if (result == ((char *) NULL))
- PRIMITIVE_RETURN (SHARP_F);
- else
- PRIMITIVE_RETURN (char_pointer_to_string (result));
+ {
+ const char * name = (utility_index_to_name (arg_ulong_integer (1)));
+ PRIMITIVE_RETURN ((name == 0) ? SHARP_F : (char_pointer_to_string (name)));
+ }
}
-DEFINE_PRIMITIVE ("BUILTIN-INDEX->NAME", Prim_builtin_index_to_name, 1, 1,
- "Given an integer, return the name of the corresponding compiled code utility.")
+DEFINE_PRIMITIVE ("BUILTIN-INDEX->NAME", Prim_builtin_index_to_name, 1, 1, 0)
{
- extern char * EXFUN (builtin_index_to_name, (int));
- char * result;
PRIMITIVE_HEADER (1);
-
- result = (builtin_index_to_name (arg_integer (1)));
- if (result == ((char *) NULL))
- PRIMITIVE_RETURN (SHARP_F);
- else
- PRIMITIVE_RETURN (char_pointer_to_string (result));
+ {
+ const char * name = (builtin_index_to_name (arg_ulong_integer (1)));
+ PRIMITIVE_RETURN ((name == 0) ? SHARP_F : (char_pointer_to_string (name)));
+ }
}
-/* This is only meaningful for the C back end. */
+#ifdef CC_IS_C
+ extern SCHEME_OBJECT initialize_C_compiled_block (int, const char *);
+#endif
DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK",
Prim_initialize_C_compiled_block, 1, 1,
"Given the tag of a compiled object, return the object.")
{
-#ifdef NATIVE_CODE_IS_C
- extern SCHEME_OBJECT EXFUN (initialize_C_compiled_block, (int, char *));
- SCHEME_OBJECT val;
-
- val = (initialize_C_compiled_block (1, (STRING_ARG (1))));
- PRIMITIVE_RETURN (val);
+ PRIMITIVE_HEADER (1);
+#ifdef CC_IS_C
+ PRIMITIVE_RETURN (initialize_C_compiled_block (1, (STRING_ARG (1))));
#else
PRIMITIVE_RETURN (SHARP_F);
#endif
Prim_declare_compiled_code_block, 1, 1,
"Ensure cache coherence for a compiled-code block newly constructed.")
{
- extern void EXFUN (declare_compiled_code_block, (SCHEME_OBJECT));
- SCHEME_OBJECT new_cc_block;
PRIMITIVE_HEADER (1);
-
- new_cc_block = (ARG_REF (1));
- if ((OBJECT_TYPE (new_cc_block)) != TC_COMPILED_CODE_BLOCK)
- error_wrong_type_arg (1);
- declare_compiled_code_block (new_cc_block);
- PRIMITIVE_RETURN (SHARP_T);
+ {
+ SCHEME_OBJECT new_cc_block = (ARG_REF (1));
+ if (!CC_BLOCK_P (new_cc_block))
+ error_wrong_type_arg (1);
+ declare_compiled_code_block (new_cc_block);
+ PRIMITIVE_RETURN (SHARP_T);
+ }
}
\f
-extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
-extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
-extern Boolean EXFUN (bkpt_p, (PTR));
-extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
-extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
-
DEFINE_PRIMITIVE ("BKPT/INSTALL", Prim_install_bkpt, 1, 1,
"(compiled-entry-object)\n\
Install a breakpoint trap in a compiled code object.\n\
Returns false or a handled needed by REMOVE-BKPT and ONE-STEP-PROCEED.")
{
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+ CHECK_ARG (1, CC_ENTRY_P);
{
SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1)));
SCHEME_OBJECT * block;
- if (bkpt_p ((PTR) entry))
+ if (bkpt_p ((void *) entry))
error_bad_range_arg (1);
- block = (compiled_entry_to_block_address (ARG_REF (1)));
+ block = (cc_entry_to_block_address (ARG_REF (1)));
if ((OBJECT_TYPE (block[0])) == TC_MANIFEST_CLOSURE)
- PRIMITIVE_RETURN (bkpt_closure_install ((PTR) entry));
+ PRIMITIVE_RETURN (bkpt_closure_install ((void *) entry));
else
- PRIMITIVE_RETURN (bkpt_install ((PTR) entry));
+ PRIMITIVE_RETURN (bkpt_install ((void *) entry));
}
}
Remove a breakpoint trap installed by INSTALL-BKPT.")
{
PRIMITIVE_HEADER (2);
- CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+ CHECK_ARG (1, CC_ENTRY_P);
CHECK_ARG (2, NON_MARKED_VECTOR_P);
{
SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1)));
SCHEME_OBJECT handle = (ARG_REF (2));
- if (! (bkpt_p ((PTR) entry)))
+ if (! (bkpt_p ((void *) entry)))
error_bad_range_arg (1);
- bkpt_remove (((PTR) entry), handle);
+ bkpt_remove (((void *) entry), handle);
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
True if there is a breakpoint trap in compiled-entry-object.")
{
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+ CHECK_ARG (1, CC_ENTRY_P);
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
- (bkpt_p ((PTR) (OBJECT_ADDRESS (ARG_REF (1))))));
+ (bkpt_p ((void *) (OBJECT_ADDRESS (ARG_REF (1))))));
}
DEFINE_PRIMITIVE ("BKPT/PROCEED", Prim_bkpt_proceed, 3, 3,
Proceed the computation from the current breakpoint.")
{
PRIMITIVE_HEADER (3);
- CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+ CHECK_ARG (1, CC_ENTRY_P);
CHECK_ARG (2, NON_MARKED_VECTOR_P);
- PRIMITIVE_RETURN (bkpt_proceed (((PTR) (OBJECT_ADDRESS (ARG_REF (1)))),
+ PRIMITIVE_RETURN (bkpt_proceed (((void *) (OBJECT_ADDRESS (ARG_REF (1)))),
(ARG_REF (2)),
(ARG_REF (3))));
}
# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
# Inc.
-timestamp='2006-07-02'
+timestamp='2007-04-22'
# This file is (in principle) common to ALL GNU software.
# The presence of a machine in this file suggests that SOME GNU software
dnl Process this file with autoconf to produce a configure script.
-AC_INIT([MIT/GNU Scheme microcode], [14.18], [bug-mit-scheme@gnu.org], [mit-scheme])
-AC_REVISION([$Id: configure.ac,v 1.39 2007/04/04 05:08:19 riastradh Exp $])
+AC_INIT([MIT/GNU Scheme microcode], [15.0], [bug-mit-scheme@gnu.org], [mit-scheme])
+AC_REVISION([$Id: configure.ac,v 1.40 2007/04/22 16:31:22 cph Exp $])
AC_CONFIG_SRCDIR([boot.c])
AC_CONFIG_HEADERS([config.h])
AC_PROG_MAKE_SET
dnl Checks for programs.
AC_PROG_CC
-AC_PROG_GCC_TRADITIONAL
+AC_C_BACKSLASH_A
+AC_C_BIGENDIAN
+AC_C_CONST
+AC_C_RESTRICT
+AC_C_VOLATILE
+AC_C_INLINE
+AC_C_STRINGIZE
+AC_C_PROTOTYPES
AC_PROG_INSTALL
AC_PROG_LN_S
AC_PROG_MAKE_SET
if test ${GCC} = yes; then
if test ${enable_debugging} = no; then
- CFLAGS="-fPIC -O3"
+ CFLAGS="-O3"
else
- CFLAGS="-fPIC -O0 -g"
+ CFLAGS="-O0 -g -DENABLE_DEBUGGING_TOOLS"
LDFLAGS="${LDFLAGS} -g"
fi
- CFLAGS="${CFLAGS} -Wall"
+ if test ${enable_native_code} = c; then
+ CFLAGS="-fPIC ${CFLAGS}"
+ fi
+ CFLAGS="${CFLAGS} -Wall -Wundef -Wpointer-arith -Winline"
+ CFLAGS="${CFLAGS} -Wstrict-prototypes -Wnested-externs -Wredundant-decls"
+
+ AC_MSG_CHECKING([for GCC>=4])
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[
+ #if __GNUC__ >= 4
+ ;
+ #else
+ #error "gcc too old"
+ #endif
+ ]],
+ [[]]
+ )],
+ [
+ AC_MSG_RESULT([yes])
+ CFLAGS="${CFLAGS} -Wextra -Wno-sign-compare -Wno-unused-parameter"
+ CFLAGS="${CFLAGS} -Wold-style-definition"
+ ],
+ [AC_MSG_RESULT([no])])
+
+ # other possibilities:
+ # -Wmissing-prototypes -Wunreachable-code -Wwrite-strings
fi
FOO=`${INSTALL} --help 2> /dev/null | fgrep -e --preserve-timestamps`
if test "x${FOO}" != x; then
[
AC_DEFINE([HAVE_LIBMHASH], [1],
[Define to 1 if you have the `mhash' library (-lmhash).])
+ if test ${enable_debugging} != no; then
+ LIBS="-lmhash ${LIBS}"
+ fi
MODULE_LIBS="-lmhash ${MODULE_LIBS}"
MODULE_BASES="${MODULE_BASES} prmhash"
if test "x${PRMD5_LIBS}" = x; then
fi
AC_MSG_CHECKING([for native-code support])
-OPTIONAL_BASES="${OPTIONAL_BASES} cmpint"
-GC_HEAD_FILES="gccode.h cmpgc.h"
+OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl"
+GC_HEAD_FILES="gccode.h cmpgc.h cmpintmd-config.h cmpintmd.h"
SCM_ARCH=none
ECN_WARNP=no
c)
SCM_ARCH=c
;;
+svm)
+ SCM_ARCH=svm1
+ ;;
no|none)
;;
*)
;;
c)
AC_MSG_RESULT([yes, using portable C code])
- AC_DEFINE([NATIVE_CODE_IS_C], [1],
- [Define that the compiler outputs C code instead of binaries.])
AC_CONFIG_LINKS([cmpauxmd.c:cmpauxmd/c.c])
AC_DEFINE([COMPILE_FOR_STATIC_LINKING], [1],
[Define to 1 for static compilation of C native code.])
LIARC_VARS=liarc-vars
LIARC_RULES=liarc-rules
;;
+svm1)
+ AC_MSG_RESULT([yes, using portable SVM code])
+ OPTIONAL_BASES="${OPTIONAL_BASES} svm1-interp"
+ ;;
*)
AC_MSG_RESULT([yes, for ${SCM_ARCH}])
AC_CONFIG_LINKS([cmpauxmd.m4:cmpauxmd/${SCM_ARCH}.m4])
AC_MSG_WARN([illegal --enable-native-code value: ${enable_native_code}])
fi
-if test ${SCM_ARCH} != none; then
- AC_DEFINE([HAS_COMPILER_SUPPORT], [1],
- [Define if architecture has native-code compiler support.])
- AC_CONFIG_LINKS([cmpintmd.h:cmpintmd/${SCM_ARCH}.h])
- GC_HEAD_FILES="${GC_HEAD_FILES} cmpintmd.h"
-fi
+AC_CONFIG_LINKS([
+ cmpintmd.h:cmpintmd/${SCM_ARCH}.h
+ cmpintmd.c:cmpintmd/${SCM_ARCH}.c
+ cmpintmd-config.h:cmpintmd/${SCM_ARCH}-config.h
+ ])
for base in ${OPTIONAL_BASES}; do
OPTIONAL_SOURCES="${OPTIONAL_SOURCES} ${base}.c"
/* -*-C-*-
-$Id: confshared.h,v 11.11 2007/01/05 21:19:25 cph Exp $
+$Id: confshared.h,v 11.12 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#ifndef SCM_CONFSHARED_H
#define SCM_CONFSHARED_H
+\f
+#ifndef __STDC__
+# include "error: compiler must support ANSI C"
+#endif
-#include "ansidecl.h"
-
-/* To enable the STEPPER. Incompatible with futures. */
-#define COMPILE_STEPPER
-
-/* Some configuration consistency testing */
+/* Enable the stepper. */
+#define COMPILE_STEPPER 1
-#ifdef COMPILE_STEPPER
-# ifdef COMPILE_FUTURES
-# include "Error: The stepper doesn't work with futures."
+#ifdef ENABLE_DEBUGGING_TOOLS
+# undef NDEBUG /* for assert() */
+# define WHEN_DEBUGGING(code) do { code } while (0)
+# define ENABLE_PRIMITIVE_PROFILING
+#else
+# define NDEBUG 1 /* for assert() */
+# define WHEN_DEBUGGING(code) do {} while (0)
+# undef ENABLE_PRIMITIVE_PROFILING
+#endif
+
+/* For use in the C pre-processor, not in code! */
+#define FALSE 0
+#define TRUE 1
+
+#include <stdio.h>
+#include <math.h>
+
+#if STDC_HEADERS
+# include <stdlib.h>
+# include <stdarg.h>
+# include <stddef.h>
+# include <string.h>
+# include <ctype.h>
+# include <limits.h>
+# include <float.h>
+# include <assert.h>
+#else
+# ifdef HAVE_LIMITS_H
+# include <limits.h>
+# endif
+# ifdef HAVE_FLOAT_H
+# include <float.h>
+# else
+# include "float.h"
+# endif
+# ifdef HAVE_ASSERT_H
+# include <assert.h>
+# endif
+# ifdef HAVE_MALLOC_H
+# include <malloc.h>
# endif
-# ifdef USE_STACKLETS
-# include "Error: The stepper doesn't work with stacklets."
+# if !HAVE_STRCHR
+# define strchr index
+# define strrchr rindex
# endif
+ extern char * strchr ();
+ extern char * strrchr ();
+# if !HAVE_MEMCPY
+# define memcpy(d, s, n) bcopy ((s), (d), (n))
+# define memmove(d, s, n) bcopy ((s), (d), (n))
+# endif
+#endif
+
+#if HAVE_STDBOOL_H
+# include <stdbool.h>
+#else
+# if !HAVE__BOOL
+# ifdef __cplusplus
+ typedef bool _Bool;
+# else
+ typedef unsigned char _Bool;
+# endif
+# endif
+# define bool _Bool
+# define false 0
+# define true 1
+# define __bool_true_false_are_defined 1
#endif
-/* For use in the C pre-processor, not in code! */
-#define FALSE 0
-#define TRUE 1
+#ifdef HAVE_STDINT_H
+# include <stdint.h>
+#endif
-/* These C type definitions are needed by everybody.
- They should not be here, but it is unavoidable. */
-typedef char Boolean;
-#define true ((Boolean) TRUE)
-#define false ((Boolean) FALSE)
+#if (CHAR_BIT != 8)
+# include "error: characters must be 8 bits wide"
+#endif
-/* This is the Scheme object type.
- The various fields are defined in "object.h". */
-typedef unsigned long SCHEME_OBJECT;
-#define OBJECT_LENGTH (CHAR_BIT * SIZEOF_UNSIGNED_LONG)
+#if (FLT_RADIX != 2)
+# include "error: floating-point radix must be 2"
+#endif
+
+#if (SIZEOF_UINTPTR_T > SIZEOF_UNSIGNED_LONG)
+# include "error: pointers must fit in 'unsigned long'"
+#endif
+
+#if ((defined (__GNUC__)) && (__GNUC__ >= 3))
+# define ATTRIBUTE(x) __attribute__ (x)
+# define NORETURN __attribute__ ((__noreturn__))
+#else
+# define ATTRIBUTE(x)
+# define NORETURN
+#endif
\f
/* Operating System / Machine dependencies:
- For each implementation, be sure to specify FASL_INTERNAL_FORMAT.
+ For each implementation, be sure to specify CURRENT_FASL_ARCH.
Make sure that there is an appropriate FASL_<machine name>.
If there isn't, add one to the list below.
available memory and thus all addresses will fit in the datum portion
of a Scheme object. The datum portion of a Scheme object is 8 bits
less than the length of a C long. */
-\f
-/* Possible values for FASL_INTERNAL_FORMAT. For the most part this
+
+/* Possible values for CURRENT_FASL_ARCH. For the most part this
means the processor type, so for example there are several aliases
for 68000 family processors. This scheme allows sharing of
compiled code on machines with the same processor type. Probably
files when we introduce new differences, such as whether or not a
68881 coprocessor is installed. */
-#define FASL_UNKNOWN 0
-#define FASL_PDP10 1
-#define FASL_VAX 2
-#define FASL_68020 3
-#define FASL_68000 4
-#define FASL_HP_9000_500 5
-#define FASL_IA32 6
-#define FASL_BFLY 7
-#define FASL_CYBER 8
-#define FASL_CELERITY 9
-#define FASL_HP_SPECTRUM 10
-#define FASL_UMAX 11
-#define FASL_PYR 12
-#define FASL_ALLIANT 13
-#define FASL_SPARC 14
-#define FASL_MIPS 15
-#define FASL_APOLLO_68K 16
-#define FASL_APOLLO_PRISM 17
-#define FASL_ALPHA 18
-#define FASL_RS6000 19
-#define FASL_PPC32 20
-#define FASL_X86_64 21
-#define FASL_PPC64 22
-#define FASL_IA64 23
+typedef enum
+{
+ FASL_UNKNOWN,
+ FASL_PDP10,
+ FASL_VAX,
+ FASL_68020,
+ FASL_68000,
+ FASL_HP_9000_500,
+ FASL_IA32,
+ FASL_BFLY,
+ FASL_CYBER,
+ FASL_CELERITY,
+ FASL_HP_SPECTRUM,
+ FASL_UMAX,
+ FASL_PYR,
+ FASL_ALLIANT,
+ FASL_SPARC,
+ FASL_MIPS,
+ FASL_APOLLO_68K,
+ FASL_APOLLO_PRISM,
+ FASL_ALPHA,
+ FASL_RS6000,
+ FASL_PPC32,
+ FASL_X86_64,
+ FASL_PPC64,
+ FASL_IA64
+} fasl_arch_t;
+
+/* Possible values for COMPILER_PROCESSOR_TYPE. This identifies the
+ processor for which native-code support is provided. This is
+ related to the fasl_arch_t types above, but can also take on values
+ that are independent of the host architecture. */
+
+typedef enum
+{
+ COMPILER_NONE_TYPE,
+ COMPILER_MC68020_TYPE,
+ COMPILER_VAX_TYPE,
+ COMPILER_SPECTRUM_TYPE,
+ COMPILER_OLD_MIPS_TYPE,
+ COMPILER_MC68040_TYPE,
+ COMPILER_SPARC_TYPE,
+ COMPILER_RS6000_TYPE,
+ COMPILER_MC88K_TYPE,
+ COMPILER_IA32_TYPE,
+ COMPILER_ALPHA_TYPE,
+ COMPILER_MIPS_TYPE,
+ COMPILER_C_TYPE,
+ COMPILER_SVM_TYPE
+} cc_arch_t;
+
+#include "cmpintmd-config.h"
\f
#ifdef vax
/* Amazingly unix and vms agree on all these */
#define MACHINE_TYPE "vax"
-#define FASL_INTERNAL_FORMAT FASL_VAX
-#define HEAP_IN_LOW_MEMORY
+#define CURRENT_FASL_ARCH FASL_VAX
+#define PC_ZERO_BITS 0
+#define HEAP_IN_LOW_MEMORY 1
/* Not on these, however */
#else
#define MACHINE_TYPE "hp9000s800"
#endif
-#define FASL_INTERNAL_FORMAT FASL_HP_SPECTRUM
+#define CURRENT_FASL_ARCH FASL_HP_SPECTRUM
+#define PC_ZERO_BITS 2
#define FLOATING_ALIGNMENT 0x7
/* Heap resides in data space, pointed at by space register 5.
#endif /* hp9000s800 */
#if defined(hp9000s300) || defined(__hp9000s300)
+
#if defined(hp9000s400) || defined(__hp9000s400)
-#define MACHINE_TYPE "hp9000s400"
+# define MACHINE_TYPE "hp9000s400"
#else
-#define MACHINE_TYPE "hp9000s300"
+# define MACHINE_TYPE "hp9000s300"
#endif
+
#ifdef MC68010
-#define FASL_INTERNAL_FORMAT FASL_68000
+# define CURRENT_FASL_ARCH FASL_68000
#else
-#define FASL_INTERNAL_FORMAT FASL_68020
+# define CURRENT_FASL_ARCH FASL_68020
#endif
-#define HEAP_IN_LOW_MEMORY
+
+#define PC_ZERO_BITS 1
+#define HEAP_IN_LOW_MEMORY 1
#endif /* hp9000s300 */
#ifdef hp9000s500
#define MACHINE_TYPE "hp9000s500"
-#define FASL_INTERNAL_FORMAT FASL_HP_9000_500
+#define CURRENT_FASL_ARCH FASL_HP_9000_500
/* An unfortunate fact of life on this machine:
the C heap is in high memory thus HEAP_IN_LOW_MEMORY is not
defined and the whole thing runs slowly. */
-/* C Compiler bug when constant folding and anchor pointing */
-#define And2(x, y) ((x) ? (y) : false)
-#define And3(x, y, z) ((x) ? ((y) ? (z) : false) : false)
-#define Or2(x, y) ((x) ? true : (y))
-#define Or3(x, y, z) ((x) ? true : ((y) ? true : (z)))
-
#endif /* hp9000s500 */
\f
#ifdef sparc
# define MACHINE_TYPE "sun4"
-# define FASL_INTERNAL_FORMAT FASL_SPARC
+# define CURRENT_FASL_ARCH FASL_SPARC
# define FLOATING_ALIGNMENT 0x7
# define HEAP_IN_LOW_MEMORY
# define HAVE_DOUBLE_TO_LONG_BUG
#ifdef sun3
# define MACHINE_TYPE "sun3"
-# define FASL_INTERNAL_FORMAT FASL_68020
+# define CURRENT_FASL_ARCH FASL_68020
# define HEAP_IN_LOW_MEMORY
# define HAVE_DOUBLE_TO_LONG_BUG
#endif
#ifdef sun2
# define MACHINE_TYPE "sun2"
-# define FASL_INTERNAL_FORMAT FASL_68000
+# define CURRENT_FASL_ARCH FASL_68000
# define HEAP_IN_LOW_MEMORY
# define HAVE_DOUBLE_TO_LONG_BUG
#endif
#ifdef NeXT
# define MACHINE_TYPE "next"
-# define FASL_INTERNAL_FORMAT FASL_68020
+# define CURRENT_FASL_ARCH FASL_68020
# define HEAP_IN_LOW_MEMORY
#endif
\f
#ifdef __IA32__
-#define FASL_INTERNAL_FORMAT FASL_IA32
-#define HEAP_IN_LOW_MEMORY
+#define CURRENT_FASL_ARCH FASL_IA32
+#define PC_ZERO_BITS 0
+#define HEAP_IN_LOW_MEMORY 1
#ifdef sequent
# define MACHINE_TYPE "sequent386"
# define MACHINE_TYPE "IA-32"
#endif
-#ifdef NATIVE_CODE_IS_C
-#undef HEAP_IN_LOW_MEMORY
-#endif
-
#endif /* __IA32__ */
\f
#ifdef mips
#define MACHINE_TYPE "mips"
-#define FASL_INTERNAL_FORMAT FASL_MIPS
+#define CURRENT_FASL_ARCH FASL_MIPS
+#define PC_ZERO_BITS 2
#define FLOATING_ALIGNMENT 0x7
-#if defined(_IRIX6) && defined(HAS_COMPILER_SUPPORT) && !defined(NATIVE_CODE_IS_C)
- extern void * irix_heap_malloc (long);
+#ifdef _IRIX6
+ extern void * irix_heap_malloc (unsigned long);
# define HEAP_MALLOC irix_heap_malloc
#endif
((SCHEME_OBJECT) (((unsigned long) (address)) & (~(MIPS_DATA_BIT))))
/* MIPS compiled binaries are large! */
-#ifdef HAS_COMPILER_SUPPORT
-
#ifndef DEFAULT_SMALL_CONSTANT
-#define DEFAULT_SMALL_CONSTANT 700
+# define DEFAULT_SMALL_CONSTANT 700
#endif
#ifndef DEFAULT_LARGE_CONSTANT
-#define DEFAULT_LARGE_CONSTANT 1500
+# define DEFAULT_LARGE_CONSTANT 1500
#endif
-#endif /* HAS_COMPILER_SUPPORT */
-
#endif /* mips */
\f
#ifdef __alpha
-#define MACHINE_TYPE "Alpha"
-#define FASL_INTERNAL_FORMAT FASL_ALPHA
-#define TYPE_CODE_LENGTH 8
-
-/* The ASCII character set is used. */
-#define HEAP_IN_LOW_MEMORY 1
+#define MACHINE_TYPE "Alpha"
+#define CURRENT_FASL_ARCH FASL_ALPHA
+#define PC_ZERO_BITS 2
+#define HEAP_IN_LOW_MEMORY 1
/* Flonums have no special alignment constraints. */
-#define FLONUM_MANTISSA_BITS 53
-#define FLONUM_EXPT_SIZE 10
-#define MAX_FLONUM_EXPONENT 1023
+#define FLONUM_MANTISSA_BITS 53
+#define FLONUM_EXPT_SIZE 10
+#define MAX_FLONUM_EXPONENT 1023
/* Floating point representation uses hidden bit. */
-#if defined(HAS_COMPILER_SUPPORT) && !defined(NATIVE_CODE_IS_C)
- extern void * alpha_heap_malloc (long);
-# define HEAP_MALLOC alpha_heap_malloc
-#endif
+extern void * alpha_heap_malloc (unsigned long);
+#define HEAP_MALLOC alpha_heap_malloc
#endif /* __alpha */
-
-#if defined(USE_MMAP_HEAP_MALLOC) && defined(HEAP_IN_LOW_MEMORY)
- extern void * mmap_heap_malloc (unsigned long);
-# define HEAP_MALLOC mmap_heap_malloc
-# define HEAP_FREE(address)
-#endif
\f
#ifdef __OS2__
extern int OS2_stack_overflowed_p (void);
#define STACK_OVERFLOWED_P OS2_stack_overflowed_p
+#define CC_ARCH_INITIALIZE i386_interface_initialize
+
#endif /* __OS2__ */
#ifdef __WIN32__
-extern void EXFUN (win32_stack_reset, (void));
+extern void win32_stack_reset (void);
#define STACK_RESET win32_stack_reset
#define HEAP_MALLOC(size) (WIN32_ALLOCATE_HEAP ((size), (&scheme_heap_handle)))
#ifdef pdp10
#define MACHINE_TYPE "pdp10"
-#define FASL_INTERNAL_FORMAT FASL_PDP10
+#define CURRENT_FASL_ARCH FASL_PDP10
#define HEAP_IN_LOW_MEMORY
#define CHAR_BIT 36 / * Ugh! Supposedly fixed in newer Cs * /
#define UNSIGNED_SHIFT_BUG
#ifdef nu
#define MACHINE_TYPE "nu"
-#define FASL_INTERNAL_FORMAT FASL_68000
+#define CURRENT_FASL_ARCH FASL_68000
#define HEAP_IN_LOW_MEMORY
#define UNSIGNED_SHIFT_BUG
#endif
#ifdef butterfly
#define MACHINE_TYPE "butterfly"
-#define FASL_INTERNAL_FORMAT FASL_BFLY
+#define CURRENT_FASL_ARCH FASL_BFLY
#define HEAP_IN_LOW_MEMORY
#include <public.h>
#endif
#ifdef cyber180
#define MACHINE_TYPE "cyber180"
-#define FASL_INTERNAL_FORMAT FASL_CYBER
+#define CURRENT_FASL_ARCH FASL_CYBER
#define HEAP_IN_LOW_MEMORY
#define UNSIGNED_SHIFT_BUG
/* The Cyber180 C compiler manifests a bug in hairy conditional expressions */
#ifdef celerity
#define MACHINE_TYPE "celerity"
-#define FASL_INTERNAL_FORMAT FASL_CELERITY
+#define CURRENT_FASL_ARCH FASL_CELERITY
#define HEAP_IN_LOW_MEMORY
#endif
#ifdef umax
#define MACHINE_TYPE "umax"
-#define FASL_INTERNAL_FORMAT FASL_UMAX
+#define CURRENT_FASL_ARCH FASL_UMAX
#define HEAP_IN_LOW_MEMORY
#endif
#ifdef pyr
#define MACHINE_TYPE "pyramid"
-#define FASL_INTERNAL_FORMAT FASL_PYR
+#define CURRENT_FASL_ARCH FASL_PYR
#define HEAP_IN_LOW_MEMORY
#endif
#ifdef alliant
#define MACHINE_TYPE "alliant"
-#define FASL_INTERNAL_FORMAT FASL_ALLIANT
+#define CURRENT_FASL_ARCH FASL_ALLIANT
#define HEAP_IN_LOW_MEMORY
#endif
#ifdef apollo
#if _ISP__M68K
#define MACHINE_TYPE "Apollo 68k"
-#define FASL_INTERNAL_FORMAT FASL_APOLLO_68K
+#define CURRENT_FASL_ARCH FASL_APOLLO_68K
#else
#define MACHINE_TYPE "Apollo Prism"
-#define FASL_INTERNAL_FORMAT FASL_APOLLO_PRISM
+#define CURRENT_FASL_ARCH FASL_APOLLO_PRISM
#endif
#define HEAP_IN_LOW_MEMORY
#endif
#ifdef _IBMR2
#define MACHINE_TYPE "IBM RS6000"
-#define FASL_INTERNAL_FORMAT FASL_RS6000
+#define CURRENT_FASL_ARCH FASL_RS6000
/* Heap is not in Low Memory. */
#define FLONUM_MANTISSA_BITS 53
#define FLONUM_EXPT_SIZE 10
#define MAX_FLONUM_EXPONENT 1023
#endif
-\f
+
#ifdef __ppc__
-#define MACHINE_TYPE "PowerPC-32"
-#define FASL_INTERNAL_FORMAT FASL_PPC32
-#define FLOATING_ALIGNMENT 0x7
+# define MACHINE_TYPE "PowerPC-32"
+# define CURRENT_FASL_ARCH FASL_PPC32
+# define FLOATING_ALIGNMENT 0x7
#endif
#ifdef __ppc64__
-#define MACHINE_TYPE "PowerPC-64"
-#define FASL_INTERNAL_FORMAT FASL_PPC64
+# define MACHINE_TYPE "PowerPC-64"
+# define CURRENT_FASL_ARCH FASL_PPC64
#endif
#ifdef __x86_64__
-#define MACHINE_TYPE "x86-64"
-#define FASL_INTERNAL_FORMAT FASL_X86_64
+# define MACHINE_TYPE "x86-64"
+# define CURRENT_FASL_ARCH FASL_X86_64
#endif
#ifdef __ia64__
-#define MACHINE_TYPE "ia64"
-#define FASL_INTERNAL_FORMAT FASL_IA64
+# define MACHINE_TYPE "ia64"
+# define CURRENT_FASL_ARCH FASL_IA64
#endif
\f
-#ifdef NATIVE_CODE_IS_C
-# ifndef HAS_COMPILER_SUPPORT
-# define HAS_COMPILER_SUPPORT
-# endif
+#ifdef sonyrisc
+ /* On the Sony NEWS 3250, this procedure initializes the
+ floating-point CPU control register to enable the IEEE traps.
+ This is normally executed by 'compiler_reset' from LOAD-BAND,
+ but the Sony operating system saves the control register in
+ 'setjmp' and restores it on 'longjmp', so we must initialize
+ the register before 'setjmp' is called. */
+#define CC_ARCH_INITIALIZE interface_initialize
#endif
/* Make sure that some definition applies. If this error occurs, and
# include "Error: confshared.h: Unknown configuration."
#endif
+#ifndef PC_ZERO_BITS
+# ifdef CC_IS_NATIVE
+# include "Error: confshared.h: Unknown PC alignment."
+# else
+# define PC_ZERO_BITS 0
+# endif
+#endif
+
+#define PC_ALIGNED_P(pc) \
+ ((((unsigned long) (pc)) & ((1 << PC_ZERO_BITS) - 1)) == 0)
+
/* Virtually all machines have 8-bit characters these days, so don't
explicitly specify this value unless it is different. */
#ifndef CHAR_BIT
# define CHAR_BIT 8
#endif
-#ifndef TYPE_CODE_LENGTH
-# define TYPE_CODE_LENGTH 6
-#endif
-
/* The GNU C compiler does not have any of these bugs. */
#ifdef __GNUC__
# undef HAVE_DOUBLE_TO_LONG_BUG
# undef Conditional_Bug
#endif
+#ifdef NO_HEAP_IN_LOW_MEMORY
+# undef HEAP_IN_LOW_MEMORY
+#endif
+
+#if defined(USE_MMAP_HEAP_MALLOC) && defined(HEAP_IN_LOW_MEMORY)
+ extern void * mmap_heap_malloc (unsigned long);
+# define HEAP_MALLOC mmap_heap_malloc
+# define HEAP_FREE(address)
+#endif
+
#endif /* SCM_CONFSHARED_H */
/* -*-C-*-
-$Id: const.h,v 9.55 2007/01/05 21:19:25 cph Exp $
+$Id: const.h,v 9.56 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Named constants used throughout the interpreter */
\f
-#if (CHAR_BIT != 8)
-#define MAX_CHAR ((1<<CHAR_BIT)-1)
-#else
-#define MAX_CHAR 0xFF
-#endif
+#define PI 3.1415926535
-#define PI 3.1415926535
-#define STACK_FRAME_HEADER 1
-
-/* Assigned TC_CONSTANT datum values:
- 0 #t
- 1 unspecific
- 2 [non-object]
- 3 #!optional
- 4 #!rest
- 5 #!key
- 6 #!eof
- 7 #!default
- 8 #!aux
- 9 '()
- */
-
-#define SHARP_F MAKE_OBJECT (TC_NULL, 0)
-#define SHARP_T MAKE_OBJECT (TC_CONSTANT, 0)
-#define UNSPECIFIC MAKE_OBJECT (TC_CONSTANT, 1)
-#define DEFAULT_OBJECT MAKE_OBJECT (TC_CONSTANT, 7)
-#define EMPTY_LIST MAKE_OBJECT (TC_CONSTANT, 9)
-#define FIXNUM_ZERO MAKE_OBJECT (TC_FIXNUM, 0)
-#define BROKEN_HEART_ZERO MAKE_OBJECT (TC_BROKEN_HEART, 0)
-
-#define EMPTY_LIST_P(object) ((object) == EMPTY_LIST)
-\f
/* Assorted sizes used in various places */
+/* Maximum # of chars in a file name. */
#ifdef MAXPATHLEN
-#define FILE_NAME_LENGTH MAXPATHLEN
+# define FILE_NAME_LENGTH MAXPATHLEN
#else
-#define FILE_NAME_LENGTH 1024 /* Max. chars. in a file name */
+# define FILE_NAME_LENGTH 1024
#endif
-#define OBARRAY_SIZE 32771 /* Interning hash table */
+/* Interning hash table */
+#define OBARRAY_SIZE 32771
+/* Cells between constant and stack before overflow occurs. */
#ifndef STACK_GUARD_SIZE
-#define STACK_GUARD_SIZE 4096 /* Cells between constant and
- stack before overflow
- occurs */
+# define STACK_GUARD_SIZE 4096
#endif
/* Some versions of stdio define this. */
#ifndef _NFILE
-#define _NFILE 15
+# define _NFILE 15
#endif
-#define FILE_CHANNELS _NFILE
+#define FILE_CHANNELS _NFILE
-#define MAX_LIST_PRINT 10
+#define MAX_LIST_PRINT 10
-#define ILLEGAL_PRIMITIVE -1
+#define ILLEGAL_PRIMITIVE -1
-/* Last immediate reference trap. */
-
-#define TRAP_MAX_IMMEDIATE 9
-
-/* For headers in pure / constant area */
-
-#define END_OF_BLOCK TC_FIXNUM
-#define CONSTANT_PART TC_CONSTANT
-#define PURE_PART TC_FALSE
-\f
-/* Primitive flow control codes: directs computation after
- * processing a primitive application.
- */
+/* Primitive flow control codes: directs computation after processing
+ a primitive application. */
#define PRIM_DONE -1
#define PRIM_DO_EXPRESSION -2
#define PRIM_POP_RETURN -7
#define PRIM_TOUCH -8
#define PRIM_APPLY_INTERRUPT -9
-#define PRIM_REENTER -10
+/* #define PRIM_REENTER -10 */
#define PRIM_NO_TRAP_POP_RETURN -11
#define ABORT_NAME_TABLE \
#define LEXPR_PRIMITIVE_ARITY -1
#define UNKNOWN_PRIMITIVE_ARITY -2
-\f
+
/* Error case detection for precomputed constants */
/* VMS preprocessor does not like line continuations in conditionals */
#define REGBLOCK_INT_MASK 1
#define REGBLOCK_VAL 2
#define REGBLOCK_ENV 3
-#define REGBLOCK_COMPILER_TEMP 4 /* For use by compiler */
+#define REGBLOCK_CC_TEMP 4 /* For use by compiler */
#define REGBLOCK_EXPR 5
#define REGBLOCK_RETURN 6
#define REGBLOCK_LEXPR_ACTUALS 7
#define REGBLOCK_REFLECT_TO_INTERFACE 13 /* For use by compiler */
#define REGBLOCK_MINIMUM_LENGTH 14
-\f
-/* Codes specifying how to start scheme at boot time. */
-
-#define BOOT_FASLOAD 0
-#define BOOT_LOAD_BAND 1
-#define BOOT_GET_WORK 2
-#define BOOT_EXECUTE 3
/* -*-C-*-
-$Id: copyrigh.c,v 1.7 2007/01/05 21:19:25 cph Exp $
+$Id: copyrigh.c,v 1.8 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
USA.
*/
-
-
-
/* -*-C-*-
-$Id: critsec.h,v 1.8 2007/01/05 21:19:25 cph Exp $
+$Id: critsec.h,v 1.9 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
There should be a stack of critical sections, each with a
queue of hooks. */
-extern char * critical_section_name;
-extern int critical_section_hook_p;
-extern void EXFUN ((*critical_section_hook), (char *));
+#ifndef SCM_CRITSEC_H
+#define SCM_CRITSEC_H 1
+
+extern const char * critical_section_name;
+extern bool critical_section_hook_p;
+extern void (*critical_section_hook) (const char *);
#define DECLARE_CRITICAL_SECTION() \
- char * critical_section_name = 0; \
- int critical_section_hook_p; \
- void (*critical_section_hook) ()
+ const char * critical_section_name = 0; \
+ bool critical_section_hook_p; \
+ void (*critical_section_hook) (const char *)
#define ENTER_CRITICAL_SECTION(name) critical_section_name = (name)
#define RENAME_CRITICAL_SECTION(name) critical_section_name = (name)
-#define EXIT_CRITICAL_SECTION(code_if_hook) \
+#define EXIT_CRITICAL_SECTION(code_if_hook) do \
{ \
if (critical_section_hook_p) \
{ \
code_if_hook; \
{ \
- char * name = critical_section_name; \
- critical_section_hook_p = 0; \
+ const char * name = critical_section_name; \
+ critical_section_hook_p = false; \
critical_section_name = 0; \
(*critical_section_hook) (name); \
} \
} \
else \
critical_section_name = 0; \
-}
+} while (0);
-#define SET_CRITICAL_SECTION_HOOK(hook) \
+#define SET_CRITICAL_SECTION_HOOK(hook) do \
{ \
critical_section_hook = (hook); \
- critical_section_hook_p = 1; \
-}
+ critical_section_hook_p = true; \
+} while (0)
-#define CLEAR_CRITICAL_SECTION_HOOK() critical_section_hook_p = 0
+#define CLEAR_CRITICAL_SECTION_HOOK() critical_section_hook_p = false
#define WITHIN_CRITICAL_SECTION_P() (critical_section_name != 0)
#define CRITICAL_SECTION_NAME() (critical_section_name)
+
+#endif /* not SCM_CRITSEC_H */
/* -*-C-*-
-$Id: daemon.c,v 9.36 2007/01/05 21:19:25 cph Exp $
+$Id: daemon.c,v 9.37 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
SCHEME_OBJECT cell = (*smash);
while (!EMPTY_LIST_P (cell))
{
- SCHEME_OBJECT weak_cell = (FAST_PAIR_CAR (cell));
- if ((FAST_PAIR_CAR (weak_cell)) == SHARP_F)
+ SCHEME_OBJECT weak_cell = (PAIR_CAR (cell));
+ if ((PAIR_CAR (weak_cell)) == SHARP_F)
{
OS_channel_close_noerror
- (UNSIGNED_FIXNUM_TO_LONG (FAST_PAIR_CDR (weak_cell)));
- cell = (FAST_PAIR_CDR (cell));
+ (UNSIGNED_FIXNUM_TO_LONG (PAIR_CDR (weak_cell)));
+ cell = (PAIR_CDR (cell));
(*smash) = cell;
}
else
Therefore, there is no gc check here. */
static void
-DEFUN (rehash_pair, (pair, hash_table, table_size),
- SCHEME_OBJECT pair AND SCHEME_OBJECT hash_table
- AND long table_size)
+rehash_pair (SCHEME_OBJECT pair, SCHEME_OBJECT hash_table,
+ long table_size)
{
long object_datum, hash_address;
SCHEME_OBJECT * new_pair;
- object_datum = (OBJECT_DATUM (FAST_PAIR_CAR (pair)));
+ object_datum = (OBJECT_DATUM (PAIR_CAR (pair)));
hash_address = (2 + (object_datum % table_size));
new_pair = Free;
*Free++ = (OBJECT_NEW_TYPE (TC_LIST, pair));
- *Free++ = (FAST_MEMORY_REF (hash_table, hash_address));
- FAST_MEMORY_SET (hash_table,
+ *Free++ = (MEMORY_REF (hash_table, hash_address));
+ MEMORY_SET (hash_table,
hash_address,
(MAKE_POINTER_OBJECT (TC_LIST, new_pair)));
}
static void
-DEFUN (rehash_bucket, (bucket, hash_table, table_size),
- SCHEME_OBJECT * bucket AND SCHEME_OBJECT hash_table
- AND long table_size)
+rehash_bucket (SCHEME_OBJECT * bucket, SCHEME_OBJECT hash_table,
+ long table_size)
{
- fast SCHEME_OBJECT weak_pair;
+ SCHEME_OBJECT weak_pair;
while (!EMPTY_LIST_P (*bucket))
{
- weak_pair = (FAST_PAIR_CAR (*bucket));
- if ((FAST_PAIR_CAR (weak_pair)) != SHARP_F)
+ weak_pair = (PAIR_CAR (*bucket));
+ if ((PAIR_CAR (weak_pair)) != SHARP_F)
{
rehash_pair (weak_pair, hash_table, table_size);
}
}
static void
-DEFUN (splice_and_rehash_bucket, (bucket, hash_table, table_size),
- SCHEME_OBJECT * bucket AND SCHEME_OBJECT hash_table
- AND long table_size)
+splice_and_rehash_bucket (SCHEME_OBJECT * bucket, SCHEME_OBJECT hash_table,
+ long table_size)
{
- fast SCHEME_OBJECT weak_pair;
+ SCHEME_OBJECT weak_pair;
while (!EMPTY_LIST_P (*bucket))
{
- weak_pair = (FAST_PAIR_CAR (*bucket));
- if ((FAST_PAIR_CAR (weak_pair)) != SHARP_F)
+ weak_pair = (PAIR_CAR (*bucket));
+ if ((PAIR_CAR (weak_pair)) != SHARP_F)
{
rehash_pair (weak_pair, hash_table, table_size);
bucket = (PAIR_CDR_LOC (*bucket));
}
else
- *bucket = (FAST_PAIR_CDR (*bucket));
+ *bucket = (PAIR_CDR (*bucket));
}
}
\f
bucket = (MEMORY_LOC ((ARG_REF (1)), 1));
while ((counter--) > 0)
{
- if ((FAST_PAIR_CAR (*bucket)) == SHARP_T)
+ if ((PAIR_CAR (*bucket)) == SHARP_T)
splice_and_rehash_bucket
((PAIR_CDR_LOC (*bucket)), (ARG_REF (2)), table_size);
else
/* -*-C-*-
-$Id: debug.c,v 9.60 2007/01/05 21:19:25 cph Exp $
+$Id: debug.c,v 9.61 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "trap.h"
#include "lookup.h"
-static void EXFUN (do_printing, (outf_channel, SCHEME_OBJECT, Boolean));
-static Boolean EXFUN (print_primitive_name, (outf_channel, SCHEME_OBJECT));
-static void EXFUN (print_expression, (outf_channel, SCHEME_OBJECT, char *));
+#ifdef CC_SUPPORT_P
+ static SCHEME_OBJECT compiled_entry_debug_filename (SCHEME_OBJECT);
+ static SCHEME_OBJECT compiled_block_debug_filename (SCHEME_OBJECT);
+#endif
+
+static void do_printing (outf_channel, SCHEME_OBJECT, bool);
+static bool print_primitive_name (outf_channel, SCHEME_OBJECT);
+static void print_expression (outf_channel, SCHEME_OBJECT, char *);
\f
/* Compiled Code Debugging */
+#ifdef CC_SUPPORT_P
+
+char *
+compiled_entry_filename (SCHEME_OBJECT entry)
+{
+ SCHEME_OBJECT result = (compiled_entry_debug_filename (entry));
+ return
+ ((STRING_P (result))
+ ? (STRING_POINTER (result))
+ : (PAIR_P (result))
+ ? (STRING_POINTER (PAIR_CAR (result)))
+ : "**** filename not known ****");
+}
+
static SCHEME_OBJECT
-DEFUN (compiled_block_debug_filename, (block), SCHEME_OBJECT block)
+compiled_entry_debug_filename (SCHEME_OBJECT entry)
+{
+ return
+ (compiled_block_debug_filename
+ (cc_entry_to_block ((cc_entry_closure_p (entry))
+ ? (cc_closure_to_entry (entry))
+ : entry)));
+}
+
+static SCHEME_OBJECT
+compiled_block_debug_filename (SCHEME_OBJECT block)
{
- extern SCHEME_OBJECT EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT));
SCHEME_OBJECT info;
- info = (compiled_block_debugging_info (block));
+ info = (cc_block_debugging_info (block));
return
(((STRING_P (info)) ||
((PAIR_P (info)) &&
: SHARP_F);
}
-extern void
- EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));
-
-extern long
- EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT)),
- EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT));
-
-extern SCHEME_OBJECT
- * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT)),
- EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT));
-
-#define COMPILED_ENTRY_TO_BLOCK(entry) \
-(MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, \
- (compiled_entry_to_block_address (entry))))
-
-static SCHEME_OBJECT
-DEFUN (compiled_entry_debug_filename, (entry), SCHEME_OBJECT entry)
-{
- long results [3];
-
- compiled_entry_type (entry, (& (results [0])));
- if (((results [0]) == 0) && (compiled_entry_closure_p (entry)))
- entry = (compiled_closure_to_entry (entry));
- return (compiled_block_debug_filename (COMPILED_ENTRY_TO_BLOCK (entry)));
-}
-
-char *
-DEFUN (compiled_entry_filename, (entry), SCHEME_OBJECT entry)
-{
- SCHEME_OBJECT result;
-
- result = (compiled_entry_debug_filename (entry));
- if (STRING_P (result))
- return ((char *) (STRING_LOC ((result), 0)));
- else if (PAIR_P (result))
- return ((char *) (STRING_LOC ((PAIR_CAR (result)), 0)));
- else
- return ("**** filename not known ****");
-}
+#endif /* CC_SUPPORT_P */
\f
void
-DEFUN_VOID (Show_Pure)
-{
- SCHEME_OBJECT *Obj_Address;
- long Pure_Size, Total_Size;
-
- Obj_Address = Constant_Space;
- while (true)
- {
- if (Obj_Address > Free_Constant)
- {
- outf_console ("Past end of area.\n");
- return;
- }
- if (Obj_Address == Free_Constant)
- {
- outf_console ("Done.\n");
- return;
- }
- Pure_Size = OBJECT_DATUM (*Obj_Address);
- Total_Size = OBJECT_DATUM (Obj_Address[1]);
- outf_console ("0x%lx: pure=0x%lx, total=0x%lx\n",
- ((long) Obj_Address), ((long) Pure_Size), ((long) Total_Size));
- if (OBJECT_TYPE (*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR)
- {
- outf_console ("Missing initial SNMV.\n");
- return;
- }
- if (OBJECT_TYPE (Obj_Address[1]) != PURE_PART)
- {
- outf_console ("Missing subsequent pure header.\n");
- }
- if (OBJECT_TYPE (Obj_Address[Pure_Size-1]) !=
- TC_MANIFEST_SPECIAL_NM_VECTOR)
- {
- outf_console ("Missing internal SNMV.\n");
- return;
- }
- if (OBJECT_TYPE (Obj_Address[Pure_Size]) != CONSTANT_PART)
- {
- outf_console ("Missing constant header.\n");
- return;
- }
- if (((long) (OBJECT_DATUM (Obj_Address[Pure_Size]))) != Pure_Size)
- {
- outf_console ("Pure size mismatch 0x%lx.\n",
- ((long) (OBJECT_DATUM (Obj_Address[Pure_Size]))));
- }
- if (OBJECT_TYPE (Obj_Address[Total_Size-1]) !=
- TC_MANIFEST_SPECIAL_NM_VECTOR)
- {
- outf_console ("Missing ending SNMV.\n");
- return;
- }
- if (OBJECT_TYPE (Obj_Address[Total_Size]) != END_OF_BLOCK)
- {
- outf_console ("Missing ending header.\n");
- return;
- }
- if (((long) (OBJECT_DATUM (Obj_Address[Total_Size]))) != Total_Size)
- {
- outf_console ("Total size mismatch 0x%lx.\n",
- ((long) (OBJECT_DATUM (Obj_Address[Total_Size]))));
- }
- Obj_Address += Total_Size+1;
-#ifdef FLOATING_ALIGNMENT
- while (*Obj_Address == MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))
- {
- Obj_Address += 1;
- }
-#endif
- }
-}
-\f
-void
-DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env)
+Show_Env (SCHEME_OBJECT The_Env)
{
SCHEME_OBJECT *name_ptr, procedure, *value_ptr, extension;
long count, i;
if (FRAME_EXTENSION_P (procedure))
{
extension = procedure;
- procedure = FAST_MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE);
+ procedure = MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE);
}
else
extension = SHARP_F;
if ((OBJECT_TYPE (procedure) != TC_PROCEDURE) &&
(OBJECT_TYPE (procedure) != TC_EXTENDED_PROCEDURE))
{
- outf_console ("Not created by a procedure");
+ outf_error ("Not created by a procedure");
return;
}
name_ptr = MEMORY_LOC (procedure, PROCEDURE_LAMBDA_EXPR);
{
Print_Expression (*name_ptr++, "Name ");
Print_Expression (*value_ptr++, " Value ");
- outf_console ("\n");
+ outf_error ("\n");
}
if (extension != SHARP_F)
{
- outf_console ("Auxiliary Variables\n");
+ outf_error ("Auxiliary Variables\n");
count = (GET_FRAME_EXTENSION_LENGTH (extension));
for (i = 0, name_ptr = (GET_FRAME_EXTENSION_BINDINGS (extension));
i < count;
{
Print_Expression ((PAIR_CAR (*name_ptr)), "Name ");
Print_Expression ((PAIR_CDR (*name_ptr)), " Value ");
- outf_console ("\n");
+ outf_error ("\n");
}
}
}
\f
static void
-DEFUN (print_list, (stream, pair), outf_channel stream AND SCHEME_OBJECT pair)
+print_list (outf_channel stream, SCHEME_OBJECT pair)
{
int count;
}
}
outf (stream, ")");
- return;
}
static void
-DEFUN (print_return_name, (stream, Ptr), outf_channel stream AND SCHEME_OBJECT Ptr)
+print_return_name (outf_channel stream, SCHEME_OBJECT Ptr)
{
- long index;
- char * name;
-
- index = (OBJECT_DATUM (Ptr));
+ unsigned long index = (OBJECT_DATUM (Ptr));
if (index <= MAX_RETURN)
{
- name = (Return_Names [index]);
- if ((name != ((char *) 0)) &&
- ((name [0]) != '\0'))
+ const char * name = (Return_Names[index]);
+ if ((name != 0) && ((name[0]) != '\0'))
{
outf (stream, "%s", name);
return;
}
}
outf (stream, "[0x%lx]", index);
- return;
}
void
-DEFUN (Print_Return, (String), char * String)
+Print_Return (char * String)
{
- outf_console ("%s: ", String);
- print_return_name (console_output, ret_register);
- outf_console ("\n");
+ outf_error ("%s: ", String);
+ print_return_name (ERROR_OUTPUT, GET_RET);
+ outf_error ("\n");
}
\f
static void
-DEFUN (print_string, (stream, string), outf_channel stream AND SCHEME_OBJECT string)
+print_string (outf_channel stream, SCHEME_OBJECT string)
{
long length;
long i;
outf (stream, "\"");
length = (STRING_LENGTH (string));
- next = ((char *) (STRING_LOC (string, 0)));
+ next = (STRING_POINTER (string));
for (i = 0; (i < length); i += 1)
{
this = (*next++);
}
}
outf (stream, "\"");
- return;
}
static void
-DEFUN (print_symbol, (stream, symbol), outf_channel stream AND SCHEME_OBJECT symbol)
+print_symbol (outf_channel stream, SCHEME_OBJECT symbol)
{
SCHEME_OBJECT string;
- long length;
- long i;
+ unsigned long length;
+ unsigned long limit;
+ unsigned long i;
char * next;
string = (MEMORY_REF (symbol, SYMBOL_NAME));
length = (STRING_LENGTH (string));
- next = ((char *) (STRING_LOC (string, 0)));
- for (i = 0; (i < length); i += 1)
- outf(stream, "%c", *next++); /*should use %s? */
- return;
+ limit = ((length > 64) ? 64 : length);
+ next = (STRING_POINTER (string));
+ for (i = 0; (i < limit); i += 1)
+ {
+ int c = (*next++);
+ if (c < 0x80)
+ outf (stream, "%c", c);
+ else
+ outf (stream, "\\x%02x", c);
+ }
+ if (limit < length)
+ outf (stream, "...");
}
\f
+#ifdef CC_SUPPORT_P
static void
-DEFUN (print_filename, (stream, filename),
- outf_channel stream AND SCHEME_OBJECT filename)
+print_filename (outf_channel stream, SCHEME_OBJECT filename)
{
long length;
char * scan;
char * slash;
length = (STRING_LENGTH (filename));
- scan = ((char *) (STRING_LOC (filename, 0)));
+ scan = (STRING_POINTER (filename));
end = (scan + length);
slash = scan;
while (scan < end)
if ((*scan++) == '/')
slash = scan;
outf (stream, "\"%s\"", slash);
- return;
}
+#endif
static void
-DEFUN (print_object, (object), SCHEME_OBJECT object)
+print_object (SCHEME_OBJECT object)
{
- do_printing (console_output, object, true);
- outf_console ("\n");
- outf_flush_console();
- return;
+ do_printing (ERROR_OUTPUT, object, true);
+ outf_error ("\n");
+ outf_flush_error();
}
DEFINE_PRIMITIVE ("DEBUGGING-PRINTER", Prim_debugging_printer, 1, 1,
}
static void
-DEFUN (print_objects, (objects, n),
- SCHEME_OBJECT * objects AND int n)
+print_objects (SCHEME_OBJECT * objects, int n)
{
SCHEME_OBJECT * scan;
SCHEME_OBJECT * end;
end = (objects + n);
while (scan < end)
{
- outf_console ("%4x: ", (((char *) scan) - ((char *) objects)));
- do_printing (console_output, (*scan++), true);
- outf_console ("\n");
+ outf_error ("%4x: ", (((char *) scan) - ((char *) objects)));
+ do_printing (ERROR_OUTPUT, (*scan++), true);
+ outf_error ("\n");
}
- outf_flush_console();
- return;
+ outf_flush_error();
}
/* This is useful because `do_printing' doesn't print the contents of
be printed out explicitly. */
void
-DEFUN (Print_Vector, (vector), SCHEME_OBJECT vector)
+Print_Vector (SCHEME_OBJECT vector)
{
print_objects
((MEMORY_LOC (vector, 1)), (OBJECT_DATUM (VECTOR_LENGTH (vector))));
}
\f
static void
-DEFUN (print_expression, (stream, expression, string),
- outf_channel stream AND SCHEME_OBJECT expression AND char * string)
+print_expression (outf_channel stream, SCHEME_OBJECT expression, char * string)
{
if ((string [0]) != 0)
outf (stream, "%s: ", string);
do_printing (stream, expression, true);
- return;
}
void
-DEFUN (Print_Expression, (expression, string),
- SCHEME_OBJECT expression AND char * string)
+Print_Expression (SCHEME_OBJECT expression, char * string)
{
- print_expression (console_output, expression, string);
- return;
+ print_expression (ERROR_OUTPUT, expression, string);
}
-extern char * Type_Names [];
-
static void
-DEFUN (do_printing, (stream, Expr, Detailed),
- outf_channel stream AND SCHEME_OBJECT Expr AND Boolean Detailed)
+do_printing (outf_channel stream, SCHEME_OBJECT Expr, bool Detailed)
{
- long Temp_Address;
- Boolean handled_p;
-
- Temp_Address = (OBJECT_DATUM (Expr));
- handled_p = false;
+ long Temp_Address = (OBJECT_DATUM (Expr));
+ bool handled_p = false;
if (EMPTY_LIST_P (Expr)) { outf (stream, "()"); return; }
else if (Expr == SHARP_F) { outf (stream, "#F"); return; }
else if (Expr == SHARP_T) { outf (stream, "#T"); return; }
else if (Expr == UNSPECIFIC) { outf (stream, "[UNSPECIFIC]"); return; }
+ else if (Expr == return_to_interpreter)
+ {
+ outf (stream, "[RETURN_TO_INTERPRETER]");
+ return;
+ }
+
+ else if (Expr == reflect_to_interface)
+ {
+ outf (stream, "[REFLECT_TO_INTERFACE]");
+ return;
+ }
+
+
switch (OBJECT_TYPE (Expr))
{
case TC_ACCESS:
Expr = (MEMORY_REF (Expr, DEFINE_NAME));
goto SPrint;
- case_TC_FIXNUMs:
+ case TC_FIXNUM:
outf (stream, "%ld", ((long) (FIXNUM_TO_LONG (Expr))));
return;
case TC_CONSTANT:
break;
+#ifdef CC_SUPPORT_P
case TC_COMPILED_ENTRY:
{
- long results [3];
- char * type_string;
+ SCHEME_OBJECT entry = Expr;
+ bool closure_p = false;
+ cc_entry_type_t cet;
+ const char * type_string;
SCHEME_OBJECT filename;
- SCHEME_OBJECT entry;
- Boolean closure_p;
-
- entry = Expr;
- closure_p = false;
- compiled_entry_type (entry, (& (results [0])));
- switch (results [0])
- {
- case 0:
- if (compiled_entry_closure_p (entry))
- {
- type_string = "COMPILED_CLOSURE";
- entry = (compiled_closure_to_entry (entry));
- closure_p = true;
- }
- else
- type_string = "COMPILED_PROCEDURE";
- break;
- case 1:
- type_string = "COMPILED_RETURN_ADDRESS";
- break;
- case 2:
- type_string = "COMPILED_EXPRESSION";
- break;
- default:
- type_string = "COMPILED_ENTRY";
- break;
- }
- outf (stream, "[%s offset: 0x%lx entry: 0x%lx",
- type_string,
- ((long) (compiled_entry_to_block_offset (entry))),
- ((long) (OBJECT_DATUM (entry))));
+ if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (entry))))
+ type_string = "UNKNOWN";
+ else
+ switch (cet.marker)
+ {
+ case CET_PROCEDURE:
+ case CET_CLOSURE:
+ if (cc_entry_closure_p (entry))
+ {
+ type_string = "COMPILED_CLOSURE";
+ entry = (cc_closure_to_entry (entry));
+ closure_p = true;
+ }
+ else
+ type_string = "COMPILED_PROCEDURE";
+ break;
+
+ case CET_CONTINUATION:
+ type_string = "COMPILED_RETURN_ADDRESS";
+ break;
+
+ case CET_EXPRESSION:
+ type_string = "COMPILED_EXPRESSION";
+ break;
+
+ case CET_INTERNAL_CONTINUATION:
+ type_string = "COMPILED_RETURN_ADDRESS";
+ break;
+
+ case CET_INTERNAL_PROCEDURE:
+ case CET_TRAMPOLINE:
+ type_string = "COMPILED_ENTRY";
+ break;
+
+ case CET_RETURN_TO_INTERPRETER:
+ type_string = "COMPILED_RETURN_ADDRESS";
+ break;
+
+ default:
+ type_string = "COMPILED_ENTRY";
+ break;
+ }
+
+ outf (stream, "[%s offset: %#lx entry: %#lx",
+ type_string,
+ (cc_entry_to_block_offset (entry)),
+ (OBJECT_DATUM (entry)));
if (closure_p)
outf (stream, " address: 0x%lx", ((long) Temp_Address));
outf (stream, "]");
return;
}
+#endif
default:
break;
}
- if (! handled_p)
+ if (!handled_p)
{
- if ((OBJECT_TYPE (Expr)) <= LAST_TYPE_CODE)
- outf (stream, "[%s", (Type_Names [OBJECT_TYPE (Expr)]));
+ unsigned int type = (OBJECT_TYPE (Expr));
+ const char * name = 0;
+ if ((OBJECT_TYPE (Expr)) < TYPE_CODE_LIMIT)
+ name = (type_names[type]);
+ if (name != 0)
+ outf (stream, "[%s", name);
else
- outf (stream, "[0x%02x", (OBJECT_TYPE (Expr)));
+ outf (stream, "[%#02x", type);
}
- outf (stream, " 0x%lx]", ((long) Temp_Address));
- return;
+ outf (stream, " %#lx]", ((unsigned long) Temp_Address));
}
extern void
-DEFUN (Debug_Print, (Expr, Detailed),
- SCHEME_OBJECT Expr AND Boolean Detailed)
+Debug_Print (SCHEME_OBJECT Expr, bool Detailed)
{
- do_printing(console_output, Expr, Detailed);
- outf_flush_console ();
- return;
+ do_printing (ERROR_OUTPUT, Expr, Detailed);
+ outf_error ("\n");
+ outf_flush_error ();
}
\f
-static Boolean
-DEFUN (print_one_continuation_frame, (stream, Temp),
- outf_channel stream AND SCHEME_OBJECT Temp)
+static bool
+print_one_continuation_frame (outf_channel stream, SCHEME_OBJECT Temp)
{
SCHEME_OBJECT Expr;
+ outf (stream, "\n ");
print_expression (stream, Temp, "Return code");
- outf (stream, "\n");
+ outf (stream, "\n ");
Expr = (STACK_POP ());
print_expression (stream, Expr, "Expression");
outf (stream, "\n");
- if (((OBJECT_DATUM (Temp)) == RC_END_OF_COMPUTATION) ||
- ((OBJECT_DATUM (Temp)) == RC_HALT))
+ if (((OBJECT_DATUM (Temp)) == RC_END_OF_COMPUTATION)
+ || ((OBJECT_DATUM (Temp)) == RC_HALT))
return (true);
if ((OBJECT_DATUM (Temp)) == RC_JOIN_STACKLETS)
- sp_register = (Previous_Stack_Pointer (Expr));
+ stack_pointer = (control_point_start (Expr));
return (false);
}
-extern Boolean EXFUN (Print_One_Continuation_Frame, (SCHEME_OBJECT));
+extern bool Print_One_Continuation_Frame (SCHEME_OBJECT);
-Boolean
-DEFUN (Print_One_Continuation_Frame, (Temp), SCHEME_OBJECT Temp)
+bool
+Print_One_Continuation_Frame (SCHEME_OBJECT Temp)
{
- return (print_one_continuation_frame (console_output, Temp));
+ return (print_one_continuation_frame (ERROR_OUTPUT, Temp));
}
\f
-/* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the
- stack; (b) Save_Cont pushes the expression first.
- */
+/* Back_Trace relies on (a) only a call to SAVE_CONT puts a return code on the
+ stack; (b) SAVE_CONT pushes the expression first. */
void
-DEFUN (Back_Trace, (stream), outf_channel stream)
+Back_Trace (outf_channel stream)
{
SCHEME_OBJECT Temp, * Old_Stack;
- Back_Trace_Entry_Hook();
- Old_Stack = sp_register;
+ Old_Stack = stack_pointer;
while (true)
- {
- if ((STACK_LOCATIVE_DIFFERENCE (Stack_Top, (STACK_LOC (0)))) <= 0)
- {
- if ((STACK_LOC (0)) == Old_Stack)
- outf (stream, "\n[Invalid stack pointer.]\n");
- else
- outf (stream, "\n[Stack ends abruptly.]\n");
- break;
- }
- if (Return_Hook_Address == (STACK_LOC (0)))
{
+#if 0
+ /* Not useful since this code prints the contents of control
+ points as well. */
+ if (!ADDRESS_IN_STACK_P (stack_pointer))
+ {
+ if (stack_pointer == Old_Stack)
+ outf (stream, "\n[Invalid stack pointer.]\n");
+ else
+ outf (stream, "\n[Stack ends abruptly.]\n");
+ break;
+ }
+#endif
Temp = (STACK_POP ());
- if (Temp != (MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT)))
- {
- outf (stream, "\n--> Return trap is missing here <--\n");
- }
+ outf (stream, "{%#lx}", ((unsigned long) stack_pointer));
+ if (RETURN_CODE_P (Temp))
+ {
+ if (print_one_continuation_frame (stream, Temp))
+ break;
+ }
else
- {
- outf (stream, "\n[Return trap found here as expected]\n");
- Temp = Old_Return_Code;
- }
- }
- else
- {
- Temp = (STACK_POP ());
- }
- if ((OBJECT_TYPE (Temp)) == TC_RETURN_CODE)
- {
- outf (stream, "{0x%x}", STACK_LOC(0));
- if (print_one_continuation_frame (stream, Temp))
- break;
- }
- else
- {
- outf (stream, "{0x%x}", STACK_LOC(0));
- print_expression (stream, Temp, " ...");
- if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR)
- {
- sp_register = (STACK_LOC (- ((long) (OBJECT_DATUM (Temp)))));
- outf (stream, " (skipping)");
- }
- outf (stream, "\n");
+ {
+ print_expression (stream, Temp, " ...");
+ if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR)
+ {
+ outf (stream, " (skipping)");
+ stack_pointer = (STACK_LOC (OBJECT_DATUM (Temp)));
+ }
+ outf (stream, "\n");
+ }
}
- }
- sp_register = Old_Stack;
- Back_Trace_Exit_Hook();
+ stack_pointer = Old_Stack;
outf_flush (stream);
}
void
-DEFUN (print_stack, (sp), SCHEME_OBJECT * sp)
+print_stack (SCHEME_OBJECT * sp)
{
- SCHEME_OBJECT * saved_sp = sp_register;
- sp_register = sp;
- Back_Trace (console_output);
- sp_register = saved_sp;
+ SCHEME_OBJECT * saved_sp = stack_pointer;
+ stack_pointer = sp;
+ Back_Trace (ERROR_OUTPUT);
+ stack_pointer = saved_sp;
}
extern void
-DEFUN_VOID(Debug_Stack_Trace)
+Debug_Stack_Trace(void)
{
print_stack(STACK_LOC(0));
}
\f
-static Boolean
-DEFUN (print_primitive_name, (stream, primitive),
- outf_channel stream AND SCHEME_OBJECT primitive)
+static bool
+print_primitive_name (outf_channel stream, SCHEME_OBJECT primitive)
{
- CONST char * name = (PRIMITIVE_NAME (primitive));
+ const char * name = (PRIMITIVE_NAME (primitive));
if (name == 0)
{
- outf (stream, "Unknown primitive 0x%08x", PRIMITIVE_NUMBER(primitive));
+ outf (stream, "Unknown primitive %#08lx", (PRIMITIVE_NUMBER (primitive)));
return false;
}
else
}
void
-DEFUN (Print_Primitive, (primitive), SCHEME_OBJECT primitive)
+Print_Primitive (SCHEME_OBJECT primitive)
{
char buffer[40];
int NArgs, i;
- outf_console ("Primitive: ");
- if (print_primitive_name (console_output, primitive))
+ outf_error ("Primitive: ");
+ if (print_primitive_name (ERROR_OUTPUT, primitive))
NArgs = (PRIMITIVE_ARITY (primitive));
else
NArgs = 3; /* Unknown primitive */
- outf_console ("\n");
+ outf_error ("\n");
for (i = 0; i < NArgs; i++)
{
sprintf (buffer, "...Arg %ld", ((long) (i + 1)));
- print_expression (console_output, (STACK_REF (i)), buffer);
- outf_console ("\n");
+ print_expression (ERROR_OUTPUT, (STACK_REF (i)), buffer);
+ outf_error ("\n");
}
- return;
}
\f
/* Code for interactively setting and clearing the interpreter
debugging flags. Invoked via the "D" command to the ^C
handler or during each FASLOAD. */
-#ifdef ENABLE_DEBUGGING_FLAGS
+#ifdef ENABLE_DEBUGGING_TOOLS
#ifndef MORE_DEBUG_FLAG_CASES
#define MORE_DEBUG_FLAG_CASES()
#define D_TRACE_ON_ERROR 12
#define D_PER_FILE 13
#define D_BIGNUM 14
-#define D_FLUIDS 15
#ifndef LAST_SWITCH
-#define LAST_SWITCH D_FLUIDS
+#define LAST_SWITCH D_BIGNUM
#endif
-static Boolean *
-DEFUN (find_flag, (flag_number), int flag_number)
+static bool *
+find_flag (int flag_number)
{
switch (flag_number)
{
case D_TRACE_ON_ERROR: return (&Trace_On_Error);
case D_PER_FILE: return (&Per_File);
case D_BIGNUM: return (&Bignum_Debug);
- case D_FLUIDS: return (&Fluids_Debug);
MORE_DEBUG_FLAG_CASES ();
default: return (0);
}
}
static char *
-DEFUN (flag_name, (flag_number), int flag_number)
+flag_name (int flag_number)
{
switch (flag_number)
{
case D_TRACE_ON_ERROR: return ("Trace_On_Error");
case D_PER_FILE: return ("Per_File");
case D_BIGNUM: return ("Bignum_Debug");
- case D_FLUIDS: return ("Fluids_Debug");
MORE_DEBUG_FLAG_NAMES ();
default: return ("Unknown Debug Flag");
}
}
static void
-DEFUN (show_flags, (all), int all)
+show_flags (int all)
{
- int i;
+ unsigned int i;
for (i = 0; (i <= LAST_SWITCH); i += 1)
{
int value = (* (find_flag (i)));
if (all || value)
- outf (console_output, "Flag %ld (%s) is %s.\n",
- ((long) i), (flag_name (i)), (value ? "set" : "clear"));
+ outf_error ("Flag %u (%s) is %s.\n",
+ i, (flag_name (i)), (value ? "set" : "clear"));
}
- outf_flush_console();
- return;
+ outf_flush_error();
}
static int
-DEFUN (set_flag, (flag_number, value), int flag_number AND int value)
+set_flag (int flag_number, int value)
{
- Boolean * flag = (find_flag (flag_number));
+ bool * flag = (find_flag (flag_number));
if (flag == 0)
show_flags (1);
else
}
static int
-DEFUN (debug_getdec, (string), CONST char * string)
+debug_getdec (const char * string)
{
int result;
- sscanf (string, "%ld", (&result));
+ sscanf (string, "%d", (&result));
return (result);
}
void
-DEFUN_VOID (debug_edit_flags)
+debug_edit_flags (void)
{
char input_line [256];
show_flags (0);
while (1)
{
- outf_console("Clear<number>, Set<number>, Done, ?, or Halt: ");
- outf_flush_console();
+ outf_error("Clear<number>, Set<number>, Done, ?, or Halt: ");
+ outf_flush_error();
{
fgets (input_line, (sizeof (input_line)), stdin);
switch (input_line[0])
}
}
-#else /* not ENABLE_DEBUGGING_FLAGS */
+#else /* not ENABLE_DEBUGGING_TOOLS */
void
-DEFUN_VOID (debug_edit_flags)
+debug_edit_flags (void)
{
outf_error ("Not a debugging version. No flags to handle.\n");
outf_flush_error();
- return;
}
static int
-DEFUN (set_flag, (flag_number, value), int flag_number AND int value)
+set_flag (int flag_number, int value)
{
signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
/*NOTREACHED*/
return (0);
}
-#endif /* not ENABLE_DEBUGGING_FLAGS */
+#endif /* not ENABLE_DEBUGGING_TOOLS */
DEFINE_PRIMITIVE("SET-DEBUG-FLAGS!", Prim_set_debug_flags, 2, 2,
- "(SET-DEBUG-FLAGS! flag_number boolean)")
+ "(FLAG_NUMBER BOOLEAN)")
{
PRIMITIVE_HEADER (2);
set_flag ((arg_integer (1)), (BOOLEAN_ARG (2)));
+++ /dev/null
-/* -*-C-*-
-
-$Id: default.h,v 9.49 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains default definitions for some hooks which
- various machines require. These machines define these hooks
- in CONFIG.H and this file defines them only if they remain
- undefined. */
-\f
-/* Compiler bug fixes. */
-
-#ifndef And2
-#define And2(x, y) ((x) && (y))
-#define And3(x, y, z) ((x) && (y) && (z))
-#define Or2(x, y) ((x) || (y))
-#define Or3(x, y, z) ((x) || (y) || (z))
-#endif
-
-#ifndef MEMORY_FETCH
-/* These definitions allow a true multi-processor with shared memory
- but no atomic longword operations (Butterfly and Concert,
- for example) to supply their own atomic operators in config.h. */
-#define MEMORY_FETCH(locative) (locative)
-#define MEMORY_STORE(locative, object) (locative) = (object)
-#endif
-
-#ifndef Get_Fixed_Obj_Slot
-#define Get_Fixed_Obj_Slot(N) FAST_VECTOR_REF (Fixed_Objects, N)
-#define Set_Fixed_Obj_Slot(N,S) FAST_VECTOR_SET (Fixed_Objects, N, S)
-#define Update_FObj_Slot(N, S) Set_Fixed_Obj_Slot(N, S)
-#define Declare_Fixed_Objects() SCHEME_OBJECT Fixed_Objects
-#define Valid_Fixed_Obj_Vector() (VECTOR_P (Fixed_Objects))
-#define Save_Fixed_Obj(Save_FO) \
- Save_FO = Fixed_Objects; \
- Fixed_Objects = SHARP_F;
-#define Restore_Fixed_Obj(Save_FO) \
- Fixed_Objects = Save_FO
-#endif
-
-/* Atomic swapping hook. Used extensively. */
-
-#ifndef SWAP_POINTERS
-#define SWAP_POINTERS(locative, object, target) do \
-{ \
- (target) = (* (locative)); \
- (* (locative)) = (object); \
-} while (0)
-#endif
-\f
-#ifndef INITIALIZE_STACK
-#define INITIALIZE_STACK() do \
-{ \
- sp_register = Stack_Top; \
- SET_STACK_GUARD (Stack_Bottom + STACK_GUARD_SIZE); \
- * Stack_Bottom \
- = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Bottom)); \
-} while (0)
-#endif
-
-#ifndef STACK_ALLOCATION_SIZE
-#define STACK_ALLOCATION_SIZE(Stack_Blocks) (Stack_Blocks)
-#endif
-
-#ifndef STACK_OVERFLOWED_P
-#define STACK_OVERFLOWED_P() \
- ((* Stack_Bottom) != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Bottom)))
-#endif
-
-#ifndef STACK_SANITY_CHECK
-#define STACK_SANITY_CHECK(name) do \
-{ \
- extern void EXFUN (stack_death, (CONST char *)); \
- \
- if (STACK_OVERFLOWED_P ()) \
- stack_death (name); \
- /*NOTREACHED */ \
-} while (0)
-#endif
-
-#ifndef SET_CONSTANT_TOP
-#define SET_CONSTANT_TOP() do \
-{ \
- ALIGN_FLOAT (Free_Constant); \
- SEAL_CONSTANT_SPACE (); \
-} while (0)
-#endif
-
-#ifndef TEST_CONSTANT_TOP
-#define TEST_CONSTANT_TOP(New_Top) ((New_Top) <= Constant_Top)
-#endif
-
-#ifndef CONSTANT_AREA_END
-#define CONSTANT_AREA_END() Free_Constant
-#endif
-
-#ifndef CONSTANT_AREA_START
-#define CONSTANT_AREA_START() sp_register
-#endif /* CONSTANT_AREA_START */
-
-#ifndef SEAL_CONSTANT_SPACE
-#define SEAL_CONSTANT_SPACE() do \
-{ \
- * Free_Constant = \
- (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant)); \
-} while (0)
-#endif
-\f
-/* Used in debug.c */
-
-#ifndef Back_Trace_Entry_Hook
-#define Back_Trace_Entry_Hook()
-#endif
-
-#ifndef Back_Trace_Exit_Hook
-#define Back_Trace_Exit_Hook()
-#endif
-
-/* Used in extern.h */
-
-#ifndef More_Debug_Flag_Externs
-#define More_Debug_Flag_Externs()
-#endif
-
-/* Used in fasdump.c */
-
-#ifndef Band_Dump_Permitted
-#define Band_Dump_Permitted()
-#endif
-
-#ifndef Band_Load_Hook
-#define Band_Load_Hook()
-#endif
-
-#ifndef Band_Dump_Exit_Hook
-#define Band_Dump_Exit_Hook()
-#endif
-
-#ifndef Fasdump_Exit_Hook
-#define Fasdump_Exit_Hook()
-#endif
-
-#ifndef Fasdump_Free_Calc
-#define Fasdump_Free_Calc(NewFree, NewMemtop) do \
-{ \
- NewFree = Unused_Heap_Bottom; \
- NewMemTop = Unused_Heap_Top; \
-} while (0)
-#endif
-\f
-/* Used in interpret.c */
-
-#ifndef Eval_Ucode_Hook
-#define Eval_Ucode_Hook()
-#endif
-
-#ifndef Pop_Return_Ucode_Hook
-#define Pop_Return_Ucode_Hook()
-#endif
-
-#ifndef Apply_Ucode_Hook
-#define Apply_Ucode_Hook()
-#endif
-
-#ifndef End_GC_Hook
-#define End_GC_Hook()
-#endif
-
-/* Used in storage.c */
-
-#ifndef More_Debug_Flag_Allocs
-#define More_Debug_Flag_Allocs()
-#endif
-
-/* Used in utils.c */
-
-#ifndef Global_Interrupt_Hook
-#define Global_Interrupt_Hook()
-#endif
-
-#ifndef Error_Exit_Hook
-#define Error_Exit_Hook()
-#endif
-
-/* Common Lisp Hooks */
-
-#ifndef SITE_EXPRESSION_DISPATCH_HOOK
-#define SITE_EXPRESSION_DISPATCH_HOOK()
-#endif
-
-#ifndef SITE_RETURN_DISPATCH_HOOK
-#define SITE_RETURN_DISPATCH_HOOK()
-#endif
-
-#ifndef FASLOAD_RELOCATE_HOOK
-#define FASLOAD_RELOCATE_HOOK(heap_low, heap_high, constant_low, constant_high)
-#endif
/* -*-C-*-
-$Id: dfloat.c,v 1.10 2007/01/05 21:19:25 cph Exp $
+$Id: dfloat.c,v 1.11 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
long length = (arg_nonnegative_integer (1));
long length_in_words = (length * FLONUM_SIZE);
SCHEME_OBJECT result;
- fast double *vect;
+ double *vect;
ALIGN_FLOAT (Free);
Primitive_GC_If_Needed (length_in_words + 1);
}
}
-extern double EXFUN (arg_flonum, (int));
+extern double arg_flonum (int);
DEFINE_PRIMITIVE ("FLOATING-VECTOR-SET!", Prim_floating_vector_set, 3, 3, 0)
{
+++ /dev/null
-/* -*-C-*-
-
-$Id: dmpwrld.c,v 9.45 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains a primitive to dump an executable version of Scheme.
- It uses unexec.c from GNU Emacs.
- Look at unexec.c for more information. */
-
-#include "scheme.h"
-#include "prims.h"
-
-#ifndef __unix__
-#include "Error: dumpworld.c does not work on non-unix machines."
-#endif
-
-#include "ux.h"
-#include "osfs.h"
-#include <sys/file.h>
-\f
-/* Compatibility definitions for GNU Emacs's unexec.c.
- Taken from the various m-*.h and s-*.h files for GNU Emacs.
-*/
-
-#define CANNOT_UNEXEC
-
-#if defined (vax)
-#undef CANNOT_UNEXEC
-#endif
-
-#if defined (hp9000s300) || defined (__hp9000s300)
-#undef CANNOT_UNEXEC
-#define ADJUST_EXEC_HEADER \
- hdr.a_magic = ((ohdr.a_magic.file_type == OLDMAGIC.file_type) ? \
- NEWMAGIC : ohdr.a_magic);
-#endif
-
-#if defined (hp9000s800) || defined (__hp9000s800)
-#undef CANNOT_UNEXEC
-#endif
-
-#if defined (sun3)
-#undef CANNOT_UNEXEC
-#define SEGMENT_MASK (SEGSIZ - 1)
-#define A_TEXT_OFFSET(HDR) sizeof (HDR)
-#define TEXT_START (PAGSIZ + (sizeof(struct exec)))
-#endif
-
-/* I haven't tried any below this point. */
-
-#if defined (umax)
-#undef CANNOT_UNEXEC
-#define HAVE_GETPAGESIZE
-#define COFF
-#define UMAX
-#define SECTION_ALIGNMENT pagemask
-#define SEGMENT_MASK (64 * 1024 - 1)
-#endif
-
-#if defined (celerity)
-#undef CANNOT_UNEXEC
-#endif
-
-#if defined (sun2)
-#undef CANNOT_UNEXEC
-#define SEGMENT_MASK (SEGSIZ - 1)
-#endif
-
-#if defined (pyr)
-#undef CANNOT_UNEXEC
-#define SEGMENT_MASK (2048-1) /* ZMAGIC format */
- /* man a.out for info */
-#endif
-\f
-#ifdef CANNOT_UNEXEC
-#include "Error: dmpwrld.c only works on a few machines."
-#endif
-
-#ifndef TEXT_START
-#define TEXT_START 0
-#endif
-
-#ifndef SEGMENT_MASK
-#define DATA_START (&etext)
-#else
-#define DATA_START \
-(((((unsigned) &etext) - 1) & ~SEGMENT_MASK) + (SEGMENT_MASK + 1))
-#endif
-
-#if defined (__HPUX__)
-#define USG
-#define HPUX
-#endif
-\f
-/* More compatibility definitions for unexec. */
-
-extern int end, etext, edata;
-
-char
-*start_of_text()
-{
- return ((char *) TEXT_START);
-}
-
-char
-*start_of_data()
-{
- return ((char *) DATA_START);
-}
-
-#if defined (USG) || defined (NO_BZERO)
-
-#define bzero(b,len) (memset((b), 0, (len)))
-
-#else
-
-extern void bzero();
-
-#endif
-
-#define static
-
-#if defined (hp9000s800) || defined (__hp9000s800)
-#include "unexhp9k800.c"
-#else
-#include "unexec.c"
-#endif
-
-#undef static
-\f
-void
-DEFUN (unix_find_pathname, (program_name, target),
- CONST char * program_name AND char * target)
-{
- int length;
- char
- * path,
- * next;
- extern char *
- EXFUN (index, (char * path AND char srchr));
- extern void
- EXFUN (strcpy, (char * target AND CONST char * source));
-
- /* Attempt first in the connected directory */
-
- if (((program_name[0]) == '/')
- || (OS_file_access (program_name, X_OK))
- || ((path = ((char *) (getenv ("PATH")))) == ((char *) NULL)))
- {
- strcpy (target, program_name);
- return;
- }
- for (next = (index (path, ':'));
- path != ((char *) NULL);
- path = (next + 1),
- next = (index (path, ':')))
- {
- length = ((next == ((char *) NULL))
- ? (strlen (path))
- : (next-path));
- strncpy (target, path, length);
- target[length] = '/';
- target[length + 1] = '\0';
- strcpy ((target + (length + 1)), program_name);
- if (OS_file_access (target, X_OK))
- {
- return;
- }
- }
- strcpy (target, program_name);
- return;
-}
-
-/* The primitive visible from Scheme. */
-
-extern Boolean scheme_dumped_p;
-
-DEFINE_PRIMITIVE ("DUMP-WORLD", Prim_dump_world, 1, 1, 0)
-{
- int result;
- SCHEME_OBJECT arg;
- Boolean saved_dumped_p;
- char
- * fname,
- path_buffer[FILE_NAME_LENGTH];
- PRIMITIVE_HEADER (1);
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
-
- arg = (ARG_REF (1));
- fname = (STRING_ARG (1));
-
- /* Set up for restore */
-
- saved_dumped_p = scheme_dumped_p;
-
- scheme_dumped_p = true;
- val_register = SHARP_T;
- POP_PRIMITIVE_FRAME (1);
-
- /* Dump! */
-
- unix_find_pathname (scheme_program_name, path_buffer);
- result = (unexec (fname,
- path_buffer,
- ((unsigned) 0), /* default */
- ((unsigned) 0), /* default */
- ((unsigned) start_of_text())));
-
- /* Restore State */
-
- val_register = SHARP_F;
- scheme_dumped_p = saved_dumped_p;
-
- /* IO: Restoring cached input for this job. */
-
- if (result != 0)
- {
- STACK_PUSH (arg);
- error_external_return ();
- }
-
- PRIMITIVE_ABORT (PRIM_POP_RETURN);
- /*NOTREACHED*/
-}
/* -*-C-*-
-$Id: dstack.h,v 1.15 2007/01/05 21:19:25 cph Exp $
+$Id: dstack.h,v 1.16 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define __DSTACK_H__
#include "config.h"
-#include "ansidecl.h"
#include <setjmp.h>
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-#endif
-
-extern void EXFUN (dstack_initialize, (void));
+extern void dstack_initialize (void);
/* Call this once to initialize the stack. */
-extern void EXFUN (dstack_reset, (void));
+extern void dstack_reset (void);
/* Call this once to reset the stack. */
-extern PTR EXFUN (dstack_alloc, (unsigned int length));
+extern void * dstack_alloc (unsigned int length);
/* Allocate a chunk of `length' bytes of space on the stack and return
a pointer to it. */
-extern void EXFUN
- (dstack_protect,
- (void EXFUN ((*protector), (PTR environment)), PTR environment));
+extern void dstack_protect
+ (void (*protector) (void * environment), void * environment);
/* Create an unwind protection frame that invokes `protector' when
the stack is unwound. `environment' is passed to `protector' as
its sole argument when it is invoked. */
-extern void EXFUN
- (dstack_alloc_and_protect,
- (unsigned int length,
- void EXFUN ((*initializer), (PTR environment)),
- void EXFUN ((*protector), (PTR environment))));
+extern void dstack_alloc_and_protect
+ (unsigned int length,
+ void (*initializer) (void * environment),
+ void (*protector) (void * environment));
/* Allocate a chunk of `length' bytes of space, call `initializer' to
initialize that space, and create an unwind protection frame that
invokes `protector' when the stack is unwound. */
-extern PTR dstack_position;
+extern void * dstack_position;
/* The current stack pointer. */
-extern void EXFUN (dstack_set_position, (PTR position));
+extern void dstack_set_position (void * position);
/* Unwind the stack to `position', which must be a previous value of
`dstack_position'. */
-extern void EXFUN (dstack_bind, (PTR location, PTR value));
+extern void dstack_bind (void * location, void * value);
/* Dynamically bind `location' to `value'. `location' is treated as
- `PTR*' -- it is declared `PTR' for programming convenience. */
+ `void **' -- it is declared `void *' for programming convenience. */
enum transaction_action_type { tat_abort, tat_commit, tat_always };
-extern void EXFUN (transaction_initialize, (void));
-extern void EXFUN (transaction_begin, (void));
-extern void EXFUN (transaction_abort, (void));
-extern void EXFUN (transaction_commit, (void));
-extern void EXFUN
- (transaction_record_action,
- (enum transaction_action_type type,
- void EXFUN ((*procedure), (PTR environment)),
- PTR environment));
+extern void transaction_initialize (void);
+extern void transaction_begin (void);
+extern void transaction_abort (void);
+extern void transaction_commit (void);
+extern void transaction_record_action
+ (enum transaction_action_type type,
+ void (*procedure) (void * environment),
+ void * environment);
\f
typedef unsigned long Tptrvec_index;
typedef unsigned long Tptrvec_length;
struct struct_ptrvec
{
Tptrvec_length length;
- PTR * elements;
+ void ** elements;
};
typedef struct struct_ptrvec * Tptrvec;
#define PTRVEC_START(ptrvec) (PTRVEC_LOC ((ptrvec), 0))
#define PTRVEC_END(ptrvec) (PTRVEC_LOC ((ptrvec), (PTRVEC_LENGTH (ptrvec))))
-extern Tptrvec EXFUN (ptrvec_allocate, (Tptrvec_length length));
-extern void EXFUN (ptrvec_deallocate, (Tptrvec ptrvec));
-extern void EXFUN (ptrvec_set_length, (Tptrvec ptrvec, Tptrvec_length length));
-extern Tptrvec EXFUN (ptrvec_copy, (Tptrvec ptrvec));
-extern void EXFUN (ptrvec_adjoin, (Tptrvec ptrvec, PTR element));
-extern int EXFUN (ptrvec_memq, (Tptrvec ptrvec, PTR element));
-extern void EXFUN
- (ptrvec_move_left,
- (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end,
- Tptrvec target, Tptrvec_index target_start));
-extern void EXFUN
- (ptrvec_move_right,
- (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end,
- Tptrvec target, Tptrvec_index target_start));
+extern Tptrvec ptrvec_allocate (Tptrvec_length length);
+extern void ptrvec_deallocate (Tptrvec ptrvec);
+extern void ptrvec_set_length (Tptrvec ptrvec, Tptrvec_length length);
+extern Tptrvec ptrvec_copy (Tptrvec ptrvec);
+extern void ptrvec_adjoin (Tptrvec ptrvec, void * element);
+extern int ptrvec_memq (Tptrvec ptrvec, void * element);
+extern void ptrvec_move_left
+ (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end,
+ Tptrvec target, Tptrvec_index target_start);
+extern void ptrvec_move_right
+ (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end,
+ Tptrvec target, Tptrvec_index target_start);
\f
typedef struct condition_type * Tcondition_type;
typedef struct condition * Tcondition;
struct condition_type
{
unsigned long index;
- PTR name;
+ void * name;
Tptrvec generalizations;
- void EXFUN ((*reporter), (Tcondition));
+ void (*reporter) (Tcondition);
};
#define CONDITION_TYPE_INDEX(type) ((type) -> index)
#define CONDITION_TYPE_NAME(type) ((type) -> name)
struct condition_restart
{
- PTR name;
+ void * name;
Tcondition_type type;
- void EXFUN ((*procedure), (PTR));
+ void (*procedure) (void *);
};
#define CONDITION_RESTART_NAME(restart) ((restart) -> name)
#define CONDITION_RESTART_TYPE(restart) ((restart) -> type)
#define CONDITION_RESTART_PROCEDURE(restart) ((restart) -> procedure)
/* Allocate and return a new condition type object. */
-extern Tcondition_type EXFUN
- (condition_type_allocate,
- (PTR name,
+extern Tcondition_type condition_type_allocate
+ (void * name,
Tptrvec generalizations,
- void EXFUN ((*reporter), (Tcondition condition))));
+ void (*reporter) (Tcondition condition));
/* Deallocate the condition type object `type'. */
-extern void EXFUN (condition_type_deallocate, (Tcondition_type type));
+extern void condition_type_deallocate (Tcondition_type type);
/* Allocate and return a new condition object. */
-extern Tcondition EXFUN
- (condition_allocate, (Tcondition_type type, Tptrvec irritants));
+extern Tcondition condition_allocate
+ (Tcondition_type type, Tptrvec irritants);
/* Deallocate the condition object `condition'. */
-extern void EXFUN (condition_deallocate, (Tcondition condition));
+extern void condition_deallocate (Tcondition condition);
/* Bind a handler for the condition type object `type'. */
-extern void EXFUN
- (condition_handler_bind,
- (Tcondition_type type, void EXFUN ((*handler), (Tcondition condition))));
+extern void condition_handler_bind
+ (Tcondition_type type, void (*handler) (Tcondition condition));
/* Signal `condition'. */
-extern void EXFUN (condition_signal, (Tcondition condition));
+extern void condition_signal (Tcondition condition);
/* Bind a restart called `name' for the condition type object `type'.
Invoking the restart causes `restart_procedure' to be executed. */
-extern void EXFUN
- (condition_restart_bind,
- (PTR name,
+extern void condition_restart_bind
+ (void * name,
Tcondition_type type,
- void EXFUN ((*procedure), (PTR argument))));
+ void (*procedure) (void * argument));
/* Find a restart called `name' that matches `condition'.
If `condition' is 0, any restart called `name' will do.
If no such restart exists, 0 is returned. */
-extern Tcondition_restart EXFUN
- (condition_restart_find, (PTR name, Tcondition condition));
+extern Tcondition_restart condition_restart_find
+ (void * name, Tcondition condition);
/* Return a ptrvec of the restarts that match `condition'.
If `condition' is 0, all restarts are returned. */
-extern Tptrvec EXFUN (condition_restarts, (Tcondition condition));
+extern Tptrvec condition_restarts (Tcondition condition);
#endif /* __DSTACK_H__ */
+++ /dev/null
-/* -*-C-*-
-
-$Id: dump.c,v 9.44 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains common code for dumping internal format binary files. */
-\f
-#ifndef PSBMAP_H_INCLUDED
-extern long
- compiler_interface_version,
- compiler_processor_type;
-
-extern SCHEME_OBJECT
- compiler_utilities;
-#endif /* PSBMAP_H_INCLUDED */
-
-void
-DEFUN (prepare_dump_header, (Buffer, Dumped_Object,
- Heap_Count, Heap_Relocation,
- Constant_Count, Constant_Relocation,
- prim_table_length, prim_table_size,
- c_table_length, c_table_size,
- cc_code_p, band_p),
- SCHEME_OBJECT * Buffer
- AND SCHEME_OBJECT * Dumped_Object
- AND long Heap_Count
- AND SCHEME_OBJECT * Heap_Relocation
- AND long Constant_Count
- AND SCHEME_OBJECT * Constant_Relocation
- AND long prim_table_length
- AND long prim_table_size
- AND long c_table_length
- AND long c_table_size
- AND Boolean cc_code_p
- AND Boolean band_p)
-{
- long i;
-
-#ifdef DEBUG
-
-#ifndef HEAP_IN_LOW_MEMORY
- fprintf(stderr, "\nmemory_base = 0x%lx\n", ((long) memory_base));
-#endif /* HEAP_IN_LOW_MEMORY */
-
- fprintf(stderr, "\nHeap_Relocation=0x%lx, dumped as 0x%lx\n",
- ((long) Heap_Relocation),
- ((long) (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Heap_Relocation))));
- fprintf(stderr, "\nDumped object=0x%lx, dumped as 0x%lx\n",
- ((long) Dumped_Object),
- ((long) (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Dumped_Object))));
-#endif /* DEBUG */
-
- Buffer[FASL_Offset_Marker] = FASL_FILE_MARKER;
- Buffer[FASL_Offset_Heap_Count] =
- MAKE_OBJECT (TC_BROKEN_HEART, Heap_Count);
- Buffer[FASL_Offset_Heap_Base] =
- MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Heap_Relocation);
- Buffer[FASL_Offset_Dumped_Obj] =
- MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Dumped_Object);
- Buffer[FASL_Offset_Const_Count] =
- MAKE_OBJECT (TC_BROKEN_HEART, Constant_Count);
- Buffer[FASL_Offset_Const_Base] =
- MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Constant_Relocation);
- Buffer[FASL_Offset_Version] =
- Make_Version(FASL_FORMAT_VERSION,
- FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
- Buffer[FASL_Offset_Stack_Top] =
-#ifdef USE_STACKLETS
- MAKE_OBJECT (TC_BROKEN_HEART, 0); /* Nothing in stack area */
-#else
- MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top);
-#endif /* USE_STACKLETS */
-\f
- Buffer[FASL_Offset_Prim_Length] =
- MAKE_OBJECT (TC_BROKEN_HEART, prim_table_length);
- Buffer[FASL_Offset_Prim_Size] =
- MAKE_OBJECT (TC_BROKEN_HEART, prim_table_size);
-
- if (cc_code_p)
- {
- Buffer[FASL_Offset_Ci_Version] =
- MAKE_CI_VERSION(band_p,
- compiler_interface_version,
- compiler_processor_type);
- Buffer[FASL_Offset_Ut_Base] = compiler_utilities;
- }
- else
- {
- /* If there is no compiled code in the file,
- flag it as if dumped without compiler support, so
- it can be loaded anywhere.
- */
- Buffer[FASL_Offset_Ci_Version] = (MAKE_CI_VERSION (band_p, 0, 0));
- Buffer[FASL_Offset_Ut_Base] = SHARP_F;
- }
-
- Buffer[FASL_Offset_C_Length] =
- MAKE_OBJECT (TC_BROKEN_HEART, c_table_length);
- Buffer[FASL_Offset_C_Size] =
- MAKE_OBJECT (TC_BROKEN_HEART, c_table_size);
-
-#ifdef HEAP_IN_LOW_MEMORY
- Buffer[FASL_Offset_Mem_Base] = ((SCHEME_OBJECT) 0);
-#else /* not HEAP_IN_LOW_MEMORY */
- Buffer[FASL_Offset_Mem_Base] = ((SCHEME_OBJECT) memory_base);
-#endif /* HEAP_IN_LOW_MEMORY */
-
- Buffer[FASL_Offset_Check_Sum] = SHARP_F;
- for (i = FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
- Buffer[i] = SHARP_F;
- return;
-}
-\f
-extern unsigned long
- EXFUN (checksum_area, (unsigned long *, long, unsigned long));
-
-Boolean
-DEFUN (Write_File, (Dumped_Object, Heap_Count, Heap_Relocation,
- Constant_Count, Constant_Relocation,
- prim_table_start, prim_table_length, prim_table_size,
- c_table_start, c_table_length, c_table_size,
- cc_code_p, band_p),
- SCHEME_OBJECT * Dumped_Object
- AND long Heap_Count
- AND SCHEME_OBJECT * Heap_Relocation
- AND long Constant_Count
- AND SCHEME_OBJECT * Constant_Relocation
- AND SCHEME_OBJECT * prim_table_start
- AND long prim_table_length
- AND long prim_table_size
- AND SCHEME_OBJECT * c_table_start
- AND long c_table_length
- AND long c_table_size
- AND Boolean cc_code_p
- AND Boolean band_p)
-{
- SCHEME_OBJECT Buffer[FASL_HEADER_LENGTH];
- unsigned long checksum;
-
- prepare_dump_header (Buffer, Dumped_Object,
- Heap_Count, Heap_Relocation,
- Constant_Count, Constant_Relocation,
- prim_table_length, prim_table_size,
- c_table_length, c_table_size,
- cc_code_p, band_p);
-
- /* This is not done in prepare_dump_header because it doesn't
- work when prepare_dump_header is invoked from bchdmp.
- The areas don't really have these values.
- For the time being, bchdmp does not dump checksums.
- */
-
- checksum = (checksum_area (((unsigned long *) (&Buffer[0])),
- ((long) FASL_Offset_Check_Sum),
- ((unsigned long) 0L)));
- checksum = (checksum_area (((unsigned long *)
- (&Buffer[FASL_Offset_Check_Sum + 1])),
- ((long) ((FASL_HEADER_LENGTH - 1) -
- FASL_Offset_Check_Sum)),
- checksum));
- checksum = (checksum_area (((unsigned long *) Heap_Relocation),
- Heap_Count,
- checksum));
- checksum = (checksum_area (((unsigned long *) Constant_Relocation),
- Constant_Count,
- checksum));
- checksum = (checksum_area (((unsigned long *) prim_table_start),
- prim_table_size,
- checksum));
- checksum = (checksum_area (((unsigned long *) c_table_start),
- c_table_size,
- checksum));
-
- Buffer[FASL_Offset_Check_Sum] = checksum;
-\f
- if ((Write_Data (FASL_HEADER_LENGTH, Buffer))
- != FASL_HEADER_LENGTH)
- return (false);
-
- if ((Heap_Count != 0)
- && ((Write_Data (Heap_Count, Heap_Relocation))
- != Heap_Count))
- return (false);
-
- if ((Constant_Count != 0)
- && ((Write_Data (Constant_Count, Constant_Relocation))
- != Constant_Count))
- return (false);
-
- if ((prim_table_size != 0)
- && ((Write_Data (prim_table_size, prim_table_start))
- != prim_table_size))
- return (false);
-
- if ((c_table_size != 0)
- && ((Write_Data (c_table_size, c_table_start))
- != c_table_size))
- return (false);
-
- return (true);
-}
-
-unsigned long
-DEFUN (checksum_area, (start, count, initial_value),
- register unsigned long * start
- AND register long count
- AND unsigned long initial_value)
-{
- register unsigned long value;
-
- value = initial_value;
- while ((--count) >= 0)
- value = (value ^ (*start++));
- return (value);
-}
-
/* -*-C-*-
-$Id: edwin.h,v 1.14 2007/04/01 17:33:07 riastradh Exp $
+$Id: edwin.h,v 1.15 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
This MUST match the definitions in the Edwin source code. */
#define GROUP_P VECTOR_P
-#define GROUP_TEXT(group) (VECTOR_REF ((group), 1))
-#define GROUP_TEXT_LOC(group, offset) \
- (((unsigned char *) (integer_to_ulong (GROUP_TEXT (group)))) + (offset))
+#define GROUP_TEXT(group, len_r) \
+ (lookup_external_string ((VECTOR_REF ((group), 1)), (len_r)))
-#define GROUP_GAP_START(group) \
- (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 2)))
-
-#define GROUP_GAP_LENGTH(group) \
- (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 3)))
-
-#define GROUP_GAP_END(group) \
- (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 4)))
+#define GROUP_TEXT_LOC(group, offset) ((GROUP_TEXT ((group), 0)) + (offset))
+#define GROUP_GAP_START(group) (FIXNUM_TO_ULONG (VECTOR_REF ((group), 2)))
+#define GROUP_GAP_LENGTH(group) (FIXNUM_TO_ULONG (VECTOR_REF ((group), 3)))
+#define GROUP_GAP_END(group) (FIXNUM_TO_ULONG (VECTOR_REF ((group), 4)))
#define GROUP_START_MARK(group) (VECTOR_REF ((group), 6))
#define GROUP_END_MARK(group) (VECTOR_REF ((group), 7))
/* -*-C-*-
-$Id: error.c,v 1.12 2007/01/05 21:19:25 cph Exp $
+$Id: error.c,v 1.13 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <stdio.h>
+#include "config.h"
#include "outf.h"
#include "dstack.h"
+#include "os.h"
-static PTR
-DEFUN (xmalloc, (length), unsigned int length)
-{
-#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__)
-#else
- extern PTR EXFUN (malloc, (unsigned int length));
-#endif
-
- PTR result = (malloc (length));
- if (result == 0)
- {
- outf_fatal ("malloc: memory allocation failed\n");
- outf_flush_fatal ();
- abort ();
- }
- return (result);
-}
+static Tptrvec generalizations_union (Tptrvec);
\f
struct handler_record
{
struct handler_record * next;
Tcondition_type type;
- void EXFUN ((*handler), (Tcondition));
+ void (*handler) (Tcondition);
};
struct restart_record
static struct restart_record * current_restart_record;
void
-DEFUN_VOID (initialize_condition_system)
+initialize_condition_system (void)
{
next_condition_type_index = 0;
current_handler_record = 0;
}
Tcondition_type
-DEFUN (condition_type_allocate, (name, generalizations, reporter),
- PTR name AND
- Tptrvec generalizations AND
- void EXFUN ((*reporter), (Tcondition condition)))
+condition_type_allocate (void * name,
+ Tptrvec generalizations,
+ void (*reporter) (Tcondition condition))
{
- Tptrvec EXFUN (generalizations_union, (Tptrvec generalizations));
- Tcondition_type type = (xmalloc (sizeof (struct condition_type)));
+ Tcondition_type type = (OS_malloc (sizeof (struct condition_type)));
Tptrvec g = (generalizations_union (generalizations));
ptrvec_adjoin (g, type);
(CONDITION_TYPE_INDEX (type)) = (next_condition_type_index++);
}
void
-DEFUN (condition_type_deallocate, (type), Tcondition_type type)
+condition_type_deallocate (Tcondition_type type)
{
ptrvec_deallocate (CONDITION_TYPE_GENERALIZATIONS (type));
free (type);
}
Tcondition
-DEFUN (condition_allocate, (type, irritants),
- Tcondition_type type AND
+condition_allocate (Tcondition_type type,
Tptrvec irritants)
{
- Tcondition condition = (xmalloc (sizeof (struct condition)));
+ Tcondition condition = (OS_malloc (sizeof (struct condition)));
(CONDITION_TYPE (condition)) = type;
(CONDITION_IRRITANTS (condition)) = irritants;
return (condition);
}
void
-DEFUN (condition_deallocate, (condition), Tcondition condition)
+condition_deallocate (Tcondition condition)
{
ptrvec_deallocate (CONDITION_IRRITANTS (condition));
free (condition);
}
\f
static Tptrvec
-DEFUN (generalizations_union_2, (x, y), Tptrvec x AND Tptrvec y)
+generalizations_union_2 (Tptrvec x, Tptrvec y)
{
- PTR * scan_x = (PTRVEC_START (x));
- PTR * end_x = (scan_x + (PTRVEC_LENGTH (x)));
- PTR * scan_y = (PTRVEC_START (y));
- PTR * end_y = (scan_y + (PTRVEC_LENGTH (y)));
+ void ** scan_x = (PTRVEC_START (x));
+ void ** end_x = (scan_x + (PTRVEC_LENGTH (x)));
+ void ** scan_y = (PTRVEC_START (y));
+ void ** end_y = (scan_y + (PTRVEC_LENGTH (y)));
Tptrvec_length length = 0;
unsigned long ix;
unsigned long iy;
Tptrvec result;
- PTR * scan_result;
+ void ** scan_result;
while (1)
{
if (scan_x == end_x)
}
Tptrvec
-DEFUN (generalizations_union, (generalizations), Tptrvec generalizations)
+generalizations_union (Tptrvec generalizations)
{
Tptrvec_length length = (PTRVEC_LENGTH (generalizations));
if (length == 0)
if (length == 1)
return (ptrvec_copy (PTRVEC_REF (generalizations, 0)));
{
- PTR * scan = (PTRVEC_START (generalizations));
- PTR * end = (scan + length);
+ void ** scan = (PTRVEC_START (generalizations));
+ void ** end = (scan + length);
Tptrvec result = ((Tptrvec) (*scan++));
result = (generalizations_union_2 (result, ((Tptrvec) (*scan++))));
while (scan < end)
}
\f
void
-DEFUN (condition_handler_bind, (type, handler),
- Tcondition_type type AND
- void EXFUN ((*handler), (Tcondition condition)))
+condition_handler_bind (Tcondition_type type,
+ void (*handler) (Tcondition condition))
{
struct handler_record * record =
(dstack_alloc (sizeof (struct handler_record)));
(CONDITION_TYPE_GENERALIZATIONS (CONDITION_TYPE (condition)))
void
-DEFUN (condition_signal, (condition), Tcondition condition)
+condition_signal (Tcondition condition)
{
Tptrvec generalizations = (GENERALIZATIONS (condition));
struct handler_record * record = current_handler_record;
Tcondition_type type = (record -> type);
if ((type == 0) || (ptrvec_memq (generalizations, type)))
{
- PTR position = dstack_position;
+ void * position = dstack_position;
dstack_bind ((¤t_handler_record), (record -> next));
(* (record -> handler)) (condition);
dstack_set_position (position);
}
\f
void
-DEFUN (condition_restart_bind, (name, type, procedure),
- PTR name AND
- Tcondition_type type AND
- void EXFUN ((*procedure), (PTR argument)))
+condition_restart_bind (void * name,
+ Tcondition_type type,
+ void (*procedure) (void * argument))
{
struct restart_record * record =
(dstack_alloc (sizeof (struct restart_record)));
}
Tcondition_restart
-DEFUN (condition_restart_find, (name, condition),
- PTR name AND
+condition_restart_find (void * name,
Tcondition condition)
{
struct restart_record * record = current_restart_record;
}
Tptrvec
-DEFUN (condition_restarts, (condition), Tcondition condition)
+condition_restarts (Tcondition condition)
{
struct restart_record * record = current_restart_record;
Tptrvec_length length = 0;
Tptrvec generalizations = 0;
Tptrvec result;
- PTR * scan_result;
+ void ** scan_result;
if (condition == 0)
while (record != 0)
{
/* -*-C-*-
-$Id: errors.h,v 9.48 2007/01/05 21:19:25 cph Exp $
+$Id: errors.h,v 9.49 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#ifndef SCM_ERRORS_H
#define SCM_ERRORS_H
\f
-/* All error and termination codes must be positive
- * to allow primitives to return either an error code
- * or a primitive flow control value (see const.h)
- */
+/* All error and termination codes must be positive to allow
+ primitives to return either an error code or a primitive flow
+ control value (see const.h). */
#define ERR_BAD_ERROR_CODE 0x00
#define ERR_UNBOUND_VARIABLE 0x01
#define ERR_ARG_2_BAD_RANGE 0x11
#define ERR_ARG_3_BAD_RANGE 0x12
#define ERR_MACRO_BINDING 0x13
-/* #define ERR_FASDUMP_OVERFLOW 0x14 */
-#define ERR_BAD_INTERRUPT_CODE 0x15 /* Not generated */
+#define ERR_FASDUMP_OBJECT_TOO_LARGE 0x14
+/* #define ERR_BAD_INTERRUPT_CODE 0x15 */
/* #define ERR_NO_ERRORS 0x16 */
#define ERR_FASL_FILE_TOO_BIG 0x17
#define ERR_FASL_FILE_BAD_DATA 0x18
-#define ERR_IMPURIFY_OUT_OF_SPACE 0x19
-\f
-/* The following do not exist in the 68000 version */
-#define ERR_WRITE_INTO_PURE_SPACE 0x1A
+/* #define ERR_IMPURIFY_OUT_OF_SPACE 0x19 */
+/* #define ERR_WRITE_INTO_PURE_SPACE 0x1A */
/* #define ERR_LOSING_SPARE_HEAP 0x1B */
/* #define ERR_NO_HASH_TABLE 0x1C */
#define ERR_BAD_SET 0x1D
#define ERR_ARG_2_FAILED_COERCION 0x1F
#define ERR_OUT_OF_FILE_HANDLES 0x20
/* #define ERR_SHELL_DIED 0x21 */
-
-/* Late additions to both 68000 and C world */
#define ERR_ARG_4_BAD_RANGE 0x22
#define ERR_ARG_5_BAD_RANGE 0x23
#define ERR_ARG_6_BAD_RANGE 0x24
#define ERR_STACK_HAS_SLIPPED 0x3D
#define ERR_CANNOT_RECURSE 0x3E
-/*
- If you add any error codes here, add them to
- the table below and to utabmd.scm as well.
- */
+/* If you add any error codes here, add them to the table below and to
+ utabmd.scm as well. */
#define MAX_ERROR 0x3E
\f
/* 0x01 */ "UNBOUND-VARIABLE", \
/* 0x02 */ "UNASSIGNED-VARIABLE", \
/* 0x03 */ "INAPPLICABLE-OBJECT", \
-/* 0x04 */ "OUT-OF-HASH-NUMBERS", \
-/* 0x05 */ "ENVIRONMENT-CHAIN-TOO-DEEP", \
+/* 0x04 */ "ERROR-IN-SYSTEM-CALL", \
+/* 0x05 */ "ERROR-WITH-ARGUMENT", \
/* 0x06 */ "BAD-FRAME", \
/* 0x07 */ "BROKEN-COMPILED-VARIABLE", \
/* 0x08 */ "UNDEFINED-USER-TYPE", \
/* 0x10 */ "ARG-1-BAD-RANGE", \
/* 0x11 */ "ARG-2-BAD-RANGE", \
/* 0x12 */ "ARG-3-BAD-RANGE", \
-/* 0x13 */ "BAD-COMBINATION", \
-/* 0x14 */ "FASDUMP-OVERFLOW", \
-/* 0x15 */ "BAD-INTERRUPT-CODE", \
-/* 0x16 */ "NO-ERRORS", \
+/* 0x13 */ "MACRO-BINDING", \
+/* 0x14 */ "FASDUMP-OBJECT-TOO-LARGE", \
+/* 0x15 */ 0, \
+/* 0x16 */ 0, \
/* 0x17 */ "FASL-FILE-TOO-BIG", \
/* 0x18 */ "FASL-FILE-BAD-DATA", \
-/* 0x19 */ "IMPURIFY-OUT-OF-SPACE", \
+/* 0x19 */ 0, \
/* 0x1A */ "WRITE-INTO-PURE-SPACE", \
-/* 0x1B */ "LOSING-SPARE-HEAP", \
-/* 0x1C */ "NO-HASH-TABLE", \
+/* 0x1B */ 0, \
+/* 0x1C */ 0, \
/* 0x1D */ "BAD-SET", \
/* 0x1E */ "ARG-1-FAILED-COERCION", \
/* 0x1F */ "ARG-2-FAILED-COERCION", \
/* 0x20 */ "OUT-OF-FILE-HANDLES", \
-/* 0x21 */ "SHELL-DIED", \
+/* 0x21 */ 0, \
/* 0x22 */ "ARG-4-BAD-RANGE", \
/* 0x23 */ "ARG-5-BAD-RANGE", \
/* 0x24 */ "ARG-6-BAD-RANGE", \
#define TERM_GC_OUT_OF_SPACE 0x14
#define TERM_NO_SPACE 0x15
#define TERM_SIGNAL 0x16
-#define TERM_TOUCH 0x17
+/* #define TERM_ 0x17 */
#define TERM_SAVE_AND_EXIT 0x18
#define TERM_TRAP 0x19
#define TERM_BAD_BACK_OUT 0x1a
/* 0x14 */ "Out of space after garbage collection", \
/* 0x15 */ "Out of memory: Available memory exceeded", \
/* 0x16 */ "Unhandled signal received", \
-/* 0x17 */ "Touch without futures support", \
+/* 0x17 */ 0, \
/* 0x18 */ "Halt requested by external source", \
/* 0x19 */ "User requested termination after trap", \
-/* 0x1a */ "Backing out of non-primitive" \
+/* 0x1A */ "Backing out of non-primitive" \
}
#endif /* SCM_ERRORS_H */
/* -*-C-*-
-$Id: extern.c,v 9.43 2007/01/12 03:45:55 cph Exp $
+$Id: extern.c,v 9.44 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
procedure), it finds the number for the external representation for\n\
the internal address.")
{
- fast SCHEME_OBJECT tc;
- fast SCHEME_OBJECT address;
+ SCHEME_OBJECT tc;
+ SCHEME_OBJECT address;
PRIMITIVE_HEADER (2);
tc = (arg_nonnegative_integer (1));
address = (ARG_REF (2));
{
case TC_RETURN_CODE:
{
- fast long number = (OBJECT_DATUM (address));
+ long number = (OBJECT_DATUM (address));
if (number > MAX_RETURN_CODE)
error_bad_range_arg (2);
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (number));
PRIMITIVE_HEADER (1);
CHECK_ARG (1, PRIMITIVE_P);
{
- fast SCHEME_OBJECT primitive = (ARG_REF (1));
+ SCHEME_OBJECT primitive = (ARG_REF (1));
if ((PRIMITIVE_NUMBER (primitive))
> ((unsigned long) (NUMBER_OF_PRIMITIVES ())))
error_bad_range_arg (1);
> ((unsigned long) (NUMBER_OF_PRIMITIVES ())))
error_bad_range_arg (1);
{
- CONST char * answer = (PRIMITIVE_DOCUMENTATION (primitive));
+ const char * answer = (PRIMITIVE_DOCUMENTATION (primitive));
PRIMITIVE_RETURN
((answer == 0)
? SHARP_F
{
PRIMITIVE_HEADER (1);
{
- fast SCHEME_OBJECT primitive = (ARG_REF (1));
+ SCHEME_OBJECT primitive = (ARG_REF (1));
if (! ((PRIMITIVE_P (primitive)) || (FIXNUM_P (primitive))))
error_wrong_type_arg (1);
{
- fast long number = (PRIMITIVE_NUMBER (primitive));
+ long number = (PRIMITIVE_NUMBER (primitive));
if ((number < 0) || (number > (NUMBER_OF_PRIMITIVES ())))
error_bad_range_arg (1);
PRIMITIVE_RETURN (char_pointer_to_string (PRIMITIVE_NAME (primitive)));
If ARITY is an integer, a primitive object will always be returned,\n\
whether the corresponding primitive is implemented or not.")
{
- fast SCHEME_OBJECT name;
- fast SCHEME_OBJECT arity_arg;
- extern SCHEME_OBJECT EXFUN
- (find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int));
- Boolean intern_p, allow_p;
+ SCHEME_OBJECT name;
+ SCHEME_OBJECT arity_arg;
+ bool intern_p, allow_p;
long arity;
PRIMITIVE_HEADER (2);
CHECK_ARG (1, SYMBOL_P);
name = (ARG_REF (1));
- TOUCH_IN_PRIMITIVE ((ARG_REF (2)), arity_arg);
+ arity_arg = (ARG_REF (2));
if (arity_arg == SHARP_F)
{
allow_p = false;
}
PRIMITIVE_RETURN
(find_primitive
- ((FAST_MEMORY_REF (name, SYMBOL_NAME)), intern_p, allow_p, arity));
+ ((MEMORY_REF (name, SYMBOL_NAME)), intern_p, allow_p, arity));
}
/* -*-C-*-
-$Id: extern.h,v 9.68 2007/01/12 03:45:55 cph Exp $
+$Id: extern.h,v 9.69 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* External Declarations */
#ifndef SCM_EXTERN_H
-#define SCM_EXTERN_H
-\f
-#ifdef ENABLE_DEBUGGING_TOOLS
-
-extern Boolean Eval_Debug;
-extern Boolean Hex_Input_Debug;
-extern Boolean Cont_Debug;
-extern Boolean File_Load_Debug;
-extern Boolean Reloc_Debug;
-extern Boolean Intern_Debug;
-extern Boolean Primitive_Debug;
-extern Boolean Define_Debug;
-extern Boolean Lookup_Debug;
-extern Boolean GC_Debug;
-extern Boolean Upgrade_Debug;
-extern Boolean Trace_On_Error;
-extern Boolean Dump_Debug;
-extern Boolean Per_File;
-extern Boolean Bignum_Debug;
-extern Boolean Fluids_Debug;
-
-extern sp_record_list SP_List;
-extern void EXFUN (Pop_Return_Break_Point, (void));
-extern int debug_slotno;
-extern int debug_nslots;
-extern int local_slotno;
-extern int local_nslots;
-extern int debug_circle [];
-extern int local_circle [];
-
-#else /* not ENABLE_DEBUGGING_TOOLS */
-
-#define Eval_Debug false
-#define Hex_Input_Debug false
-#define File_Load_Debug false
-#define Reloc_Debug false
-#define Intern_Debug false
-#define Cont_Debug false
-#define Primitive_Debug false
-#define Lookup_Debug false
-#define Define_Debug false
-#define GC_Debug false
-#define Upgrade_Debug false
-#define Trace_On_Error false
-#define Dump_Debug false
-#define Per_File false
-#define Bignum_Debug false
-#define Fluids_Debug false
-
-#endif /* ENABLE_DEBUGGING_TOOLS */
+#define SCM_EXTERN_H 1
+#include "outf.h"
+\f
/* The register block */
-#ifdef __WIN32__
-extern SCHEME_OBJECT *RegistersPtr;
-#define Registers RegistersPtr
-#else
extern SCHEME_OBJECT Registers [];
+
+#define GET_REG_O(i) (Registers[REGBLOCK_##i])
+#define GET_REG_P(i) ((SCHEME_OBJECT *) (Registers[REGBLOCK_##i]))
+#define GET_REG_N(i) ((unsigned long) (Registers[REGBLOCK_##i]))
+
+#define SET_REG_O(i, v) ((Registers[REGBLOCK_##i]) = (v))
+#define SET_REG_P(i, v) (set_ptr_register ((REGBLOCK_##i), (v)))
+#define SET_REG_N(i, v) (set_ulong_register ((REGBLOCK_##i), (v)))
+
+extern void set_ptr_register (unsigned int, SCHEME_OBJECT *);
+extern void set_ulong_register (unsigned int, unsigned long);
+
+#define GET_MEMTOP GET_REG_P (MEMTOP)
+#define GET_INT_MASK GET_REG_N (INT_MASK)
+#define GET_VAL GET_REG_O (VAL)
+#define GET_ENV GET_REG_O (ENV)
+#define GET_CC_TEMP GET_REG_O (CC_TEMP)
+#define GET_EXP GET_REG_O (EXPR)
+#define GET_RET GET_REG_O (RETURN)
+#define GET_LEXPR_ACTUALS GET_REG_N (LEXPR_ACTUALS)
+#define GET_PRIMITIVE GET_REG_O (PRIMITIVE)
+#define GET_CLOSURE_FREE GET_REG_P (CLOSURE_FREE)
+#define GET_CLOSURE_SPACE GET_REG_P (CLOSURE_SPACE)
+#define GET_STACK_GUARD GET_REG_P (STACK_GUARD)
+#define GET_INT_CODE GET_REG_N (INT_CODE)
+#define GET_REFLECTOR GET_REG_O (REFLECT_TO_INTERFACE)
+
+#define SET_MEMTOP(v) SET_REG_P (MEMTOP, v)
+#define SET_INT_MASK(v) SET_REG_N (INT_MASK, v)
+#define SET_VAL(v) SET_REG_O (VAL, v)
+#define SET_ENV(v) SET_REG_O (ENV, v)
+#define SET_CC_TEMP(v) SET_REG_O (COMPILER_TEMP, v)
+#define SET_EXP(v) SET_REG_O (EXPR, v)
+#define SET_RET(v) SET_REG_O (RETURN, v)
+#define SET_LEXPR_ACTUALS(v) SET_REG_N (LEXPR_ACTUALS, v)
+#define SET_PRIMITIVE(v) SET_REG_O (PRIMITIVE, v)
+#define SET_CLOSURE_FREE(v) SET_REG_P (CLOSURE_FREE, v)
+#define SET_CLOSURE_SPACE(v) SET_REG_P (CLOSURE_SPACE, v)
+#define SET_STACK_GUARD(v) SET_REG_P (STACK_GUARD, v)
+#define SET_INT_CODE(v) SET_REG_N (INT_CODE, v)
+#define SET_REFLECTOR(v) SET_REG_O (REFLECT_TO_INTERFACE, v)
+
+#define PUSH_ENV() STACK_PUSH (GET_ENV)
+#define PUSH_VAL() STACK_PUSH (GET_VAL)
+#define PUSH_EXP() STACK_PUSH (GET_EXP)
+#define PUSH_RET() STACK_PUSH (GET_RET)
+
+#define POP_ENV() SET_ENV (STACK_POP ())
+#define POP_VAL() SET_VAL (STACK_POP ())
+#define POP_EXP() SET_EXP (STACK_POP ())
+#define POP_RET() SET_RET (STACK_POP ())
+
+#define GET_RC (OBJECT_DATUM (GET_RET))
+#define SET_RC(code) SET_RET (MAKE_OBJECT (TC_RETURN_CODE, (code)))
+#define PUSH_RC(code) STACK_PUSH (MAKE_OBJECT (TC_RETURN_CODE, (code)))
+\f
+#ifdef ENABLE_DEBUGGING_TOOLS
+ extern bool Eval_Debug;
+ extern bool Hex_Input_Debug;
+ extern bool Cont_Debug;
+ extern bool File_Load_Debug;
+ extern bool Reloc_Debug;
+ extern bool Intern_Debug;
+ extern bool Primitive_Debug;
+ extern bool Define_Debug;
+ extern bool Lookup_Debug;
+ extern bool GC_Debug;
+ extern bool Upgrade_Debug;
+ extern bool Trace_On_Error;
+ extern bool Dump_Debug;
+ extern bool Per_File;
+ extern bool Bignum_Debug;
+
+ extern void Pop_Return_Break_Point (void);
+ extern unsigned int debug_slotno;
+ extern unsigned int debug_nslots;
+ extern unsigned int local_slotno;
+ extern unsigned int local_nslots;
+ extern unsigned int debug_circle [];
+ extern unsigned int local_circle [];
+#else
+# define Eval_Debug 0
+# define Hex_Input_Debug 0
+# define File_Load_Debug 0
+# define Reloc_Debug 0
+# define Intern_Debug 0
+# define Cont_Debug 0
+# define Primitive_Debug 0
+# define Lookup_Debug 0
+# define Define_Debug 0
+# define GC_Debug 0
+# define Upgrade_Debug 0
+# define Trace_On_Error 0
+# define Dump_Debug 0
+# define Per_File 0
+# define Bignum_Debug 0
#endif
-extern SCHEME_OBJECT
- * MemTop, /* Top of free space available */
- * Free, /* Next free word in heap */
- * Heap_Top, /* Top of current heap */
- * Heap_Bottom, /* Bottom of current heap */
- * Unused_Heap_Top, /* Top of unused heap */
- * Unused_Heap_Bottom, /* Bottom of unused heap */
- * Stack_Guard, /* Guard area at end of stack */
- * sp_register, /* Next available slot in control stack */
- * Stack_Bottom, /* Bottom of control stack */
- * Stack_Top, /* Top of control stack */
- * Free_Constant, /* Next free word in constant space */
- * Constant_Space, /* Bottom of constant+pure space */
- * Constant_Top, /* Top of constant+pure space */
- * Local_Heap_Base, /* Per-processor CONSing area */
- * Free_Stacklets, /* Free list of stacklets */
- * history_register, /* History register */
- Current_State_Point, /* Dynamic state point */
- Fluid_Bindings; /* Fluid bindings AList */
+extern SCHEME_OBJECT * Free;
+extern SCHEME_OBJECT * heap_alloc_limit;
+extern SCHEME_OBJECT * heap_start;
+extern SCHEME_OBJECT * heap_end;
+
+extern SCHEME_OBJECT * stack_pointer;
+extern SCHEME_OBJECT * stack_guard;
+extern SCHEME_OBJECT * stack_start;
+extern SCHEME_OBJECT * stack_end;
+
+extern SCHEME_OBJECT * constant_alloc_next;
+extern SCHEME_OBJECT * constant_start;
+extern SCHEME_OBJECT * constant_end;
+
+extern SCHEME_OBJECT current_state_point;
\f
/* Address of the most recent return code in the stack. This is
- only meaningful while in compiled code. *** This must be changed
- when stacklets are used. *** */
+ only meaningful while in compiled code. */
extern SCHEME_OBJECT * last_return_code;
+extern SCHEME_OBJECT fixed_objects;
-/* Return code/address used by the compiled code interface to make
- compiled code return to the interpreter. */
-extern SCHEME_OBJECT return_to_interpreter;
+extern char * CONT_PRINT_RETURN_MESSAGE;
+extern char * CONT_PRINT_EXPR_MESSAGE;
+extern char * RESTORE_CONT_RETURN_MESSAGE;
+extern char * RESTORE_CONT_EXPR_MESSAGE;
-extern Declare_Fixed_Objects ();
+extern unsigned long MAX_RETURN;
-extern long
- temp_long, /* temporary for sign extension */
- GC_Reserve, /* Scheme pointer overflow space in heap */
- GC_Space_Needed; /* Amount of space needed when GC triggered */
+extern const char * Return_Names [];
+extern const char * type_names [];
+extern const char * Abort_Names [];
+extern const char * Error_Names [];
+extern const char * Term_Names [];
+extern const char * term_messages [];
-extern char * Return_Names [];
-extern long MAX_RETURN;
+extern bool trapping;
-extern char
- * CONT_PRINT_RETURN_MESSAGE,
- * CONT_PRINT_EXPR_MESSAGE,
- * RESTORE_CONT_RETURN_MESSAGE,
- * RESTORE_CONT_EXPR_MESSAGE;
-
-extern int GC_Type_Map [];
+extern const char * scheme_program_name;
+extern const char * OS_Name;
+extern const char * OS_Variant;
+extern struct obstack scratch_obstack;
-extern Boolean Trapping;
-extern SCHEME_OBJECT Old_Return_Code;
-extern SCHEME_OBJECT * Return_Hook_Address;
+extern unsigned long n_heap_blocks;
+extern unsigned long n_constant_blocks;
+extern unsigned long n_stack_blocks;
-extern SCHEME_OBJECT * Prev_Restore_History_Stacklet;
-extern long Prev_Restore_History_Offset;
+extern SCHEME_OBJECT * memory_block_start;
+extern SCHEME_OBJECT * memory_block_end;
-extern CONST char * scheme_program_name;
-extern CONST char * OS_Name;
-extern CONST char * OS_Variant;
-extern struct obstack scratch_obstack;
+extern unsigned long heap_reserved;
-extern long Heap_Size;
-extern long Constant_Size;
-extern long Stack_Size;
-extern SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address;
+/* Amount of space needed when GC requested */
+extern unsigned long gc_space_needed;
\f
/* Arithmetic utilities */
-extern long EXFUN (fixnum_to_long, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (double_to_fixnum, (double));
-extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
-extern Boolean EXFUN (integer_to_long_p, (SCHEME_OBJECT));
-extern long EXFUN (integer_to_long, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
-extern Boolean EXFUN (integer_to_ulong_p, (SCHEME_OBJECT));
-extern unsigned long EXFUN (integer_to_ulong, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (ulong_to_integer, (unsigned long));
-extern Boolean EXFUN (integer_to_double_p, (SCHEME_OBJECT));
-extern double EXFUN (integer_to_double, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (double_to_integer, (double));
-extern double EXFUN (double_truncate, (double));
-extern Boolean EXFUN (real_number_to_double_p, (SCHEME_OBJECT));
-extern double EXFUN (real_number_to_double, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (bignum_to_fixnum, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (bignum_to_integer, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (bignum_to_flonum, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (flonum_floor, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (flonum_ceiling, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (flonum_round, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (flonum_normalize, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (flonum_denormalize,
- (SCHEME_OBJECT, SCHEME_OBJECT));
-extern Boolean EXFUN (integer_zero_p, (SCHEME_OBJECT));
-extern Boolean EXFUN (integer_negative_p, (SCHEME_OBJECT));
-extern Boolean EXFUN (integer_positive_p, (SCHEME_OBJECT));
-extern Boolean EXFUN (integer_equal_p, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern Boolean EXFUN (integer_less_p, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (integer_negate, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (integer_add, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (integer_add_1, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (integer_subtract, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (integer_subtract_1, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (integer_multiply, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern Boolean EXFUN (integer_divide,
- (SCHEME_OBJECT, SCHEME_OBJECT,
- SCHEME_OBJECT *, SCHEME_OBJECT *));
-extern SCHEME_OBJECT EXFUN (integer_quotient, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (integer_remainder, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (integer_length_in_bits, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN
- (integer_shift_left, (SCHEME_OBJECT, SCHEME_OBJECT));
+extern SCHEME_OBJECT Mul (SCHEME_OBJECT, SCHEME_OBJECT);
+extern long fixnum_to_long (SCHEME_OBJECT);
+extern SCHEME_OBJECT double_to_fixnum (double);
+extern bool integer_to_long_p (SCHEME_OBJECT);
+extern long integer_to_long (SCHEME_OBJECT);
+extern SCHEME_OBJECT long_to_integer (long);
+extern bool integer_to_ulong_p (SCHEME_OBJECT);
+extern unsigned long integer_to_ulong (SCHEME_OBJECT);
+extern SCHEME_OBJECT ulong_to_integer (unsigned long);
+extern bool integer_to_double_p (SCHEME_OBJECT);
+extern double integer_to_double (SCHEME_OBJECT);
+extern SCHEME_OBJECT double_to_integer (double);
+extern double double_truncate (double);
+extern double double_round (double);
+extern SCHEME_OBJECT bignum_to_fixnum (SCHEME_OBJECT);
+extern SCHEME_OBJECT bignum_to_integer (SCHEME_OBJECT);
+extern SCHEME_OBJECT bignum_to_flonum (SCHEME_OBJECT);
+extern bool flonum_integer_p (SCHEME_OBJECT);
+extern SCHEME_OBJECT flonum_floor (SCHEME_OBJECT);
+extern SCHEME_OBJECT flonum_ceiling (SCHEME_OBJECT);
+extern SCHEME_OBJECT flonum_round (SCHEME_OBJECT);
+extern SCHEME_OBJECT flonum_normalize (SCHEME_OBJECT);
+extern SCHEME_OBJECT flonum_denormalize (SCHEME_OBJECT, SCHEME_OBJECT);
+extern bool integer_zero_p (SCHEME_OBJECT);
+extern bool integer_negative_p (SCHEME_OBJECT);
+extern bool integer_positive_p (SCHEME_OBJECT);
+extern bool integer_equal_p (SCHEME_OBJECT, SCHEME_OBJECT);
+extern bool integer_less_p (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_negate (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_add (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_add_1 (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_subtract (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_subtract_1 (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_multiply (SCHEME_OBJECT, SCHEME_OBJECT);
+extern bool integer_divide
+ (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, SCHEME_OBJECT *);
+extern SCHEME_OBJECT integer_quotient (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_remainder (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_length_in_bits (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_shift_left (SCHEME_OBJECT, unsigned long);
+
+extern SCHEME_OBJECT double_to_flonum (double);
+extern bool real_number_to_double_p (SCHEME_OBJECT);
+extern double real_number_to_double (SCHEME_OBJECT);
/* Character utilities */
-extern long EXFUN (char_downcase, (long));
-extern long EXFUN (char_upcase, (long));
+extern long char_downcase (long);
+extern long char_upcase (long);
/* Allocation utilities */
-extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (system_pair_cons,
- (long, SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (hunk3_cons,
- (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (allocate_non_marked_vector, (int, long, Boolean));
-extern SCHEME_OBJECT EXFUN (allocate_marked_vector, (int, long, Boolean));
-extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
-extern SCHEME_OBJECT EXFUN (allocate_string, (unsigned long));
-extern SCHEME_OBJECT EXFUN (allocate_string_no_gc, (unsigned long));
-extern SCHEME_OBJECT EXFUN (memory_to_string, (unsigned long, CONST void *));
-extern SCHEME_OBJECT EXFUN
- (memory_to_string_no_gc, (unsigned long, CONST void *));
-extern SCHEME_OBJECT EXFUN (char_pointer_to_string, (CONST char *));
-extern SCHEME_OBJECT EXFUN (char_pointer_to_string_no_gc, (CONST char *));
-extern CONST char * EXFUN (arg_symbol, (int));
-extern CONST char * EXFUN (arg_interned_symbol, (int));
-extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (char_pointer_to_symbol, (CONST char *));
-extern SCHEME_OBJECT EXFUN (memory_to_symbol, (unsigned long, CONST char *));
-extern SCHEME_OBJECT EXFUN (find_symbol, (unsigned long, CONST char *));
-
+extern SCHEME_OBJECT cons (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT system_pair_cons (long, SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT hunk3_cons (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT allocate_vector
+ (unsigned int, unsigned int, unsigned long, SCHEME_OBJECT **);
+extern SCHEME_OBJECT allocate_non_marked_vector
+ (unsigned int, unsigned long, bool);
+extern SCHEME_OBJECT allocate_marked_vector
+ (unsigned int, unsigned long, bool);
+extern SCHEME_OBJECT make_vector (unsigned long, SCHEME_OBJECT, bool);
+extern SCHEME_OBJECT allocate_string (unsigned long);
+extern SCHEME_OBJECT allocate_string_no_gc (unsigned long);
+extern SCHEME_OBJECT memory_to_string (unsigned long, const void *);
+extern SCHEME_OBJECT memory_to_string_no_gc (unsigned long, const void *);
+extern SCHEME_OBJECT char_pointer_to_string (const char *);
+extern SCHEME_OBJECT char_pointer_to_string_no_gc (const char *);
+extern SCHEME_OBJECT allocate_bit_string (unsigned long);
+extern const char * arg_symbol (int);
+extern const char * arg_interned_symbol (int);
+extern SCHEME_OBJECT intern_symbol (SCHEME_OBJECT);
+extern SCHEME_OBJECT string_to_symbol (SCHEME_OBJECT);
+extern SCHEME_OBJECT char_pointer_to_symbol (const char *);
+extern SCHEME_OBJECT memory_to_symbol (unsigned long, const void *);
+extern SCHEME_OBJECT find_symbol (unsigned long, const char *);
/* Random and OS utilities */
-extern Boolean EXFUN (Restore_History, (SCHEME_OBJECT));
-extern Boolean EXFUN (interpreter_applicable_p, (SCHEME_OBJECT));
-extern void EXFUN
- (add_reload_cleanup, (void EXFUN ((*cleanup_procedure), (void))));
+extern int strcmp_ci (const char *, const char *);
+extern bool interpreter_applicable_p (SCHEME_OBJECT);
+extern void add_reload_cleanup (void (*) (void));
+extern void execute_reload_cleanups (void);
+extern void clear_bit_string (SCHEME_OBJECT);
+extern void bit_string_set (SCHEME_OBJECT, long, int);
+extern unsigned char * lookup_external_string (SCHEME_OBJECT, unsigned long *);
/* Memory management utilities */
-
-extern Boolean EXFUN (Pure_Test, (SCHEME_OBJECT *));
+extern bool object_in_constant_space_p (SCHEME_OBJECT);
+extern SCHEME_OBJECT * copy_to_constant_space (SCHEME_OBJECT *, unsigned long);
+
+extern void setup_memory (unsigned long, unsigned long, unsigned long);
+extern void reset_memory (void);
+
+/* Utilities for primitives */
+
+typedef struct
+{
+ unsigned long * internal;
+ unsigned long * external;
+ unsigned long next_code;
+} prim_renumber_t;
+
+extern prim_renumber_t * make_prim_renumber (void);
+extern SCHEME_OBJECT renumber_primitive (SCHEME_OBJECT, prim_renumber_t *);
+extern unsigned long renumbered_primitives_export_length (prim_renumber_t *);
+extern void export_renumbered_primitives (SCHEME_OBJECT *, prim_renumber_t *);
+extern unsigned long primitive_table_export_length (void);
+extern void export_primitive_table (SCHEME_OBJECT *);
+
+extern void import_primitive_table
+ (SCHEME_OBJECT *, unsigned long, SCHEME_OBJECT *);
+
+extern void initialize_primitives (void);
+extern SCHEME_OBJECT make_primitive (const char *, int);
+extern SCHEME_OBJECT find_primitive (SCHEME_OBJECT, bool, bool, int);
\f
/* Interpreter utilities */
-extern void EXFUN (Microcode_Termination, (int code));
-extern void EXFUN (termination_normal, (CONST int));
-extern void EXFUN (termination_init_error, (void));
-extern void EXFUN (termination_end_of_computation, (void));
-extern void EXFUN (termination_trap, (void));
-extern void EXFUN (termination_no_error_handler, (void));
-extern void EXFUN (termination_gc_out_of_space, (void));
-extern void EXFUN (termination_eof, (void));
-extern void EXFUN (termination_signal, (CONST char * signal_name));
-
-extern void EXFUN (Setup_Interrupt, (long Masked_Interrupts));
-extern void EXFUN (preserve_interrupt_mask, (void));
-extern void EXFUN (back_out_of_primitive, (void));
-
-extern void EXFUN (Interpret, (int));
-extern void EXFUN (Do_Micro_Error, (long, Boolean));
-extern void EXFUN (Translate_To_Point, (SCHEME_OBJECT));
-extern void EXFUN (Stop_History, (void));
-extern void EXFUN (Stack_Death, (void));
-
-extern SCHEME_OBJECT * EXFUN (Make_Dummy_History, (void));
-extern SCHEME_OBJECT EXFUN (Find_State_Space, (SCHEME_OBJECT));
+extern void Microcode_Termination (int code) NORETURN;
+extern void termination_normal (const int) NORETURN;
+extern void termination_init_error (void) NORETURN;
+extern void termination_end_of_computation (void) NORETURN;
+extern void termination_trap (void) NORETURN;
+extern void termination_no_error_handler (void) NORETURN;
+extern void termination_gc_out_of_space (void) NORETURN;
+extern void termination_eof (void) NORETURN;
+extern void termination_signal (const char * signal_name) NORETURN;
+
+extern void setup_interrupt (unsigned long);
+extern void preserve_interrupt_mask (void);
+extern void canonicalize_primitive_context (void);
+extern void back_out_of_primitive (void);
+
+extern void Interpret (void);
+extern void Do_Micro_Error (long, bool);
+extern void Translate_To_Point (SCHEME_OBJECT);
+extern void Stack_Death (void) NORETURN;
+extern SCHEME_OBJECT * control_point_start (SCHEME_OBJECT);
+extern SCHEME_OBJECT * control_point_end (SCHEME_OBJECT);
+extern void unpack_control_point (SCHEME_OBJECT);
+
+extern SCHEME_OBJECT Find_State_Space (SCHEME_OBJECT);
/* Debugging utilities */
-extern void EXFUN (debug_edit_flags, (void));
-
-extern void EXFUN (Back_Trace, (outf_channel));
-extern void EXFUN (Debug_Stack_Trace, (void));
-extern void EXFUN (Debug_Print, (SCHEME_OBJECT, Boolean));
-extern void EXFUN (Show_Env, (SCHEME_OBJECT));
-extern void EXFUN (Show_Pure, (void));
-extern void EXFUN (Print_Return, (char *));
-extern void EXFUN (Print_Expression, (SCHEME_OBJECT, char *));
-extern void EXFUN (Print_Primitive, (SCHEME_OBJECT));
-
-/* Conditional utilities */
-
-#ifdef USE_STACKLETS
-extern void EXFUN (Allocate_New_Stacklet, (long));
-#endif
-
-#if FALSE
-extern void EXFUN (Clear_Perfinfo_Data, (void));
-#endif
+extern void Back_Trace (outf_channel);
+extern void Debug_Stack_Trace (void);
+extern void Debug_Print (SCHEME_OBJECT, bool);
+extern void Show_Env (SCHEME_OBJECT);
+extern void Print_Return (char *);
+extern void Print_Expression (SCHEME_OBJECT, char *);
+extern void Print_Primitive (SCHEME_OBJECT);
#endif /* not SCM_EXTERN_H */
/* -*-C-*-
-$Id: fasdump.c,v 9.70 2007/01/05 21:19:25 cph Exp $
+$Id: fasdump.c,v 9.71 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "trap.h"
#include "lookup.h"
#include "fasl.h"
+#include <setjmp.h>
-static Tchannel dump_channel;
-
-#define Write_Data(size, buffer) \
- ((long) \
- ((OS_channel_write_dump_file \
- (dump_channel, \
- ((char *) (buffer)), \
- ((size) * (sizeof (SCHEME_OBJECT))))) \
- / (sizeof (SCHEME_OBJECT))))
-
-#include "dump.c"
-
-extern SCHEME_OBJECT
- EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)),
- * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)),
- * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
- * EXFUN (cons_whole_primitive_table,
- (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
- * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
-\f
-/* Some statics used freely in this file */
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+# define SAVE_GC_VARS save_gc_vars
+ static void save_gc_vars (void);
+# define COMPARE_GC_VARS compare_gc_vars
+ static void compare_gc_vars (void);
+# ifdef HAVE_MHASH_H
+# include <mhash.h>
+# define SAVE_MEMORY_CHECKSUM save_memory_checksum
+ static void save_memory_checksum (void);
+# define COMPARE_MEMORY_CHECKSUM compare_memory_checksum
+ static void compare_memory_checksum (void);
+ static void * compute_memory_checksum (void);
+# endif
+#else
+# define SAVE_GC_VARS() do {} while (false)
+# define COMPARE_GC_VARS() do {} while (false)
+#endif
-static SCHEME_OBJECT *NewFree, *NewMemTop, *Fixup;
-static Boolean compiled_code_present_p;
-static CONST char * dump_file_name = ((char *) 0);
+#ifndef SAVE_MEMORY_CHECKSUM
+# define SAVE_MEMORY_CHECKSUM() do {} while (false)
+# define COMPARE_MEMORY_CHECKSUM() do {} while (false)
+#endif
-/* FASDUMP:
+typedef enum { FE_ERROR, FE_DUMP, FE_DROP_CC } env_mode_t;
- Hair squared! ... in order to dump an object it must be traced (as
- in a garbage collection), but with some significant differences.
- First, the copy must have the global value cell of symbols set to
- UNBOUND and variables uncompiled. Second, and worse, all the
- broken hearts created during the process must be restored to their
- original values. This last is done by growing the copy of the
- object in the bottom of spare heap, keeping track of the locations
- of broken hearts and original contents at the top of the spare
- heap.
-
- FASDUMP is called with three arguments:
- Argument 1: Object to dump.
- Argument 2: File name.
- Argument 3: Flag.
- Currently, flag is ignored.
-*/
+typedef struct
+{
+ const char * filename;
+ fasl_file_handle_t handle;
+} fasl_file_info_t;
+
+static void close_fasl_file (void *);
+static gc_walk_proc_t save_tospace_write;
+
+static fasl_header_t fasl_header;
+static fasl_header_t * fh;
+static env_mode_t current_env_mode;
+static prim_renumber_t * current_pr;
+static bool cc_seen_p;
+
+static gc_table_t * fasdump_table (void);
+static gc_handler_t handle_primitive;
+static gc_handler_t handle_manifest_closure;
+static gc_handler_t handle_linkage_section;
+static gc_handler_t handle_symbol;
+static gc_handler_t handle_broken_heart;
+static gc_handler_t handle_variable;
+static gc_handler_t handle_environment;
+
+static gc_object_handler_t fasdump_cc_entry;
+static gc_precheck_from_t fasdump_precheck_from;
+static gc_transport_words_t fasdump_transport_words;
+
+static void initialize_fixups (void);
+static void add_fixup (SCHEME_OBJECT *);
+static void run_fixups (void *);
+
+static void initialize_fasl_header (bool);
+static bool write_fasl_file
+ (SCHEME_OBJECT *, SCHEME_OBJECT *, fasl_file_handle_t);
\f
-/*
- Copy of GCLoop, except (a) copies out of constant space into the
- object to be dumped; (b) changes symbols and variables as
- described; (c) keeps track of broken hearts and their original
- contents (e) To_Pointer is now NewFree.
-*/
-
-#define Setup_Pointer_for_Dump(Extra_Code) \
- Dump_Pointer (Fasdump_Setup_Pointer (Extra_Code, \
- Normal_BH (false, continue)))
-
-#define Dump_Pointer(Code) \
- Old = (OBJECT_ADDRESS (Temp)); \
- Code
+/* FASDUMP:
-#define DUMP_RAW_POINTER(Code) \
- Old = (SCHEME_ADDR_TO_ADDR (Temp)); \
- Code
+ In order to dump an object it must be traced (as in a garbage
+ collection), but with some significant differences. First, the
+ copy must have the global value cell of symbols set to UNBOUND.
+ Second, and worse, all the broken hearts created during the process
+ must be restored to their original values. This last is done by
+ growing the copy of the object in the bottom of spare heap, keeping
+ track of the locations of broken hearts and original contents at
+ the top of the spare heap. */
+
+DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3,
+ "(OBJECT NAMESTRING FLAG)\n\
+Writes a binary representation of OBJECT to the file NAMESTRING.\n\
+Returns #T if the operation is successful, or #F otherwise.\n\
+\n\
+FLAG specifies how to handle environment objects that OBJECT points\n\
+to: #F means generate an error; #T means write them as ordinary\n\
+objects; any other value is like #F except that environments pointed\n\
+at by compiled code are ignored (and discarded).")
+{
+ fasl_file_info_t ff_info;
+ SCHEME_OBJECT * new_heap_start;
+ SCHEME_OBJECT * prim_table_start;
+ unsigned long prim_table_length;
+ bool ok;
+ PRIMITIVE_HEADER (3);
-/* This depends on the fact that the last word in a compiled code block
- contains the environment, and that To will be pointing to the word
- immediately after that!
- */
+ SAVE_GC_VARS ();
+ SAVE_MEMORY_CHECKSUM ();
+
+ transaction_begin (); /* 1 */
+ (ff_info . filename) = (STRING_ARG (2));
+ if (!open_fasl_output_file ((ff_info . filename), (& (ff_info . handle))))
+ error_bad_range_arg (2);
+ transaction_record_action (tat_always, close_fasl_file, (&ff_info));
+
+ open_tospace (heap_start);
+ initialize_fixups ();
+
+ new_heap_start = (get_newspace_ptr ());
+ add_to_tospace (ARG_REF (1));
+
+ transaction_begin (); /* 2 */
+
+ current_gc_table = (fasdump_table ());
+ current_env_mode
+ = (((ARG_REF (3)) == SHARP_F)
+ ? FE_ERROR
+ : ((ARG_REF (3)) == SHARP_T)
+ ? FE_DUMP
+ : FE_DROP_CC);
+ current_pr = (make_prim_renumber ());
+ cc_seen_p = false;
+ gc_scan_tospace (new_heap_start, 0);
+
+ prim_table_start = (get_newspace_ptr ());
+ prim_table_length = (renumbered_primitives_export_length (current_pr));
+ increment_tospace_ptr (prim_table_length);
+ export_renumbered_primitives
+ ((newspace_to_tospace (prim_table_start)), current_pr);
+
+ transaction_commit (); /* 2 */
+
+ initialize_fasl_header (cc_seen_p);
+ (FASLHDR_BAND_P (fh)) = false;
+ (FASLHDR_CONSTANT_START (fh)) = new_heap_start;
+ (FASLHDR_CONSTANT_END (fh)) = new_heap_start;
+ (FASLHDR_HEAP_START (fh)) = new_heap_start;
+ (FASLHDR_HEAP_END (fh)) = prim_table_start;
+ (FASLHDR_ROOT_POINTER (fh)) = new_heap_start;
+ (FASLHDR_N_PRIMITIVES (fh)) = (current_pr->next_code);
+ (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)) = prim_table_length;
+
+ ok = ((write_fasl_header (fh, (ff_info . handle)))
+ && (save_tospace (save_tospace_write, (&ff_info))));
+ transaction_commit (); /* 1 */
+
+ COMPARE_GC_VARS ();
+ COMPARE_MEMORY_CHECKSUM ();
+
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (ok));
+}
-#define Fasdump_Transport_Compiled() \
-{ \
- Transport_Compiled (); \
- if ((mode == 2) && ((OBJECT_TYPE (*(To - 1))) == TC_ENVIRONMENT)) \
- *(To - 1) = SHARP_F; \
+static void
+close_fasl_file (void * p)
+{
+ fasl_file_info_t * ff_info = p;
+ if (!close_fasl_output_file (ff_info->handle))
+ OS_file_remove (ff_info->filename);
}
-#define FASDUMP_TRANSPORT_RAW_COMPILED() \
-{ \
- TRANSPORT_RAW_COMPILED (); \
- if ((mode == 2) && ((OBJECT_TYPE (*(To - 1))) == TC_ENVIRONMENT)) \
- *(To - 1) = SHARP_F; \
+static bool
+save_tospace_write (SCHEME_OBJECT * start, SCHEME_OBJECT * end, void * p)
+{
+ fasl_file_info_t * ff_info = p;
+ return (write_to_fasl_file (start, (end - start), (ff_info->handle)));
}
+\f
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
-#define Dump_Compiled_Entry(label) \
-{ \
- Dump_Pointer \
- (Fasdump_Setup_Aligned (Fasdump_Transport_Compiled (), \
- Compiled_BH (false, goto label))); \
+static SCHEME_OBJECT * fasdump_saved_Free;
+static SCHEME_OBJECT * fasdump_saved_heap_alloc_limit;
+static SCHEME_OBJECT * fasdump_saved_heap_start;
+static SCHEME_OBJECT * fasdump_saved_heap_end;
+static SCHEME_OBJECT * fasdump_saved_stack_pointer;
+static SCHEME_OBJECT * fasdump_saved_stack_guard;
+static SCHEME_OBJECT * fasdump_saved_stack_start;
+static SCHEME_OBJECT * fasdump_saved_stack_end;
+static SCHEME_OBJECT * fasdump_saved_constant_alloc_next;
+static SCHEME_OBJECT * fasdump_saved_constant_start;
+static SCHEME_OBJECT * fasdump_saved_constant_end;
+
+#define SAVE_GC_VAR(name) fasdump_saved_##name = name
+
+static void
+save_gc_vars (void)
+{
+ SAVE_GC_VAR (Free);
+ SAVE_GC_VAR (heap_alloc_limit);
+ SAVE_GC_VAR (heap_start);
+ SAVE_GC_VAR (heap_end);
+ SAVE_GC_VAR (stack_pointer);
+ SAVE_GC_VAR (stack_guard);
+ SAVE_GC_VAR (stack_start);
+ SAVE_GC_VAR (stack_end);
+ SAVE_GC_VAR (constant_alloc_next);
+ SAVE_GC_VAR (constant_start);
+ SAVE_GC_VAR (constant_end);
}
-#define DUMP_RAW_COMPILED_ENTRY(label) \
+#define COMPARE_GC_VAR(name) do \
{ \
- DUMP_RAW_POINTER \
- (Fasdump_Setup_Aligned (FASDUMP_TRANSPORT_RAW_COMPILED (), \
- RAW_COMPILED_BH (false, \
- goto label))); \
+ if (fasdump_saved_##name != name) \
+ outf_error ("GC variable changed: " #name ": %p -> %p\n", \
+ fasdump_saved_##name, name); \
+} while (false)
+
+static void
+compare_gc_vars (void)
+{
+ COMPARE_GC_VAR (Free);
+ COMPARE_GC_VAR (heap_alloc_limit);
+ COMPARE_GC_VAR (heap_start);
+ COMPARE_GC_VAR (heap_end);
+ COMPARE_GC_VAR (stack_pointer);
+ COMPARE_GC_VAR (stack_guard);
+ COMPARE_GC_VAR (stack_start);
+ COMPARE_GC_VAR (stack_end);
+ COMPARE_GC_VAR (constant_alloc_next);
+ COMPARE_GC_VAR (constant_start);
+ COMPARE_GC_VAR (constant_end);
}
-/* Should be big enough for the largest fixed size object (a Quad)
- and 2 for the Fixup.
- */
+#ifdef HAVE_MHASH_H
-#define FASDUMP_FIX_BUFFER 10
+static void * fasdump_original_digest;
-long
-DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode)
+static void
+save_memory_checksum (void)
{
- fast SCHEME_OBJECT *To, *Old, Temp, New_Address, *Fixes;
- long result;
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
- SCHEME_OBJECT object_referencing;
-#endif
-
- To = NewFree;
- Fixes = Fixup;
+ fasdump_original_digest = (compute_memory_checksum ());
+ if (fasdump_original_digest == 0)
+ outf_error ("Unable to compute fasdump memory checksum.");
+}
- for ( ; Scan != To; Scan++)
- {
- Temp = *Scan;
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
- object_referencing = Temp;
-#endif
-\f
- Switch_by_GC_Type (Temp)
+static void
+compare_memory_checksum (void)
+{
+ if (fasdump_original_digest != 0)
{
- case TC_PRIMITIVE:
- case TC_PCOMB0:
- * Scan = (dump_renumber_primitive (* Scan));
- break;
-
- case TC_BROKEN_HEART:
- if ((OBJECT_DATUM (Temp)) != 0)
- {
- sprintf (gc_death_message_buffer,
- "dumploop: broken heart (0x%lx) in scan",
- ((long) Temp));
- gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
- /*NOTREACHED*/
- }
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += (OBJECT_DATUM (Temp));
- break;
-
- /* Compiled code relocation. */
-
- case_compiled_entry_point:
- compiled_code_present_p = true;
- Dump_Compiled_Entry (after_entry);
- after_entry:
- * Scan = Temp;
- break;
-
- case TC_MANIFEST_CLOSURE:
- {
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * area_end;
-
- compiled_code_present_p = true;
- START_CLOSURE_RELOCATION (Scan);
- Scan += 1;
- count = (MANIFEST_CLOSURE_COUNT (Scan));
- word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan));
- area_end = ((MANIFEST_CLOSURE_END (Scan, count)) - 1);
-
- while ((--count) >= 0)
- {
- Scan = ((SCHEME_OBJECT *) (word_ptr));
- word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
- EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
- DUMP_RAW_COMPILED_ENTRY (after_closure);
- after_closure:
- STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
- }
- Scan = area_end;
- END_CLOSURE_RELOCATION (Scan);
- break;
- }
-\f
- case TC_LINKAGE_SECTION:
- {
- compiled_code_present_p = true;
- switch (READ_LINKAGE_KIND (Temp))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- /* Assumes that all others are objects of type TC_QUAD without
- their type codes.
- */
-
- fast long count;
-
- Scan++;
- for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
- --count >= 0;
- Scan += 1)
- {
- Temp = (* Scan);
- DUMP_RAW_POINTER (Fasdump_Setup_Pointer
- (TRANSPORT_RAW_TRIPLE (),
- RAW_BH (false, continue)));
- }
- Scan -= 1;
- break;
- }
-
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- {
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * end_scan;
-
- START_OPERATOR_RELOCATION (Scan);
- count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
- word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
- end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
-
- while (--count >= 0)
- {
- Scan = ((SCHEME_OBJECT *) (word_ptr));
- word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
- EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
- DUMP_RAW_COMPILED_ENTRY (after_operator);
- after_operator:
- STORE_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
- }
- Scan = end_scan;
- END_OPERATOR_RELOCATION (Scan);
- break;
- }
-
- case CLOSURE_PATTERN_LINKAGE_KIND:
- Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
- break;
-
- default:
- {
- gc_death (TERM_EXIT,
- "fasdump: Unknown compiler linkage kind.",
- Scan, Free);
- /*NOTREACHED*/
- }
- }
- break;
- }
-\f
- case_Cell:
- Setup_Pointer_for_Dump (Transport_Cell ());
- break;
-
- case TC_REFERENCE_TRAP:
- if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
+ void * digest = (compute_memory_checksum ());
+ if (digest == 0)
+ outf_error ("Unable to recompute fasdump memory checksum.");
+ else
{
- /* It is a non pointer. */
- break;
+ if ((memcmp (digest,
+ fasdump_original_digest,
+ (mhash_get_block_size (MHASH_MD5))))
+ != 0)
+ outf_error ("Memory mismatch after fasdump.");
+ free (digest);
}
- /* Fall through. */
+ free (fasdump_original_digest);
+ }
+}
- case TC_WEAK_CONS:
- case_Fasdump_Pair:
- Setup_Pointer_for_Dump (Transport_Pair ());
- break;
+static void *
+compute_memory_checksum (void)
+{
+ MHASH ctx = (mhash_init (MHASH_MD5));
+ if (ctx == MHASH_FAILED)
+ return (0);
+ (void) mhash (ctx,
+ fasdump_saved_constant_start,
+ ((fasdump_saved_constant_alloc_next
+ - fasdump_saved_constant_start)
+ * SIZEOF_SCHEME_OBJECT));
+ (void) mhash (ctx,
+ fasdump_saved_heap_start,
+ ((fasdump_saved_Free - fasdump_saved_heap_start)
+ * SIZEOF_SCHEME_OBJECT));
+ return (mhash_end (ctx));
+}
- case TC_INTERNED_SYMBOL:
- Setup_Pointer_for_Dump (Fasdump_Symbol (BROKEN_HEART_ZERO));
- break;
+#endif /* HAVE_MHASH_H */
+#endif /* ENABLE_GC_DEBUGGING_TOOLS */
+\f
+static gc_table_t *
+fasdump_table (void)
+{
+ static bool initialized_p = false;
+ static gc_table_t table;
- case TC_UNINTERNED_SYMBOL:
- Setup_Pointer_for_Dump (Fasdump_Symbol (UNBOUND_OBJECT));
- break;
+ if (!initialized_p)
+ {
+ initialize_gc_table ((&table), true);
+
+ (GCT_CC_ENTRY ((&table))) = fasdump_cc_entry;
+ (GCT_PRECHECK_FROM ((&table))) = fasdump_precheck_from;
+ (GCT_TRANSPORT_WORDS ((&table))) = fasdump_transport_words;
+
+ (GCT_ENTRY ((&table), TC_PRIMITIVE)) = handle_primitive;
+ (GCT_ENTRY ((&table), TC_PCOMB0)) = handle_primitive;
+ (GCT_ENTRY ((&table), TC_MANIFEST_CLOSURE)) = handle_manifest_closure;
+ (GCT_ENTRY ((&table), TC_LINKAGE_SECTION)) = handle_linkage_section;
+ (GCT_ENTRY ((&table), TC_INTERNED_SYMBOL)) = handle_symbol;
+ (GCT_ENTRY ((&table), TC_BROKEN_HEART)) = handle_broken_heart;
+ (GCT_ENTRY ((&table), TC_UNINTERNED_SYMBOL)) = handle_symbol;
+ (GCT_ENTRY ((&table), TC_VARIABLE)) = handle_variable;
+ (GCT_ENTRY ((&table), TC_ENVIRONMENT)) = handle_environment;
+ (GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair;
+
+ initialized_p = true;
+ }
+ return (&table);
+}
- case_Triple:
- Setup_Pointer_for_Dump (Transport_Triple ());
- break;
+static
+DEFINE_GC_OBJECT_HANDLER (fasdump_cc_entry)
+{
+#ifdef CC_SUPPORT_P
+ SCHEME_OBJECT * old_addr;
+ SCHEME_OBJECT * new_addr;
+ unsigned long length;
+ SCHEME_OBJECT * eptr;
+
+ cc_seen_p = true;
+ old_addr = (cc_entry_to_block_address (object));
+ if (old_addr == (OBJECT_ADDRESS (compiler_utilities)))
+ return (object);
+ new_addr = (GC_PRECHECK_FROM (old_addr));
+ if (new_addr == 0)
+ {
+ length = (OBJECT_DATUM (*old_addr));
+ new_addr = (GC_TRANSPORT_WORDS (old_addr, (1 + length), true));
+ eptr = (new_addr + length);
+ if ((current_env_mode == FE_DROP_CC)
+ && ((OBJECT_TYPE (read_tospace (eptr))) == TC_ENVIRONMENT))
+ write_tospace (eptr, SHARP_F);
+ }
+ return (CC_ENTRY_NEW_BLOCK (object, new_addr, old_addr));
+#else
+ gc_no_cc_support ();
+ return (object);
+#endif
+}
- case TC_VARIABLE:
- Setup_Pointer_for_Dump (Fasdump_Variable ());
- break;
-\f
- case_Quadruple:
- Setup_Pointer_for_Dump (Transport_Quadruple ());
- break;
-
- case_Aligned_Vector:
- Dump_Pointer (Fasdump_Setup_Aligned (goto Move_Vector,
- Normal_BH (false, continue)));
- break;
-
- case_Purify_Vector:
- process_vector:
- Setup_Pointer_for_Dump (Transport_Vector ());
- break;
-
- case TC_ENVIRONMENT:
- if (mode == 1)
- goto process_vector;
- /* Make fasdump fail */
- result = ERR_FASDUMP_ENVIRONMENT;
- goto exit_dumploop;
-
- case TC_FUTURE:
- Setup_Pointer_for_Dump (Transport_Future ());
- break;
-
- default:
- GC_BAD_TYPE ("dumploop", Temp);
- /* Fall Through */
-
- case TC_STACK_ENVIRONMENT:
- case_Fasload_Non_Pointer:
- break;
- }
- }
- result = PRIM_DONE;
+static
+DEFINE_GC_PRECHECK_FROM (fasdump_precheck_from)
+{
+ return ((BROKEN_HEART_P (*from)) ? (OBJECT_ADDRESS (*from)) : 0);
+}
-exit_dumploop:
- NewFree = To;
- Fixup = Fixes;
- return (result);
+static
+DEFINE_GC_TRANSPORT_WORDS (fasdump_transport_words)
+{
+ /* Signal error here if insufficient space -- otherwise
+ gc_transport_words() might terminate the microcode. */
+ if (!tospace_available_p (n_words))
+ signal_error_from_primitive (ERR_FASDUMP_OBJECT_TOO_LARGE);
+ add_fixup (from);
+ return (gc_transport_words (from, n_words, align_p));
}
\f
-#define DUMPLOOP(obj, mode) \
-{ \
- long value; \
- \
- value = (DumpLoop (obj, mode)); \
- if (value != PRIM_DONE) \
- { \
- PRIMITIVE_RETURN (Fasdump_Exit (value, false)); \
- } \
+static
+DEFINE_GC_HANDLER (handle_primitive)
+{
+ (*scan) = (renumber_primitive (object, current_pr));
+ return (scan + 1);
}
-#define FASDUMP_INTERRUPT() \
-{ \
- PRIMITIVE_RETURN (Fasdump_Exit (PRIM_INTERRUPT, false)); \
+static
+DEFINE_GC_HANDLER (handle_manifest_closure)
+{
+ cc_seen_p = true;
+ return (gc_handle_manifest_closure (scan, object));
}
-SCHEME_OBJECT
-DEFUN (Fasdump_Exit, (code, close_p), long code AND Boolean close_p)
+static
+DEFINE_GC_HANDLER (handle_linkage_section)
{
- Boolean result;
- fast SCHEME_OBJECT *Fixes;
+ cc_seen_p = true;
+ return (gc_handle_linkage_section (scan, object));
+}
- Fixes = Fixup;
- if (close_p)
- OS_channel_close_noerror (dump_channel);
+static
+DEFINE_GC_HANDLER (handle_symbol)
+{
+ SCHEME_OBJECT * from = (OBJECT_ADDRESS (object));
+ SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from));
+ if (new_address == 0)
+ {
+ new_address = (GC_TRANSPORT_WORDS (from, 2, false));
+ write_tospace ((new_address + SYMBOL_GLOBAL_VALUE),
+ (((OBJECT_TYPE (object)) == TC_INTERNED_SYMBOL)
+ ? BROKEN_HEART_ZERO
+ : UNBOUND_OBJECT));
+ }
+ (*scan) = (OBJECT_NEW_ADDRESS (object, new_address));
+ return (scan + 1);
+}
- result = true;
- while (Fixes != NewMemTop)
- {
- fast SCHEME_OBJECT *Fix_Address;
+static
+DEFINE_GC_HANDLER (handle_broken_heart)
+{
+ return
+ (((OBJECT_DATUM (object)) == 0)
+ ? (scan + 1)
+ : (gc_handle_broken_heart (scan, object)));
+}
- Fix_Address = (OBJECT_ADDRESS (*Fixes++)); /* Where it goes. */
- *Fix_Address = *Fixes++; /* Put it there. */
- }
- Fixup = Fixes;
- if ((close_p) && ((!result) || (code != PRIM_DONE)))
- OS_file_remove (dump_file_name);
+static
+DEFINE_GC_HANDLER (handle_variable)
+{
+ SCHEME_OBJECT * from = (OBJECT_ADDRESS (object));
+ SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from));
+ if (new_address == 0)
+ {
+ new_address = (GC_TRANSPORT_WORDS (from, 3, false));
+ write_tospace ((new_address + 1), UNCOMPILED_VARIABLE);
+ write_tospace ((new_address + 2), SHARP_F);
+ }
+ (*scan) = (OBJECT_NEW_ADDRESS (object, new_address));
+ return (scan + 1);
+}
- dump_file_name = ((char *) 0);
- Fasdump_Exit_Hook ();
- if (!result)
- {
- signal_error_from_primitive (ERR_IO_ERROR);
- /*NOTREACHED*/
- return (0);
- }
- if (code == PRIM_DONE)
- return (SHARP_T);
- else if (code == PRIM_INTERRUPT)
- return (SHARP_F);
- else
- {
- signal_error_from_primitive (code);
- /*NOTREACHED*/
- return (0);
- }
+static
+DEFINE_GC_HANDLER (handle_environment)
+{
+ if (current_env_mode != FE_DUMP)
+ signal_error_from_primitive (ERR_FASDUMP_ENVIRONMENT);
+ (*scan) = (GC_HANDLE_VECTOR (object, false));
+ return (scan + 1);
}
\f
-/* (PRIMITIVE-FASDUMP object-to-dump filename-or-channel flag)
-
- 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 or channel. The primitive returns #T or #F indicating
- whether it successfully dumped the object (it can fail on an object
- that is too large). It should signal an error rather than return
- false, but ... some other time.
-
- The third argument, FLAG, specifies how to handle the dumping of
- environment objects:
- - SHARP_F means that it is an error to dump an object containing
- environment objects.
- - SHARP_T means that they should be dumped as if they were ordinary
- objects.
- - anything else means that the environment objects pointed at by
- compiled code blocks should be eliminated on the dumped copy,
- but other environments are not allowed.
-*/
-
-DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
+typedef struct
{
- Tchannel channel = NO_CHANNEL;
- Boolean arg_string_p;
- SCHEME_OBJECT Object, *New_Object, arg2, flag;
- SCHEME_OBJECT * prim_table_start, * prim_table_end;
- long Length, prim_table_length;
- Boolean result;
- PRIMITIVE_HEADER (3);
+ SCHEME_OBJECT * addr;
+ SCHEME_OBJECT object;
+} fixup_t;
- Object = (ARG_REF (1));
- arg2 = (ARG_REF (2));
- arg_string_p = (STRING_P (arg2));
- if (!arg_string_p)
- channel = (arg_channel (2));
- flag = (ARG_REF (3));
+static fixup_t * fixups_start;
+static fixup_t * fixups_next;
+static fixup_t * fixups_end;
+
+static void
+initialize_fixups (void)
+{
+ fixup_t * data = (OS_malloc (64 * (sizeof (fixup_t))));
+ fixups_start = data;
+ fixups_next = data;
+ fixups_end = (data + 64);
+ transaction_record_action (tat_always, run_fixups, 0);
+}
- compiled_code_present_p = false;
+static void
+add_fixup (SCHEME_OBJECT * addr)
+{
+ if (fixups_next >= fixups_end)
+ {
+ unsigned long n = ((fixups_end - fixups_start) * 2);
+ unsigned long m = (fixups_next - fixups_start);
+ fixup_t * data = (OS_realloc (fixups_start, (n * (sizeof (fixup_t)))));
+ fixups_start = data;
+ fixups_next = (data + m);
+ fixups_end = (data + n);
+ }
+ (fixups_next -> addr) = addr;
+ (fixups_next -> object) = (*addr);
+ fixups_next += 1;
+}
- prim_table_end = &Free[(Space_Before_GC ())];
- prim_table_start = (initialize_primitive_table (Free, prim_table_end));
- if (prim_table_start >= prim_table_end)
- Primitive_GC (prim_table_start - Free);
+static void
+run_fixups (void * p)
+{
+ fixup_t * scan = fixups_start;
+ while (scan < fixups_next)
+ {
+ (* (scan->addr)) = (scan->object);
+ scan += 1;
+ }
+ OS_free (fixups_start);
+}
+\f
+DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2,
+ "(PROCEDURE NAMESTRING)\n\
+Saves an image of the current world to the file NAMESTRING.\n\
+When the file is reloaded, PROCEDURE is called with an argument of #F.")
+{
+ SCHEME_OBJECT * to = Free;
+ SCHEME_OBJECT * prim_table_start;
+ SCHEME_OBJECT * c_code_table_start;
+ bool result;
+ PRIMITIVE_HEADER (2);
- Fasdump_Free_Calc (NewFree, NewMemTop);
- Fixup = NewMemTop;
- ALIGN_FLOAT (NewFree);
- New_Object = NewFree;
- *NewFree++ = Object;
+ CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
+ CHECK_ARG (2, STRING_P);
- if (arg_string_p)
+ Primitive_GC_If_Needed (5);
+ initialize_fasl_header (true);
+ (FASLHDR_BAND_P (fh)) = true;
{
- /* This needs to be done before Fasdump_Exit is called.
- DUMPLOOP may do that.
- It should not be done if the primitive will not call
- Fasdump_Exit on its way out (ie. Primitive_GC above).
- */
- dump_file_name = ((CONST char *) (STRING_LOC (arg2, 0)));
+ SCHEME_OBJECT comb;
+ SCHEME_OBJECT root;
+
+ comb = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, to));
+ (to[COMB_1_FN]) = (ARG_REF (1));
+ (to[COMB_1_ARG_1]) = SHARP_F;
+ to += 2;
+
+ root = (MAKE_POINTER_OBJECT (TC_LIST, to));
+ (*to++) = comb;
+ (*to++) = compiler_utilities;
+
+ (FASLHDR_ROOT_POINTER (fh)) = to;
+ (*to++) = root;
}
- DUMPLOOP (New_Object,
- ((flag == SHARP_F) ? 0 : ((flag == SHARP_T) ? 1 : 2)));
- Length = (NewFree - New_Object);
- prim_table_start = NewFree;
- prim_table_end = (cons_primitive_table (NewFree, Fixup, &prim_table_length));
- if (prim_table_end >= Fixup)
- FASDUMP_INTERRUPT ();
+ prim_table_start = to;
+ (FASLHDR_N_PRIMITIVES (fh)) = MAX_PRIMITIVE;
+ (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)) = (primitive_table_export_length ());
+ to += (FASLHDR_PRIMITIVE_TABLE_SIZE (fh));
-#ifdef NATIVE_CODE_IS_C
+ c_code_table_start = to;
+#ifdef CC_IS_C
+ (FASLHDR_C_CODE_TABLE_SIZE (fh))
+ = (c_code_table_export_length (& (FASLHDR_N_C_CODE_BLOCKS (fh))));
+ to += (FASLHDR_C_CODE_TABLE_SIZE (fh));
+#endif
+
+ if (to > heap_end)
+ result = false;
+ else
+ {
+ const char * filename = (STRING_POINTER (ARG_REF (2)));
+ SCHEME_OBJECT * faligned_heap = heap_start;
+ SCHEME_OBJECT * faligned_constant = constant_start;
+ fasl_file_handle_t handle;
+
+ export_primitive_table (prim_table_start);
+#ifdef CC_IS_C
+ export_c_code_table (c_code_table_start);
+#endif
- /* Cannot dump C compiled code. */
+ while (!FLOATING_ALIGNED_P (faligned_heap))
+ faligned_heap += 1;
- if (compiled_code_present_p)
- PRIMITIVE_RETURN (Fasdump_Exit (ERR_COMPILED_CODE_ERROR, false));
+ while (!FLOATING_ALIGNED_P (faligned_constant))
+ faligned_constant += 1;
-#endif /* NATIVE_CODE_IS_C */
+ (FASLHDR_HEAP_START (fh)) = faligned_heap;
+ (FASLHDR_HEAP_END (fh)) = prim_table_start;
+ (FASLHDR_CONSTANT_START (fh)) = faligned_constant;
+ (FASLHDR_CONSTANT_END (fh)) = constant_alloc_next;
- if (arg_string_p)
- {
- channel = (OS_open_dump_file (dump_file_name));
- if (channel == NO_CHANNEL)
- PRIMITIVE_RETURN (Fasdump_Exit (ERR_ARG_2_BAD_RANGE, false));
- }
+ OS_file_remove_link (filename);
+ if (!open_fasl_output_file (filename, (&handle)))
+ error_bad_range_arg (2);
+
+ result
+ = (write_fasl_file (prim_table_start, c_code_table_start, handle));
- dump_channel = channel;
- result = (Write_File (New_Object,
- Length, New_Object,
- 0, Constant_Space,
- prim_table_start, prim_table_length,
- ((long) (prim_table_end - prim_table_start)),
- prim_table_end, 0, 0,
- compiled_code_present_p, false));
-
- PRIMITIVE_RETURN (Fasdump_Exit ((result ? PRIM_DONE : PRIM_INTERRUPT),
- arg_string_p));
+ if (!close_fasl_output_file (handle))
+ OS_file_remove (filename);
+ }
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
}
\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 #F.
-*/
-
-DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
+static void
+initialize_fasl_header (bool cc_p)
{
- SCHEME_OBJECT
- Combination, * saved_free,
- * prim_table_start, * prim_table_end,
- * c_table_start, * c_table_end;
- long
- prim_table_length,
- c_table_length;
- Boolean result = false;
- PRIMITIVE_HEADER (2);
+ fh = (&fasl_header);
+ (FASLHDR_VERSION (fh)) = OUTPUT_FASL_VERSION;
+ (FASLHDR_ARCH (fh)) = CURRENT_FASL_ARCH;
+
+#ifdef HEAP_IN_LOW_MEMORY
+ (FASLHDR_MEMORY_BASE (fh)) = 0;
+#else
+ (FASLHDR_MEMORY_BASE (fh)) = memory_block_start;
+#endif
+ (FASLHDR_HEAP_RESERVED (fh)) = heap_reserved;
- Band_Dump_Permitted ();
- CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
- CHECK_ARG (2, STRING_P);
- if (Unused_Heap_Bottom < Heap_Bottom)
- /* Cause the image to be in the low heap, to increase
- the probability that no relocation is needed on reload. */
- Primitive_GC (0);
- Primitive_GC_If_Needed (5);
- saved_free = Free;
- Combination = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free));
- Free[COMB_1_FN] = (ARG_REF (1));
- Free[COMB_1_ARG_1] = SHARP_F;
- Free += 2;
- (* Free++) = Combination;
- (* Free++) = compiler_utilities;
- (* Free) = (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)));
- Free ++; /* Some compilers are TOO clever about this and increment Free
- before calculating Free-2! */
- prim_table_start = Free;
- prim_table_end = (cons_whole_primitive_table (prim_table_start,
- Heap_Top,
- &prim_table_length));
- if (prim_table_end >= Heap_Top)
- goto done;
-
- c_table_start = prim_table_end;
- c_table_end = (cons_c_code_table (c_table_start, Heap_Top, &c_table_length));
- if (c_table_end >= Heap_Top)
- goto done;
+ (FASLHDR_STACK_START (fh)) = stack_start;
+ (FASLHDR_STACK_END (fh)) = stack_end;
- {
- SCHEME_OBJECT * faligned_heap, * faligned_constant;
- CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0)));
-
- OS_file_remove_link (filename);
- dump_channel = (OS_open_dump_file (filename));
- if (dump_channel == NO_CHANNEL)
- error_bad_range_arg (2);
-
- for (faligned_heap = Heap_Bottom;
- (! (FLOATING_ALIGNED_P (faligned_heap)));
- faligned_heap += 1)
- ;
-
- for (faligned_constant = Constant_Space;
- (! (FLOATING_ALIGNED_P (faligned_constant)));
- faligned_constant += 1)
- ;
-
- result = (Write_File ((Free - 1),
- ((long) (Free - faligned_heap)),
- faligned_heap,
- ((long) (Free_Constant - faligned_constant)),
- faligned_constant,
- prim_table_start, prim_table_length,
- ((long) (prim_table_end - prim_table_start)),
- c_table_start, c_table_length,
- ((long) (c_table_end - c_table_start)),
- (compiler_utilities != SHARP_F), true));
- OS_channel_close_noerror (dump_channel);
- if (! result)
- OS_file_remove (filename);
- }
+ if (cc_p)
+ {
+ (FASLHDR_CC_VERSION (fh)) = compiler_interface_version;
+ (FASLHDR_CC_ARCH (fh)) = compiler_processor_type;
+ (FASLHDR_UTILITIES_VECTOR (fh)) = compiler_utilities;
+ }
+ else
+ {
+ (FASLHDR_CC_VERSION (fh)) = 0;
+ (FASLHDR_CC_ARCH (fh)) = COMPILER_NONE_TYPE;
+ (FASLHDR_UTILITIES_VECTOR (fh)) = SHARP_F;
+ }
+ (FASLHDR_N_C_CODE_BLOCKS (fh)) = 0;
+ (FASLHDR_C_CODE_TABLE_SIZE (fh)) = 0;
+}
-done:
- Band_Dump_Exit_Hook ();
- Free = saved_free;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
+static bool
+write_fasl_file (SCHEME_OBJECT * prim_table_start,
+ SCHEME_OBJECT * c_code_table_start,
+ fasl_file_handle_t handle)
+{
+ return
+ ((write_fasl_header (fh, handle))
+ && (write_to_fasl_file ((FASLHDR_HEAP_START (fh)),
+ (FASLHDR_HEAP_SIZE (fh)),
+ handle))
+ && (write_to_fasl_file ((FASLHDR_CONSTANT_START (fh)),
+ (FASLHDR_CONSTANT_SIZE (fh)),
+ handle))
+ && (write_to_fasl_file (prim_table_start,
+ (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)),
+ handle))
+ && (write_to_fasl_file (c_code_table_start,
+ (FASLHDR_C_CODE_TABLE_SIZE (fh)),
+ handle)));
}
--- /dev/null
+/* -*-C-*-
+
+$Id: fasl.c,v 11.1 2007/04/22 16:31:22 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* I/O for fasdump and fasload */
+
+#include "config.h"
+#include "fasl.h"
+
+static void encode_fasl_header (SCHEME_OBJECT *, fasl_header_t *);
+static bool decode_fasl_header (SCHEME_OBJECT *, fasl_header_t *);
+static SCHEME_OBJECT * faslobj_address (SCHEME_OBJECT, fasl_header_t *);
+\f
+bool
+open_fasl_output_file (const char * filename, fasl_file_handle_t * handle_r)
+{
+ FILE * s = (fopen (filename, "wb"));
+ if (s == 0)
+ return (false);
+ (*handle_r) = s;
+ return (true);
+}
+
+bool
+close_fasl_output_file (fasl_file_handle_t handle)
+{
+ return ((fclose (handle)) == 0);
+}
+
+bool
+write_fasl_header (fasl_header_t * h, fasl_file_handle_t handle)
+{
+ SCHEME_OBJECT raw [FASL_HEADER_LENGTH];
+
+ encode_fasl_header (raw, h);
+ return (write_to_fasl_file (raw, FASL_HEADER_LENGTH, handle));
+}
+
+bool
+write_to_fasl_file (const void * start, size_t n_words,
+ fasl_file_handle_t handle)
+{
+ return ((fwrite (start, SIZEOF_SCHEME_OBJECT, n_words, handle)) == n_words);
+}
+
+bool
+open_fasl_input_file (const char * filename, fasl_file_handle_t * handle_r)
+{
+ FILE * s = (fopen (filename, "rb"));
+ if (s == 0)
+ return (false);
+ (*handle_r) = s;
+ return (true);
+}
+
+bool
+close_fasl_input_file (fasl_file_handle_t handle)
+{
+ return ((fclose (handle)) == 0);
+}
+
+bool
+read_fasl_header (fasl_header_t * h, fasl_file_handle_t handle)
+{
+ SCHEME_OBJECT raw [FASL_HEADER_LENGTH];
+ return
+ ((read_from_fasl_file (raw, FASL_HEADER_LENGTH, handle))
+ && (decode_fasl_header (raw, h)));
+}
+
+bool
+read_from_fasl_file (void * start, size_t n_words, fasl_file_handle_t handle)
+{
+ return ((fread (start, SIZEOF_SCHEME_OBJECT, n_words, handle)) == n_words);
+}
+
+fasl_read_status_t
+check_fasl_version (fasl_header_t * fh)
+{
+ return
+ ((((FASLHDR_VERSION (fh)) >= OLDEST_INPUT_FASL_VERSION)
+ && ((FASLHDR_VERSION (fh)) <= NEWEST_INPUT_FASL_VERSION))
+ ? ((((FASLHDR_ARCH (fh)) == CURRENT_FASL_ARCH)
+#ifdef HEAP_IN_LOW_MEMORY
+ && ((FASLHDR_MEMORY_BASE (fh)) == 0)
+#else
+ && ((FASLHDR_MEMORY_BASE (fh)) != 0)
+#endif
+ )
+ ? FASL_FILE_FINE
+ : FASL_FILE_BAD_MACHINE)
+ : FASL_FILE_BAD_VERSION);
+}
+
+fasl_read_status_t
+check_fasl_cc_version (fasl_header_t * fh,
+ unsigned long version, unsigned long type)
+{
+ return
+ ((((FASLHDR_CC_VERSION (fh)) == 0)
+ && ((FASLHDR_CC_ARCH (fh)) == COMPILER_NONE_TYPE))
+ ? FASL_FILE_FINE
+ : ((FASLHDR_CC_VERSION (fh)) == version)
+ ? (((FASLHDR_CC_ARCH (fh)) == type)
+ ? FASL_FILE_FINE
+ : FASL_FILE_BAD_PROCESSOR)
+ : FASL_FILE_BAD_INTERFACE);
+}
+\f
+static void
+encode_fasl_header (SCHEME_OBJECT * raw, fasl_header_t * h)
+{
+ {
+ SCHEME_OBJECT * p = raw;
+ SCHEME_OBJECT * e = (raw + FASL_HEADER_LENGTH);
+ while (p < e)
+ (*p++) = SHARP_F;
+ }
+#ifdef DEBUG
+#ifdef HEAP_IN_LOW_MEMORY
+ fprintf (stderr, "\nmemory_base = %#lx\n",
+ ((unsigned long) (FASLHDR_MEMORY_BASE (h))));
+#endif
+ fprintf (stderr, "\nheap start %#lx\n",
+ ((unsigned long) (FASLHDR_HEAP_START (h))));
+ fprintf (stderr, "\nroot object %#lx\n",
+ ((unsigned long) (FASLHDR_ROOT_POINTER (h))));
+#endif
+
+ (raw[FASL_OFFSET_MARKER]) = FASL_FILE_MARKER;
+
+ (raw[FASL_OFFSET_VERSION])
+ = (MAKE_FASL_VERSION ((FASLHDR_VERSION (h)), (FASLHDR_ARCH (h))));
+ (raw[FASL_OFFSET_CI_VERSION])
+ = (MAKE_CI_VERSION ((FASLHDR_BAND_P (h)),
+ (FASLHDR_CC_VERSION (h)),
+ (FASLHDR_CC_ARCH (h))));
+
+ (raw[FASL_OFFSET_MEM_BASE])
+ = ((SCHEME_OBJECT) (FASLHDR_MEMORY_BASE (h)));
+
+ (raw[FASL_OFFSET_DUMPED_OBJ])
+ = (MAKE_BROKEN_HEART (FASLHDR_ROOT_POINTER (h)));
+
+ (raw[FASL_OFFSET_HEAP_BASE])
+ = (MAKE_BROKEN_HEART (FASLHDR_HEAP_START (h)));
+ (raw[FASL_OFFSET_HEAP_SIZE])
+ = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_HEAP_SIZE (h))));
+
+ if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END)
+ (raw[FASL_OFFSET_HEAP_RSVD])
+ = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_HEAP_RESERVED (h))));
+
+ (raw[FASL_OFFSET_CONST_BASE])
+ = (MAKE_BROKEN_HEART (FASLHDR_CONSTANT_START (h)));
+ (raw[FASL_OFFSET_CONST_SIZE])
+ = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_CONSTANT_SIZE (h))));
+
+ if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END)
+ {
+ (raw[FASL_OFFSET_STACK_START])
+ = (MAKE_BROKEN_HEART (FASLHDR_STACK_START (h)));
+ (raw[FASL_OFFSET_STACK_SIZE])
+ = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_STACK_SIZE (h))));
+ }
+ else
+ (raw[FASL_OFFSET_STACK_START])
+ = (MAKE_BROKEN_HEART (FASLHDR_STACK_END (h)));
+
+ (raw[FASL_OFFSET_PRIM_LENGTH])
+ = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_N_PRIMITIVES (h))));
+ (raw[FASL_OFFSET_PRIM_SIZE])
+ = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_PRIMITIVE_TABLE_SIZE (h))));
+
+ (raw[FASL_OFFSET_C_LENGTH])
+ = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_N_C_CODE_BLOCKS (h))));
+ (raw[FASL_OFFSET_C_SIZE])
+ = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_C_CODE_TABLE_SIZE (h))));
+
+ (raw[FASL_OFFSET_UT_BASE]) = (FASLHDR_UTILITIES_VECTOR (h));
+}
+\f
+static bool
+decode_fasl_header (SCHEME_OBJECT * raw, fasl_header_t * h)
+{
+ if ((raw[FASL_OFFSET_MARKER]) != FASL_FILE_MARKER)
+ return (false);
+ {
+ SCHEME_OBJECT object = (raw[FASL_OFFSET_VERSION]);
+ (FASLHDR_VERSION (h)) = (FASL_VERSION (object));
+ (FASLHDR_ARCH (h)) = (FASL_ARCH (object));
+ }
+ {
+ SCHEME_OBJECT object = (raw[FASL_OFFSET_CI_VERSION]);
+ (FASLHDR_CC_VERSION (h)) = (CI_VERSION (object));
+ (FASLHDR_CC_ARCH (h)) = (CI_PROCESSOR (object));
+ (FASLHDR_BAND_P (h)) = (CI_BAND_P (object));
+ }
+ {
+ SCHEME_OBJECT * fasl_memory_base
+ = ((SCHEME_OBJECT *) (raw[FASL_OFFSET_MEM_BASE]));
+ (FASLHDR_MEMORY_BASE (h)) = fasl_memory_base;
+
+ (FASLHDR_ROOT_POINTER (h))
+ = (faslobj_address ((raw[FASL_OFFSET_DUMPED_OBJ]), h));
+
+ (FASLHDR_HEAP_START (h))
+ = (faslobj_address ((raw[FASL_OFFSET_HEAP_BASE]), h));
+ (FASLHDR_HEAP_END (h))
+ = ((FASLHDR_HEAP_START (h))
+ + (OBJECT_DATUM (raw[FASL_OFFSET_HEAP_SIZE])));
+ (FASLHDR_HEAP_RESERVED (h))
+ = (((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END)
+ ? (OBJECT_DATUM (raw[FASL_OFFSET_HEAP_RSVD]))
+ : 4500);
+
+ (FASLHDR_CONSTANT_START (h))
+ = (faslobj_address ((raw[FASL_OFFSET_CONST_BASE]), h));
+ (FASLHDR_CONSTANT_END (h))
+ = ((FASLHDR_CONSTANT_START (h))
+ + (OBJECT_DATUM (raw[FASL_OFFSET_CONST_SIZE])));
+
+ if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END)
+ {
+ (FASLHDR_STACK_START (h))
+ = (faslobj_address ((raw[FASL_OFFSET_STACK_START]), h));
+ (FASLHDR_STACK_END (h))
+ = ((FASLHDR_STACK_START (h))
+ + (OBJECT_DATUM (raw[FASL_OFFSET_STACK_SIZE])));
+ }
+ else
+ /* In older versions, the "stack start" field held "stack
+ bottom" instead. Since the stack grows downwards, this was
+ the maximum address. */
+ {
+ (FASLHDR_STACK_END (h))
+ = (faslobj_address ((raw[FASL_OFFSET_STACK_START]), h));
+ /* If !HEAP_IN_LOW_MEMORY then fasl_memory_base is the right
+ value. Otherwise, fasl_memory_base is zero and that is at
+ least guaranteed to encompass the whole stack. */
+ (FASLHDR_STACK_START (h)) = fasl_memory_base;
+ }
+
+ (FASLHDR_N_PRIMITIVES (h))
+ = (OBJECT_DATUM (raw[FASL_OFFSET_PRIM_LENGTH]));
+ (FASLHDR_PRIMITIVE_TABLE_SIZE (h))
+ = (OBJECT_DATUM (raw[FASL_OFFSET_PRIM_SIZE]));
+
+ (FASLHDR_N_C_CODE_BLOCKS (h))
+ = (OBJECT_DATUM (raw[FASL_OFFSET_C_LENGTH]));
+ (FASLHDR_C_CODE_TABLE_SIZE (h))
+ = (OBJECT_DATUM (raw[FASL_OFFSET_C_SIZE]));
+
+ {
+ SCHEME_OBJECT ruv = (raw[FASL_OFFSET_UT_BASE]);
+ if (ruv == SHARP_F)
+ {
+ (FASLHDR_UTILITIES_VECTOR (h)) = SHARP_F;
+ (FASLHDR_UTILITIES_START (h)) = 0;
+ }
+ else
+ {
+ SCHEME_OBJECT fuv
+ = (OBJECT_NEW_ADDRESS (ruv, (faslobj_address (ruv, h))));
+ (FASLHDR_UTILITIES_VECTOR (h)) = fuv;
+ (FASLHDR_UTILITIES_START (h)) = (OBJECT_ADDRESS (fuv));
+ }
+ }
+ (__FASLHDR_UTILITIES_END (h)) = 0;
+ }
+ return (true);
+}
+
+static SCHEME_OBJECT *
+faslobj_address (SCHEME_OBJECT o, fasl_header_t * h)
+{
+ return
+ (((FASLHDR_MEMORY_BASE (h)) == 0)
+ ? (OBJECT_ADDRESS (o))
+ : ((FASLHDR_MEMORY_BASE (h)) + (OBJECT_DATUM (o))));
+}
+
+SCHEME_OBJECT *
+faslhdr_utilities_end (fasl_header_t * h)
+{
+ if (((__FASLHDR_UTILITIES_END (h)) == 0)
+ && (VECTOR_P (FASLHDR_UTILITIES_VECTOR (h))))
+ (__FASLHDR_UTILITIES_END (h))
+ = (VECTOR_LOC ((FASLHDR_UTILITIES_VECTOR (h)),
+ (VECTOR_LENGTH (FASLHDR_UTILITIES_VECTOR (h)))));
+ return (__FASLHDR_UTILITIES_END (h));
+}
/* -*-C-*-
-$Id: fasl.h,v 9.43 2007/01/05 21:19:25 cph Exp $
+$Id: fasl.h,v 9.44 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Contains information relating to the format of FASL files.
The machine/opsys information is contained in config.h
The processor and compiled code version information is
- contained in the appropriate cmp* file, or compiler.c */
-\f
-/* FASL Version */
+ contained in the appropriate cmp* file, or compiler.c. */
+
+#ifndef SCM_FASL_H
+#define SCM_FASL_H 1
+
+#include "object.h"
-#if (SIZEOF_UNSIGNED_LONG == 8)
-#define FASL_FILE_MARKER 0xFAFAFAFAFAFAFAFAULL
+#if (SIZEOF_UNSIGNED_LONG == 4)
+# define FASL_FILE_MARKER 0xFAFAFAFAUL
#else
-#define FASL_FILE_MARKER 0xFAFAFAFAUL
+# if (SIZEOF_UNSIGNED_LONG == 8)
+# define FASL_FILE_MARKER 0xFAFAFAFAFAFAFAFAUL
+# endif
#endif
/* The FASL file has a header which begins as follows: */
#define FASL_HEADER_LENGTH 50 /* Scheme objects in header */
-#define FASL_Offset_Marker 0 /* Marker to indicate FASL format */
-#define FASL_Offset_Heap_Count 1 /* Count of objects in heap */
-#define FASL_Offset_Heap_Base 2 /* Address of heap when dumped */
-#define FASL_Offset_Dumped_Obj 3 /* Where dumped object was */
-#define FASL_Offset_Const_Count 4 /* Count of objects in const. area */
-#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */
-#define FASL_Offset_Version 6 /* FASL format version info. */
-#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
-#define FASL_Offset_Prim_Length 8 /* Number of entries in primitive table */
-#define FASL_Offset_Prim_Size 9 /* Size of primitive table in SCHEME_OBJECTs */
-#define FASL_Offset_Ci_Version 10 /* Version number for compiled code interface */
-#define FASL_Offset_Ut_Base 11 /* Address of the utilities vector */
-#define FASL_Offset_Check_Sum 12 /* Header and data checksum. */
-#define FASL_Offset_C_Length 13 /* Number of entries in the C code table */
-#define FASL_Offset_C_Size 14 /* Size of C code table in SCHEME_OBJECTs */
-#define FASL_Offset_Mem_Base 15 /* Base address when not HEAP_IN_LOW_MEMORY */
-
-#define FASL_Offset_First_Free 16 /* Used to clear header */
-
-/* Aliases for backwards compatibility. */
-
-/* Where ext. prims. vector is */
-#define FASL_Offset_Ext_Loc FASL_Offset_Prim_Length
-
-/* Version information encoding */
+#define FASL_OFFSET_MARKER 0 /* Marker to indicate FASL format */
+#define FASL_OFFSET_HEAP_SIZE 1 /* # of words in heap */
+#define FASL_OFFSET_HEAP_BASE 2 /* Address of heap when dumped */
+#define FASL_OFFSET_DUMPED_OBJ 3 /* Where dumped object was */
+#define FASL_OFFSET_CONST_SIZE 4 /* # of words in constant area */
+#define FASL_OFFSET_CONST_BASE 5 /* Address of const. area at dump */
+#define FASL_OFFSET_VERSION 6 /* FASL format version info. */
+#define FASL_OFFSET_STACK_START 7 /* value of stack_start when dumped */
+#define FASL_OFFSET_PRIM_LENGTH 8 /* # of entries in primitive table */
+#define FASL_OFFSET_PRIM_SIZE 9 /* # of words in primitive table */
+#define FASL_OFFSET_CI_VERSION 10 /* Version of comp. code interface */
+#define FASL_OFFSET_UT_BASE 11 /* Address of the utilities vector */
+
+#if 0
+#define FASL_OFFSET_CHECK_SUM 12 /* Header and data checksum. */
+#endif
-#define ONE ((SCHEME_OBJECT) 1)
-
-#define MACHINE_TYPE_LENGTH (OBJECT_LENGTH / 2)
-#define MACHINE_TYPE_MASK ((ONE << MACHINE_TYPE_LENGTH) - 1)
-#define The_Machine_Type(P) ((P) & MACHINE_TYPE_MASK)
-#define SUBVERSION_LENGTH (MACHINE_TYPE_LENGTH - TYPE_CODE_LENGTH)
-#define SUBVERSION_MASK ((ONE << SUBVERSION_LENGTH) - 1)
-#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUBVERSION_MASK)
-#define The_Version(P) (OBJECT_TYPE (P))
-
-#define Make_Version(V, S, M) \
- MAKE_OBJECT ((V), ((((unsigned long) (S)) << MACHINE_TYPE_LENGTH) \
- | (M))) \
-
-#define CI_MASK ((ONE << (DATUM_LENGTH / 2)) - 1)
-#define CI_VERSION(P) (((P) >> (DATUM_LENGTH / 2)) & CI_MASK)
-#define CI_PROCESSOR(P) ((P) & CI_MASK)
-#define CI_BAND_P(P) ((OBJECT_TYPE (P)) == TC_CONSTANT)
-
-#define MAKE_CI_VERSION(Band_p, Version, Processor_Type) \
- MAKE_OBJECT (((Band_p) ? TC_CONSTANT : TC_NULL), \
- ((((unsigned long) (Version)) << (DATUM_LENGTH / 2)) \
- | (Processor_Type)))
+#define FASL_OFFSET_C_LENGTH 13 /* # of entries in the C code table */
+#define FASL_OFFSET_C_SIZE 14 /* # of words in the C code table */
+#define FASL_OFFSET_MEM_BASE 15 /* Saved value of memory_base */
+#define FASL_OFFSET_STACK_SIZE 16 /* # of words in stack area */
+#define FASL_OFFSET_HEAP_RSVD 17 /* value of heap_reserved */
\f
-/* "Memorable" FASL versions -- ones where we modified something
- and want to remain backwards compatible.
-*/
-
-/* Versions. */
-
-#define FASL_FORMAT_ADDED_STACK 1
-
-/* Subversions of highest numbered version. */
-
-#define FASL_LONG_HEADER 3
-#define FASL_DENSE_TYPES 4
-#define FASL_PADDED_STRINGS 5
-#define FASL_REFERENCE_TRAP 6
-#define FASL_MERGED_PRIMITIVES 7
-#define FASL_INTERFACE_VERSION 8
-#define FASL_NEW_BIGNUMS 9
-#define FASL_C_CODE 10
-
-/* Current parameters. Always used on output. */
-
-#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_C_CODE
-
-/*
- The definitions below correspond to the ones above. They usually
- have the same values. They differ when the format is changing: A
- system can be built which reads the old format, but dumps the new one.
- */
-
-#ifndef FASL_READ_VERSION
-#define FASL_READ_VERSION FASL_FORMAT_ADDED_STACK
-#endif
+/* Version information encoding */
-#ifndef FASL_READ_SUBVERSION
-#define FASL_READ_SUBVERSION FASL_NEW_BIGNUMS
+#define FASL_ARCH_LENGTH (OBJECT_LENGTH / 2)
+#define FASL_ARCH(P) ((P) & ((1UL << FASL_ARCH_LENGTH) - 1))
+
+#define FASL_VERSION_LENGTH (FASL_ARCH_LENGTH - TYPE_CODE_LENGTH)
+#define FASL_VERSION(P) \
+ (((P) >> FASL_ARCH_LENGTH) & ((1UL << FASL_VERSION_LENGTH) - 1))
+
+/* The '1' here is for upwards compatibility. */
+#define MAKE_FASL_VERSION(s, a) \
+ (MAKE_OBJECT (1, ((((unsigned long) (s)) << FASL_ARCH_LENGTH) | (a))))
+
+#define CI_VERSION(P) (((P) >> HALF_DATUM_LENGTH) & HALF_DATUM_MASK)
+#define CI_PROCESSOR(P) ((cc_arch_t) ((P) & HALF_DATUM_MASK))
+#define CI_BAND_P(P) ((OBJECT_TYPE (P)) == TC_CONSTANT)
+
+#define MAKE_CI_VERSION(b, v, a) \
+ (MAKE_OBJECT (((b) ? TC_CONSTANT : TC_NULL), \
+ ((((unsigned long) (v)) << HALF_DATUM_LENGTH) \
+ | ((unsigned long) (a)))))
+
+typedef enum
+{
+ FASL_VERSION_NONE,
+ FASL_VERSION_LONG_HEADER = 3,
+ FASL_VERSION_DENSE_TYPES,
+ FASL_VERSION_PADDED_STRINGS,
+ FASL_VERSION_REFERENCE_TRAP,
+ FASL_VERSION_MERGED_PRIMITIVES,
+ FASL_VERSION_INTERFACE_VERSION,
+ FASL_VERSION_NEW_BIGNUMS,
+ FASL_VERSION_C_CODE,
+ FASL_VERSION_STACK_END
+} fasl_version_t;
+
+#define OLDEST_INPUT_FASL_VERSION FASL_VERSION_C_CODE
+#define NEWEST_INPUT_FASL_VERSION FASL_VERSION_STACK_END
+
+#if 0
+/* Temporarily disabled for testing. */
+#define OUTPUT_FASL_VERSION FASL_VERSION_STACK_END
+#else
+#define OUTPUT_FASL_VERSION FASL_VERSION_C_CODE
#endif
-
-/* These are for Bintopsb.
- They are the values of the oldest supported formats.
- */
-
-#define FASL_OLDEST_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_OLDEST_SUBVERSION FASL_PADDED_STRINGS
+\f
+typedef struct
+{
+ fasl_version_t version;
+ fasl_arch_t arch;
+ unsigned int cc_version;
+ cc_arch_t cc_arch;
+ bool band_p;
+ SCHEME_OBJECT * memory_base;
+ SCHEME_OBJECT * root_pointer;
+ SCHEME_OBJECT * heap_start;
+ SCHEME_OBJECT * heap_end;
+ unsigned long heap_reserved;
+ SCHEME_OBJECT * constant_start;
+ SCHEME_OBJECT * constant_end;
+ SCHEME_OBJECT * stack_start;
+ SCHEME_OBJECT * stack_end;
+ unsigned long n_primitives;
+ unsigned long primitive_table_size;
+ unsigned long n_c_code_blocks;
+ unsigned long c_code_table_size;
+ SCHEME_OBJECT utilities_vector;
+ SCHEME_OBJECT * utilities_start;
+ SCHEME_OBJECT * utilities_end;
+} fasl_header_t;
+
+#define FASLHDR_VERSION(h) ((h)->version)
+#define FASLHDR_ARCH(h) ((h)->arch)
+#define FASLHDR_CC_VERSION(h) ((h)->cc_version)
+#define FASLHDR_CC_ARCH(h) ((h)->cc_arch)
+#define FASLHDR_BAND_P(h) ((h)->band_p)
+#define FASLHDR_MEMORY_BASE(h) ((h)->memory_base)
+#define FASLHDR_ROOT_POINTER(h) ((h)->root_pointer)
+#define FASLHDR_HEAP_START(h) ((h)->heap_start)
+#define FASLHDR_HEAP_END(h) ((h)->heap_end)
+#define FASLHDR_HEAP_RESERVED(h) ((h)->heap_reserved)
+#define FASLHDR_CONSTANT_START(h) ((h)->constant_start)
+#define FASLHDR_CONSTANT_END(h) ((h)->constant_end)
+#define FASLHDR_STACK_START(h) ((h)->stack_start)
+#define FASLHDR_STACK_END(h) ((h)->stack_end)
+#define FASLHDR_N_PRIMITIVES(h) ((h)->n_primitives)
+#define FASLHDR_PRIMITIVE_TABLE_SIZE(h) ((h)->primitive_table_size)
+#define FASLHDR_N_C_CODE_BLOCKS(h) ((h)->n_c_code_blocks)
+#define FASLHDR_C_CODE_TABLE_SIZE(h) ((h)->c_code_table_size)
+#define FASLHDR_UTILITIES_VECTOR(h) ((h)->utilities_vector)
+#define FASLHDR_UTILITIES_START(h) ((h)->utilities_start)
+#define __FASLHDR_UTILITIES_END(h) ((h)->utilities_end)
+
+#define FASLHDR_UTILITIES_END(h) (faslhdr_utilities_end (h))
+
+#define FASLHDR_HEAP_SIZE(h) \
+ ((unsigned long) \
+ ((FASLHDR_HEAP_END (h)) - (FASLHDR_HEAP_START (h))))
+
+#define FASLHDR_CONSTANT_SIZE(h) \
+ ((unsigned long) \
+ ((FASLHDR_CONSTANT_END (h)) - (FASLHDR_CONSTANT_START (h))))
+
+#define FASLHDR_STACK_SIZE(h) \
+ ((unsigned long) \
+ ((FASLHDR_STACK_END (h)) - (FASLHDR_STACK_START (h))))
+
+typedef enum
+{
+ FASL_FILE_FINE,
+ FASL_FILE_TOO_SHORT,
+ FASL_FILE_NOT_FASL,
+ FASL_FILE_BAD_MACHINE,
+ FASL_FILE_BAD_VERSION,
+ FASL_FILE_BAD_SUBVERSION, /* unused */
+ FASL_FILE_BAD_PROCESSOR,
+ FASL_FILE_BAD_INTERFACE
+} fasl_read_status_t;
+
+typedef FILE * fasl_file_handle_t;
+
+extern bool open_fasl_output_file (const char *, fasl_file_handle_t *);
+extern bool close_fasl_output_file (fasl_file_handle_t);
+extern bool write_fasl_header (fasl_header_t *, fasl_file_handle_t);
+extern bool write_to_fasl_file (const void *, size_t, fasl_file_handle_t);
+extern bool open_fasl_input_file (const char *, fasl_file_handle_t *);
+extern bool close_fasl_input_file (fasl_file_handle_t);
+extern bool read_fasl_header (fasl_header_t *, fasl_file_handle_t);
+extern bool read_from_fasl_file (void *, size_t, fasl_file_handle_t);
+extern SCHEME_OBJECT * faslhdr_utilities_end (fasl_header_t *);
+extern fasl_read_status_t check_fasl_version (fasl_header_t *);
+extern fasl_read_status_t check_fasl_cc_version
+ (fasl_header_t *, unsigned long, unsigned long);
+
+#endif /* not SCM_FASL_H */
/* -*-C-*-
-$Id: fasload.c,v 9.100 2007/04/14 03:53:32 cph Exp $
+$Id: fasload.c,v 9.101 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* The "fast loader" which reads in and relocates binary files and then
- interns symbols. It is called with one argument: the (character
- string) name of a file to load. It is called as a primitive, and
- returns a single object read in. */
+/* The "fast loader" reads a FASL file, which contains a binary
+ representation of an object. The "band loader" reads a special
+ FASL file containing a world image. */
#include "scheme.h"
#include "prims.h"
+#include "history.h"
#include "osscheme.h"
#include "osfile.h"
#include "osio.h"
#include "gccode.h"
#include "trap.h"
#include "option.h"
-#include "prmcon.h"
-
-static Tchannel load_channel;
-
-#define Load_Data(size, buffer) \
- ((long) \
- ((OS_channel_read_load_file \
- (load_channel, \
- ((char *) (buffer)), \
- ((size) * (sizeof (SCHEME_OBJECT))))) \
- / (sizeof (SCHEME_OBJECT))))
+#include "fasl.h"
+
+static fasl_header_t fasl_header;
+static fasl_header_t * fh;
+static SCHEME_OBJECT * new_heap_start;
+static SCHEME_OBJECT * new_constant_start;
+static SCHEME_OBJECT * new_stack_start;
+static SCHEME_OBJECT * new_stack_end;
+static SCHEME_OBJECT * new_utilities;
+static SCHEME_OBJECT * new_prim_table;
+
+#define REQUIRED_HEAP(h) \
+ ((FASLHDR_HEAP_SIZE (h)) \
+ + (FASLHDR_N_PRIMITIVES (h)) \
+ + (FASLHDR_PRIMITIVE_TABLE_SIZE (h)))
+
+struct load_band_termination_state
+{
+ const char * file_name;
+ bool no_return_p;
+};
-#include "load.c"
+typedef void (*cleanup_t) (void);
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# include <string.h>
-#else
- extern char * EXFUN (malloc, (int));
- extern int EXFUN (strlen, (const char *));
- extern char * EXFUN (strcpy, (char *, const char *));
+static const char * reload_band_name = 0;
+static Tptrvec reload_cleanups = 0;
+static unsigned long reload_heap_size = 0;
+static unsigned long reload_constant_size = 0;
+
+static void init_fasl_file (const char *, bool, fasl_file_handle_t *);
+static void close_fasl_file (void *);
+
+static SCHEME_OBJECT load_file (fasl_file_handle_t);
+static void * read_from_file (void *, size_t, fasl_file_handle_t);
+static bool primitive_numbers_unchanged_p (SCHEME_OBJECT *);
+
+static gc_table_t * relocate_block_table (void);
+static gc_handler_t handle_primitive;
+static gc_tuple_handler_t fasload_tuple;
+static gc_vector_handler_t fasload_vector;
+static gc_object_handler_t fasload_cc_entry;
+#ifndef HEAP_IN_LOW_MEMORY
+static gc_raw_address_to_object_t fasload_raw_address_to_object;
+static gc_raw_address_to_cc_entry_t fasload_raw_address_to_cc_entry;
#endif
+static void * relocate_address (void *);
-extern char * Error_Names [];
-extern char * Abort_Names [];
-extern SCHEME_OBJECT * load_renumber_table;
-extern SCHEME_OBJECT compiler_utilities;
-
-extern SCHEME_OBJECT
- EXFUN (intern_symbol, (SCHEME_OBJECT));
-
-extern void
- EXFUN (install_primitive_table, (SCHEME_OBJECT *, long)),
- EXFUN (compiler_reset_error, (void)),
- EXFUN (compiler_initialize, (long)),
- EXFUN (compiler_reset, (SCHEME_OBJECT));
+static gc_table_t * intern_block_table (void);
+static gc_handler_t intern_handle_symbol;
+static gc_tuple_handler_t intern_tuple;
+static gc_vector_handler_t intern_vector;
+static gc_object_handler_t intern_cc_entry;
-extern Boolean
- EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
+static SCHEME_OBJECT read_band_file (SCHEME_OBJECT);
+static void terminate_band_load (void *);
\f
-static long failed_heap_length = -1;
-
-#define MODE_BAND 0
-#define MODE_CHANNEL 1
-#define MODE_FNAME 2
-
-static void
-DEFUN (read_channel_continue, (header, mode, repeat_p),
- SCHEME_OBJECT * header AND int mode AND Boolean repeat_p)
+DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, "(NAMESTRING)\n\
+Load the contents of the file NAMESTRING into memory. The file was\n\
+presumably made by a call to PRIMITIVE-FASDUMP, and may contain data\n\
+for the heap and/or the pure area. The value returned is the object\n\
+that was dumped.")
{
- extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *));
- long value, heap_length;
-
- value = (initialize_variables_from_fasl_header (header));
-
- if (value != FASL_FILE_FINE)
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
- switch (value)
- {
- /* These may want to be separated further. */
- case FASL_FILE_TOO_SHORT:
- case FASL_FILE_NOT_FASL:
- case FASL_FILE_BAD_MACHINE:
- case FASL_FILE_BAD_VERSION:
- case FASL_FILE_BAD_SUBVERSION:
- signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA);
- /*NOTREACHED*/
-
- case FASL_FILE_BAD_PROCESSOR:
- case FASL_FILE_BAD_INTERFACE:
- signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
- /*NOTREACHED*/
- }
- }
+ fasl_file_handle_t handle;
+ static unsigned long failed_heap_length = 0;
+ unsigned long heap_length;
+ SCHEME_OBJECT result;
+ PRIMITIVE_HEADER (1);
- if (Or2 (Reloc_Debug, File_Load_Debug))
- print_fasl_information();
+ canonicalize_primitive_context ();
+ transaction_begin ();
- if (((mode == MODE_BAND)
- && (! (update_allocator_parameters (Free_Constant + Const_Count))))
- || ((mode != MODE_BAND)
- && (! (TEST_CONSTANT_TOP (Free_Constant + Const_Count)))))
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
+ init_fasl_file ((STRING_ARG (1)), false, (&handle));
+ if ((FASLHDR_CONSTANT_SIZE (fh)) > 0)
signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
- /*NOTREACHED*/
- }
- if (mode == MODE_BAND)
- {
- SET_CONSTANT_TOP ();
- ALIGN_FLOAT (Free);
- SET_MEMTOP (Heap_Top);
- }
- heap_length = (Heap_Count
- + Primitive_Table_Size
- + Primitive_Table_Length
- + C_Code_Table_Size);
-\f
- if (GC_Check (heap_length))
- {
- if (repeat_p
- || (heap_length == failed_heap_length)
- || (mode == MODE_BAND))
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
- signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
- /*NOTREACHED*/
- }
- else if (mode == MODE_CHANNEL)
- {
- SCHEME_OBJECT reentry_record[1];
-
- /* IMPORTANT: This KNOWS that it was called from BINARY-FASLOAD.
- If this is ever called from elsewhere with MODE_CHANNEL,
- it will have to be parameterized better.
-
- This reentry record must match the expectations of
- continue_fasload below.
- */
-
- Request_GC (heap_length);
-
- /* This assumes that header == (Free + 1) */
- header = Free;
- Free += (FASL_HEADER_LENGTH + 1);
- *header = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, FASL_HEADER_LENGTH));
-
- reentry_record[0] = (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, header));
-
- suspend_primitive (CONT_FASLOAD,
- ((sizeof (reentry_record))
- / (sizeof (SCHEME_OBJECT))),
- &reentry_record[0]);
- immediate_interrupt ();
- /*NOTREACHED*/
- }
- else
+ heap_length = (REQUIRED_HEAP (fh));
+ if (GC_NEEDED_P (heap_length))
{
+ if (heap_length == failed_heap_length)
+ signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
failed_heap_length = heap_length;
- OS_channel_close_noerror (load_channel);
- Request_GC (heap_length);
+ REQUEST_GC (heap_length);
signal_interrupt_from_primitive ();
- /*NOTREACHED*/
}
- }
- failed_heap_length = -1;
+ failed_heap_length = 0;
- if ((band_p) && (mode != MODE_BAND))
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
- signal_error_from_primitive (ERR_FASLOAD_BAND);
- }
- return;
+ result = (load_file (handle));
+ transaction_commit ();
+ PRIMITIVE_RETURN (result);
}
-\f
+
static void
-DEFUN (read_channel_start, (channel, mode), Tchannel channel AND int mode)
+init_fasl_file (const char * file_name, bool band_p,
+ fasl_file_handle_t * handle)
{
- load_channel = channel;
-
- if (GC_Check (FASL_HEADER_LENGTH + 1))
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
- Request_GC (FASL_HEADER_LENGTH + 1);
- signal_interrupt_from_primitive ();
- /* NOTREACHED */
- }
+ if (!open_fasl_input_file (file_name, handle))
+ error_bad_range_arg (1);
+ transaction_record_action (tat_always, close_fasl_file, handle);
- if ((Load_Data (FASL_HEADER_LENGTH, ((char *) (Stack_Bottom + 1))))
- != FASL_HEADER_LENGTH)
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
+ fh = (&fasl_header);
+ if (!read_fasl_header (fh, (*handle)))
signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA);
- }
- read_channel_continue ((Stack_Bottom + 1), mode, false);
- return;
-}
+#ifndef INHIBIT_FASL_VERSION_CHECK
+ if ((check_fasl_version (fh)) != FASL_FILE_FINE)
+ {
+ outf_error ("\nBad version in FASL File: %s\n", file_name);
+ outf_error
+ ("File has: Version %4u Architecture %4u.\n",
+ (FASLHDR_VERSION (fh)), (FASLHDR_ARCH (fh)));
+ outf_error
+ ("Expected: Version between %4u and %4u Architecture %4u.\n",
+ OLDEST_INPUT_FASL_VERSION,
+ NEWEST_INPUT_FASL_VERSION,
+ CURRENT_FASL_ARCH);
+ signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA);
+ }
+#endif
-static void
-DEFUN (read_file_start, (file_name, from_band_load),
- CONST char * file_name AND Boolean from_band_load)
-{
- Tchannel channel;
+#ifndef INHIBIT_COMPILED_VERSION_CHECK
+ if ((check_fasl_cc_version (fh,
+ compiler_interface_version,
+ compiler_processor_type))
+ != FASL_FILE_FINE)
+ {
+ outf_error ("\nBad compiled-code version in FASL File: %s\n", file_name);
+ outf_error
+ ("File has: compiled-code interface %4u; architecture %4u.\n",
+ (FASLHDR_CC_VERSION (fh)), (FASLHDR_CC_ARCH (fh)));
+ outf_error
+ ("Expected: compiled code interface %4u; architecture %4u.\n",
+ compiler_interface_version, compiler_processor_type);
+ signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
+ }
+#endif
- channel = (OS_open_load_file (file_name));
-
- if (Per_File)
- debug_edit_flags ();
- if (channel == NO_CHANNEL)
- error_bad_range_arg (1);
- read_channel_start (channel, (from_band_load ? MODE_BAND : MODE_FNAME));
- return;
+ if ((FASLHDR_BAND_P (fh)) != band_p)
+ signal_error_from_primitive (ERR_FASLOAD_BAND);
}
-\f
+
static void
-DEFUN (read_file_end, (mode, prim_table_ptr, c_code_table_ptr),
- int mode
- AND SCHEME_OBJECT ** prim_table_ptr
- AND SCHEME_OBJECT ** c_code_table_ptr)
+close_fasl_file (void * p)
{
- SCHEME_OBJECT * prim_table, * c_code_table;
- extern unsigned long checksum_area ();
-
- if ((Load_Data (Heap_Count, ((char *) Free))) != Heap_Count)
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
- signal_error_from_primitive (ERR_IO_ERROR);
- }
- computed_checksum =
- (checksum_area (((unsigned long *) Free),
- Heap_Count,
- computed_checksum));
- NORMALIZE_REGION(((char *) Free), Heap_Count);
- Free += Heap_Count;
-
- if ((Load_Data (Const_Count, ((char *) Free_Constant))) != Const_Count)
- {
- SET_CONSTANT_TOP ();
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
- signal_error_from_primitive (ERR_IO_ERROR);
- }
- computed_checksum =
- (checksum_area (((unsigned long *) Free_Constant),
- Const_Count,
- computed_checksum));
- NORMALIZE_REGION (((char *) Free_Constant), Const_Count);
- Free_Constant += Const_Count;
- SET_CONSTANT_TOP ();
-
- prim_table = Free;
- if ((Load_Data (Primitive_Table_Size, ((char *) prim_table)))
- != Primitive_Table_Size)
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
- signal_error_from_primitive (ERR_IO_ERROR);
- }
- computed_checksum =
- (checksum_area (((unsigned long *) prim_table),
- Primitive_Table_Size,
- computed_checksum));
- NORMALIZE_REGION (((char *) prim_table), Primitive_Table_Size);
- Free += Primitive_Table_Size;
-
- c_code_table = Free;
- * c_code_table = FIXNUM_ZERO;
- if ((C_Code_Table_Size != 0)
- && ((Load_Data (C_Code_Table_Size, ((char *) c_code_table)))
- != C_Code_Table_Size))
- {
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
- signal_error_from_primitive (ERR_IO_ERROR);
- }
- computed_checksum =
- (checksum_area (((unsigned long *) c_code_table),
- C_Code_Table_Size,
- computed_checksum));
- NORMALIZE_REGION (((char *) c_code_table), C_Code_Table_Size);
- Free += C_Code_Table_Size;
-
- if (mode != MODE_CHANNEL)
- OS_channel_close_noerror (load_channel);
-
- if ((computed_checksum != ((unsigned long) 0))
- && (dumped_checksum != SHARP_F))
- signal_error_from_primitive (ERR_IO_ERROR);
-
- * prim_table_ptr = prim_table;
- * c_code_table_ptr = c_code_table;
- return;
+ (void) close_fasl_input_file (* ((fasl_file_handle_t *) p));
}
\f
-/* Statics used by Relocate, below */
-
-relocation_type
- heap_relocation,
- const_relocation,
- stack_relocation;
+DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, "(NAMESTRING)\n\
+Restores the heap and constant space from the contents of the file\n\
+NAMESTRING, which is typically a file created by DUMP-BAND. The file\n\
+can, however, be any file which can be loaded with BINARY-FASLOAD.")
+{
+ SCHEME_OBJECT result;
+ PRIMITIVE_HEADER (1);
-/* Relocate a pointer as read in from the file. If the pointer used
- to point into the heap, relocate it into the heap. If it used to
- be constant area, relocate it to constant area. Otherwise give an
- error.
-*/
+ CHECK_ARG (1, STRING_P);
+ canonicalize_primitive_context ();
+ result = (read_band_file (ARG_REF (1)));
-#ifdef ENABLE_DEBUGGING_TOOLS
+ /* Reset implementation state parameters. */
+ INITIALIZE_INTERRUPTS (0);
+#ifdef CC_SUPPORT_P
+ compiler_utilities = (PAIR_CDR (result));
+ if (compiler_utilities != SHARP_F)
+ compiler_reset (compiler_utilities);
+ else
+ compiler_initialize (true);
+#endif
+ fixed_objects = SHARP_F;
+ current_state_point = SHARP_F;
-static Boolean Warned = false;
+ /* Setup initial program */
+ SET_RC (RC_END_OF_COMPUTATION);
+ SET_EXP (SHARP_F);
+ SAVE_CONT ();
+ SET_EXP (PAIR_CAR (result));
+ SET_ENV (THE_GLOBAL_ENV);
+
+ /* Clear various interpreter state parameters. */
+ trapping = false;
+ history_register = (make_dummy_history ());
+ prev_restore_history_offset = 0;
+ CC_TRANSPORT_END ();
+ execute_reload_cleanups ();
+ EXIT_CRITICAL_SECTION ({});
-static SCHEME_OBJECT *
-DEFUN (relocate, (P), long P)
-{
- SCHEME_OBJECT * Result;
-
- if ((P >= Heap_Base) && (P < Dumped_Heap_Top))
- Result = ((SCHEME_OBJECT *) (P + heap_relocation));
- else if ((P >= Const_Base) && (P < Dumped_Constant_Top))
- Result = ((SCHEME_OBJECT *) (P + const_relocation));
- else if ((P >= Dumped_Constant_Top) && (P < Dumped_Stack_Top))
- Result = ((SCHEME_OBJECT *) (P + stack_relocation));
- else
- {
- outf_console ("Pointer out of range: 0x%lx\n", P);
- if (!Warned)
- {
- outf_console ("Heap: %lx-%lx, Constant: %lx-%lx, Stack: ?-0x%lx\n",
- ((long) Heap_Base), ((long) Dumped_Heap_Top),
- ((long) Const_Base), ((long) Dumped_Constant_Top),
- ((long) Dumped_Stack_Top));
- Warned = true;
- }
- Result = ((SCHEME_OBJECT *) 0);
- }
- if (Reloc_Debug)
- outf_console ("0x%06lx -> 0x%06lx\n", P, ((long) Result));
- return (Result);
+ /* Return in a non-standard way. */
+ PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
+ /*NOTREACHED*/
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-#define RELOCATE relocate
-#define RELOCATE_INTO(Loc, P) (Loc) = relocate(P)
-\f
-#else /* not ENABLE_DEBUGGING_TOOLS */
-
-#define RELOCATE_INTO(Loc, P) do \
-{ \
- long _P = (P); \
- \
- if ((P >= Heap_Base) && (_P < Dumped_Heap_Top)) \
- (Loc) = ((SCHEME_OBJECT *) (_P + heap_relocation)); \
- else if ((P >= Const_Base) && (_P < Dumped_Constant_Top)) \
- (Loc) = ((SCHEME_OBJECT *) (_P + const_relocation)); \
- else \
- (Loc) = ((SCHEME_OBJECT *) (_P + stack_relocation)); \
-} while (0)
-
-#ifndef Conditional_Bug
-
-#define RELOCATE(P) \
-((((P) >= Heap_Base) && ((P) < Dumped_Heap_Top)) \
- ? ((SCHEME_OBJECT *) ((P) + heap_relocation)) \
- : ((((P) >= Const_Base) && ((P) < Dumped_Constant_Top)) \
- ? ((SCHEME_OBJECT *) ((P) + const_relocation)) \
- : ((SCHEME_OBJECT *) ((P) + stack_relocation))))
-
-#else /* Conditional_Bug */
-
-static SCHEME_OBJECT * relocate_temp;
-
-#define RELOCATE(P) \
- (RELOCATE_INTO (relocate_temp, P), relocate_temp)
-
-#endif /* Conditional_Bug */
-#endif /* ENABLE_DEBUGGING_TOOLS */
-\f
-/* Next_Pointer starts by pointing to the beginning of the block of
- memory to be handled. This loop relocates all pointers in the
- block of memory.
-*/
-
-static long
-DEFUN (primitive_dumped_number, (datum), unsigned long datum)
+static SCHEME_OBJECT
+read_band_file (SCHEME_OBJECT s)
{
- unsigned long high_bits = (datum >> HALF_DATUM_LENGTH);
- return ((high_bits != 0) ? high_bits : datum);
-}
+ const char * file_name;
+ struct load_band_termination_state * state;
+ fasl_file_handle_t handle;
+ SCHEME_OBJECT result;
+ void * old_name;
+
+ transaction_begin ();
+ file_name = (OS_malloc ((STRING_LENGTH (s)) + 1));
+ strcpy (((char *) file_name), (STRING_POINTER (s)));
+ state = (dstack_alloc (sizeof (struct load_band_termination_state)));
+ (state->file_name) = file_name;
+ (state->no_return_p) = false;
+ transaction_record_action (tat_abort, terminate_band_load, state);
+
+ init_fasl_file (file_name, true, (&handle));
+ if (!allocations_ok_p ((FASLHDR_CONSTANT_SIZE (fh)),
+ (REQUIRED_HEAP (fh))))
+ signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
-#define PRIMITIVE_DUMPED_NUMBER(prim) \
- (primitive_dumped_number (OBJECT_DATUM (prim)))
+ /* Now read the file into memory. Past this point we can't abort
+ and return to the old image. */
+ ENTER_CRITICAL_SECTION ("band load");
+ (state->no_return_p) = true;
-static void
-DEFUN (Relocate_Block, (Scan, Stop_At),
- fast SCHEME_OBJECT * Scan AND fast SCHEME_OBJECT * Stop_At)
-{
- fast long address;
- fast SCHEME_OBJECT Temp;
+ reset_allocator_parameters (FASLHDR_CONSTANT_SIZE (fh));
+ result = (load_file (handle));
- if (Reloc_Debug)
- {
- outf_error
- ("\nRelocate_Block: block = 0x%lx, length = 0x%lx, end = 0x%lx.\n",
- ((long) Scan), ((long) ((Stop_At - Scan) - 1)), ((long) Stop_At));
- }
+ /* Done -- we have the new image. */
+ transaction_commit ();
- while (Scan < Stop_At)
- {
- Temp = * Scan;
- Switch_by_GC_Type (Temp)
- {
- case TC_BROKEN_HEART:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_Fasload_Non_Pointer:
-#ifdef EMPTY_LIST_VALUE
- if (Temp == EMPTY_LIST_VALUE)
- * Scan = EMPTY_LIST;
-#endif
- Scan += 1;
- break;
-
- case TC_PRIMITIVE:
- *Scan++ = (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)]);
- break;
-
- case TC_PCOMB0:
- *Scan++ =
- OBJECT_NEW_TYPE
- (TC_PCOMB0,
- (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)]));
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- Scan += ((OBJECT_DATUM (Temp)) + 1);
- break;
-\f
- case TC_LINKAGE_SECTION:
- {
- switch (READ_LINKAGE_KIND (Temp))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- /* Assumes that all others are objects of type TC_HUNK3
- without their type codes. */
-
- fast long count;
-
- Scan++;
- for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
- --count >= 0;
- )
- {
- address = (SCHEME_ADDR_TO_OLD_DATUM (* Scan));
- *Scan++ = (ADDR_TO_SCHEME_ADDR (RELOCATE (address)));
- }
- break;
- }
+ /* Save the band name for possible later use. */
+ old_name = ((void *) reload_band_name);
+ reload_band_name = file_name;
+ if (old_name != 0)
+ OS_free (old_name);
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- {
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * end_scan;
-
- START_OPERATOR_RELOCATION (Scan);
- count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
- word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
- end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
-
- while(--count >= 0)
- {
- Scan = ((SCHEME_OBJECT *) (word_ptr));
- word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
- EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, Scan);
- address = (SCHEME_ADDR_TO_OLD_DATUM (address));
- address = ((long) (RELOCATE (address)));
- STORE_OPERATOR_LINKAGE_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)),
- Scan);
- }
- Scan = &end_scan[1];
- END_OPERATOR_RELOCATION (Scan - 1);
- break;
- }
+ return (result);
+}
- case CLOSURE_PATTERN_LINKAGE_KIND:
- Scan += (1 + (READ_CACHE_LINKAGE_COUNT (Temp)));
- break;
+static void
+terminate_band_load (void * ap)
+{
+ struct load_band_termination_state * state = ap;
+ int abort_value;
- default:
- {
- gc_death (TERM_EXIT,
- "Relocate_Block: Unknown compiler linkage kind.",
- Scan, NULL);
- /*NOTREACHED*/
- }
- }
- break;
- }
-\f
- case TC_MANIFEST_CLOSURE:
- {
- /* See comment about relocation in TC_LINKAGE_SECTION above. */
-
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * area_end;
-
- START_CLOSURE_RELOCATION (Scan);
- Scan += 1;
- count = (MANIFEST_CLOSURE_COUNT (Scan));
- word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan));
- area_end = ((MANIFEST_CLOSURE_END (Scan, count)) - 1);
-
- while ((--count) >= 0)
- {
- Scan = ((SCHEME_OBJECT *) (word_ptr));
- word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
- EXTRACT_CLOSURE_ENTRY_ADDRESS (address, Scan);
- address = (SCHEME_ADDR_TO_OLD_DATUM (address));
- address = ((long) (RELOCATE (address)));
- STORE_CLOSURE_ENTRY_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)), Scan);
- }
- END_CLOSURE_RELOCATION (area_end);
- Scan = (area_end + 1);
- break;
- }
-\f
-#ifdef BYTE_INVERSION
- case TC_CHARACTER_STRING:
- String_Inversion (RELOCATE (OBJECT_DATUM (Temp)));
- goto normal_pointer;
-#endif
+ if (! (state->no_return_p))
+ {
+ OS_free ((void *) (state->file_name));
+ return;
+ }
- case TC_REFERENCE_TRAP:
- if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
- {
- Scan += 1;
- break;
- }
- /* It is a pointer, fall through. */
+ abort_value = (abort_to_interpreter_argument ());
- /* Compiled entry points and stack environments work automagically. */
- /* This should be more strict. */
+ fputs ("\nload-band: ", stderr);
+ if (abort_value > 0)
+ {
+ const char * message
+ = ((abort_value <= MAX_ERROR)
+ ? (Error_Names[abort_value])
+ : 0);
+ if (message == 0)
+ outf_fatal ("Unknown error %#lx", ((unsigned long) abort_value));
+ else
+ outf_fatal ("Error %#lx (%s)", ((unsigned long) abort_value), message);
+ }
+ else
+ {
+ abort_value = ((-abort_value) - 1);
+ outf_fatal ("Abort %d (%s)", abort_value, (Abort_Names[abort_value]));
+ }
+ outf_fatal (" past the point of no return.\n");
+ outf_fatal ("file name = \"%s\".\n", (state->file_name));
+ OS_free ((void *) (state->file_name));
- default:
-#ifdef BYTE_INVERSION
- normal_pointer:
-#endif
- address = (OBJECT_DATUM (Temp));
- *Scan++ = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (Temp)),
- (RELOCATE (address))));
- break;
- }
- }
- return;
+ execute_reload_cleanups ();
+ EXIT_CRITICAL_SECTION ({});
+ Microcode_Termination (TERM_DISK_RESTORE);
+ /*NOTREACHED*/
}
-\f
-static Boolean
-DEFUN (check_primitive_numbers, (table, length),
- fast SCHEME_OBJECT * table AND fast long length)
-{
- fast long count;
- for (count = 0; count < length; count += 1)
- if (table[count] != (MAKE_PRIMITIVE_OBJECT (count)))
- return (false);
- return (true);
+DEFINE_PRIMITIVE ("RELOAD-BAND-NAME", Prim_reload_band_name, 0, 0, "()\n\
+Return the filename from which the runtime system was last restored.\n\
+The result is a string, or #F if the system was not restored.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN
+ ((reload_band_name != 0)
+ ? (char_pointer_to_string (reload_band_name))
+ : (option_band_file != 0)
+ ? (char_pointer_to_string (option_band_file))
+ : SHARP_F);
}
-extern void EXFUN (get_band_parameters, (long * heap_size, long * const_size));
-
void
-DEFUN (get_band_parameters, (heap_size, const_size),
- long * heap_size AND long * const_size)
+get_band_parameters (unsigned long * heap_size, unsigned long * const_size)
{
- /* This assumes we have just aborted out of a band load. */
- (*heap_size) = Heap_Count;
- (*const_size) = Const_Count;
+ (*heap_size) = reload_heap_size;
+ (*const_size) = reload_constant_size;
}
-\f
-static void
-DEFUN (Intern_Block, (Next_Pointer, Stop_At),
- fast SCHEME_OBJECT * Next_Pointer AND fast SCHEME_OBJECT * Stop_At)
-{
- if (Reloc_Debug)
- {
- outf_console ("Interning a block.\n");
- }
- while (Next_Pointer < Stop_At)
- {
- switch (OBJECT_TYPE (*Next_Pointer))
+void
+add_reload_cleanup (cleanup_t cleanup_procedure)
+{
+ if (reload_cleanups == 0)
{
- case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += (1 + (OBJECT_DATUM (* Next_Pointer)));
- break;
-
- case TC_INTERNED_SYMBOL:
- if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_GLOBAL_VALUE))) ==
- TC_BROKEN_HEART)
- {
- SCHEME_OBJECT old_symbol = (*Next_Pointer);
- MEMORY_SET (old_symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
- {
- SCHEME_OBJECT new_symbol = (intern_symbol (old_symbol));
- if (new_symbol != old_symbol)
- {
- (*Next_Pointer) = new_symbol;
- MEMORY_SET
- (old_symbol,
- SYMBOL_NAME,
- (OBJECT_NEW_TYPE (TC_BROKEN_HEART, new_symbol)));
- }
- }
- }
- else if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_NAME))) ==
- TC_BROKEN_HEART)
- {
- *Next_Pointer =
- (MAKE_OBJECT_FROM_OBJECTS
- ((*Next_Pointer),
- (FAST_MEMORY_REF ((*Next_Pointer), SYMBOL_NAME))));
- }
- Next_Pointer += 1;
- break;
-
- default:
- Next_Pointer += 1;
- break;
+ reload_cleanups = (ptrvec_allocate (1));
+ (* ((cleanup_t *) (PTRVEC_LOC (reload_cleanups, 0))))
+ = cleanup_procedure;
}
- }
- if (Reloc_Debug)
- {
- outf_console ("Done interning block.\n");
- }
- return;
+ else
+ ptrvec_adjoin (reload_cleanups, cleanup_procedure);
}
-\f
-/* This should be moved to config.h! */
-
-#ifndef COMPUTE_RELOCATION
-#define COMPUTE_RELOCATION(new, old) (((relocation_type) (new)) - (old))
-#endif
+void
+execute_reload_cleanups (void)
+{
+ void ** scan = (PTRVEC_START (reload_cleanups));
+ void ** end = (PTRVEC_END (reload_cleanups));
+ while (scan < end)
+ (* ((cleanup_t *) (scan++))) ();
+}
+\f
static SCHEME_OBJECT
-DEFUN (load_file, (mode), int mode)
+load_file (fasl_file_handle_t handle)
{
- SCHEME_OBJECT
- * Orig_Heap,
- * Constant_End, * Orig_Constant,
- * temp, * primitive_table, * c_code_table;
-
- /* Read File */
-
-#ifdef ENABLE_DEBUGGING_TOOLS
- Warned = false;
-#endif
-
- load_renumber_table = Free;
- Free += Primitive_Table_Length;
- ALIGN_FLOAT (Free);
- Orig_Heap = Free;
- Orig_Constant = Free_Constant;
- read_file_end (mode, &primitive_table, &c_code_table);
- Constant_End = Free_Constant;
- heap_relocation = (COMPUTE_RELOCATION (Orig_Heap, Heap_Base));
-
- /*
- Magic!
- The relocation of compiled code entry points depends on the fact
- that fasdump never dumps the compiler utilities vector (which
- contains entry points used by compiled code to invoke microcode
- provided utilities, like return_to_interpreter).
-
- If the file is not a band, any pointers into constant space are
- pointers into the compiler utilities vector. const_relocation is
- computed appropriately.
-
- Otherwise (the file is a band, and only bands can contain constant
- space segments) the utilities vector stuff is relocated
- automagically: the utilities vector is part of the band.
- */
-
- if ((! band_p) && (dumped_utilities != SHARP_F))
+ new_heap_start = Free;
+ new_constant_start = constant_alloc_next;
+ new_stack_start = stack_start;
+ new_stack_end = stack_end;
+ new_utilities
+ = ((compiler_utilities == SHARP_F)
+ ? 0
+ : (OBJECT_ADDRESS (compiler_utilities)));
+
+ Free = (read_from_file (Free, (FASLHDR_HEAP_SIZE (fh)), handle));
+ constant_alloc_next
+ = (read_from_file (constant_alloc_next,
+ (FASLHDR_CONSTANT_SIZE (fh)),
+ handle));
+
+ new_prim_table = Free;
{
- if (compiler_utilities == SHARP_F)
- signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
-
- const_relocation =
- (COMPUTE_RELOCATION ((OBJECT_ADDRESS (compiler_utilities)),
- (OBJECT_DATUM (dumped_utilities))));
- Dumped_Constant_Top =
- (ADDRESS_TO_DATUM
- (MEMORY_LOC (dumped_utilities,
- (1 + (VECTOR_LENGTH (compiler_utilities))))));
+ SCHEME_OBJECT * raw_prim_table = (Free + (FASLHDR_N_PRIMITIVES (fh)));
+ read_from_file (raw_prim_table,
+ (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)),
+ handle);
+ import_primitive_table
+ (raw_prim_table, (FASLHDR_N_PRIMITIVES (fh)), new_prim_table);
}
- else
- const_relocation = (COMPUTE_RELOCATION (Orig_Constant, Const_Base));
- stack_relocation = (COMPUTE_RELOCATION (Stack_Top, Dumped_Stack_Top));
-\f
-#ifdef BYTE_INVERSION
- Setup_For_String_Inversion ();
+#ifdef CC_IS_C
+ if ((FASLHDR_BAND_P (fh)) && ((FASLHDR_C_CODE_TABLE_SIZE (fh)) > 0))
+ {
+ SCHEME_OBJECT * raw_table = (Free + (FASLHDR_N_PRIMITIVES (fh)));
+ read_from_file (raw_table, (FASLHDR_C_CODE_TABLE_SIZE (fh)), handle);
+ if (!import_c_code_table (raw_table, (FASLHDR_N_C_CODE_BLOCKS (fh))))
+ signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
+ }
#endif
- /* Setup the primitive and C code tables */
-
- install_primitive_table (primitive_table, Primitive_Table_Length);
- if ((mode == MODE_BAND)
- && (! (install_c_code_table (c_code_table, C_Code_Table_Length))))
+ if ((!FASLHDR_BAND_P (fh))
+ && ((FASLHDR_UTILITIES_VECTOR (fh)) != SHARP_F)
+ && (compiler_utilities == SHARP_F))
+ /* The file contains compiled code, but there's no compiled-code
+ support available. */
signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
- if ((mode != MODE_BAND)
- || (heap_relocation != ((relocation_type) 0))
- || (const_relocation != ((relocation_type) 0))
- || (stack_relocation != ((relocation_type) 0))
- || (! (check_primitive_numbers (load_renumber_table,
- Primitive_Table_Length))))
- {
- /* We need to relocate. Oh well. */
- if (Reloc_Debug)
- outf_console
- ("heap_relocation = %ld = %lx; const_relocation = %ld = %lx\n",
- ((long) heap_relocation), ((long) heap_relocation),
- ((long) const_relocation), ((long) const_relocation));
-
- /*
- Relocate the new data.
-
- There are no pointers in the primitive table, thus
- there is no need to relocate it.
- */
-
- Relocate_Block (Orig_Heap, primitive_table);
- Relocate_Block (Orig_Constant, Constant_End);
- }
-\f
-#ifdef BYTE_INVERSION
- Finish_String_Inversion ();
-#endif
-
- if (mode != MODE_BAND)
- {
- /* Again, there are no symbols in the primitive table. */
-
- Intern_Block (Orig_Heap, primitive_table);
- Intern_Block (Orig_Constant, Constant_End);
- }
+ if (! ((FASLHDR_BAND_P (fh))
+ && ((FASLHDR_HEAP_START (fh)) == new_heap_start)
+ && (((FASLHDR_CONSTANT_START (fh)) == new_constant_start)
+ || ((FASLHDR_CONSTANT_START (fh)) == (FASLHDR_CONSTANT_END (fh))))
+ && (((FASLHDR_STACK_START (fh)) == 0)
+ || ((FASLHDR_STACK_START (fh)) == new_stack_start))
+ && ((FASLHDR_STACK_END (fh)) == new_stack_end)
+ && ((FASLHDR_MEMORY_BASE (fh)) == memory_base)
+ && (primitive_numbers_unchanged_p (new_prim_table))))
+ {
+ current_gc_table = (relocate_block_table ());
+ gc_scan_oldspace (new_heap_start, Free);
+ gc_scan_oldspace (new_constant_start, constant_alloc_next);
+ }
+ if (!FASLHDR_BAND_P (fh))
+ {
+ current_gc_table = (intern_block_table ());
+ gc_scan_oldspace (new_heap_start, Free);
+ gc_scan_oldspace (new_constant_start, constant_alloc_next);
+ }
#ifdef PUSH_D_CACHE_REGION
- if (dumped_interface_version != 0)
- {
- if (primitive_table != Orig_Heap)
- PUSH_D_CACHE_REGION (Orig_Heap, (primitive_table - Orig_Heap));
- if (Constant_End != Orig_Constant)
- PUSH_D_CACHE_REGION (Orig_Constant, (Constant_End - Orig_Constant));
- }
+ if ((FASLHDR_CC_VERSION (fh)) != COMPILER_NONE_TYPE)
+ {
+ if ((FASLHDR_HEAP_SIZE (fh)) > 0)
+ PUSH_D_CACHE_REGION (new_heap_start, (FASLHDR_HEAP_SIZE (fh)));
+ if ((FASLHDR_CONSTANT_SIZE (fh)) > 0)
+ PUSH_D_CACHE_REGION (new_constant_start, (FASLHDR_CONSTANT_SIZE (fh)));
+ }
#endif
- FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table,
- Orig_Constant, Constant_End);
- RELOCATE_INTO (temp, Dumped_Object);
- return (* temp);
+ return
+ (* ((SCHEME_OBJECT *)
+ (relocate_address (FASLHDR_ROOT_POINTER (fh)))));
}
-\f
-/* (BINARY-FASLOAD FILE-NAME-OR-CHANNEL)
- Load the contents of FILE-NAME-OR-CHANNEL into memory. The file
- was presumably made by a call to PRIMITIVE-FASDUMP, and may contain
- data for the heap and/or the pure area. The value returned is the
- object which was dumped. Typically (but not always) this will be a
- piece of SCode which is then evaluated to perform definitions in
- some environment.
- If a file name is given, the corresponding file is opened before
- loading and closed after loading. A channel remains open.
-*/
-DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, 0)
+static void *
+read_from_file (void * p, size_t n_words, fasl_file_handle_t handle)
{
- SCHEME_OBJECT arg, result;
- PRIMITIVE_HEADER (1);
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- arg = (ARG_REF (1));
- if (STRING_P (arg))
- {
- read_file_start ((STRING_ARG (1)), false);
- result = (load_file (MODE_FNAME));
- }
- else
- {
- read_channel_start ((arg_channel (1)), MODE_CHANNEL);
- result = (load_file (MODE_CHANNEL));
- }
-#ifdef AUTOCLOBBER_BUG
- *Free = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- ((PAGE_SIZE / (sizeof (SCHEME_OBJECT)))
- - 1)));
- Free += (PAGE_SIZE / (sizeof (SCHEME_OBJECT)));
-#endif
- PRIMITIVE_RETURN (result);
+ if (!read_from_fasl_file (p, n_words, handle))
+ signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA);
+ return (((char *) p) + (n_words * SIZEOF_SCHEME_OBJECT));
}
-SCHEME_OBJECT
-DEFUN (continue_fasload, (reentry_record), SCHEME_OBJECT * reentry_record)
+static bool
+primitive_numbers_unchanged_p (SCHEME_OBJECT * table)
{
- SCHEME_OBJECT header;
-
- /* The reentry record was prepared by read_channel_continue above. */
+ unsigned long count;
- load_channel = (arg_channel (1));
- header = (reentry_record[0]);
- read_channel_continue ((VECTOR_LOC (header, 0)), MODE_CHANNEL, true);
- PRIMITIVE_RETURN (load_file (MODE_CHANNEL));
+ for (count = 0; (count < (FASLHDR_N_PRIMITIVES (fh))); count += 1)
+ if ((table[count]) != (MAKE_PRIMITIVE_OBJECT (count)))
+ return (false);
+ return (true);
}
\f
-/* Band loading. */
-
-static char *reload_band_name = 0;
-static Tptrvec reload_cleanups = 0;
-
-DEFINE_PRIMITIVE ("RELOAD-BAND-NAME", Prim_reload_band_name, 0, 0,
- "Return the filename from which the runtime system was last restored.\n\
-The result is a string, or #F if the system was not restored.")
+static gc_table_t *
+relocate_block_table (void)
{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN
- ((reload_band_name != 0)
- ? (char_pointer_to_string (reload_band_name))
- : (option_band_file != 0)
- ? (char_pointer_to_string (option_band_file))
- : SHARP_F);
-}
-
-typedef void EXFUN ((*Tcleanup), (void));
+ static bool initialized_p = false;
+ static gc_table_t table;
-void
-DEFUN (add_reload_cleanup, (cleanup_procedure), Tcleanup cleanup_procedure)
-{
- if (reload_cleanups == 0)
+ if (!initialized_p)
{
- reload_cleanups = (ptrvec_allocate (1));
- (* ((Tcleanup *) (PTRVEC_LOC (reload_cleanups, 0)))) = cleanup_procedure;
+ initialize_gc_table ((&table), false);
+
+ (GCT_TUPLE (&table)) = fasload_tuple;
+ (GCT_VECTOR (&table)) = fasload_vector;
+ (GCT_CC_ENTRY (&table)) = fasload_cc_entry;
+#ifndef HEAP_IN_LOW_MEMORY
+ (GCT_RAW_ADDRESS_TO_OBJECT (&table)) = fasload_raw_address_to_object;
+ (GCT_RAW_ADDRESS_TO_CC_ENTRY (&table)) = fasload_raw_address_to_cc_entry;
+#endif
+
+ (GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair;
+ (GCT_ENTRY ((&table), TC_PRIMITIVE)) = handle_primitive;
+ (GCT_ENTRY ((&table), TC_PCOMB0)) = handle_primitive;
+ (GCT_ENTRY ((&table), TC_BROKEN_HEART)) = gc_handle_non_pointer;
+
+ initialized_p = true;
}
- else
- ptrvec_adjoin (reload_cleanups, (PTR) cleanup_procedure);
+ return (&table);
}
-void
-DEFUN_VOID (execute_reload_cleanups)
+static
+DEFINE_GC_HANDLER (handle_primitive)
{
- PTR * scan = (PTRVEC_START (reload_cleanups));
- PTR * end = (PTRVEC_END (reload_cleanups));
- while (scan < end)
- (* ((Tcleanup *) (scan++))) ();
+ unsigned long datum = (OBJECT_DATUM (object));
+ unsigned long high_bits = (datum >> HALF_DATUM_LENGTH);
+ (*scan)
+ = (MAKE_OBJECT_FROM_OBJECTS
+ (object,
+ (new_prim_table [((high_bits != 0) ? high_bits : datum)])));
+ return (scan + 1);
}
-/* Utility for load band below. */
+#ifdef HEAP_IN_LOW_MEMORY
-void
-DEFUN_VOID (compiler_reset_error)
-{
- outf_fatal ("\ncompiler_reset_error: The band being restored and\n");
- outf_fatal
- ("the compiled code interface in this microcode are inconsistent.\n");
- Microcode_Termination (TERM_COMPILER_DEATH);
-}
-\f
-#ifndef START_BAND_LOAD
-#define START_BAND_LOAD() do \
-{ \
- ENTER_CRITICAL_SECTION ("band load"); \
-} while (0)
-#endif
+#define OLD_ADDRESS OBJECT_ADDRESS
+#define OLD_CC_ADDRESS CC_ENTRY_ADDRESS
-#ifndef END_BAND_LOAD
-#define END_BAND_LOAD(success, dying) do \
-{ \
- if (success || dying) \
- execute_reload_cleanups (); \
- EXIT_CRITICAL_SECTION ({}); \
-} while (0)
-#endif
+#else
-struct memmag_state
-{
- SCHEME_OBJECT * heap_bottom;
- SCHEME_OBJECT * heap_top;
- SCHEME_OBJECT * unused_heap_bottom;
- SCHEME_OBJECT * unused_heap_top;
- SCHEME_OBJECT * free;
- SCHEME_OBJECT * memtop;
- SCHEME_OBJECT * constant_space;
- SCHEME_OBJECT * constant_top;
- SCHEME_OBJECT * free_constant;
- SCHEME_OBJECT * stack_pointer;
- SCHEME_OBJECT * stack_bottom;
- SCHEME_OBJECT * stack_top;
- SCHEME_OBJECT * stack_guard;
-};
+#define OLD_ADDRESS(object) \
+ ((FASLHDR_MEMORY_BASE (fh)) + (OBJECT_DATUM (object)))
-static void
-DEFUN (abort_band_load, (ap), PTR ap)
+#define OLD_CC_ADDRESS(object) \
+ (((insn_t *) (FASLHDR_MEMORY_BASE (fh))) + (OBJECT_DATUM (object)))
+
+static SCHEME_OBJECT
+fasload_raw_address_to_object (unsigned int type, SCHEME_OBJECT * address)
{
- struct memmag_state * mp = ((struct memmag_state *) ap);
-
- Heap_Bottom = mp->heap_bottom;
- Heap_Top = mp->heap_top;
- Unused_Heap_Bottom = mp->unused_heap_bottom;
- Unused_Heap_Top = mp->unused_heap_top;
- Free = mp->free;
- Free_Constant = mp->free_constant;
- Constant_Space = mp->constant_space;
- Constant_Top = mp->constant_top;
- sp_register = mp->stack_pointer;
- Stack_Bottom = mp->stack_bottom;
- Stack_Top = mp->stack_top;
- Stack_Guard = mp->stack_guard;
- SET_MEMTOP (mp->memtop);
-
- END_BAND_LOAD (false, false);
- return;
+ return (MAKE_OBJECT (type, (address - (FASLHDR_MEMORY_BASE (fh)))));
}
-static void
-DEFUN (terminate_band_load, (ap), PTR ap)
+SCHEME_OBJECT
+fasload_raw_address_to_cc_entry (insn_t * address)
{
- fputs ("\nload-band: ", stderr);
- {
- int abort_value = (abort_to_interpreter_argument ());
- if (abort_value > 0)
- outf_fatal ("Error %ld (%s)",
- ((long) abort_value),
- (Error_Names [abort_value]));
- else
- outf_fatal ("Abort %ld (%s)",
- ((long) abort_value),
- (Abort_Names [(-abort_value) - 1]));
- }
- outf_fatal (" past the point of no return.\n");
- {
- char * band_name = (* ((char **) ap));
- if (band_name != 0)
- {
- outf_fatal ("band-name = \"%s\".\n", band_name);
- free (band_name);
- }
- }
- END_BAND_LOAD (false, true);
- Microcode_Termination (TERM_DISK_RESTORE);
- /*NOTREACHED*/
+ return (MAKE_OBJECT (TC_COMPILED_ENTRY,
+ (address - ((insn_t *) (FASLHDR_MEMORY_BASE (fh))))));
}
-\f
-/* (LOAD-BAND FILE-NAME)
- Restores the heap and pure space from the contents of FILE-NAME,
- which is typically a file created by DUMP-BAND. The file can,
- however, be any file which can be loaded with BINARY-FASLOAD.
-*/
-DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0)
-{
- extern void EXFUN (reset_allocator_parameters, (void));
- SCHEME_OBJECT result;
- PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+#endif /* !HEAP_IN_LOW_MEMORY */
- {
- CONST char * file_name = (STRING_ARG (1));
- transaction_begin ();
- {
- struct memmag_state * mp = (dstack_alloc (sizeof (struct memmag_state)));
-
- mp->heap_bottom = Heap_Bottom;
- mp->heap_top = Heap_Top;
- mp->unused_heap_bottom = Unused_Heap_Bottom;
- mp->unused_heap_top = Unused_Heap_Top;
- mp->free = Free;
- mp->memtop = MemTop;
- mp->free_constant = Free_Constant;
- mp->constant_space = Constant_Space;
- mp->constant_top = Constant_Top;
- mp->stack_pointer = sp_register;
- mp->stack_bottom = Stack_Bottom;
- mp->stack_top = Stack_Top;
- mp->stack_guard = Stack_Guard;
- transaction_record_action (tat_abort, abort_band_load, mp);
- }
-
- reset_allocator_parameters ();
- SET_MEMTOP (Heap_Top);
- START_BAND_LOAD ();
- read_file_start (file_name, true);
- transaction_commit ();
-
- /* Point of no return. */
- {
- long length = ((strlen (file_name)) + 1);
- char * band_name = (malloc (length));
- if (band_name != 0)
- strcpy (band_name, file_name);
- transaction_begin ();
- {
- char ** ap = (dstack_alloc (sizeof (char *)));
- (*ap) = band_name;
- transaction_record_action (tat_abort, terminate_band_load, ap);
- }
- result = (load_file (MODE_BAND));
- transaction_commit ();
- if (reload_band_name != 0)
- free (reload_band_name);
- reload_band_name = band_name;
- }
- }
- /* Reset implementation state paramenters */
- INITIALIZE_INTERRUPTS ();
- INITIALIZE_STACK ();
- SET_MEMTOP (Heap_Top - GC_Reserve);
- {
- SCHEME_OBJECT cutl = (MEMORY_REF (result, 1));
- if (cutl != SHARP_F)
- {
- compiler_utilities = cutl;
- compiler_reset (cutl);
- }
- else
- compiler_initialize (true);
- }
- /* Until the continuation is invoked. */
- SET_INTERRUPT_MASK (0);
- Restore_Fixed_Obj (SHARP_F);
- Fluid_Bindings = EMPTY_LIST;
- Current_State_Point = SHARP_F;
- /* Setup initial program */
- Store_Return (RC_END_OF_COMPUTATION);
- exp_register = SHARP_F;
- Save_Cont ();
- exp_register = (MEMORY_REF (result, 0));
- env_register = THE_GLOBAL_ENV;
- /* Clear various interpreter state parameters. */
- Trapping = false;
- Return_Hook_Address = 0;
- history_register = (Make_Dummy_History ());
- Prev_Restore_History_Stacklet = 0;
- Prev_Restore_History_Offset = 0;
- COMPILER_TRANSPORT_END ();
- END_BAND_LOAD (true, false);
- Band_Load_Hook ();
- /* Return in a non-standard way. */
- PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
- /*NOTREACHED*/
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-#ifdef BYTE_INVERSION
+#define RELOCATE_OBJECT(object) \
+ (OBJECT_NEW_ADDRESS ((object), \
+ ((SCHEME_OBJECT *) \
+ (relocate_address (OLD_ADDRESS (object))))))
-#define MAGIC_OFFSET (TC_FIXNUM + 1)
+static
+DEFINE_GC_TUPLE_HANDLER (fasload_tuple)
+{
+ return (RELOCATE_OBJECT (tuple));
+}
-SCHEME_OBJECT String_Chain, Last_String;
+static
+DEFINE_GC_VECTOR_HANDLER (fasload_vector)
+{
+ return (RELOCATE_OBJECT (vector));
+}
-void
-DEFUN_VOID (Setup_For_String_Inversion)
+static
+DEFINE_GC_OBJECT_HANDLER (fasload_cc_entry)
{
- String_Chain = SHARP_F;
- Last_String = SHARP_F;
- return;
+#ifdef CC_SUPPORT_P
+ return
+ (CC_ENTRY_NEW_ADDRESS (object,
+ (relocate_address (OLD_CC_ADDRESS (object)))));
+#else
+ return (object);
+#endif
}
-void
-DEFUN_VOID (Finish_String_Inversion)
+/* Relocate an address as read in from the file. The address is
+ examined to see what region of memory it belongs in. */
+
+static void *
+relocate_address (void * vaddr)
{
- if (Byte_Invert_Fasl_Files)
- while (String_Chain != SHARP_F)
+ byte_t * caddr = vaddr;
+ byte_t * result;
+
+ if ((caddr >= ((byte_t *) (FASLHDR_HEAP_START (fh))))
+ && (caddr < ((byte_t *) (FASLHDR_HEAP_END (fh)))))
+ result
+ = (((byte_t *) new_heap_start)
+ + (caddr - ((byte_t *) (FASLHDR_HEAP_START (fh)))));
+ else if ((caddr >= ((byte_t *) (FASLHDR_CONSTANT_START (fh))))
+ && (caddr < ((byte_t *) (FASLHDR_CONSTANT_END (fh)))))
+ result
+ = (((byte_t *) new_constant_start)
+ + (caddr - ((byte_t *) (FASLHDR_CONSTANT_START (fh)))));
+ else if ((caddr >= ((byte_t *) (FASLHDR_UTILITIES_START (fh))))
+ && (caddr < ((byte_t *) (FASLHDR_UTILITIES_END (fh)))))
+ result
+ = (((byte_t *) new_utilities)
+ + (caddr - ((byte_t *) (FASLHDR_UTILITIES_START (fh)))));
+ else if (ADDRESS_IN_STACK_REGION_P (caddr,
+ ((byte_t *) (FASLHDR_STACK_START (fh))),
+ ((byte_t *) (FASLHDR_STACK_END (fh)))))
+ result
+ = (N_PUSHED_TO_SP
+ ((SP_TO_N_PUSHED (caddr,
+ ((byte_t *) (FASLHDR_STACK_START (fh))),
+ ((byte_t *) (FASLHDR_STACK_END (fh))))),
+ ((byte_t *) new_stack_start),
+ ((byte_t *) new_stack_end)));
+ else
{
- long Count;
- SCHEME_OBJECT Next;
-
- Count = OBJECT_DATUM (FAST_MEMORY_REF (String_Chain, STRING_HEADER));
- Count = 4 * (Count - 2) + (OBJECT_TYPE (String_Chain)) - MAGIC_OFFSET;
- if (Reloc_Debug)
- {
- outf_console ("String at 0x%lx: restoring length of %ld.\n",
- ((long) (OBJECT_ADDRESS (String_Chain))),
- ((long) Count));
- }
- Next = (STRING_LENGTH (String_Chain));
- SET_STRING_LENGTH (String_Chain, Count);
- String_Chain = Next;
+ outf_fatal ("Pointer out of range: %#lx\n", ((unsigned long) caddr));
+ outf_fatal ("Heap: %#lx-%#lx, Constant: %#lx-%#lx, Stack: %#lx-%#lx\n",
+ ((unsigned long) (FASLHDR_HEAP_START (fh))),
+ ((unsigned long) (FASLHDR_HEAP_END (fh))),
+ ((unsigned long) (FASLHDR_CONSTANT_START (fh))),
+ ((unsigned long) (FASLHDR_CONSTANT_END (fh))),
+ ((unsigned long) (FASLHDR_STACK_START (fh))),
+ ((unsigned long) (FASLHDR_STACK_END (fh))));
+ termination_init_error ();
}
- return;
+ return (result);
}
\f
-#define print_char(C) outf_console (((C < ' ') || (C > '|')) ? \
- "\\%03o" : "%c", (C && UCHAR_MAX));
-
-void
-DEFUN (String_Inversion, (Orig_Pointer), SCHEME_OBJECT * Orig_Pointer)
+static gc_table_t *
+intern_block_table (void)
{
- SCHEME_OBJECT *Pointer_Address;
- char *To_Char;
- long Code;
+ static bool initialized_p = false;
+ static gc_table_t table;
- if (!Byte_Invert_Fasl_Files)
- return;
+ if (!initialized_p)
+ {
+ initialize_gc_table ((&table), false);
- Code = OBJECT_TYPE (Orig_Pointer[STRING_LENGTH_INDEX]);
- if (Code == 0) /* Already reversed? */
- {
- long Count, old_size, new_size, i;
+ (GCT_TUPLE (&table)) = intern_tuple;
+ (GCT_VECTOR (&table)) = intern_vector;
+ (GCT_CC_ENTRY (&table)) = intern_cc_entry;
- old_size = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER]));
- new_size =
- 2 + (((long) (Orig_Pointer[STRING_LENGTH_INDEX]))) / 4;
+ (GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair;
+ (GCT_ENTRY ((&table), TC_INTERNED_SYMBOL)) = intern_handle_symbol;
+ (GCT_ENTRY ((&table), TC_BROKEN_HEART)) = gc_handle_non_pointer;
- if (Reloc_Debug)
- {
- outf_console ("\nString at 0x%lx with %ld characters",
- ((long) Orig_Pointer),
- ((long) (Orig_Pointer[STRING_LENGTH_INDEX])));
+ initialized_p = true;
}
- if (old_size != new_size)
- {
- outf_fatal ("\nWord count changed from %ld to %ld: ",
- ((long) old_size), ((long) new_size));
- outf_fatal ("\nWhich, of course, is impossible!!\n");
- Microcode_Termination (TERM_EXIT);
- }
+ return (&table);
+}
- Count = ((long) (Orig_Pointer[STRING_LENGTH_INDEX])) % 4;
- if (Count == 0)
- Count = 4;
- if (Last_String == SHARP_F)
- String_Chain = MAKE_POINTER_OBJECT (Count + MAGIC_OFFSET, Orig_Pointer);
- else
- FAST_MEMORY_SET
- (Last_String, STRING_LENGTH_INDEX,
- (MAKE_POINTER_OBJECT ((Count + MAGIC_OFFSET), Orig_Pointer)));
-\f
- Last_String = (MAKE_POINTER_OBJECT (TC_NULL, Orig_Pointer));
- Orig_Pointer[STRING_LENGTH_INDEX] = SHARP_F;
- Count = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER])) - 1;
- if (Reloc_Debug)
- outf_console ("\nCell count = %ld\n", ((long) Count));
- Pointer_Address = &(Orig_Pointer[STRING_CHARS]);
- To_Char = (char *) Pointer_Address;
- for (i = 0; i < Count; i++, Pointer_Address++)
+static
+DEFINE_GC_HANDLER (intern_handle_symbol)
+{
+ if (BROKEN_HEART_P (GET_SYMBOL_GLOBAL_VALUE (object)))
{
- int C1, C2, C3, C4;
-
- C4 = OBJECT_TYPE (*Pointer_Address) & 0xFF;
- C3 = (((long) *Pointer_Address)>>16) & 0xFF;
- C2 = (((long) *Pointer_Address)>>8) & 0xFF;
- C1 = ((long) *Pointer_Address) & 0xFF;
- if (Reloc_Debug || (old_size != new_size))
+ SET_SYMBOL_GLOBAL_VALUE (object, UNBOUND_OBJECT);
{
- print_char(C1);
- print_char(C2);
- print_char(C3);
- print_char(C4);
+ SCHEME_OBJECT new = (intern_symbol (object));
+ if (new != object)
+ {
+ (*scan) = new;
+ SET_SYMBOL_NAME (object, (OBJECT_NEW_TYPE (TC_BROKEN_HEART, new)));
+ }
}
- *To_Char++ = C1;
- *To_Char++ = C2;
- *To_Char++ = C3;
- *To_Char++ = C4;
}
- }
- if (Reloc_Debug)
- outf_console ("\n");
- return;
+ else if (BROKEN_HEART_P (GET_SYMBOL_NAME (object)))
+ (*scan)
+ = (MAKE_OBJECT_FROM_OBJECTS (object,
+ (GET_SYMBOL_NAME (object))));
+ return (scan + 1);
+}
+
+static
+DEFINE_GC_TUPLE_HANDLER (intern_tuple)
+{
+ return (tuple);
+}
+
+static
+DEFINE_GC_VECTOR_HANDLER (intern_vector)
+{
+ return (vector);
+}
+
+static
+DEFINE_GC_OBJECT_HANDLER (intern_cc_entry)
+{
+ return (object);
}
-#endif /* BYTE_INVERSION */
+++ /dev/null
-/* -*-C-*-
-
-$Id: fft.c,v 9.37 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Time-Frequency Transforms (pas) */
-
-#include "scheme.h"
-#include "prims.h"
-#include "zones.h"
-#include <math.h>
-#include "array.h"
-#include "image.h"
-\f
-/* SUMMARY
- - pas_cft (complex data, DIF, split-radix)
- - pas_rft (real data, DIT, split-radix) output is conjugate-symmetric
- - pas_csft (cs data, DIF, split-radix) output is real
- - pas_cft
- - pas_rft2d
- - pas_csft2d
-
-
- Stuff before 4-15-1989
- - C_Array_FFT (complex data, radix=2, NOT-in-place)
- - CZT (chirp-z-transform) uses the old cft (hence slow).
- - 2d DFT
- */
-
-/* The DFT is as defined in Siebert 6003 book,
- i.e.
- forward DFT = Negative exponent and division by N
- backward DFT = Positive exponent
- (note Seibert forward DFT is Oppenheim backward DFT)
- */
-
-/* mathematical constants */
-#ifdef PI
-#undef PI
-#endif
-#define PI 3.141592653589793238462643
-#define TWOPI 6.283185307179586476925287
-#define SQRT_2 1.4142135623730950488
-#define ONE_OVER_SQRT_2 .7071067811865475244
-/* Abramowitz and Stegun */
-\f
-DEFINE_PRIMITIVE ("PAS-CFT!", Prim_pas_cft, 5, 5, 0)
-{ long i, length, power, flag;
- REAL *f1,*f2, *wcos,*w3cos,*w3sin;
- void pas_cft();
- PRIMITIVE_HEADER (5);
- CHECK_ARG (2, ARRAY_P); /* real part */
- CHECK_ARG (3, ARRAY_P); /* imag part */
- CHECK_ARG (4, ARRAY_P); /* twiddle tables, total length = 3*(length/4) */
- CHECK_ARG (5, FIXNUM_P); /* (1)=tables precomputed, else recompute */
-
- flag = (arg_integer (1));
- length = ARRAY_LENGTH(ARG_REF(2));
- if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2);
-
- for (power=0, i=length; i>1; power++)
- { if ( (i % 2) == 1) error_bad_range_arg(2);
- i=i/2; }
-
- f1 = ARRAY_CONTENTS(ARG_REF(2));
- f2 = ARRAY_CONTENTS(ARG_REF(3));
- if (f1==f2) error_wrong_type_arg(2);
-
- wcos = ARRAY_CONTENTS(ARG_REF(4)); /* twiddle tables */
- if (ARRAY_LENGTH(ARG_REF(4)) != (3*length/4)) error_bad_range_arg(4);
- w3cos = wcos + length/4;
- w3sin = w3cos + length/4;
- if ((arg_nonnegative_integer(5)) == 1)
- pas_cft(1, flag, f1,f2, length, power, wcos,w3cos,w3sin);
- else
- pas_cft(0, flag, f1,f2, length, power, wcos,w3cos,w3sin);
- /* 1 means tables are already made
- 0 means compute new tables */
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("PAS-CFT-MAKE-TWIDDLE-TABLES!",
- Prim_pas_cft_make_twiddle_tables, 2, 2, 0)
-{ long length, power, i;
- REAL *wcos,*w3cos,*w3sin;
- void pas_cft_make_twiddle_tables_once();
- PRIMITIVE_HEADER (2);
-
- length = arg_nonnegative_integer(1); /* length of cft that we intend to compute */
- CHECK_ARG (2, ARRAY_P); /* storage for twiddle tables */
- if (ARRAY_LENGTH(ARG_REF(2)) != (3*length/4)) error_bad_range_arg(2);
-
- power=0;
- for (power=0, i=length; i>1; power++)
- { if ( (i % 2) == 1) error_bad_range_arg(1);
- i=i/2; }
-
- wcos = ARRAY_CONTENTS(ARG_REF(2)); /* twiddle tables */
- w3cos = wcos + length/4;
- w3sin = w3cos + length/4;
- pas_cft_make_twiddle_tables_once(length, power, wcos,w3cos,w3sin);
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/*
- C COMPLEX FOURIER TRANSFORM (Split-Radix, Decimation-in-frequency)
- C (adapted and optimized from Sorensen,et.al. ASSP-34 no.1 page 152, February 1986)
- */
-
-/* Twiddle Tables for PAS_CFT;
- (tables for forward transform only)
- Inverse transform === forward CFT (without 1/N scaling) followed by time-reversal.
- /
- The tables contain (2pi/N)*i for i=0,1,2,..,N/4
- (except i=0 is ignored, never used)
- /
- Table for wsin[i] is not needed because wsin[i]=wcos[n4-i].
- Table for w3sin[i] is needed however. The previous relationship does not work for w3sin.
- */
-
-/* There are two routines for making twiddle tables:
- a fast one, and a slower one but more precise.
- The differences in speed and accuracy are actually rather small, but anyway.
- Use the slow one for making permanent tables.
- */
-
-void
-pas_cft_make_twiddle_tables (n,m, wcos,w3cos,w3sin) /* efficient version */
- REAL *wcos, *w3cos, *w3sin;
- long n,m;
-{ long i, n4;
- double tm;
- REAL costm,sintm;
- n4 = n/4;
- for (i=1; i<n4; i++) /* start from table entry 1 */
- { tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
- }
- for (i=1; i<n4; i++)
- { costm = wcos[i];
- sintm = wcos[n4-i];
- w3cos[i] = costm * (1 - 4*sintm*sintm); /* see my notes */
- w3sin[i] = sintm * (4*costm*costm - 1);
- }
-}
-
-void
-pas_cft_make_twiddle_tables_once (n,m, wcos,w3cos,w3sin) /* slow version, more accurate */
- REAL *wcos, *w3cos, *w3sin;
- long n,m;
-{ long i, n4;
- double tm;
- REAL costm,sintm;
- n4 = n/4;
- for (i=1; i<n4; i++) /* start from table entry 1 */
- { tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
- tm = tm * 3.0; /* this is more precise (in the 16th decimal) than */
- w3cos[i] = (REAL) cos(tm); /* the more efficient version. (I tested by for/backward) */
- w3sin[i] = (REAL) sin(tm);
- }
-}
-
-void
-pas_cft (tables_ok,flag, x,y,n,m, wcos,w3cos,w3sin)
- REAL *x,*y, *wcos,*w3cos,*w3sin;
- long n,m, flag, tables_ok;
-{ REAL scale;
- long i,j;
- void pas_cft_make_twiddle_tables();
- void C_Array_Time_Reverse();
- void pas_cft_forward_loop();
-
- if (tables_ok != 1) /* 1 means = tables already made */
- pas_cft_make_twiddle_tables(n,m, wcos,w3cos,w3sin);
-
- if (flag == 1) /* forward cft */
- { pas_cft_forward_loop(x,y,n,m, wcos,w3cos,w3sin);
- scale = (REAL) (1.0 / ((double) n));
- for (i=0; i<n; i++)
- { x[i] = x[i]*scale;
- y[i] = y[i]*scale; }}
- else /* backward cft */
- { for (j=0; j<n; j++) y[j] = (-y[j]); /* conjugate before */
- pas_cft_forward_loop(x,y,n,m, wcos,w3cos,w3sin);
- for (j=0; j<n; j++) y[j] = (-y[j]); /* conjugate after */
- }
-}
-
-void
-pas_cft_forward_loop (x,y,n,m, wcos,w3cos,w3sin) /* n >= 4 */
- REAL *x,*y, *wcos,*w3cos,*w3sin;
- long n,m;
-{ /* REAL a,a3,e; no need anymore, use tables */
- REAL r1,r2,s1,s2,s3, xt, cc1,cc3,ss1,ss3;
- long n1,n2,n4, i,j,k, is,id, i0,i1,i2,i3;
- long windex0, windex, windex_n4; /* indices for twiddle tables */
- /********** fortran indices start from 1,... **/
- x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
- y = y-1;
- /********** fortran indices start from 1,... **/
- /* c */
- /* c-----first M-1 stages of transform */
- /* c */
- windex_n4 = n/4; /* need for indexing sin via wcos twiddle table */
- n2 = 2*n;
- for (k=1; k<m; k++) /* DO 10 K = 1, M-1 */
- { n2 = n2>>1; /* n2 = n2/2; */
- n4 = n2>>2; /* n4 = n2/4; */
- /* e = 6.283185307179586476925287 / ((REAL) n2); no need anymore, use tables */
- /* a = 0.0; */
- {
- /* j=1; */
- /* The first iteration in the loop "DO 20 J = 1, N4"
- is done specially to save operations involving sin=0, cos=1 */
- /* a = j*e; no need anymore, use tables */
- is = 1; /* is = j; */
- id = 2*n2;
- label40first:
- for (i0=is; i0<n; i0=i0+id) /* 40 DO 30 I0 = IS,N-1,ID */
- { i1 = i0 + n4;
- i2 = i1 + n4;
- i3 = i2 + n4;
- /* c */
- r1 = x[i0] - x[i2];
- x[i0] = x[i0] + x[i2];
- r2 = x[i1] - x[i3];
- x[i1] = x[i1] + x[i3];
- s1 = y[i0] - y[i2];
- y[i0] = y[i0] + y[i2];
- s2 = y[i1] - y[i3];
- y[i1] = y[i1] + y[i3];
- /* c */
- s3 = r1 - s2;
- r1 = r1 + s2;
- s2 = s1 - r2; /* original used to be s2 = r2 - s1; */
- r2 = r2 + s1;
- x[i2] = r1;
- y[i2] = s2; /* used to be y[i2] = (-s2); */
- x[i3] = s3;
- y[i3] = r2;
- /* x[i2] = r1*cc1 + s2*ss1; used to be, see below
- y[i2] = s2*cc1 - r1*ss1; used to be, see below, inside the DO 20 J=1,N4
- x[i3] = s3*cc3 + r2*ss3;
- y[i3] = r2*cc3 - s3*ss3; */
- } /* 30 CONTINUE */
- is = 2*id - n2 + 1; /* is = 2*id - n2 + j; */
- id = 4*id;
- if (is < n) goto label40first; /* IF (IS.LT.N) GOTO 40 */
- }
- /* c */
- windex0 = 1<<(k-1);
- windex = windex0;
- for (j=2; j<=n4; j++) /* DO 20 J = 1, N4 */
- {
- /* windex = (j-1)*(1<<(k-1)); -- done with trick to avoid (j-1) and 1<<(k-1) */
- cc1 = wcos[windex];
- ss1 = wcos[windex_n4 - windex]; /* see my notes */
- cc3 = w3cos[windex];
- ss3 = w3sin[windex]; /* sin-from-cos trick does not work here */
- windex = j*windex0; /* same trick as "a = j*e" */
- /* a3 = 3*a;
- cc1 = cos(a);
- ss1 = sin(a);
- cc3 = cos(a3);
- ss3 = sin(a3);
- a = j*e;*/
- is = j;
- id = 2*n2;
- label40:
- for (i0=is; i0<n; i0=i0+id) /* 40 DO 30 I0 = IS,N-1,ID */
- { i1 = i0 + n4;
- i2 = i1 + n4;
- i3 = i2 + n4;
- /* c */
- r1 = x[i0] - x[i2];
- x[i0] = x[i0] + x[i2];
- r2 = x[i1] - x[i3];
- x[i1] = x[i1] + x[i3];
- s1 = y[i0] - y[i2];
- y[i0] = y[i0] + y[i2];
- s2 = y[i1] - y[i3];
- y[i1] = y[i1] + y[i3];
- /* c */
- s3 = r1 - s2;
- r1 = r1 + s2;
- s2 = s1 - r2; /* original used to be s2 = r2 - s1; */
- r2 = r2 + s1;
- x[i2] = r1*cc1 + s2*ss1; /* used to be x[i2] = r1*cc1 - s2*ss1; */
- y[i2] = s2*cc1 - r1*ss1; /* used to be y[i2] = (-s2*cc1 - r1*ss1); */
- x[i3] = s3*cc3 + r2*ss3;
- y[i3] = r2*cc3 - s3*ss3;
- } /* 30 CONTINUE */
- is = 2*id - n2 + j;
- id = 4*id;
- if (is < n) goto label40; /* IF (IS.LT.N) GOTO 40 */
- } /* 20 CONTINUE */
- } /* 10 CONTINUE */
- /* c
- c-----------last-stage, length-2 butterfly ----------------c
- c */
- is = 1;
- id = 4;
- label50:
- for (i0=is; i0<=n; i0=i0+id) /* 50 DO 60 I0 = IS, N, ID */
- { i1 = i0 + 1;
- r1 = x[i0];
- x[i0] = r1 + x[i1];
- x[i1] = r1 - x[i1];
- r1 = y[i0];
- y[i0] = r1 + y[i1];
- y[i1] = r1 - y[i1];
- } /* 60 CONTINUE */
- is = 2*id - 1;
- id = 4*id;
- if (is < n) goto label50; /* IF (IS.LT.N) GOTO 50 */
- /*
- c
- c-----------bit-reverse-counter---------------c
- */
- label100:
- j = 1;
- n1 = n - 1;
- for (i=1; i<=n1; i++) /* DO 104 I = 1, N1 */
- { if (i >= j) goto label101; /* if (i .ge. j) goto 101 */
- xt = x[j];
- x[j] = x[i];
- x[i] = xt;
- xt = y[j];
- y[j] = y[i];
- y[i] = xt;
- label101: k = n>>1; /* k = n/2; */
- label102: if (k>=j) goto label103;
- j = j - k;
- k = k>>1; /* k = k/2; */
- goto label102;
- label103: j = j + k;
- } /* 104 CONTINUE */
- /* c-------------------------------------*/
- /* c */
-} /* RETURN ^M END */
-\f
-DEFINE_PRIMITIVE ("PAS-RFT-CSFT!", Prim_pas_rft_csft, 5, 5, 0)
-{ long i, length, power, flag, ft_type;
- REAL *f1, *wcos,*w3cos,*w3sin;
- void pas_rft(), pas_csft();
- PRIMITIVE_HEADER (5);
- CHECK_ARG (2, ARRAY_P); /* Input data (real or cs) */
- CHECK_ARG (3, ARRAY_P); /* Twiddle tables, total length = 4*(length/8) */
- CHECK_ARG (4, FIXNUM_P); /* (1)=tables precomputed, else recompute */
- CHECK_ARG (5, FIXNUM_P); /* ft_type = 1 or 3
- 1 means compute rft, 3 means compute csft */
- flag = (arg_integer (1));
- f1 = ARRAY_CONTENTS(ARG_REF(2));
- length = ARRAY_LENGTH(ARG_REF(2));
- for (power=0, i=length; i>1; power++)
- { if ( (i % 2) == 1) error_bad_range_arg(2);
- i=i/2; }
-
- wcos = ARRAY_CONTENTS(ARG_REF(3)); /* twiddle tables */
- if (ARRAY_LENGTH(ARG_REF(3)) != (4*length/8)) error_bad_range_arg(3);
- w3cos = wcos + (length/4);
- w3sin = w3cos + (length/8);
-
- ft_type = (arg_nonnegative_integer(5)); /* rft or csft */
- if (ft_type == 1) {
- if ((arg_nonnegative_integer(4)) == 1)
- pas_rft (1, flag, f1, length, power, wcos,w3cos,w3sin);
- else pas_rft (0, flag, f1, length, power, wcos,w3cos,w3sin);
- }
- else if (ft_type == 3) {
- if ((arg_nonnegative_integer(4)) == 1)
- pas_csft (1, flag, f1, length, power, wcos,w3cos,w3sin);
- else pas_csft (0, flag, f1, length, power, wcos,w3cos,w3sin);
- /* 1 means tables are already made
- 0 means compute new tables */
- }
- else error_bad_range_arg(5);
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("PAS-REALDATA-MAKE-TWIDDLE-TABLES!",
- Prim_pas_realdata_make_twiddle_tables, 2, 2, 0)
-{ long length, power, i;
- REAL *wcos,*w3cos,*w3sin;
- void pas_realdata_make_twiddle_tables_once();
- PRIMITIVE_HEADER (2);
-
- length = arg_nonnegative_integer(1); /* length of rft that we intend to compute */
- CHECK_ARG (2, ARRAY_P); /* storage for twiddle tables */
- if (ARRAY_LENGTH(ARG_REF(2)) != (4*length/8)) error_bad_range_arg(2);
-
- power=0;
- for (power=0, i=length; i>1; power++)
- { if ( (i % 2) == 1) error_bad_range_arg(1);
- i=i/2; }
-
- wcos = ARRAY_CONTENTS(ARG_REF(2)); /* twiddle tables */
- w3cos = wcos + length/4;
- w3sin = w3cos + length/8;
- pas_realdata_make_twiddle_tables_once(length, power, wcos,w3cos,w3sin);
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/*
- C REAL FOURIER TRANSFORM (Split-Radix, Decimation-in-time)
- C (adapted from Sorensen,et.al. ASSP-35 no.6 page 849, October 1986)
- C
- C the output is [Re(0),Re(1),...,Re(n/2), Im(n/2-1),...,Im(1)]
- */
-
-/* Twiddle Tables for PAS_RFT and PAS_CSFT
- are identical. -> pas_realdata_make_twiddle_tables
- (but they are indexed differently in each case)
- /
- The tables contain (2pi/N)*i where i=0,1,2,..,N/4 for wcos
- and (2pi/N)*i where i=0,1,2,..,N/8 for w3cos w3sin
- (except i=0 is ignored, never used)
- /
- Table for wsin[i] is not needed because wsin[i]=wcos[n4-i].
- Table for w3sin[i] is needed however. The previous relationship does not work for w3sin.
- /
- Instead of getting sin() from a wsin[i] table with i=1,..,N/8
- we get it from wcos[n4-i].
- This way we can use a CFT table which goes up to N/4
- for RFT CSFT also. We do so in image-processing (rft2d-csft2d).
- */
-
-/* There are two routines for making twiddle tables:
- a fast one, and a slower one but more precise.
- The differences in speed and accuracy are actually rather small, but anyway.
- Use the slow one for making tables that stay around.
- */
-
-void pas_realdata_make_twiddle_tables(n,m, wcos,w3cos,w3sin) /* efficient version */
- REAL *wcos, *w3cos, *w3sin;
- long n,m;
-{ long i, n4, n8;
- double tm;
- REAL costm,sintm;
- n4 = n/4;
- n8 = n/8;
- for (i=1; i<n4; i++) /* start from table entry 1 */
- { tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
- }
- for (i=1; i<n8; i++)
- { costm = wcos[i];
- sintm = wcos[n4-i];
- w3cos[i] = costm * (1 - 4*sintm*sintm); /* see my notes */
- w3sin[i] = sintm * (4*costm*costm - 1);
- }
-}
-
-void pas_realdata_make_twiddle_tables_once(n,m, wcos,w3cos,w3sin) /* slow version, more accurate */
- REAL *wcos, *w3cos, *w3sin;
- long n,m;
-{ long i, n4, n8;
- double tm;
- REAL costm,sintm;
- n4 = n/4;
- n8 = n/8;
- for (i=1; i<n8; i++) /* start from table entry 1 */
- { tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
- tm = tm * 3.0; /* this is more precise (in the 16th decimal) than */
- w3cos[i] = (REAL) cos(tm); /* the more efficient version. (I tested by for/backward) */
- w3sin[i] = (REAL) sin(tm);
- }
- for (i=n8; i<n4; i++)
- { tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
- }
-}
-
-void pas_rft(tables_ok,flag, x,n,m, wcos,w3cos,w3sin)
- REAL *x, *wcos,*w3cos,*w3sin;
- long n,m, flag, tables_ok;
-{ REAL scale;
- long i;
- void pas_realdata_make_twiddle_tables();
- void pas_rft_forward_loop();
-
- if (tables_ok != 1) /* 1 means = tables already made */
- pas_realdata_make_twiddle_tables(n,m, wcos,w3cos,w3sin);
-
- pas_rft_forward_loop(x,n,m, wcos,w3cos,w3sin);
-
- if (flag == 1) /* forward rft */
- { scale = (REAL) (1.0 / ((double) n));
- for (i=0; i<n; i++) x[i] = x[i] * scale; }
- else /* backward rft */
- for (i=((n/2)+1); i<n; i++) x[i] = (-x[i]); /* time-reverse cs-array */
-}
-
-/* rft
- forward transform === forward_loop + 1/N scaling
- inverse transform === forward_loop + time-reversal (without 1/N scaling)
- */
-
-/* wcos must be length n/4
- w3cos, w3sin must be length n/8
- (greater than n/8 is fine also, e.g. use cft tables)
- */
-
-void pas_rft_forward_loop(x,n,m, wcos,w3cos,w3sin)
- REAL *x, *wcos,*w3cos,*w3sin;
- long n,m;
-{ /* REAL a,a3,e; no need anymore, use tables */
- REAL r1, xt, cc1,cc3,ss1,ss3, t1,t2,t3,t4,t5,t6;
- long n1,n2,n4,n8, i,j,k, is,id, i0,i1,i2,i3,i4,i5,i6,i7,i8;
- long windex0, windex, windex_n4; /* indices for twiddle tables */
- /********** fortran indices start from 1,... **/
- x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
- /********** fortran indices start from 1,... **/
- /* c */
- windex_n4 = n/4; /* need for indexing sin via wcos twiddle table */
- /* c
- c-----------bit-reverse-counter---------------c
- */
- label100:
- j = 1;
- n1 = n - 1;
- for (i=1; i<=n1; i++) /* DO 104 I = 1, N1 */
- { if (i >= j) goto label101; /* if (i .ge. j) goto 101 */
- xt = x[j];
- x[j] = x[i];
- x[i] = xt;
- label101: k = n>>1; /* k = n/2; */
- label102: if (k>=j) goto label103;
- j = j - k;
- k = k>>1; /* k = k/2; */
- goto label102;
- label103: j = j + k;
- } /* 104 CONTINUE */
- /* c-------------------------------------*/
- /* c */
- /* c ----length-two-butterflies----------- */
- is = 1;
- id = 4;
- label70:
- for (i0=is; i0<=n; i0=i0+id) /* 70 DO 60 I0 = IS,N,ID */
- { i1 = i0 + 1;
- r1 = x[i0];
- x[i0] = r1 + x[i1];
- x[i1] = r1 - x[i1];
- } /* 60 CONTINUE */
- is = 2*id - 1;
- id = 4*id;
- if (is < n) goto label70; /* IF (IS.LT.N) GOTO 70 */
- /* C
- C -------L-shaped-butterflies-------- */
- n2 = 2;
- for (k=2; k<=m; k++) /* DO 10 K = 2,M */
- { n2 = n2 * 2;
- n4 = n2>>2; /* n4 = n2/4; */
- n8 = n2>>3; /* n8 = n2/8; */
- /* e = 6.283185307179586476925287 / ((REAL) n2); no need anymore, use tables */
- is = 0;
- id = n2 * 2;
- label40:
- for (i=is; i<n; i=i+id) /* 40 DO 38 I = IS,N-1,ID */
- { i1 = i + 1;
- i2 = i1 + n4;
- i3 = i2 + n4;
- i4 = i3 + n4;
- t1 = x[i4] + x[i3];
- x[i4] = x[i4] - x[i3];
- x[i3] = x[i1] - t1;
- x[i1] = x[i1] + t1;
- if (n4 == 1) goto label38; /* IF (N4.EQ.1) GOTO 38 */
- i1 = i1 + n8;
- i2 = i2 + n8;
- i3 = i3 + n8;
- i4 = i4 + n8;
- /* t1 = (x[i3] + x[i4]) / sqrt(2.0); -- this is more precise, it uses extended
- t2 = (x[i3] - x[i4]) / sqrt(2.0); -- precision inside 68881, but slower */
- t1 = (x[i3] + x[i4]) * ONE_OVER_SQRT_2;
- t2 = (x[i3] - x[i4]) * ONE_OVER_SQRT_2;
- x[i4] = x[i2] - t1;
- x[i3] = -x[i2] - t1;
- x[i2] = x[i1] - t2;
- x[i1] = x[i1] + t2;
- label38: /* 38 CONTINUE */
- ;
- }
- is = 2*id - n2;
- id = 4*id;
- if (is < n) goto label40; /* IF (IS.LT.N) GOTO 40 */
- /* a = e; */
- windex0 = 1<<(m-k);
- windex = windex0;
- for (j=2; j<=n8; j++) /* DO 32 J = 2,N8 */
- {
- /* windex = (j-1)*(1<<(m-k)); -- done with trick to avoid (j-1) and 1<<(m-k) */
- cc1 = wcos[windex];
- ss1 = wcos[windex_n4 - windex]; /* sin-from-cos trick: see my notes */
- cc3 = w3cos[windex];
- ss3 = w3sin[windex]; /* sin-from-cos trick does not work here */
- windex = j*windex0; /* same trick as "a = j*e" */
- /* a3 = 3*a;
- cc1 = cos(a);
- ss1 = sin(a);
- cc3 = cos(a3);
- ss3 = sin(a3);
- a = j*e;*/
- is = 0;
- id = 2*n2;
- label36: /* 36 DO 30 I = IS,N-1,ID */
- for (i=is; i<n; i=i+id)
- { i1 = i + j;
- i2 = i1 + n4;
- i3 = i2 + n4;
- i4 = i3 + n4;
- i5 = i + n4 - j + 2;
- i6 = i5 + n4;
- i7 = i6 + n4;
- i8 = i7 + n4;
- t1 = x[i3]*cc1 + x[i7]*ss1;
- t2 = x[i7]*cc1 - x[i3]*ss1;
- t3 = x[i4]*cc3 + x[i8]*ss3;
- t4 = x[i8]*cc3 - x[i4]*ss3;
- t5 = t1 + t3;
- t6 = t2 + t4;
- t3 = t3 - t1; /* t3 = t1 - t3; */
- t4 = t2 - t4;
- x[i8] = x[i6] + t6;
- x[i3] = t6 - x[i6];
- x[i4] = x[i2] + t3; /* x[i4] = x[i2] - t3; */
- x[i7] = t3 - x[i2]; /* x[i7] = -x[i2] - t3; */
- x[i6] = x[i1] - t5;
- x[i1] = x[i1] + t5;
- x[i2] = x[i5] + t4;
- x[i5] = x[i5] - t4;
- } /* 30 CONTINUE */
- is = 2*id - n2;
- id = 4*id;
- if (is < n) goto label36; /* IF (IS.LT.N) GOTO 36 */
- } /* 32 CONTINUE */
- } /* 10 CONTINUE */
-} /* RETURN ^M END */
-
-
-/*
- C CONJUGATE SYMMETRIC FOURIER TRANSFORM (Split-Radix, Decimation-in-time)
- C (adapted from Sorensen,et.al. ASSP-35 no.6 page 849, October 1986)
- C
- C input is [Re(0),Re(1),...,Re(n/2), Im(n/2-1),...,Im(1)]
- C output is real
- */
-
-/* twiddle tables identical with rft
- for comments see rft */
-
-void pas_csft(tables_ok,flag, x,n,m, wcos,w3cos,w3sin)
- REAL *x, *wcos,*w3cos,*w3sin;
- long n,m, flag, tables_ok;
-{ REAL scale;
- long i,n2;
- void pas_realdata_make_twiddle_tables();
- void C_Array_Time_Reverse();
- void pas_csft_backward_loop();
-
- if (tables_ok != 1) /* 1 means = tables already made */
- pas_realdata_make_twiddle_tables(n,m, wcos,w3cos,w3sin);
-
- if (flag == 1) /* forward csft */
- { n2 = n/2;
- scale = (REAL) (1.0 / ((double) n));
- for (i=0; i<=n2; i++) x[i] = x[i]*scale;
- scale = (-scale);
- for (i=n2+1; i<n; i++) x[i] = x[i]*scale; /* scale and conjugate cs-array */
- pas_csft_backward_loop(x,n,m, wcos,w3cos,w3sin);
- }
- else /* backward csft */
- pas_csft_backward_loop(x,n,m, wcos,w3cos,w3sin);
-}
-
-/* csft
- forward transform === backward_loop + 1/N scaling + time-reversal
- inverse transform === backward_loop
- */
-
-/* wcos must be length n/4
- w3cos, w3sin must be length n/8
- (greater than n/8 is fine also, e.g. use cft tables)
- */
-
-void pas_csft_backward_loop(x,n,m, wcos,w3cos,w3sin)
- REAL *x, *wcos,*w3cos,*w3sin;
- long n,m;
-{ /* REAL a,a3,e; no need anymore, use tables */
- REAL r1, xt, cc1,cc3,ss1,ss3, t1,t2,t3,t4,t5;
- long n1,n2,n4,n8, i,j,k, is,id, i0,i1,i2,i3,i4,i5,i6,i7,i8;
- long windex0, windex, windex_n4; /* indices for twiddle tables */
- /********** fortran indices start from 1,... **/
- x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
- /********** fortran indices start from 1,... **/
- /* c */
- windex_n4 = n/4; /* need for indexing sin via wcos twiddle table */
- /* c */
- /* c */
- /* c
- c -------L-shaped-butterflies-------- */
- n2 = 2*n;
- for (k=1; k<m; k++) /* do 10 k = 1,m-1 */
- { is = 0;
- id = n2;
- n2 = n2>>1; /* n2 = n2/2; */
- n4 = n2>>2; /* n4 = n2/4; */
- n8 = n4>>1; /* n8 = n4/2; */
- /* e = 6.283185307179586476925287 / ((REAL) n2); no need anymore, use tables */
- label17:
- for (i=is; i<n; i=i+id) /* 17 do 15 i = is,(n-1),id */
- { i1 = i + 1;
- i2 = i1 + n4;
- i3 = i2 + n4;
- i4 = i3 + n4;
- t1 = x[i1] - x[i3];
- x[i1] = x[i1] + x[i3];
- x[i2] = 2*x[i2];
- x[i3] = t1 - 2*x[i4];
- x[i4] = t1 + 2*x[i4];
- if (n4 == 1) goto label15; /* if (n4.eq.1) goto 15 */
- i1 = i1 + n8;
- i2 = i2 + n8;
- i3 = i3 + n8;
- i4 = i4 + n8;
- t1 = (x[i2] - x[i1]) * ONE_OVER_SQRT_2;
- t2 = (-(x[i4] + x[i3])) * ONE_OVER_SQRT_2;
- /* t1 = (x[i2] - x[i1])/sqrt(2.0);
- t2 = (x[i4] + x[i3])/sqrt(2.0); */
- x[i1] = x[i1] + x[i2];
- x[i2] = x[i4] - x[i3];
- x[i3] = 2 * (t2-t1); /* x[i3] = 2 * (-t2-t1); */
- x[i4] = 2 * (t2+t1); /* x[i4] = 2 * (-t2+t1); */
- label15:
- ;
- } /* 15 continue */
- is = 2*id - n2;
- id = 4*id;
- if (is < (n-1)) goto label17; /* if (is.lt.(n-1)) goto 17 */
- /* a = e; */
- windex0 = 1<<(k-1); /* see my notes */
- windex = windex0;
- for (j=2; j<=n8; j++) /* do 20 j=2,n8 */
- {
- /* windex = (j-1)*(1<<(k-1)); -- done with trick to avoid (j-1) and 1<<(k-1) */
- cc1 = wcos[windex];
- ss1 = wcos[windex_n4 - windex]; /* sin-from-cos trick: see my notes */
- cc3 = w3cos[windex];
- ss3 = w3sin[windex]; /* sin-from-cos trick does not work here */
- windex = j*windex0; /* same trick as "a = j*e" */
- /* a3 = 3*a;
- cc1 = cos(a);
- ss1 = sin(a);
- cc3 = cos(a3);
- ss3 = sin(a3);
- a = j*e; */
- is = 0;
- id = 2*n2;
- label40:
- for (i=is; i<n; i=i+id) /* 40 do 30 i = is,(n-1),id */
- { i1 = i + j;
- i2 = i1 + n4;
- i3 = i2 + n4;
- i4 = i3 + n4;
- i5 = i + n4 - j + 2;
- i6 = i5 + n4;
- i7 = i6 + n4;
- i8 = i7 + n4;
- t1 = x[i1] - x[i6];
- x[i1] = x[i1] + x[i6];
- t2 = x[i5] - x[i2];
- x[i5] = x[i5] + x[i2];
- t3 = x[i8] + x[i3];
- x[i6] = x[i8] - x[i3];
- t4 = x[i4] + x[i7];
- x[i2] = x[i4] - x[i7];
- t5 = t1 - t4;
- t1 = t1 + t4;
- t4 = t2 - t3;
- t2 = t2 + t3;
- x[i3] = t5*cc1 + t4*ss1;
- x[i7] = t5*ss1 - t4*cc1; /* x[i7] = (-t4*cc1) + t5*ss1; */
- x[i4] = t1*cc3 - t2*ss3;
- x[i8] = t2*cc3 + t1*ss3;
- } /* 30 continue */
- is = 2*id - n2;
- id = 4*id;
- if (is < (n-1)) goto label40; /* if (is.lt.(n-1)) goto 40 */
- } /* 20 continue */
- } /* 10 continue */
- /* c */
- /* c ----length-two-butterflies----------- */
- is = 1;
- id = 4;
- label70:
- for (i0=is; i0<=n; i0=i0+id) /* 70 DO 60 I0 = IS,N,ID */
- { i1 = i0 + 1;
- r1 = x[i0];
- x[i0] = r1 + x[i1];
- x[i1] = r1 - x[i1];
- } /* 60 CONTINUE */
- is = 2*id - 1;
- id = 4*id;
- if (is < n) goto label70; /* IF (IS.LT.N) GOTO 70 */
- /* c */
- /* c-----------bit-reverse-counter---------------c */
- label100:
- j = 1;
- n1 = n - 1;
- for (i=1; i<=n1; i++) /* DO 104 I = 1, N1 */
- { if (i >= j) goto label101; /* if (i .ge. j) goto 101 */
- xt = x[j];
- x[j] = x[i];
- x[i] = xt;
- label101: k = n>>1; /* k = n/2; */
- label102: if (k>=j) goto label103;
- j = j - k;
- k = k>>1; /* k = k/2; */
- goto label102;
- label103: j = j + k;
- } /* 104 CONTINUE */
- /* c */
-} /* RETURN ^M END */
-
-
-\f
-
-/* Image processing only for square images
- (old stuff handles non-square but is slow)
- For 2d FTs precomputed tables or not, make almost no difference in total time.
- */
-
-DEFINE_PRIMITIVE ("PAS-CFT2D!", Prim_pas_cft2d, 5,5, 0)
-{ long i, length, power, flag, rows,rowpower;
- REAL *f1,*f2, *wcos,*w3cos,*w3sin;
- void pas_cft2d();
- PRIMITIVE_HEADER (5);
- CHECK_ARG (2, ARRAY_P); /* real part */
- CHECK_ARG (3, ARRAY_P); /* imag part */
- CHECK_ARG (4, ARRAY_P); /* twiddle tables, length = 3*(rows/4) */
-
- flag = (arg_integer (1));
- length = ARRAY_LENGTH(ARG_REF(2));
- if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2);
-
- for (power=0, i=length; i>1; power++) /* length must be power of 2 */
- { if ( (i % 2) == 1) error_bad_range_arg(2);
- i=i/2; }
-
- if ((power % 2) == 1) error_bad_range_arg(2);
- rowpower = (power/2);
- rows = (1<<rowpower); /* square image */
-
- f1 = ARRAY_CONTENTS(ARG_REF(2));
- f2 = ARRAY_CONTENTS(ARG_REF(3));
- if (f1==f2) error_wrong_type_arg(2);
-
- wcos = ARRAY_CONTENTS(ARG_REF(4)); /* twiddle tables */
- if (ARRAY_LENGTH(ARG_REF(4)) != (3*rows/4)) error_bad_range_arg(4);
- w3cos = wcos + rows/4;
- w3sin = w3cos + rows/4;
- if ((arg_nonnegative_integer(5)) == 1)
- pas_cft2d(1, flag, f1,f2, rows, rowpower, wcos,w3cos,w3sin);
- else
- pas_cft2d(0, flag, f1,f2, rows, rowpower, wcos,w3cos,w3sin);
- /* 1 means tables are already made
- 0 means compute new tables */
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* pas_cft2d
- n = rows of square image, rows is power of 2
- m = rowpower
- Scaling (1/n) is done all-at-once at the end.
- Time-Reversing is done intermediately, it is more efficient.
- */
-void pas_cft2d(tables_ok,flag, x,y,n,m, wcos,w3cos,w3sin)
- REAL *x,*y, *wcos,*w3cos,*w3sin;
- long n,m, flag, tables_ok;
-{ REAL scale, *xrow,*yrow;
- long i,j, rows,cols, total_length;
- void pas_cft_make_twiddle_tables_once();
- void C_Array_Time_Reverse();
- void pas_cft_forward_loop();
-
- if (tables_ok != 1) /* 1 means = tables already made */
- pas_cft_make_twiddle_tables_once(n,m, wcos,w3cos,w3sin);
-
- rows = n;
- cols = rows; /* square image */
- total_length = rows*rows;
-
- if (flag != 1) /* backward transform */
- for (i=0; i<total_length; i++) y[i] = (-y[i]); /* conjugate before */
-
- xrow = x; yrow = y; /* ROW-WISE */
- for (i=0; i<rows; i++) /* forward or backward */
- { pas_cft_forward_loop( xrow,yrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols;
- yrow = yrow + cols; }
-
- Image_Fast_Transpose(x, rows); /* COLUMN-WISE */
- Image_Fast_Transpose(y, rows);
- xrow = x; yrow = y;
- for (i=0; i<rows; i++) /* forward or backward */
- { pas_cft_forward_loop( xrow,yrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols;
- yrow = yrow + cols; }
-
- Image_Fast_Transpose(x, rows);
- Image_Fast_Transpose(y, rows);
-
- if (flag == 1) /* forward : scale */
- { scale = (REAL) (1.0 / ((double) total_length));
- for (i=0; i<total_length; i++)
- { x[i] = x[i]*scale;
- y[i] = y[i]*scale; }}
- else /* backward : conjugate after */
- for (i=0; i<total_length; i++) y[i] = (-y[i]);
-}
-
-
-DEFINE_PRIMITIVE ("PAS-RFT2D-CSFT2D!", Prim_pas_rft2d_csft2d, 5,5, 0)
-{ long i, length, power, flag, ft_type, rows,rowpower;
- REAL *f1, *wcos,*w3cos,*w3sin;
- void pas_rft2d(), pas_csft2d();
- PRIMITIVE_HEADER (5);
- CHECK_ARG (2, ARRAY_P); /* Input data (real or cs) */
- CHECK_ARG (3, ARRAY_P); /* CFT twiddle tables, length = 3*(rows/4) */
- CHECK_ARG (4, FIXNUM_P); /* (1)=tables precomputed, else recompute */
- flag = (arg_integer (1));
- f1 = ARRAY_CONTENTS(ARG_REF(2));
- length = ARRAY_LENGTH(ARG_REF(2));
- for (power=0, i=length; i>1; power++) /* length must be power of 2 */
- { if ( (i % 2) == 1) error_bad_range_arg(2);
- i=i/2; }
-
- if ((power % 2) == 1) error_bad_range_arg(2);
- rowpower = (power/2);
- rows = (1<<rowpower); /* square image */
-
- wcos = ARRAY_CONTENTS(ARG_REF(3)); /* CFT twiddle tables */
- if (ARRAY_LENGTH(ARG_REF(3)) != (3*rows/4)) error_bad_range_arg(3);
- w3cos = wcos + rows/4;
- w3sin = w3cos + rows/4;
-
- ft_type = (arg_nonnegative_integer(5)); /* rft2d or csft2d */
- if (ft_type == 1) {
- if ((arg_nonnegative_integer(4)) == 1)
- pas_rft2d (1, flag, f1, rows, rowpower, wcos,w3cos,w3sin);
- else pas_rft2d (0, flag, f1, rows, rowpower, wcos,w3cos,w3sin);
- }
- else if (ft_type == 3) {
- if ((arg_nonnegative_integer(4)) == 1)
- pas_csft2d (1, flag, f1, rows, rowpower, wcos,w3cos,w3sin);
- else pas_csft2d (0, flag, f1, rows, rowpower, wcos,w3cos,w3sin);
- /* 1 means tables are already made
- 0 means compute new tables */
- }
- else error_bad_range_arg(5);
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* c RFT2D CSFT2D
- The frequencies are scrabled wrt what cft2d (and the old image-fft) give.
- See cs-image-magnitude and cs-image-real which unscrable automatically.
- c
- c Implementation notes:
- c conjugate in one domain is reverse and conjugate in other
- c reverse in one domain is reverse in other
- c
- c reverse cs-array which is identical to conjugate cs-array (same domain)
- c is reverse in other domain
- c
- c conjugate cs-array before csft is-better-than reverse real-array afterwards
- c
- c
- c rft2d-csft2d use 1d-cft tables to compute rft
- c cft tables are simply larger than realdata tables.
- */
-
-/* pas_rft2d
- n = rows of square image, rows is power of 2
- m = rowpower
- Scaling (1/n) is done all-at-once at the end.
- Time-Reversing is done intermediately, it is more efficient.
- */
-void pas_rft2d(tables_ok,flag, x, n,m, wcos,w3cos,w3sin)
- REAL *x, *wcos,*w3cos,*w3sin;
- long n,m, flag, tables_ok;
-{ REAL scale, *xrow,*yrow;
- long i,j, rows,cols, total_length, n2;
- void pas_cft_make_twiddle_tables_once();
- void C_Array_Time_Reverse();
- void pas_rft_forward_loop(), pas_cft_forward_loop();
-
- if (tables_ok != 1) /* 1 means = tables already made */
- pas_cft_make_twiddle_tables_once(n,m, wcos,w3cos,w3sin);
-
- rows = n;
- cols = rows; /* square image */
- n2 = n/2;
- total_length = rows*rows;
-
- xrow = x; /* First ROW-WISE */
- if (flag == 1) /* forward transform */
- for (i=0; i<rows; i++)
- { pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols; }
- else /* backward transform */
- for (i=0; i<rows; i++)
- { pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
- for (j=n2+1; j<n; j++) xrow[j] = (-xrow[j]); /* time-reverse cs-array */
- xrow = xrow + cols; }
-
- Image_Fast_Transpose(x, rows); /* COLUMN-WISE */
-
- /* TREAT specially rows 0 and n2,
- they are real and go into cs-arrays */
- if (flag == 1) /* forward transform */
- { xrow = x + 0 ;
- pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
- xrow = x + n2*cols;
- pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin); }
- else /* backward transform */
- { xrow = x + 0 ;
- pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
- for (j=n2+1; j<n; j++) xrow[j] = (-xrow[j]); /* time-reverse cs-array */
- xrow = x + n2*cols;
- pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
- for (j=n2+1; j<n; j++) xrow[j] = (-xrow[j]); /* time-reverse cs-array */
- }
-
- /* TREAT the rest of the rows with CFT
- */
- if (flag != 1) /* backward : conjugate before */
- for (i=(n2+1)*cols; i<total_length; i++) x[i] = (-x[i]);
-
- xrow = x + cols; /* real part */
- yrow = x + (rows-1)*cols; /* imag part */
- for (i=1; i<n2; i++) /* forward or backward transform */
- { pas_cft_forward_loop(xrow,yrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols;
- yrow = yrow - cols; }
- /* DO NOT TRANSPOSE BACK, leave real-imag in horizontal rows, save.
- */
-
- if (flag == 1) /* forward : scale */
- { scale = (REAL) (1.0 / ((double) total_length));
- for (i=0; i<total_length; i++)
- x[i] = x[i]*scale; }
- else /* backward : conjugate after */
- for (i=(n2+1)*cols; i<total_length; i++)
- x[i] = (-x[i]);
-}
-
-
-/* pas_csft2d
- n = rows of square image, rows is power of 2
- m = rowpower
- Scaling (1/n) is done all-at-once at the end.
- Time-Reversing is done intermediately, it is more efficient.
- */
-void pas_csft2d(tables_ok,flag, x, n,m, wcos,w3cos,w3sin)
- REAL *x, *wcos,*w3cos,*w3sin;
- long n,m, flag, tables_ok;
-{ REAL scale, *xrow,*yrow;
- long i,j, rows,cols, total_length, n2;
- void pas_cft_make_twiddle_tables_once();
- void C_Array_Time_Reverse();
- void pas_csft_backward_loop(), pas_cft_forward_loop();
-
- if (tables_ok != 1) /* 1 means = tables already made */
- pas_cft_make_twiddle_tables_once(n,m, wcos,w3cos,w3sin);
-
- rows = n;
- cols = rows; /* square image */
- n2 = n/2;
- total_length = rows*rows;
-
- /* First ROW-WISE */
-
- /* TREAT SPECIALLY ROWS 0 and n2, they are cs-arrays and they go into real */
- if (flag == 1) /* forward transform */
- { xrow = x + 0 ;
- for (j=n2+1; j<n; j++) xrow[j]=(-xrow[j]); /* conjugate before */
- pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin);
- xrow = x + n2*cols;
- for (j=n2+1; j<n; j++) xrow[j]=(-xrow[j]); /* conjugate before */
- pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin); }
- else /* backward transform */
- { xrow = x + 0 ;
- pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin);
- xrow = x + n2*cols;
- pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin); }
-
- /* TREAT the rest of the rows with CFT
- */
- if (flag != 1) /* backward : conjugate before */
- for (i=(n2+1)*cols; i<total_length; i++) x[i] = (-x[i]);
-
- xrow = x + cols; /* real part */
- yrow = x + (rows-1)*cols; /* imag part */
- for (i=1; i<n2; i++) /* forward or backward transform */
- { pas_cft_forward_loop(xrow,yrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols;
- yrow = yrow - cols; }
-
- if (flag != 1) /* backward : conjugate after */
- for (i=(n2+1)*cols; i<total_length; i++) x[i] = (-x[i]);
-
- Image_Fast_Transpose(x, rows);
- /* Second COLUMN-WISE
- Everything should be cs-arrays now */
-
- xrow = x;
- if (flag == 1) /* forward transform */
- for (i=0; i<rows; i++)
- { for (j=n2+1; j<n; j++) xrow[j]=(-xrow[j]); /* conjugate before */
- pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols; }
- else /* backward transform */
- for (i=0; i<rows; i++)
- { pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols; }
-
- if (flag == 1) /* forward : scale */
- { scale = (REAL) (1.0 / ((double) total_length));
- for (i=0; i<total_length; i++)
- x[i] = x[i] * scale; }
-}
-
-
-\f
-/* STUFF BEFORE 4-15-1989
- */
-
-void Make_FFT_Tables(w1, w2, n, flag)
- REAL *w1, *w2; long n, flag; /* n = length of data */
-{ long m, n2=n/2; /* n2 = length of w1,w2 */
- double tm;
- if (flag==1) /* FORWARD FFT */
- for (m=0; m<n2; m++) {
- tm = TWOPI * ((double) m) / ((double) n);
- w1[m] = (REAL) cos(tm);
- w2[m] = (REAL) - sin(tm); }
- else
- for (m=0; m<n2; m++) {
- tm = TWOPI * ((double) m) / ((double) n);
- w1[m] = (REAL) cos(tm);
- w2[m] = (REAL) sin(tm); }
-}
-
-#define mult(pf1, pf2, pg1, pg2, w1, w2) \
- { long x, y, p2, p3, p4, p5, p6, p7; \
- REAL tmp1, tmp2; \
- a = a / 2; \
- p2 = - a; \
- p3 = 0; \
- for ( x = 1; x <= n2; x = x + a ) { \
- p2 = p2 + a; \
- for( y = 1; y <= a; ++y ) { \
- ++p3; \
- p4 = p2 + 1; \
- p5 = p2 + p3; \
- p5 = ((p5-1) % n) + 1; \
- p6 = p5 + a; \
- tmp1 = w1[p4-1] * pf1[p6-1] \
- - w2[p4-1] * pf2[p6-1]; \
- tmp2 = w1[p4-1] * pf2[p6-1] \
- + w2[p4-1] * pf1[p6-1]; \
- pg1[p3-1] = pf1[p5-1] + tmp1; \
- pg2[p3-1] = pf2[p5-1] + tmp2; \
- p7 = p3 + n2; \
- pg1[p7-1] = pf1[p5-1] - tmp1; \
- pg2[p7-1] = pf2[p5-1] - tmp2; \
- } \
- } \
-}
-
-/* n = length of input data f1,f2;
- power = log2(n),
- g1,g2 are intermediate arrays of length n,
- w1,w2 point to FFT tables (twiddle factors),
- flag 1 for forward FFT, else inverse.
- */
-/* The arrays w1,w2 are half the size of f1,f2,g1,g2.
- f1,f2 contain the real and imaginary parts of the signal.
- The answer is left in f1, f2.
- */
-
-/* C_Array_FFT
- complex data, radix=2, not-in-place.
- (adapted from an fft program I got from Yekta)
- */
-void C_Array_FFT(flag, power, n, f1, f2, g1,g2,w1,w2)
- long flag, power, n; REAL f1[], f2[], g1[], g2[], w1[], w2[];
-{ long n2=n>>1, a;
- long i, l, m;
- REAL tm;
- a = n; /* initially equal to length of data */
-
- for (m=0; m<n; m++) { g1[m] = f1[m]; g2[m] = f2[m]; }
- Make_FFT_Tables(w1,w2,n, flag);
-
- if ((power % 2) == 1) l = 2; else l = 1; /* even,odd power */
- for ( i = l; i <= power ; i = i + 2 ) {
- mult(g1,g2,f1,f2,w1,w2);
- mult(f1,f2,g1,g2,w1,w2); }
-
- if (flag==1) { /* FORWARD FFT */
- tm = 1. / ((REAL) n); /* normalizing factor */
- if (l==1) /* even power */
- for (m=0; m<n; m++) { f1[m] = tm * g1[m]; f2[m] = tm * g2[m]; }
- else { /* odd power ==> do one more mult */
- mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
- for (m=0; m<n; m++) { f1[m] = tm * f1[m]; f2[m] = tm * f2[m]; }}
- }
- else { /* BACKWARD FFT */
- if (l==1) /* even power */
- for (m=0; m<n; m++) { f1[m] = g1[m]; f2[m] = g2[m]; }
- else /* odd power ==> do one more mult */
- mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
- }
-}
-
-void C_Array_FFT_With_Given_Tables(flag, power, n, f1, f2, g1,g2,w1,w2)
- long flag, power, n; REAL f1[], f2[], g1[], g2[], w1[], w2[];
-{ long n2=n>>1, a;
- long i, l, m;
- REAL tm;
- a = n; /* initially equal to length */
-
- for (m=0; m<n; m++) { g1[m] = f1[m]; g2[m] = f2[m]; }
-
- if ((power % 2) == 1) l = 2; else l = 1; /* even,odd power */
- for ( i = l; i <= power ; i = i + 2 ) {
- mult(g1,g2,f1,f2,w1,w2);
- mult(f1,f2,g1,g2,w1,w2); }
-
- if (flag==1) { /* FORWARD FFT */
- tm = 1. / ((REAL) n); /* normalizing factor */
- if (l==1) /* even power */
- for (m=0; m<n; m++) { f1[m] = tm * g1[m]; f2[m] = tm * g2[m]; }
- else { /* odd power ==> do one more mult */
- mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
- for (m=0; m<n; m++) { f1[m] = tm * f1[m]; f2[m] = tm * f2[m]; }}
- }
- else { /* BACKWARD FFT */
- if (l==1) /* even power */
- for (m=0; m<n; m++) { f1[m] = g1[m]; f2[m] = g2[m]; }
- else /* odd power ==> do one more mult */
- mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
- }
-}
-
-\f
-/* CHIRP-Z-TRANSFORM (complex data)
- */
-
-/* C_Array_CZT Generalization of DFT
- ;;
- Frequency is scaled as an L/2-point DFT of the input data (zero padded to L/2).
- ;;
- phi = starting point (on unit circle) -- Range 0,1 (covers 0,2pi like DFT angle)
- rho = resolution (angular frequency spacing) -- Range 0,1 (maps 0,2pi like DFT angle)
- N = input data length
- M = output data length
- log2_L = smallest_power_of_2_ge(N+M-1) ----
- f1,f2 contain the input data (complex).
- f1,f2,fo1,fo2,g1,g2 must be of length L
- fft_w1,fft_w2 must be of length L/2
- czt_w1,czt_w2 must be of length max(M,N) ----
- ;;
- RESULT is left on f1,f2 (M complex numbers).
- */
-C_Array_CZT(phi,rho, N,M,log2_L, f1,f2,fo1,fo2, g1,g2, fft_w1,fft_w2,czt_w1,czt_w2)
- double phi, rho;
- REAL *f1,*f2,*fo1,*fo2, *g1,*g2, *fft_w1,*fft_w2,*czt_w1,*czt_w2;
- long N,M,log2_L;
-{ long i, maxMN, L, L2;
- void Make_CZT_Tables(), CZT_Pre_Multiply(), Make_Chirp_Filter();
- void Make_FFT_Tables(), C_Array_FFT_With_Given_Tables(), C_Array_Complex_Multiply_Into_First_One();
-
- maxMN = max(M,N);
- L = 1<<log2_L;
- L2 = L/2;
-
- CZT_Pre_Multiply(phi,rho, f1,f2, N,L);
- Make_FFT_Tables(fft_w1,fft_w2, L, 1); /* PREPARE TABLES FOR FORWARD FFT */
- C_Array_FFT_With_Given_Tables(1, log2_L, L, f1,f2, g1,g2, fft_w1,fft_w2);
-
- Make_CZT_Tables(czt_w1,czt_w2, rho, maxMN);
- Make_Chirp_Filter(fo1,fo2, N,M,L, czt_w1,czt_w2);
- C_Array_FFT_With_Given_Tables(1, log2_L, L, fo1,fo2, g1,g2, fft_w1,fft_w2);
-
- C_Array_Complex_Multiply_Into_First_One(f1,f2, fo1,fo2, L);
- for (i=0;i<L2;i++) fft_w2[i] = (-fft_w2[i]); /* PREPARE TABLES FOR INVERSE FFT */
- C_Array_FFT_With_Given_Tables(-1, log2_L, L, f1,f2, g1,g2, fft_w1,fft_w2);
- C_Array_Complex_Multiply_Into_First_One(f1,f2, czt_w1,czt_w2, M);
-}
-
-void CZT_Pre_Multiply(phi,rho, f1,f2, N,L) /* phi = starting point */
- double phi,rho; REAL *f1,*f2; long N,L; /* this proc is two complex multiplication */
-{ long i;
- double tmp, A1, A2;
- rho = rho*.5; /* To make 1/2 in exponent "(n^2)/2" */
- for (i=0;i<N;i++)
- { tmp = ((double) i);
- tmp = TWOPI * ((phi + (rho*tmp)) * tmp);
- A1 = cos(tmp);
- A2 = sin(tmp);
- tmp = A1*f1[i] - A2*f2[i];
- f2[i] = (REAL) (A1*f2[i] + A2*f1[i]);
- f1[i] = (REAL) tmp;
- }
- for (i=N;i<L;i++) { f1[i] = 0.0; /* zero pad */
- f2[i] = 0.0; }
-}
-
-void Make_Chirp_Filter(fo1,fo2, N,M,L, czt_w1,czt_w2)
- REAL *fo1,*fo2, *czt_w1,*czt_w2; long N,M,L;
-{ long i, L_minus_N_plus_1 = L-N+1;
- for (i=0;i<M;i++) { fo1[i] = czt_w1[i];
- fo2[i] = - czt_w2[i]; }
- for (i=M;i<L_minus_N_plus_1;i++) { fo1[i] = 0.0; /* arbitrary region, circular convolution */
- fo2[i] = 0.0; }
- for (i=L_minus_N_plus_1;i<L;i++) { fo1[i] = czt_w1[(L-i)];
- fo2[i] = - czt_w2[(L-i)]; }
-}
-
-void Make_CZT_Tables(czt_w1,czt_w2, rho, maxMN) /* rho = resolution */
- double rho; REAL *czt_w1,*czt_w2; long maxMN;
-{ long i;
- double tmp;
- rho = rho*.5; /* the 1/2 in the "(n^2)/2" exponent */
- for (i=0;i<maxMN;i++)
- { tmp = ((double) i);
- tmp = TWOPI * (tmp * (rho*tmp));
- czt_w1[i] = (REAL) cos(tmp);
- czt_w2[i] = (REAL) sin(tmp); }
-}
-
-
-long smallest_power_of_2_ge(n)
- long n;
-{ long i,power;
- if (n<0) { printf("\n ABORT program! smallest_pwr_of_2_ge negative argument--- %d\n", n); fflush(stdout); }
- power=0; i=1;
- while (i<n)
- { power++; i=i*2; }
- return(power);
-}
-
-/* stuff not currently used
-
-void CZT_Post_Multiply(f1,f2,czt_w1,czt_w2,M)
- REAL *f1,*f2,*czt_w1,*czt_w2; long M;
-{ long i;
- REAL tmp;
- for (i=0;i<M;i++)
- { tmp = f1[i]*czt_w1[i] - f2[i]*czt_w2[i];
- f2[i] = 2.0 * (f1[i]*czt_w2[i] + f2[i]*czt_w1[i]);
- f1[i] = 2.0 * tmp;
- }}
-
-#define take_modulo_one(x, answer) \
-{ long ignore_integral_part; \
- double modf(); \
- answer = (double) modf( ((double) x), &ignore_integral_part); }
- ^ this only works when answer is double
-
-*/
-
-
-\f
-/* 2D DFT ---------------- row-column decomposition
- (3D not working yet)
- */
-C_Array_2D_FFT_In_Scheme_Heap(flag, nrows, ncols, Real_Array, Imag_Array)
- long flag, nrows, ncols; REAL *Real_Array, *Imag_Array;
-{ long i, j;
- REAL *Temp_Array;
- REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
- long nrows_power, ncols_power, Length = nrows*ncols;
-
- if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */
- Square_Image_2D_FFT_In_Scheme_Heap(flag, nrows, Real_Array, Imag_Array);
- }
- else { /* NOT A SQUARE IMAGE, CANNOT DO FAST_TRANSPOSE */
- /* FIRST (NCOLS-1)POINT FFTS FOR EACH ROW, THEN (NROWS-1)POINT FFTS FOR EACH COLUMN */
-
- for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */
- if ( (i % 2) == 1) error_bad_range_arg (2);
- i=i/2; }
- for (nrows_power=0, i=nrows; i>1; nrows_power++) {
- if ( (i % 2) == 1) error_bad_range_arg (1);
- i=i/2; }
-
-#if (REAL_IS_DEFINED_DOUBLE != 0)
- ALIGN_FLOAT (Free);
- Free += 1;
-#endif
- Primitive_GC_If_Needed(Length*REAL_SIZE + ((max(nrows,ncols))*3*REAL_SIZE));
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + ncols;
- w1 = Work_Here + (ncols<<1);
- w2 = Work_Here + (ncols<<1) + (ncols>>1);
- Make_FFT_Tables(w1,w2,ncols, flag);
- for (i=0;i<nrows;i++) { /* ROW-WISE */
- f1 = Real_Array + (i*ncols);
- f2 = Imag_Array + (i*ncols);
- C_Array_FFT_With_Given_Tables(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
- }
-
- Temp_Array = Work_Here;
- Work_Here = Temp_Array + Length;
- Image_Transpose(Real_Array, Temp_Array, nrows, ncols); /* TRANSPOSE: (1) order of frequencies. (2) read columns.*/
- Image_Transpose(Imag_Array, Real_Array, nrows, ncols);
-
- g1 = Work_Here;
- g2 = Work_Here + nrows;
- w1 = Work_Here + (nrows<<1);
- w2 = Work_Here + (nrows<<1) + (nrows>>1);
- Make_FFT_Tables(w1,w2,nrows,flag);
- for (i=0;i<ncols;i++) { /* COLUMN-WISE */
- f1 = Temp_Array + (i*nrows); /* THIS IS REAL DATA */
- f2 = Real_Array + (i*nrows); /* THIS IS IMAG DATA */
- C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
- }
-
- Image_Transpose(Real_Array, Imag_Array, ncols, nrows); /* DO FIRST THIS !!!, do not screw up Real_Data !!! */
- Image_Transpose(Temp_Array, Real_Array, ncols, nrows); /* TRANSPOSE BACK: order of frequencies. */
- }
-}
-
-Square_Image_2D_FFT_In_Scheme_Heap(flag, nrows, Real_Array, Imag_Array)
- long flag,nrows; REAL *Real_Array, *Imag_Array;
-{ REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
- long nrows_power;
- long i;
-
- for (nrows_power=0, i=nrows; i>1; nrows_power++) { /* FIND/CHECK POWERS OF ROWS */
- if ( (i % 2) == 1) error_bad_range_arg (2);
- i=i/2; }
-#if (REAL_IS_DEFINED_DOUBLE != 0)
- ALIGN_FLOAT (Free);
- Free += 1;
-#endif
- Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + nrows;
- w1 = Work_Here + (nrows<<1);
- w2 = Work_Here + (nrows<<1) + (nrows>>1);
- Make_FFT_Tables(w1, w2, nrows, flag); /* MAKE TABLES */
- for (i=0;i<nrows;i++) { /* ROW-WISE */
- f1 = Real_Array + (i*nrows);
- f2 = Imag_Array + (i*nrows);
- C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
- }
- Image_Fast_Transpose(Real_Array, nrows); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
- Image_Fast_Transpose(Imag_Array, nrows);
-
- for (i=0;i<nrows;i++) { /* COLUMN-WISE */
- f1 = Real_Array + (i*nrows);
- f2 = Imag_Array + (i*nrows);
- C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2); /* ncols=nrows... Twiddles... */
- }
- Image_Fast_Transpose(Real_Array, nrows); /* TRANSPOSE BACK: order of frequencies. */
- Image_Fast_Transpose(Imag_Array, nrows);
-}
-
-C_Array_3D_FFT_In_Scheme_Heap(flag, ndeps, nrows, ncols, Real_Array, Imag_Array)
- long flag, ndeps, nrows, ncols; REAL *Real_Array, *Imag_Array;
-{ long l, m, n;
- REAL *Temp_Array;
- REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
- long ndeps_power, nrows_power, ncols_power;
-
- if ((ndeps==nrows) && (nrows==ncols)) { /* CUBIC IMAGE, OPTIMIZE... */
- Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array);
- }
- else {
- for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWERS OF DEPS,ROWS,COLS */
- if ( (l % 2) == 1) error_bad_range_arg (2);
- l=l/2; }
- for (nrows_power=0, m=nrows; m>1; nrows_power++) {
- if ( (m % 2) == 1) error_bad_range_arg (2);
- m=m/2; }
- for (ncols_power=0, n=ncols; n>1; ncols_power++) {
- if ( (n % 2) == 1) error_bad_range_arg (2);
- n=n/2; }
-
- printf("3D FFT implemented only for cubic-spaces.\n");
- printf("aborted\n.");
- }
-}
-
-Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array)
- long flag, ndeps; REAL *Real_Array, *Imag_Array;
-{ fast long l, m, n;
- fast long ndeps_power, Surface_Length;
- fast REAL *From_Real, *From_Imag;
- fast REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
-
- for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWER OF NDEPS */
- if ( (l % 2) == 1) error_bad_range_arg (2);
- l=l/2; }
-#if (REAL_IS_DEFINED_DOUBLE != 0)
- ALIGN_FLOAT (Free);
- Free += 1;
-#endif
- Primitive_GC_If_Needed(ndeps*3*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + ndeps;
- w1 = Work_Here + (ndeps<<1);
- w2 = Work_Here + (ndeps<<1) + (ndeps>>1);
- Make_FFT_Tables(w1, w2, ndeps, flag); /* MAKE TABLES */
-
- Surface_Length=ndeps*ndeps;
- From_Real = Real_Array; From_Imag = Imag_Array;
-
- for (l=0; l<ndeps; l++,From_Real+=Surface_Length,From_Imag+=Surface_Length) { /* DEPTH-WISE */
-
- f1 = From_Real; f2 = From_Imag;
- for (m=0; m<ndeps; m++,f1+=ndeps,f2+=ndeps) { /* ROW-WISE */
- C_Array_FFT_With_Given_Tables(flag, ndeps_power, ndeps, f1,f2,g1,g2,w1,w2); }
- Image_Fast_Transpose(From_Real, ndeps); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
- Image_Fast_Transpose(From_Imag, ndeps);
-
- /* ndeps=nrows=ncols, same Twiddle Tables */
-
- f1 = From_Real; f2 = From_Imag;
- for (n=0; n<ndeps; n++,f1+=ndeps,f2+=ndeps) { /* COLUMN-WISE */
- C_Array_FFT_With_Given_Tables(flag, ndeps_power, ndeps, f1,f2,g1,g2,w1,w2); }
- Image_Fast_Transpose(From_Real, ndeps); /* TRANSPOSE BACK: order of frequencies. */
- Image_Fast_Transpose(From_Imag, ndeps);
- }
-}
-
-\f
-/*----------------------- scheme primitives ------------------------- */
-
-/* Real and Imag arrays must be different.
- Arg1=1 --> forward FFT, otherwise backward.
- */
-
-DEFINE_PRIMITIVE ("ARRAY-FFT!", Prim_array_fft, 3, 3, 0)
-{ long length, power, flag, i;
- SCHEME_OBJECT answer;
- REAL *f1,*f2,*g1,*g2,*w1,*w2;
- REAL *Work_Here;
-
- PRIMITIVE_HEADER (4);
- flag = arg_integer(1); /* forward or backward */
- CHECK_ARG (2, ARRAY_P); /* input real */
- CHECK_ARG (3, ARRAY_P); /* input imag */
-
- length = ARRAY_LENGTH(ARG_REF(2));
- if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2);
-
- for (power=0, i=length; i>1; power++) {
- if ( (i % 2) == 1) error_bad_range_arg(2);
- i=i/2; }
-
- f1 = ARRAY_CONTENTS(ARG_REF(2));
- f2 = ARRAY_CONTENTS(ARG_REF(3));
- if (f1==f2) error_wrong_type_arg(2);
-
-#if (REAL_IS_DEFINED_DOUBLE != 0)
- ALIGN_FLOAT (Free);
- Free += 1;
-#endif
- Primitive_GC_If_Needed(length*3*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + length;
- w1 = Work_Here + (length<<1);
- w2 = Work_Here + (length<<1) + (length>>1);
-
- C_Array_FFT(flag, power, length, f1,f2,g1,g2,w1,w2);
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("ARRAY-CZT!", Prim_array_czt, 6,6, 0)
-{ double phi,rho;
- long N,M,L, i;
- long log2_L, maxMN;
- long smallest_power_of_2_ge();
- int errcode;
- REAL *a,*b,*c,*d;
- REAL *f1,*f2,*fo1,*fo2, *g1,*g2, *fft_w1,*fft_w2,*czt_w1,*czt_w2, *Work_Here;
-
- PRIMITIVE_HEADER (6);
- phi = (arg_real_number (1)); /* starting point [0,1]*/
- rho = (arg_real_number (2)); /* resolution [0,1] */
- CHECK_ARG (3, ARRAY_P); /* input real */
- CHECK_ARG (4, ARRAY_P); /* input imag */
- CHECK_ARG (5, ARRAY_P); /* output real */
- CHECK_ARG (6, ARRAY_P); /* output imag */
-
- a = ARRAY_CONTENTS(ARG_REF(3));
- b = ARRAY_CONTENTS(ARG_REF(4));
- c = ARRAY_CONTENTS(ARG_REF(5));
- d = ARRAY_CONTENTS(ARG_REF(6));
-
- N = ARRAY_LENGTH(ARG_REF(3)); /* N = input length */
- M = ARRAY_LENGTH(ARG_REF(5)); /* M = output length */
- if (N!=(ARRAY_LENGTH(ARG_REF(4)))) error_bad_range_arg(3);
- if (M!=(ARRAY_LENGTH(ARG_REF(6)))) error_bad_range_arg(5);
-
- if ((M+N-1) < 4) error_bad_range_arg(5);
- log2_L = smallest_power_of_2_ge(M+N-1);
- L = 1<<log2_L; /* length of intermediate computation arrays */
- maxMN = (((M)<(N)) ? (N) : (M)); /* length of czt tables = maximum(M,N) */
-
-#if (REAL_IS_DEFINED_DOUBLE != 0)
- ALIGN_FLOAT (Free);
- Free += 1;
-#endif
- Primitive_GC_If_Needed( ((7*L) + (2*maxMN)) * REAL_SIZE);
- g1 = (REAL *) Free;
- g2 = g1 + L;
- fo1 = g2 + L;
- fo2 = fo1 + L;
- fft_w1 = fo2 + L;
- fft_w2 = fft_w1 + (L/2);
- czt_w1 = fft_w2 + (L/2);
- czt_w2 = czt_w1 + maxMN;
- f1 = czt_w2 + maxMN; /* CZT stores its results here */
- f2 = f1 + L;
-
- for (i=0; i<N; i++) { f1[i] = a[i]; /* input data */
- f2[i] = b[i]; }
-
- C_Array_CZT(phi,rho, N,M,log2_L, f1,f2,fo1,fo2, g1,g2, fft_w1,fft_w2,czt_w1,czt_w2);
-
- for (i=0; i<M; i++) { c[i] = f1[i]; /* results */
- d[i] = f2[i]; }
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("ARRAY-2D-FFT!", Prim_array_2d_fft, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- {
- fast long nrows = (arg_integer_in_range (2, 1, 513));
- fast long ncols = (arg_integer_in_range (3, 1, 513));
- fast SCHEME_OBJECT real_image = (ARG_REF (4));
- fast SCHEME_OBJECT imag_image = (ARG_REF (5));
- CHECK_ARG (4, ARRAY_P);
- CHECK_ARG (5, ARRAY_P);
- if (real_image == imag_image)
- error_wrong_type_arg (5);
- Set_Time_Zone (Zone_Math);
- {
- long length = (ARRAY_LENGTH (real_image));
- if ((length != (ARRAY_LENGTH (imag_image))) ||
- (length != (nrows * ncols)))
- error_bad_range_arg (5);
- }
- C_Array_2D_FFT_In_Scheme_Heap
- ((arg_integer (1)), /* flag 1=forward else backward */
- nrows,
- ncols,
- (ARRAY_CONTENTS (real_image)),
- (ARRAY_CONTENTS (imag_image)));
- PRIMITIVE_RETURN (cons (real_image, (cons (imag_image, EMPTY_LIST))));
- }
-}
-
-DEFINE_PRIMITIVE ("ARRAY-3D-FFT!", Prim_array_3d_fft, 6, 6, 0)
-{
- PRIMITIVE_HEADER (6);
- {
- fast long ndeps = (arg_integer_in_range (2, 1, 513));
- fast long nrows = (arg_integer_in_range (3, 1, 513));
- fast long ncols = (arg_integer_in_range (4, 1, 513));
- fast SCHEME_OBJECT real_image = (ARG_REF (5));
- fast SCHEME_OBJECT imag_image = (ARG_REF (6));
- CHECK_ARG (5, ARRAY_P);
- CHECK_ARG (6, ARRAY_P);
- if (real_image == imag_image)
- error_wrong_type_arg (6);
- {
- long length = (ARRAY_LENGTH (real_image));
- if ((length != (ARRAY_LENGTH (imag_image))) ||
- (length != (ndeps * nrows * ncols)))
- error_bad_range_arg (6);
- }
- C_Array_3D_FFT_In_Scheme_Heap
- ((arg_integer (1)),
- ndeps,
- nrows,
- ncols,
- (ARRAY_CONTENTS (real_image)),
- (ARRAY_CONTENTS (imag_image)));
- PRIMITIVE_RETURN (cons (real_image, (cons (imag_image, EMPTY_LIST))));
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: fhooks.c,v 9.39 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains hooks and handles for the new fluid bindings
- scheme for multiprocessors. */
-
-#include "scheme.h"
-#include "prims.h"
-#include "trap.h"
-#include "lookup.h"
-#include "locks.h"
-\f
-DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1)
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, APPARENT_LIST_P);
- {
- SCHEME_OBJECT result = Fluid_Bindings;
- Fluid_Bindings = (ARG_REF (1));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (Fluid_Bindings);
-}
-
-DEFINE_PRIMITIVE ("WITH-SAVED-FLUID-BINDINGS", Prim_with_saved_fluid_bindings, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT thunk = (ARG_REF (1));
- PRIMITIVE_CANONICALIZE_CONTEXT ();
- POP_PRIMITIVE_FRAME (1);
- Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- /* Save previous fluid bindings for later restore */
- exp_register = Fluid_Bindings;
- Store_Return (RC_RESTORE_FLUIDS);
- Save_Cont ();
- /* Invoke the thunk. */
- STACK_PUSH (thunk);
- STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- }
-}
-\f
-#define lookup_slot(environment, variable) \
- (lookup_cell ((OBJECT_ADDRESS (variable)), (environment)))
-
-DEFINE_PRIMITIVE ("ADD-FLUID-BINDING!", Prim_add_fluid_binding, 3, 3,
- "(ADD-FLUID-BINDING! ENVIRONMENT SYMBOL/VARIABLE VALUE)\n\
-Dynamically bind SYMBOL/VARIABLE to VALUE in ENVIRONMENT.\n\
-If SYMBOL/VARIABLE has not been \"fluidized\", do so first.")
-{
- extern SCHEME_OBJECT * lookup_cell ();
- static SCHEME_OBJECT new_fluid_binding ();
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, ENVIRONMENT_P);
- {
- fast SCHEME_OBJECT environment = (ARG_REF (1));
- fast SCHEME_OBJECT name = (ARG_REF (2));
- fast SCHEME_OBJECT * cell;
- switch (OBJECT_TYPE (name))
- {
- /* The next two cases are a temporary fix since compiler doesn't
- do scode-quote the same way that the interpreter does.
-
- Ultimately we need to redesign deep fluid-let support anyway,
- so this will go away.
- */
-
- case TC_LIST:
- cell = (lookup_slot (environment, (PAIR_CAR (name))));
- break;
-
- case TC_SCODE_QUOTE:
- cell =
- (lookup_slot
- (environment, (FAST_MEMORY_REF (name, SCODE_QUOTE_OBJECT))));
- break;
-
- case TC_VARIABLE:
- cell = (lookup_slot (environment, name));
- break;
-
- case TC_INTERNED_SYMBOL:
- case TC_UNINTERNED_SYMBOL:
- cell = (deep_lookup (environment, name, fake_variable_object));
- break;
-
- default:
- error_wrong_type_arg (2);
- }
- PRIMITIVE_RETURN (new_fluid_binding (cell, (ARG_REF (3)), false));
- }
-}
-\f
-static SCHEME_OBJECT
-new_fluid_binding (cell, value, force)
- SCHEME_OBJECT * cell;
- SCHEME_OBJECT value;
- Boolean force;
-{
- fast SCHEME_OBJECT trap;
- Lock_Handle set_serializer;
- SCHEME_OBJECT new_trap_value;
- long new_trap_kind = TRAP_FLUID;
- long trap_kind;
- SCHEME_OBJECT saved_extension = SHARP_F;
- SCHEME_OBJECT saved_value;
-
- setup_lock (set_serializer, cell);
-
- new_fluid_binding_restart:
- trap = (*cell);
- new_trap_value = trap;
- if (REFERENCE_TRAP_P (trap))
- {
- get_trap_kind (trap_kind, trap);
- switch (trap_kind)
- {
- case TRAP_DANGEROUS:
- MEMORY_SET
- (trap,
- TRAP_TAG,
- (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID | (trap_kind & 1))));
- /* Fall through */
- case TRAP_FLUID:
- case TRAP_FLUID_DANGEROUS:
- new_trap_kind = -1;
- break;
-
- case TRAP_UNBOUND:
- case TRAP_UNBOUND_DANGEROUS:
- if (! force)
- {
- remove_lock (set_serializer);
- signal_error_from_primitive (ERR_UNBOUND_VARIABLE);
- }
- /* Fall through */
- case TRAP_UNASSIGNED:
- case TRAP_UNASSIGNED_DANGEROUS:
- new_trap_kind = (TRAP_FLUID | (trap_kind & 1));
- new_trap_value = UNASSIGNED_OBJECT;
- break;
-
- case TRAP_COMPILER_CACHED:
- case TRAP_COMPILER_CACHED_DANGEROUS:
- saved_extension = (FAST_MEMORY_REF ((*cell), TRAP_EXTRA));
- cell = (MEMORY_LOC (saved_extension, TRAP_EXTENSION_CELL));
- update_lock (set_serializer, cell);
- saved_value = (*cell);
- if (REFERENCE_TRAP_P (saved_value))
- /* No need to recache uuo links, they must already be recached. */
- saved_extension = SHARP_F;
- goto new_fluid_binding_restart;
-
- default:
- remove_lock (set_serializer);
- signal_error_from_primitive (ERR_ILLEGAL_REFERENCE_TRAP);
- }
- }
-
- if (new_trap_kind != -1)
- {
- if (GC_allocate_test (2))
- {
- remove_lock (set_serializer);
- Primitive_GC (2);
- }
- trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
- (*Free++) = (LONG_TO_UNSIGNED_FIXNUM (new_trap_kind));
- (*Free++) = new_trap_value;
- (*cell) = trap;
- }
- if (saved_extension != SHARP_F)
- {
- extern long recache_uuo_links ();
- long value = (recache_uuo_links (saved_extension, saved_value));
- if (value != PRIM_DONE)
- {
- remove_lock (set_serializer);
- if (value == PRIM_INTERRUPT)
- signal_interrupt_from_primitive ();
- else
- signal_error_from_primitive (value);
- }
- }
- remove_lock (set_serializer);
-
- /* Fluid_Bindings is per processor private. */
- Fluid_Bindings = (cons ((cons (trap, value)), Fluid_Bindings));
- return (SHARP_F);
-}
/* -*-C-*-
-$Id: findprim.c,v 9.60 2007/01/05 21:19:25 cph Exp $
+$Id: findprim.c,v 9.61 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "config.h"
#include <stdio.h>
-#define ASSUME_ANSIDECL
-
-/* For macros toupper, isalpha, etc,
- supposedly on the standard library. */
-
-#include <ctype.h>
-
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# include <string.h>
-#else
- extern void EXFUN (exit, (int));
- extern PTR EXFUN (malloc, (int));
- extern PTR EXFUN (realloc, (PTR, int));
- extern void EXFUN (free, (PTR));
- extern int EXFUN (strcmp, (CONST char *, CONST char *));
- extern int EXFUN (strlen, (CONST char *));
-#endif
-
-typedef int boolean;
-
#ifdef vms
/* VMS version 3 has no void. */
/* #define void */
#define pseudo_void int
#define pseudo_return return (0)
-PTR
-DEFUN (xmalloc, (length), unsigned long length)
+void *
+xmalloc (unsigned long length)
{
- PTR result = (malloc (length));
+ void * result = (malloc (length));
if (result == 0)
{
fprintf (stderr, "malloc: unable to allocate %ld bytes\n", length);
return (result);
}
-PTR
-DEFUN (xrealloc, (ptr, length), PTR ptr AND unsigned long length)
+void *
+xrealloc (void * ptr, unsigned long length)
{
- PTR result = (realloc (ptr, length));
+ void * result = (realloc (ptr, length));
if (result == 0)
{
fprintf (stderr, "realloc: unable to allocate %ld bytes\n", length);
\f
/* Maximum number of primitives that can be handled. */
-boolean built_in_p;
+bool built_in_p;
char * token_array [4];
char default_token [] = "Define_Primitive";
char built_in_token [] = "Built_In_Primitive";
char external_token [] = "Define_Primitive";
-typedef pseudo_void EXFUN ((* TOKEN_PROCESSOR), (void));
+typedef pseudo_void (* TOKEN_PROCESSOR) (void);
TOKEN_PROCESSOR token_processors [4];
char * the_kind;
/* forward references */
-TOKEN_PROCESSOR EXFUN (scan, (void));
-boolean EXFUN (whitespace, (int c));
-int EXFUN (compare_descriptors, (struct descriptor * d1, struct descriptor * d2));
-int EXFUN (read_index, (char * arg, char * identification));
-int EXFUN (strcmp_ci, (char * s1, char * s2));
-pseudo_void EXFUN (create_alternate_entry, (void));
-pseudo_void EXFUN (create_builtin_entry, (void));
-pseudo_void EXFUN (create_normal_entry, (void));
-void EXFUN (dump, (boolean check));
-void EXFUN (grow_data_buffer, (void));
-void EXFUN (grow_token_buffer, (void));
-void EXFUN (initialize_builtin, (char * arg));
-void EXFUN (initialize_data_buffer, (void));
-void EXFUN (initialize_default, (void));
-void EXFUN (initialize_external, (void));
-void EXFUN (initialize_token_buffer, (void));
-static void EXFUN
- (fp_mergesort, (int, int, struct descriptor **, struct descriptor **));
-void EXFUN (print_procedure, (FILE * output,
+TOKEN_PROCESSOR scan (void);
+bool whitespace (int c);
+int compare_descriptors (struct descriptor * d1, struct descriptor * d2);
+int read_index (char * arg, char * identification);
+int strcmp_ci (char * s1, char * s2);
+pseudo_void create_alternate_entry (void);
+pseudo_void create_builtin_entry (void);
+pseudo_void create_normal_entry (void);
+void dump (bool check);
+void grow_data_buffer (void);
+void grow_token_buffer (void);
+void initialize_builtin (char * arg);
+void initialize_data_buffer (void);
+void initialize_default (void);
+void initialize_external (void);
+void initialize_token_buffer (void);
+static void fp_mergesort
+ (int, int, struct descriptor **, struct descriptor **);
+void print_procedure (FILE * output,
struct descriptor * primitive_descriptor,
- char * error_string));
-void EXFUN (print_primitives, (FILE * output, int limit));
-void EXFUN (print_spaces, (FILE * output, int how_many));
-void EXFUN (print_entry, (FILE * output, int index,
- struct descriptor * primitive_descriptor));
-void EXFUN (process, (void));
-void EXFUN (process_argument, (char * fn));
-void EXFUN (scan_to_token_start, (void));
-void EXFUN (skip_token, (void));
-void EXFUN (sort, (void));
-void EXFUN (update_from_entry, (struct descriptor * primitive_descriptor));
+ char * error_string);
+void print_primitives (FILE * output, int limit);
+void print_spaces (FILE * output, int how_many);
+void print_entry (FILE * output, int index,
+ struct descriptor * primitive_descriptor);
+void process (void);
+void process_argument (char * fn);
+void scan_to_token_start (void);
+void skip_token (void);
+void sort (void);
+void update_from_entry (struct descriptor * primitive_descriptor);
\f
int
-DEFUN (main, (argc, argv),
- int argc AND
- char **argv)
+main (int argc, char ** argv)
{
name = argv[0];
/* Check whether there are any files left. */
if (argc == 1)
{
- dump (FALSE);
+ dump (0);
goto done;
}
if (file_list_file == NULL)
{
fprintf (stderr, "Error: %s can't open %s\n", name, argv[2]);
- dump (TRUE);
+ dump (1);
exit (1);
}
while ((fgets (fn, 1024, file_list_file)) != NULL)
sort ();
}
dprintf ("About to dump %s\n", "");
- dump (TRUE);
+ dump (1);
done:
if (output != stdout)
}
\f
void
-DEFUN (process_argument, (fn),
- char * fn)
+process_argument (char * fn)
{
file_name = fn;
if ((strcmp ("-", file_name)) == 0)
else if ((input = (fopen (file_name, "r"))) == NULL)
{
fprintf (stderr, "Error: %s can't open %s\n", name, file_name);
- dump (TRUE);
+ dump (1);
exit (1);
}
else
/* Search for tokens and when found, create primitive entries. */
void
-DEFUN_VOID (process)
+process (void)
{
TOKEN_PROCESSOR processor;
- while (TRUE)
+ while (1)
{
processor = (scan ());
if (processor == NULL) break;
*/
TOKEN_PROCESSOR
-DEFUN_VOID (scan)
+scan (void)
{
- register int c;
+ int c;
char compare_buffer [1024];
c = '\n';
if ((c = (getc (input))) == '*')
{
c = (getc (input));
- while (TRUE)
+ while (1)
{
while (c != '*')
{
fprintf (stderr,
"Error: EOF in comment in file %s, or %s confused\n",
file_name, name);
- dump (TRUE);
+ dump (1);
exit (1);
}
c = (getc (input));
case '\n':
{
{
- register char * scan_buffer;
+ char * scan_buffer;
scan_buffer = (& (compare_buffer [0]));
- while (TRUE)
+ while (1)
{
c = (getc (input));
if (c == EOF)
}
}
{
- register char **scan_tokens;
+ char **scan_tokens;
for (scan_tokens = (& (token_array [0]));
((* scan_tokens) != NULL);
/* Output Routines */
void
-DEFUN (dump, (check),
- boolean check)
+dump (bool check)
{
- register int max_index;
- register int count;
+ int max_index;
+ int count;
FIND_INDEX_LENGTH (buffer_index, max_index_length);
max_index = (buffer_index - 1);
fprintf (output, "extern SCHEME_OBJECT\n");
for (count = 0; (count <= max_index); count += 1)
{
-#ifdef ASSUME_ANSIDECL
- fprintf (output, " EXFUN (%s, (void))",
- (((* data_buffer) [count]) . c_name));
-#else
- fprintf (output, " %s ()",
+ fprintf (output, " %s (void)",
(((* data_buffer) [count]) . c_name));
-#endif
if (count == max_index)
fprintf (output, ";\n\n");
else
}
void
-DEFUN (print_procedure, (output, primitive_descriptor, error_string),
- FILE * output AND
- struct descriptor * primitive_descriptor AND
- char * error_string)
+print_procedure (FILE * output,
+ struct descriptor * primitive_descriptor,
+ char * error_string)
{
fprintf (output, "SCHEME_OBJECT\n");
-#ifdef ASSUME_ANSIDECL
- fprintf (output, "DEFUN_VOID (%s)\n",
- (primitive_descriptor -> c_name));
-#else
- fprintf (output, "%s ()\n",
+ fprintf (output, "%s (void)\n",
(primitive_descriptor -> c_name));
-#endif
fprintf (output, "{\n");
fprintf (output, " PRIMITIVE_HEADER (%s);\n",
(primitive_descriptor -> arity));
}
void
-DEFUN (print_primitives, (output, limit),
- FILE * output AND
- register int limit)
+print_primitives (FILE * output, int limit)
{
- register int last;
- register int count;
- register char * table_entry;
+ int last;
+ int count;
+ char * table_entry;
last = (limit - 1);
/* Print the procedure table. */
-#ifdef ASSUME_ANSIDECL
fprintf
(output,
- "\f\nSCHEME_OBJECT EXFUN ((* (%s_Procedure_Table [])), (void)) = {\n",
+ "\f\nSCHEME_OBJECT (* (%s_Procedure_Table [])) (void) = {\n",
the_kind);
-#else
- fprintf (output, "\f\nSCHEME_OBJECT (* (%s_Procedure_Table [])) () = {\n",
- the_kind);
-#endif
for (count = 0; (count < limit); count += 1)
{
print_entry (output, count, (result_buffer [count]));
fprintf (output, "\n};\n");
/* Print the names table. */
- fprintf (output, "\f\nCONST char * %s_Name_Table [] = {\n", the_kind);
+ fprintf (output, "\f\nconst char * %s_Name_Table [] = {\n", the_kind);
for (count = 0; (count < limit); count += 1)
{
fprintf (output, " \"%s\",\n", ((result_buffer [count]) -> scheme_name));
fprintf (output, " \"%s\"\n};\n", inexistent_entry.scheme_name);
/* Print the documentation table. */
- fprintf (output, "\f\nCONST char * %s_Documentation_Table [] = {\n", the_kind);
+ fprintf (output, "\f\nconst char * %s_Documentation_Table [] = {\n", the_kind);
for (count = 0; (count < limit); count += 1)
{
fprintf (output, " ");
}
void
-DEFUN (print_entry, (output, index, primitive_descriptor),
- FILE * output AND
- int index AND
- struct descriptor * primitive_descriptor)
+print_entry (FILE * output,
+ int index,
+ struct descriptor * primitive_descriptor)
{
int index_length;
}
void
-DEFUN (print_spaces, (output, how_many),
- FILE * output AND
- register int how_many)
+print_spaces (FILE * output, int how_many)
{
while ((--how_many) >= 0)
putc (' ', output);
int token_buffer_length;
void
-DEFUN_VOID (initialize_token_buffer)
+initialize_token_buffer (void)
{
token_buffer_length = 80;
token_buffer = (xmalloc (token_buffer_length));
}
void
-DEFUN_VOID (grow_token_buffer)
+grow_token_buffer (void)
{
token_buffer_length *= 2;
token_buffer = (xrealloc (token_buffer, token_buffer_length));
}
#define TOKEN_BUFFER_DECLS() \
- register char * TOKEN_BUFFER_scan; \
- register char * TOKEN_BUFFER_end
+ char * TOKEN_BUFFER_scan; \
+ char * TOKEN_BUFFER_end
#define TOKEN_BUFFER_START() \
{ \
};
void
-DEFUN (copy_token, (target, size, token_type),
- char ** target AND
- int * size AND
- register enum tokentype token_type)
+copy_token (char ** target, int * size, enum tokentype token_type)
{
- register int c;
+ int c;
TOKEN_BUFFER_DECLS ();
TOKEN_BUFFER_START ();
return;
}
-boolean
-DEFUN (whitespace, (c),
- register int c)
+bool
+whitespace (int c)
{
switch (c)
{
case '\r':
case '(':
case ')':
- case ',': return TRUE;
- default: return FALSE;
+ case ',': return 1;
+ default: return 0;
}
}
void
-DEFUN_VOID (scan_to_token_start)
+scan_to_token_start (void)
{
- register int c;
+ int c;
while (whitespace (c = (getc (input)))) ;
ungetc (c, input);
}
void
-DEFUN_VOID (skip_token)
+skip_token (void)
{
- register int c;
+ int c;
while (! (whitespace (c = (getc (input))))) ;
ungetc (c, input);
}
\f
void
-DEFUN_VOID (initialize_data_buffer)
+initialize_data_buffer (void)
{
buffer_length = 0x200;
buffer_index = 0;
}
void
-DEFUN_VOID (grow_data_buffer)
+grow_data_buffer (void)
{
char * old_data_buffer = ((char *) data_buffer);
buffer_length *= 2;
(xrealloc (((char *) data_buffer),
(buffer_length * (sizeof (struct descriptor))))));
{
- register struct descriptor ** scan = result_buffer;
- register struct descriptor ** end = (result_buffer + buffer_index);
- register long offset = (((char *) data_buffer) - old_data_buffer);
+ struct descriptor ** scan = result_buffer;
+ struct descriptor ** end = (result_buffer + buffer_index);
+ long offset = (((char *) data_buffer) - old_data_buffer);
while (scan < end)
{
(*scan) = ((struct descriptor *) (((char*) (*scan)) + offset));
}
\f
void
-DEFUN_VOID (initialize_default)
+initialize_default (void)
{
- built_in_p = FALSE;
+ built_in_p = 0;
(token_array [0]) = (& (default_token [0]));
(token_array [1]) = (& (default_token_alternate [0]));
(token_array [2]) = NULL;
}
void
-DEFUN_VOID (initialize_external)
+initialize_external (void)
{
- built_in_p = FALSE;
+ built_in_p = 0;
(token_array [0]) = (& (external_token [0]));
(token_array [1]) = NULL;
(token_processors [0]) = create_normal_entry;
}
void
-DEFUN (initialize_builtin, (arg),
- char * arg)
+initialize_builtin (char * arg)
{
- register int length;
- register int index;
+ int length;
+ int index;
- built_in_p = TRUE;
+ built_in_p = 1;
length = (read_index (arg, "built_in_table_size"));
while (buffer_length < length)
grow_data_buffer ();
}
void
-DEFUN (update_from_entry, (primitive_descriptor),
- register struct descriptor * primitive_descriptor)
+update_from_entry (struct descriptor * primitive_descriptor)
{
- register int temp;
+ int temp;
temp = (strlen (primitive_descriptor -> scheme_name));
if (max_scheme_name_length < temp)
}
pseudo_void
-DEFUN_VOID (create_normal_entry)
+create_normal_entry (void)
{
MAYBE_GROW_BUFFER ();
COPY_C_NAME ((* data_buffer) [buffer_index]);
}
pseudo_void
-DEFUN_VOID (create_alternate_entry)
+create_alternate_entry (void)
{
MAYBE_GROW_BUFFER ();
COPY_SCHEME_NAME ((* data_buffer) [buffer_index]);
}
pseudo_void
-DEFUN_VOID (create_builtin_entry)
+create_builtin_entry (void)
{
struct descriptor desc;
- register int length;
+ int length;
int index;
char * index_buffer;
length = (index + 1);
if (buffer_length < length)
{
- register int i;
+ int i;
while (buffer_length < length)
grow_data_buffer ();
}
int
-DEFUN (read_index, (arg, identification),
- char * arg AND
- char * identification)
+read_index (char * arg, char * identification)
{
int result = 0;
if (((arg [0]) == '0') && ((arg [1]) == 'x'))
/* Sorting */
void
-DEFUN_VOID (sort)
+sort (void)
{
- register struct descriptor ** temp_buffer;
- register int count;
+ struct descriptor ** temp_buffer;
+ int count;
if (buffer_index <= 0)
return;
}
static void
-DEFUN (fp_mergesort, (low, high, array, temp_array),
- int low AND
- register int high AND
- register struct descriptor ** array AND
- register struct descriptor ** temp_array)
+fp_mergesort (int low,
+ int high,
+ struct descriptor ** array,
+ struct descriptor ** temp_array)
{
- register int index;
- register int low1;
- register int low2;
+ int index;
+ int low1;
+ int low2;
int high1;
int high2;
}
int
-DEFUN (compare_descriptors, (d1, d2),
- struct descriptor * d1 AND
- struct descriptor * d2)
+compare_descriptors (struct descriptor * d1, struct descriptor * d2)
{
int value;
}
int
-DEFUN (strcmp_ci, (s1, s2),
- register char * s1 AND
- register char * s2)
+strcmp_ci (char * s1, char * s2)
{
int length1 = (strlen (s1));
int length2 = (strlen (s2));
- register int length = ((length1 < length2) ? length1 : length2);
+ int length = ((length1 < length2) ? length1 : length2);
while ((length--) > 0)
{
- register int c1 = (*s1++);
- register int c2 = (*s2++);
+ int c1 = (*s1++);
+ int c2 = (*s2++);
if (islower (c1)) c1 = (toupper (c1));
if (islower (c2)) c2 = (toupper (c2));
if (c1 < c2) return (-1);
/* -*-C-*-
-$Id: fixnum.c,v 9.48 2007/01/05 21:19:25 cph Exp $
+$Id: fixnum.c,v 9.49 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
static long
-DEFUN (arg_fixnum, (n), int n)
+arg_fixnum (int n)
{
- fast SCHEME_OBJECT argument = (ARG_REF (n));
+ SCHEME_OBJECT argument = (ARG_REF (n));
if (! (FIXNUM_P (argument)))
error_wrong_type_arg (n);
return (FIXNUM_TO_LONG (argument));
}
static long
-DEFUN (arg_unsigned_fixnum, (n), int n)
+arg_unsigned_fixnum (int n)
{
- fast SCHEME_OBJECT argument = (ARG_REF (n));
+ SCHEME_OBJECT argument = (ARG_REF (n));
if (! (FIXNUM_P (argument)))
error_wrong_type_arg (n);
return (UNSIGNED_FIXNUM_TO_LONG (argument));
#define FIXNUM_RESULT(fixnum) \
{ \
- fast long result = (fixnum); \
+ long result = (fixnum); \
if (! (LONG_TO_FIXNUM_P (result))) \
error_bad_range_arg (1); \
PRIMITIVE_RETURN (LONG_TO_FIXNUM (result)); \
CHECK_ARG (1, FIXNUM_P);
CHECK_ARG (2, FIXNUM_P);
{
- fast long result = (Mul ((ARG_REF (1)), (ARG_REF (2))));
+ long result = (Mul ((ARG_REF (1)), (ARG_REF (2))));
if (result == SHARP_F)
error_bad_range_arg (1);
PRIMITIVE_RETURN (result);
\f
DEFINE_PRIMITIVE ("DIVIDE-FIXNUM", Prim_divide_fixnum, 2, 2, 0)
{
- fast long numerator;
- fast long denominator;
- fast long quotient;
- fast long remainder;
+ long numerator;
+ long denominator;
+ long quotient;
+ long remainder;
PRIMITIVE_HEADER (2);
numerator = (arg_fixnum (1));
denominator = (arg_fixnum (2));
{
PRIMITIVE_HEADER (2);
{
- fast long numerator = (arg_fixnum (1));
- fast long denominator = (arg_fixnum (2));
- fast long quotient =
+ long numerator = (arg_fixnum (1));
+ long denominator = (arg_fixnum (2));
+ long quotient =
((denominator > 0)
? ((numerator < 0)
? (- ((- numerator) / denominator))
{
PRIMITIVE_HEADER (2);
{
- fast long numerator = (arg_fixnum (1));
- fast long denominator = (arg_fixnum (2));
+ long numerator = (arg_fixnum (1));
+ long denominator = (arg_fixnum (2));
PRIMITIVE_RETURN
(LONG_TO_FIXNUM
((denominator > 0)
DEFINE_PRIMITIVE ("GCD-FIXNUM", Prim_gcd_fixnum, 2, 2, 0)
{
- fast long x;
- fast long y;
- fast long z;
+ long x;
+ long y;
+ long z;
PRIMITIVE_HEADER (2);
x = (arg_fixnum (1));
y = (arg_fixnum (2));
#define FIXNUM_BOOLEAN_BODY(operation) \
do \
{ \
- fast unsigned long x, y, z; \
+ unsigned long x, y, z; \
\
PRIMITIVE_HEADER (2); \
\
DEFINE_PRIMITIVE ("FIXNUM-NOT", Prim_fixnum_not, 1, 1, 0)
{
- fast unsigned long x, z;
+ unsigned long x, z;
PRIMITIVE_HEADER (1);
DEFINE_PRIMITIVE ("FIXNUM-LSH", Prim_fixnum_lsh, 2, 2, 0)
{
- fast unsigned long x, z;
- fast long y;
+ unsigned long x, z;
+ long y;
PRIMITIVE_HEADER (2);
/* -*-C-*-
-$Id: fixobj.h,v 9.42 2007/01/05 21:19:25 cph Exp $
+$Id: fixobj.h,v 9.43 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
/* Declarations of user offsets into the Fixed Objects Vector.
- This should correspond to the file "utabmd.scm". */
+ This should correspond to the file "utabmd.scm". */
\f
-#define Non_Object 0x00 /* Used for unassigned variables. */
-#define System_Interrupt_Vector 0x01 /* Handlers for interrupts. */
-#define System_Error_Vector 0x02 /* Handlers for errors. */
-#define OBArray 0x03 /* Array for interning symbols. */
-#define Types_Vector 0x04 /* Type number -> Name map. */
-#define Returns_Vector 0x05 /* Return code -> Name map. */
+#define NON_OBJECT 0x00 /* Used for unassigned variables. */
+#define SYSTEM_INTERRUPT_VECTOR 0x01 /* Handlers for interrupts. */
+#define SYSTEM_ERROR_VECTOR 0x02 /* Handlers for errors. */
+#define OBARRAY 0x03 /* Array for interning symbols. */
+#define TYPES_VECTOR 0x04 /* Type number -> Name map. */
+#define RETURNS_VECTOR 0x05 /* Return code -> Name map. */
/* For each interrupt, an interrupt mask to be set when invoking the
handler for that interrupt. */
#define FIXOBJ_INTERRUPT_MASK_VECTOR 0x06
-#define Errors_Vector 0x07 /* Error code -> Name map. */
-#define Identification_Vector 0x08 /* ID Vector index -> name map. */
+#define ERRORS_VECTOR 0x07 /* Error code -> Name map. */
+#define IDENTIFICATION_VECTOR 0x08 /* ID Vector index -> name map. */
#define FIXOBJ_SYSTEM_CALL_NAMES 0x09 /* System call index -> name */
#define FIXOBJ_SYSTEM_CALL_ERRORS 0x0A /* System call error -> name */
-#define GC_Daemon 0x0B /* Procedure to run after GC. */
-#define Trap_Handler 0x0C /* Abort after disaster. */
+#define GC_DAEMON 0x0B /* Procedure to run after GC. */
+#define TRAP_HANDLER 0x0C /* Abort after disaster. */
#define FIXOBJ_EDWIN_AUTO_SAVE 0x0D /* Files to save if fatal error. */
-#define Stepper_State 0x0E /* UNUSED in CScheme. */
-#define Fixed_Objects_Slots 0x0F /* Names of these slots. */
+#define STEPPER_STATE 0x0E
+#define FIXED_OBJECTS_SLOTS 0x0F /* Names of these slots. */
#define FIXOBJ_FILES_TO_DELETE 0x10 /* Temporary files to delete. */
#define State_Space_Tag 0x11 /* Tag for state spaces. */
#define State_Point_Tag 0x12 /* Tag for state points. */
-#define Dummy_History 0x13 /* Empty history structure. */
+#define DUMMY_HISTORY 0x13 /* Empty history structure. */
#define Bignum_One 0x14 /* Cache for bignum one. */
-#define System_Scheduler 0x15 /* MultiScheme:
- Scheduler for touched futures. */
+/* #define UNUSED 0x15 */
#define Termination_Vector 0x16 /* Names for terminations. */
#define Termination_Proc_Vector 0x17 /* Handlers for terminations. */
-#define Me_Myself 0x18 /* MultiScheme:
- The shared fixed objects vector. */
-#define The_Work_Queue 0x19 /* MultiScheme:
- Where work is stored. */
-#define Future_Logger 0x1A /* MultiScheme: When logging futures,
- routine to log touched futures. */
-#define Touched_Futures 0x1B /* MultiScheme: When logging futures,
- vector of touched futures. */
+/* #define UNUSED 0x18 */
+/* #define UNUSED 0x19 */
+/* #define UNUSED 0x1A */
+/* #define UNUSED 0x1B */
#define Precious_Objects 0x1C /* Objects that should not be lost! */
#define Error_Procedure 0x1D /* User invoked error handler. */
-#define Unsnapped_Link 0x1E /* UNUSED in CScheme. */
-#define Utilities_Vector 0x1F /* UNUSED in CScheme. */
-#define Compiler_Err_Procedure 0x20 /* User invoked error handler
- from compiled code. */
+/* #define UNUSED 0x1E */
+/* #define UNUSED 0x1F */
+#define CC_ERROR_PROCEDURE 0x20 /* Error handler for compiled code. */
#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */
#define State_Space_Root 0x22 /* Root of state space. */
#define Primitive_Profiling_Table 0x23 /* Table of profile counts for
primitives. */
/* Trampolines for various generic arithmetic operations.
- These facilitate upwards compatibility and simplify compilation.
- */
+ These facilitate upwards compatibility and simplify compilation. */
#define GENERIC_TRAMPOLINE_ZERO_P 0x24
#define GENERIC_TRAMPOLINE_POSITIVE_P 0x25
#define PC_Sample_Prob_Comp_Table 0x3D /* Sure looked compiled ?! */
#define PC_Sample_UFO_Table 0x3E /* Invalid ENV at sample time */
-#define COMPILED_CODE_BKPT_HANDLER 0x3F /* Procedure to invoke when
+#define CC_BKPT_PROCEDURE 0x3F /* Procedure to invoke when
compiled code hits a
- breakpoint.
- */
-
-#define GC_WABBIT_DESCRIPTOR 0x40 /* #F or a vector of 4 elements:
- - A boolean flag
- - A vector of objects to find
- - A vector to fill with
- references.
- - A boolean flag = do you want
- a vector of all obj heads
- returned in this slot. If so,
- slot 0 will be a boolean flag
- indicating if there may be more.
- */
-
-#define NFixed_Objects 0x41
+ breakpoint. */
+/* #F or a vector of 4 elements:
+ - A boolean flag
+ - A vector of objects to find
+ - A vector to fill with references
+ - A boolean flag = do you want a vector of all obj heads returned
+ in this slot. If so, slot 0 will be a boolean flag indicating if
+ there may be more. */
+
+#define GC_WABBIT_DESCRIPTOR 0x40
+
+/* 4 extra slots for expansion and debugging. */
+#define N_FIXED_OBJECTS 0x45
/* -*-C-*-
-$Id: flonum.c,v 9.47 2007/01/05 21:19:25 cph Exp $
+$Id: flonum.c,v 9.48 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
-#include "zones.h"
#include <errno.h>
double
-DEFUN (arg_flonum, (arg_number), int arg_number)
+arg_flonum (int arg_number)
{
SCHEME_OBJECT argument = (ARG_REF (arg_number));
if (! (FLONUM_P (argument)))
#define BOOLEAN_RESULT(x) PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (x))
SCHEME_OBJECT
-DEFUN (double_to_flonum, (value), double value)
+double_to_flonum (double value)
{
ALIGN_FLOAT (Free);
Primitive_GC_If_Needed (FLONUM_SIZE + 1);
#define FLONUM_BINARY_OPERATION(operator) \
{ \
PRIMITIVE_HEADER (2); \
- Set_Time_Zone (Zone_Math); \
FLONUM_RESULT ((arg_flonum (1)) operator (arg_flonum (2))); \
}
DEFINE_PRIMITIVE ("FLONUM-DIVIDE", Prim_flonum_divide, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
- Set_Time_Zone (Zone_Math);
{
- fast double denominator = (arg_flonum (2));
+ double denominator = (arg_flonum (2));
if (denominator == 0)
error_bad_range_arg (2);
FLONUM_RESULT ((arg_flonum (1)) / denominator);
DEFINE_PRIMITIVE ("FLONUM-NEGATE", Prim_flonum_negate, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- Set_Time_Zone (Zone_Math);
FLONUM_RESULT (- (arg_flonum (1)));
}
DEFINE_PRIMITIVE ("FLONUM-ABS", Prim_flonum_abs, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- Set_Time_Zone (Zone_Math);
{
- fast double x = (arg_flonum (1));
+ double x = (arg_flonum (1));
FLONUM_RESULT ((x < 0) ? (-x) : x);
}
}
#define FLONUM_BINARY_PREDICATE(operator) \
{ \
PRIMITIVE_HEADER (2); \
- Set_Time_Zone (Zone_Math); \
BOOLEAN_RESULT ((arg_flonum (1)) operator (arg_flonum (2))); \
}
#define FLONUM_UNARY_PREDICATE(operator) \
{ \
PRIMITIVE_HEADER (1); \
- Set_Time_Zone (Zone_Math); \
BOOLEAN_RESULT ((arg_flonum (1)) operator 0); \
}
\f
#define SIMPLE_TRANSCENDENTAL_FUNCTION(function) \
{ \
- extern double EXFUN (function, (double)); \
double result; \
PRIMITIVE_HEADER (1); \
- Set_Time_Zone (Zone_Math); \
errno = 0; \
result = (function (arg_flonum (1))); \
if (errno != 0) \
#define RESTRICTED_TRANSCENDENTAL_FUNCTION(function, restriction) \
{ \
- extern double EXFUN (function, (double)); \
double x; \
double result; \
PRIMITIVE_HEADER (1); \
- Set_Time_Zone (Zone_Math); \
x = (arg_flonum (1)); \
if (! (restriction)) \
error_bad_range_arg (1); \
DEFINE_PRIMITIVE ("FLONUM-ATAN2", Prim_flonum_atan2, 2, 2, 0)
{
- extern double EXFUN (atan2, (double, double));
PRIMITIVE_HEADER (2);
{
- fast double y = (arg_flonum (1));
- fast double x = (arg_flonum (2));
+ double y = (arg_flonum (1));
+ double x = (arg_flonum (2));
if ((x == 0) && (y == 0))
error_bad_range_arg (2);
FLONUM_RESULT (atan2 (y, x));
DEFINE_PRIMITIVE ("FLONUM-EXPT", Prim_flonum_expt, 2, 2, 0)
{
- extern double EXFUN (pow, (double, double));
PRIMITIVE_HEADER (2);
FLONUM_RESULT (pow ((arg_flonum (1)), (arg_flonum (2))));
}
DEFINE_PRIMITIVE ("FLONUM-INTEGER?", Prim_flonum_integer_p, 1, 1, 0)
{
- extern Boolean EXFUN (flonum_integer_p, (SCHEME_OBJECT));
PRIMITIVE_HEADER (1);
CHECK_ARG (1, FLONUM_P);
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (flonum_integer_p (ARG_REF (1))));
#define FLONUM_CONVERSION(converter) \
{ \
PRIMITIVE_HEADER (1); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, FLONUM_P); \
PRIMITIVE_RETURN (converter (ARG_REF (1))); \
}
DEFINE_PRIMITIVE ("FLONUM-TRUNCATE->EXACT", Prim_flonum_truncate_to_exact, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, FLONUM_P);
- PRIMITIVE_RETURN (FLONUM_TO_INTEGER (ARG_REF (1)));
+ PRIMITIVE_RETURN (FLONUM_TO_INTEGER (ARG_REF (1)));
}
#define FLONUM_EXACT_CONVERSION(converter) \
{ \
PRIMITIVE_HEADER (1); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, FLONUM_P); \
PRIMITIVE_RETURN (FLONUM_TO_INTEGER (converter (ARG_REF (1)))); \
}
DEFINE_PRIMITIVE ("FLONUM-NORMALIZE", Prim_flonum_normalize, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, FLONUM_P);
PRIMITIVE_RETURN (flonum_normalize (ARG_REF (1)));
}
DEFINE_PRIMITIVE ("FLONUM-DENORMALIZE", Prim_flonum_denormalize, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, FLONUM_P);
CHECK_ARG (2, INTEGER_P);
PRIMITIVE_RETURN (flonum_denormalize ((ARG_REF (1)), (ARG_REF (2))));
+++ /dev/null
-/* -*-C-*-
-
-$Id: foreign.c,v 1.9 2007/01/12 03:45:55 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains the primitive support for the foreign function */
-/* interface. */
-
-#include <stdio.h>
-#include <dl.h>
-#include "scheme.h"
-#include "prims.h"
-#include "ux.h"
-#include "osfs.h"
-#include "foreign.h"
-
-static int initialization_done = 0;
-
-#define INITIALIZE_ONCE() \
-{ \
- if (!initialization_done) \
- initialize_once (); \
-}
-
-static void EXFUN (initialize_once, (void));
-\f
-/* Allocation table stuff stolen from x11base.c */
-
-PTR
-DEFUN (foreign_malloc, (size), unsigned int size)
-{
- PTR result = (UX_malloc (size));
- if (result == 0)
- error_external_return ();
- return (result);
-}
-
-PTR
-DEFUN (foreign_realloc, (ptr, size), PTR ptr AND unsigned int size)
-{
- PTR result = (UX_realloc (ptr, size));
- if (result == 0)
- error_external_return ();
- return (result);
-}
-\f
-struct allocation_table
-{
- PTR * items;
- int length;
-};
-
-static struct allocation_table foreign_object_table;
-static struct allocation_table foreign_function_table;
-
-static void
-DEFUN (allocation_table_initialize, (table), struct allocation_table * table)
-{
- (table -> length) = 0;
-}
-
-static unsigned int
-DEFUN (allocate_table_index, (table, item),
- struct allocation_table * table AND
- PTR item)
-{
- unsigned int length = (table -> length);
- unsigned int new_length;
- PTR * items = (table -> items);
- PTR * new_items;
- PTR * scan;
- PTR * end;
- if (length == 0)
- {
- new_length = 4;
- new_items = (foreign_malloc ((sizeof (PTR)) * new_length));
- }
- else
- {
- scan = items;
- end = (scan + length);
- while (scan < end)
- if ((*scan++) == 0)
- {
- (*--scan) = item;
- return (scan - items);
- }
- new_length = (length * 2);
- new_items = (foreign_realloc (items, ((sizeof (PTR)) * new_length)));
- }
- scan = (new_items + length);
- end = (new_items + new_length);
- (*scan++) = item;
- while (scan < end)
- (*scan++) = 0;
- (table -> items) = new_items;
- (table -> length) = new_length;
- return (length);
-}
-\f
-static PTR
-DEFUN (allocation_item_arg, (arg, table),
- unsigned int arg AND
- struct allocation_table * table)
-{
- unsigned int index = (arg_index_integer (arg, (table -> length)));
- PTR item = ((table -> items) [index]);
- if (item == 0)
- error_bad_range_arg (arg);
- return (item);
-}
-\f
-/* Helper functions */
-HANDLE
-DEFUN (arg_handle, (arg_number), unsigned int arg_number)
-{
- SCHEME_OBJECT arg;
-
- return (index_to_handle (arg_index_integer (arg_number,
- foreign_object_table . length)));
-}
-
-HANDLE
-DEFUN (foreign_pointer_to_handle, (ptr), PTR ptr)
-{
- unsigned int index;
- HANDLE handle;
- FOREIGN_OBJECT *ptr_object;
-
- INITIALIZE_ONCE ();
- ptr_object = (FOREIGN_OBJECT *) foreign_malloc (sizeof (FOREIGN_OBJECT));
- ptr_object -> ptr = ptr;
- ptr_object -> handle = handle;
- index = allocate_table_index (&foreign_object_table, (PTR) ptr_object);
- handle = index_to_handle (index);
- ((FOREIGN_OBJECT *) ((foreign_object_table . items) [index])) -> handle =
- handle;
- return (handle_to_integer (handle));
-}
-
-PTR
-DEFUN (handle_to_foreign_pointer, (handle), HANDLE handle)
-{
- unsigned int index;
-
- index = handle_to_index (handle);
- if (index >= foreign_object_table . length) {
- error_external_return ();
- }
- return
- (((FOREIGN_OBJECT *) ((foreign_object_table . items) [index])) -> ptr);
-}
-
-int
-DEFUN (find_foreign_function, (func_name), char *func_name)
-{
- int i;
- FOREIGN_FUNCTION *func_item;
-
- for (i=0; i < foreign_function_table . length; i++) {
- func_item = (foreign_function_table . items) [i];
- if (func_item == 0) continue;
- if (! strcmp (func_item -> name, func_name)) {
- return (i);
- }
- }
- return (-1);
-}
-
-unsigned int
-DEFUN (register_foreign_function, (name, applicable_function),
- char * name AND
- PTR applicable_function)
-{
- FOREIGN_FUNCTION *func_item;
- char * name_copy;
-
- INITIALIZE_ONCE ();
- func_item = (FOREIGN_FUNCTION *) foreign_malloc (sizeof (FOREIGN_FUNCTION));
- name_copy = (char *) foreign_malloc (1 + strlen (name));
- strcpy (name_copy, name);
- func_item -> name = name_copy;
- func_item -> applicable_function = applicable_function;
- return (allocate_table_index (&foreign_function_table, (PTR) func_item));
-}
-
-unsigned int
-DEFUN (list_length, (list), SCHEME_OBJECT list)
-{
- unsigned int i;
-
- i = 0;
- TOUCH_IN_PRIMITIVE (list, list);
- while (PAIR_P (list)) {
- i += 1;
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
- }
- return (i);
-}
-
-PTR
-DEFUN (apply_foreign_function, (func, arg_list),
- PTR (*func)() AND
- SCHEME_OBJECT arg_list)
-{
- unsigned int arg_list_length;
- PTR * arg_vec;
- PTR result;
- unsigned int i;
-
- arg_list_length = list_length (arg_list);
- arg_vec = (PTR *) foreign_malloc (arg_list_length);
- for (i = 0; i < arg_list_length; i++, arg_list = PAIR_CDR (arg_list)) {
- arg_vec [i] = handle_to_foreign_pointer (PAIR_CAR (arg_list));
- }
- result = (*func) (arg_vec);
- free (arg_vec);
- return (result);
-}
-
-SCHEME_OBJECT
-DEFUN (foreign_pointer_to_scheme_object, (ptr, type_translator),
- PTR ptr AND
- SCHEME_OBJECT (*type_translator) ())
-{
- return (type_translator (ptr));
-}
-
-/* old version of foreign_pointer_to_scheme_object */
-#if 0
-/* Note that foreign_pointer_to_scheme_object takes a pointer to pointer
- (i.e. a call by reference to a pointer) so that it can increment the
- pointer according to its type. This is used by the code which builds
- the composite objects. */
-
-SCHEME_OBJECT
-DEFUN (foreign_pointer_to_scheme_object, (ptr_to_ptr, type),
- PTR ptr_to_ptr AND
- SCHEME_OBJECT type)
-{
- long type_enum;
-
- if (foreign_primtive_type_p (type)) {
- long long_val;
- double double_val;
- PTR temp_ptr;
- type_enum = integer_to_long (type);
- switch (type_enum) {
- case FOREIGN_INT:
- temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_INT);
- *ptr_to_ptr = (((int *) temp_ptr) + 1);
- long_val = (long) ((int) *temp_ptr);
- case FOREIGN_SHORT:
- temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_SHORT);
- *ptr_to_ptr = (((short *) temp_ptr) + 1);
- long_val = (long) ((short) *temp_ptr);
- case FOREIGN_LONG:
- temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_INT);
- *ptr_to_ptr = (((long *) temp_ptr) + 1);
- long_val = (long) *temp_ptr;
- return (long_to_integer (long_val));
- case FOREIGN_CHAR:
- temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_CHAR);
- *ptr_to_ptr = (((char *) temp_ptr) + 1);
- return (ASCII_TO_CHAR ((char) *temp_ptr));
- case FOREIGN_FLOAT:
- temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_FLOAT);
- *ptr_to_ptr = (((float *) temp_ptr) + 1);
- double_val = (double) ((float) *temp_ptr);
- case FOREIGN_DOUBLE:
- temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_DOUBLE);
- *ptr_to_ptr = (((double *) temp_ptr) + 1);
- double_val = (double) *temp_ptr;
- return (double_to_flonum (double_val));
- case FOREIGN_STRING:
- temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_STRING);
- *ptr_to_ptr = (((unsigned char *) temp_ptr) + 1);
- return (char_pointer_to_string (temp_ptr));
- case FOREIGN_PTR:
- temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_PTR);
- *ptr_to_ptr = (((PTR) temp_ptr) + 1);
- return (long_to_integer ((long) *temp_ptr));
- default:
- error_external_return ();
- }
- } else if (foreign_composite_type_p (type)) {
- /* We should probably tag the result vector. */
- type_enum = integer_to_long (which_composite_type (type));
- switch (type_enum) {
- case FOREIGN_STRUCT:
- case FOREIGN_UNION:
- {
- int num_fields;
- SCHEME_OBJECT field_types;
- SCHEME_OBJECT result_vector;
- unsigned int i;
-
- field_types = composite_type_field_types (type);
- num_fields = list_length (field_types);
- result_vector = allocate_marked_vector (TC_VECTOR, num_fields, true);
- for (i = 0; i < num_fields; ++i) {
- if (!(PAIR_P (field_types))) {
- error_external_return ();
- }
- FAST_VECTOR_SET (result_vector,
- i,
- foreign_pointer_to_scheme_object (
- ptr_to_ptr, PAIR_CAR (field_types)));
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (field_types)), field_types);
- }
- return (result_vector);
- }
- default:
- error_external_return ();
- }
- } else {
- error_external_return ();
- }
-}
-#endif /* if 0 */
-
-static void
-DEFUN_VOID (initialize_once)
-{
- allocation_table_initialize (&foreign_object_table);
- allocation_table_initialize (&foreign_function_table);
-
- initialization_done = 1;
-}
-\f
-/* Functions to go in osxx.c */
-
-#include <dl.h>
-
-char *
-DEFUN_VOID (OS_create_temporary_file_name)
-{
- char * name_string;
-
- name_string = (char *) foreign_malloc (1 + TEMP_FILE_NAME_MAX_LEN);
- (void) UX_tmpnam (name_string);
- return (name_string);
-}
-
-#ifdef HAVE_DYNAMIC_LOADING
-#ifdef __HPUX__
-#include <dl.h>
-
-LOAD_INFO *
-DEFUN (OS_load_object_file, (load_file_name), char * load_file_name)
-{
- shl_t shl_handle;
- int result;
- struct shl_descriptor *shl_desc;
- LOAD_INFO *info;
-
- shl_handle = shl_load (load_file_name, BIND_DEFERRED, 0L);
-
- if (shl_handle == NULL) {
- error_external_return ();
- }
-
- result = shl_gethandle (shl_handle, &shl_desc);
-
- if (result == -1) {
- error_external_return ();
- }
-
- info = foreign_malloc (sizeof (LOAD_INFO));
- info -> load_module_descriptor = shl_handle;
- info -> program_start = shl_desc -> tstart;
- info -> program_end = shl_desc -> tend;
- info -> data_start = shl_desc -> dstart;
- info -> data_end = shl_desc -> dend;
- return (info);
-}
-
-PTR
-DEFUN (OS_find_function, (load_info, func_name),
- LOAD_INFO * load_info AND
- char * func_name)
-{
- int return_code;
- PTR (* test_proc)();
- LOAD_DESCRIPTOR desc;
-
- desc = (load_info -> load_module_descriptor);
- return_code = shl_findsym (&desc ,
- func_name,
- TYPE_PROCEDURE,
- (long *) &test_proc);
-
- return ((return_code == 0) ?
- test_proc :
- NULL);
-}
-
-#endif /* __HPUX__ */
-#endif /* HAVE_DYNAMIC_LOADING */
-\f
-/* Definitions of primitives */
-
-DEFINE_PRIMITIVE ("CALL-FOREIGN-FUNCTION",
- Prim_call_foreign_function, 2, 2,
-"Calls the foreign function referenced by HANDLE with the ARG-LIST \n\
-arguments. \n\
-Returns a handle to the return value; \n\
-The foreign function should have been created by \n\
-CREATE_PRIMITIVE_FOREIGN_FUNCTION. \n\
-The elements of the ARG-LIST must be handles to foreign objects. \n\
-Type and arity checking on the arguments should already have been done.")
-{
- PRIMITIVE_HEADER (2);
- {
- SCHEME_OBJECT arg_list;
- PTR result;
-
- CHECK_ARG (2, APPARENT_LIST_P);
- arg_list = ARG_REF (2);
- result = apply_foreign_function (handle_to_foreign_pointer
- (arg_handle (1)), arg_list);
- PRIMITIVE_RETURN (foreign_pointer_to_handle (result));
- }
-}
-
-DEFINE_PRIMITIVE ("&CALL-FOREIGN-FUNCTION-RETURNING-SCHEME-OBJECT",
- Prim_call_foreign_function_returning_scheme_object, 2, 2,
-"Calls the foreign function referenced by HANDLE with the ARG-LIST \n\
-arguments. \n\
-Returns the result of the foreign function (which better be a scheme \n\
-object. \n\
-The foreign function should have been created by \n\
-CREATE_PRIMITIVE_FOREIGN_FUNCTION. \n\
-The elements of the ARG-LIST must be handles to foreign objects. \n\
-Type and arity checking on the arguments should already have been done.")
-{
- PRIMITIVE_HEADER (2);
- {
- SCHEME_OBJECT arg_list;
- PTR result;
-
- CHECK_ARG (2, APPARENT_LIST_P);
- arg_list = ARG_REF (2);
- result = apply_foreign_function (handle_to_foreign_pointer
- (arg_handle (1)), arg_list);
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("FOREIGN-HANDLE-TO-SCHEME-OBJECT",
- Prim_foreign_handle_to_scheme_object, 2, 2,
-"Returns the Scheme object corresponding to the foreign HANDLE \n\
-interpreted as the foreign type TYPE. \n\
-A type is either an integer which enumerates the various foreign types \n\
-(i.e. FOREIGN_INT, FOREIGN_CHAR, FOREIGN_SHORT, FOREIGN_LONG, \n\
-(FOREIGN_PTR, FOREIGN_DOUBLE, FOREIGN_STRING) or a list whose car is \n\
-an integer representing FOREIGN_STRUCT or FOREIGN_UNION and whose cdr \n\
-is a list of types.")
-{
- PRIMITIVE_HEADER (2);
- {
- SCHEME_OBJECT arg2;
- PTR arg1_ptr;
-
- arg1_ptr = handle_to_foreign_pointer (arg_handle (1));
- arg2 = ARG_REF (2);
- if (! (INTEGER_P (arg2) || PAIR_P (arg2))) {
- error_wrong_type_arg (2);
- }
- PRIMITIVE_RETURN (foreign_pointer_to_scheme_object (&arg1_ptr, arg2));
- }
-}
-
-DEFINE_PRIMITIVE (LOAD-FOREIGN-FILE, Prim_load_foreign_file, 1, 1,
-"Load the foreign object file FILENAME. \n\
-Returns a handle to a LOAD_INFO data structure.")
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (foreign_pointer_to_handle
- (OS_load_object_file (STRING_ARG (1))));
-}
-
-DEFINE_PRIMITIVE (CREATE-TEMPORARY-FILE-NAME, Prim_get_temporary_file_name,
- 0, 0,
-"Return a temporary file name.")
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (char_pointer_to_string (OS_create_temporary_file_name ()));
-}
-
-DEFINE_PRIMITIVE (FIND-FOREIGN-FUNCTION, Prim_find_foreign_function, 2, 2,
-"Returns a handle to a foreign function. \n\
-Takes the FUNCTION_NAME as a string and LOAD_INFO \n\
-which is a handle to a load_info structure returned by LOAD-FOREIGN-FILE. \n\
-If LOAD_INFO is not #F then we search for FUNCTION_NAME in the code which \n\
-was loaded to yield LOAD_INFO. \n\
-If LOAD_INFO is #F then we search over all the dynamically loaded files.")
-{
- PRIMITIVE_HEADER (2);
- {
- PTR func_ptr;
- LOAD_INFO * load_info;
-
- load_info = ((EMPTY_LIST_P (ARG_REF (2))) ?
- ((LOAD_INFO *) NULL) :
- ((LOAD_INFO *) handle_to_foreign_pointer (arg_handle (2))));
-
- func_ptr = OS_find_function (load_info, STRING_ARG (1));
-
- PRIMITIVE_RETURN ((func_ptr == NULL) ?
- SHARP_F :
- foreign_pointer_to_handle (func_ptr));
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: foreign.h,v 1.7 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains the primitive support for the foreign function */
-/* interface. */
-
-struct foreign_function {
- char * name;
- PTR applicable_function;
-};
-
-typedef unsigned int HANDLE;
-
-typedef struct foreign_function FOREIGN_FUNCTION;
-
-struct foreign_object {
- PTR ptr;
- HANDLE handle;
-};
-
-typedef struct foreign_object FOREIGN_OBJECT;
-
-#ifdef __HPUX__
-typedef shl_t LOAD_DESCRIPTOR;
-typedef unsigned long LOAD_ADDRESS;
-#endif
-
-struct load_info {
- LOAD_DESCRIPTOR load_module_descriptor;
- LOAD_ADDRESS program_start;
- LOAD_ADDRESS program_end;
- LOAD_ADDRESS data_start;
- LOAD_ADDRESS data_end;
-};
-
-typedef struct load_info LOAD_INFO;
-
-#define index_to_handle(index) ((HANDLE) index)
-#define handle_to_index(handle) ((unsigned int) handle)
-#define handle_to_integer(handle) (long_to_integer ((unsigned long) handle))
-#define foreign_primtive_type_p(object) (FIXNUM_P (object))
-#define foreign_composite_type_p(object) (PAIR_P (object))
-#define which_composite_type(type) (PAIR_CAR (type))
-#define composite_type_field_types(type) (PAIR_CDR (type))
-
-/* the following define should be in some other .h file */
-#define TEMP_FILE_NAME_MAX_LEN L_tmpnam /* in stdio.h */
-
-/* The following should be ifdef'ed up the wazoo for different machines */
-#define DYNAMIC_COMPILE_SWITCHES "+z"
-
-/* These need to match the appropriate enumerations in foreign.scm */
-#define FOREIGN_FIRST_TYPE 0
-#define FOREIGN_INT 0
-#define FOREIGN_SHORT 1
-#define FOREIGN_LONG 2
-#define FOREIGN_CHAR 3
-#define FOREIGN_FLOAT 4
-#define FOREIGN_DOUBLE 5
-#define FOREIGN_STRING 6
-#define FOREIGN_PTR 7
-#define FOREIGN_STRUCT 8
-#define FOREIGN_UNION 9
-#define FOREIGN_LAST_TYPE 9
-
-/* This is a bunch of stuff to figure out the alignment of fields in
- structures */
-
-/* This defines a union which is guaranteed to have the most restrictive
- possible alignment constraint */
-union greatest_alignment {
- int my_int;
- short my_short;
- long my_long;
- char my_char;
- float my_float;
- double my_double;
- char * my_string;
- void * my_ptr;
-}
-
-/* We hope that char's are the smallest sized objects */
-typedef char smallest_size;
-
-struct int_field {
- union greatest_alignment foo;
- smallest_size bar;
- int int_item;
-}
-#define INT_ALIGNMENT_MASK \
- ((long) ((sizeof (int_field) - sizeof (int)) - 1))
-
-struct short_field {
- union greatest_alignment foo;
- smallest_size bar;
- short short_item;
-}
-#define SHORT_ALIGNMENT_MASK \
- ((long) ((sizeof (short_field) - sizeof (short)) - 1))
-
-struct long_field {
- union greatest_alignment foo;
- smallest_size bar;
- long long_item;
-}
-#define LONG_ALIGNMENT_MASK \
- ((long) ((sizeof (long_field) - sizeof (long)) - 1))
-
-struct char_field {
- union greatest_alignment foo;
- smallest_size bar;
- char char_item;
-}
-#define CHAR_ALIGNMENT_MASK \
- ((long) ((sizeof (char_field) - sizeof (char)) - 1))
-
-struct float_field {
- union greatest_alignment foo;
- smallest_size bar;
- float float_item;
-}
-#define FLOAT_ALIGNMENT_MASK \
- ((long) ((sizeof (float_field) - sizeof (float)) - 1))
-
-struct double_field {
- union greatest_alignment foo;
- smallest_size bar;
- double double_item;
-}
-#define DOUBLE_ALIGNMENT_MASK \
- ((long) ((sizeof (double_field) - sizeof (double)) - 1))
-
-struct string_field {
- union greatest_alignment foo;
- smallest_size bar;
- char * string_item;
-}
-#define STRING_ALIGNMENT_MASK \
- ((long) ((sizeof (string_field) - sizeof (char *)) - 1))
-
-struct ptr_field {
- union greatest_alignment foo;
- smallest_size bar;
- PTR ptr_item;
-}
-#define PTR_ALIGNMENT_MASK \
- ((long) ((sizeof (ptr_field) - sizeof (PTR)) - 1))
-
-struct struct_field {
- union greatest_alignment foo;
- smallest_size bar;
- struct greatest_alignment2 struct_item;
-}
-
-#define ALIGN_FOREIGN_POINTER(ptr,type) \
-# if (type == FOREIGN_INT) \
- (((int *) (ptr & INT_ALIGNMENT_MASK)) + 1) \
-# else \
-# if (type == FOREIGN_SHORT) \
- (((short *) (ptr & SHORT_ALIGNMENT_MASK)) + 1) \
-# else \
-# if (type == FOREIGN_LONG) \
- (((long *) (ptr & LONG_ALIGNMENT_MASK)) + 1) \
-# else \
-# if (type == FOREIGN_CHAR) \
- (((char *) (ptr & CHAR_ALIGNMENT_MASK)) + 1) \
-# else \
-# if (type == FOREIGN_FLOAT) \
- (((float *) (ptr & FLOAT_ALIGNMENT_MASK)) + 1) \
-# else \
-# if (type == FOREIGN_DOUBLE) \
- (((double *) (ptr & DOUBLE_ALIGNMENT_MASK)) + 1) \
-# else \
-# if (type == FOREIGN_STRING) \
- (((unsigned char *) (ptr & STRING_ALIGNMENT_MASK)) + 1) \
-# else \
-# if (type == FOREIGN_PTR) \
- (((PTR) (ptr & PTR_ALIGNMENT_MASK)) + 1) \
-# endif \
-# endif \
-# endif \
-# endif \
-# endif \
-# endif \
-# endif \
-# endif
-
-
-/* End of alignment junk */
+++ /dev/null
-/* -*-C-*-
-
-$Id: future.c,v 9.33 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Support code for futures */
-
-#include "scheme.h"
-#include "prims.h"
-#include "locks.h"
-\f
-#ifndef COMPILE_FUTURES
-#include "Error: future.c is useless without COMPILE_FUTURES"
-#endif
-
-/* This is how we support future numbering for external metering */
-#ifndef New_Future_Number
-#define New_Future_Number() SHARP_F
-#else
-SCHEME_OBJECT Get_New_Future_Number ();
-#endif
-
-/*
-
-A future is a VECTOR starting with <determined?>, <locked?> and
-<waiting queue / value>,
-
-where <determined?> is #!false if no value is known yet,
- #!true if value is known and future can vanish at GC,
- otherwise value is known, but keep the slot
-
-and where <locked> is #!true if someone wants slot kept for a time.
-
-*/
-
-DEFINE_PRIMITIVE ("TOUCH", Prim_touch, 1, 1, 0)
-{
- SCHEME_OBJECT result;
- PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), result);
- PRIMITIVE_RETURN (result);
-}
-
-DEFINE_PRIMITIVE ("FUTURE?", Prim_future_p, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (FUTURE_P (ARG_REF (1))));
-}
-\f
-/* Utility setting routine for use by the various test and set if
- equal operators.
-*/
-
-long
-Set_If_Equal(Base, Offset, New, Wanted)
- SCHEME_OBJECT Base, Wanted, New;
- long Offset;
-{
- Lock_Handle lock;
- SCHEME_OBJECT Old_Value, Desired, Remember_Value;
- long success;
-
- TOUCH_IN_PRIMITIVE(Wanted, Desired);
-Try_Again:
- Remember_Value = MEMORY_REF (Base, Offset);
- TOUCH_IN_PRIMITIVE(Remember_Value, Old_Value);
- lock = Lock_Cell(MEMORY_LOC (Base, Offset));
- if (Remember_Value != FAST_MEMORY_REF (Base, Offset))
- {
- Unlock_Cell(lock);
- goto Try_Again;
- }
- if (Old_Value == Desired)
- {
- Do_Store_No_Lock(MEMORY_LOC (Base, Offset), New);
- success = true;
- }
- else
- {
- success = false;
- }
- Unlock_Cell(lock);
- return success;
-}
-\f
-DEFINE_PRIMITIVE ("SET-CAR-IF-EQ?!", Prim_set_car_if_eq, 3, 3,
- "Replace the car of PAIR with NEW-VALUE iff it contains OLD-VALUE.\n\
-Return PAIR if so, otherwise return '().")
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, PAIR_P);
- {
- fast SCHEME_OBJECT pair = (ARG_REF (1));
- if (Set_If_Equal (pair, CONS_CAR, (ARG_REF (2)), (ARG_REF (3))))
- PRIMITIVE_RETURN (pair);
- }
- PRIMITIVE_RETURN (EMPTY_LIST);
-}
-
-DEFINE_PRIMITIVE ("SET-CDR-IF-EQ?!", Prim_set_cdr_if_eq, 3, 3,
- "Replace the cdr of PAIR with NEW-VALUE iff it contains OLD-VALUE.\n\
-Return PAIR if so, otherwise return '().")
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, PAIR_P);
- {
- fast SCHEME_OBJECT pair = (ARG_REF (1));
- if (Set_If_Equal (pair, CONS_CDR, (ARG_REF (2)), (ARG_REF (3))))
- PRIMITIVE_RETURN (pair);
- }
- PRIMITIVE_RETURN (EMPTY_LIST);
-}
-
-/* (VECTOR-SET-IF-EQ?! <Vector> <Offset> <New Value> <Old Value>)
- Replaces the <Offset>th element of <Vector> with <New Value> if it used
- to contain <Old Value>. The value returned is either <Vector> (if
- the modification takes place) or '() if it does not.
-*/
-DEFINE_PRIMITIVE ("VECTOR-SET-IF-EQ?!", Prim_vector_set_if_eq, 4, 4,
- "Replace VECTOR's INDEX'th element with NEW-VALUE iff it contains OLD-VALUE.\n\
-Return VECTOR if so, otherwise return '().")
-{
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, VECTOR_P);
- {
- fast SCHEME_OBJECT vector = (ARG_REF (1));
- if (Set_If_Equal
- (vector,
- ((arg_index_integer (2, (VECTOR_LENGTH (vector)))) + 1),
- (ARG_REF (3)),
- (ARG_REF (4))))
- PRIMITIVE_RETURN (vector);
- }
- PRIMITIVE_RETURN (EMPTY_LIST);
-}
-
-DEFINE_PRIMITIVE ("SET-CXR-IF-EQ?!", Prim_set_cxr_if_eq, 4, 4,
- "Replace HUNK3's INDEX'th element with NEW-VALUE iff it contains OLD-VALUE.\n\
-Return HUNK3 if so, otherwise return '().")
-{
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, HUNK3_P);
- {
- fast SCHEME_OBJECT hunk3 = (ARG_REF (1));
- if (Set_If_Equal
- (hunk3,
- ((arg_index_integer (2, 3)) + 1),
- (ARG_REF (3)),
- (ARG_REF (4))))
- PRIMITIVE_RETURN (hunk3);
- }
- PRIMITIVE_RETURN (EMPTY_LIST);
-}
-\f
-DEFINE_PRIMITIVE ("FUTURE-SIZE", Prim_future_size, 1, 1,
- "Return the number of elements in FUTURE.\n\
-This is similar to SYSTEM-VECTOR-SIZE,\n\
-but works only on futures and doesn't touch them.")
-{
- PRIMITIVE_HEADER (1)
- CHECK_ARG (1, FUTURE_P);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (VECTOR_LENGTH (ARG_REF (1))));
-}
-
-DEFINE_PRIMITIVE ("FUTURE-REF", Prim_future_ref, 2, 2,
- "Return FUTURE's INDEX'th element.\n\
-This is similar to SYSTEM-VECTOR-REF,\n\
-but works only on futures and doesn't touch them.")
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, FUTURE_P);
- {
- fast SCHEME_OBJECT future = (ARG_REF (1));
- PRIMITIVE_RETURN
- (VECTOR_REF
- (future, (arg_index_integer (2, (VECTOR_LENGTH (future))))));
- }
-}
-
-DEFINE_PRIMITIVE ("FUTURE-SET!", Prim_future_set, 3, 3,
- "Modify FUTURE's INDEX'th element to be VALUE.\n\
-This is similar to SYSTEM-VECTOR-SET!,\n\
-but works only on futures and doesn't touch them.")
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, FUTURE_P);
- {
- fast SCHEME_OBJECT future = (ARG_REF (1));
- fast long index = (arg_index_integer (2, (VECTOR_LENGTH (future))));
- fast SCHEME_OBJECT result = (VECTOR_REF (future, index));
- VECTOR_SET (future, index, (ARG_REF (3)));
- PRIMITIVE_RETURN (result);
- }
-}
-\f
-DEFINE_PRIMITIVE ("LOCK-FUTURE!", Prim_lock_future, 1, 1,
- "Set the lock flag on FUTURE.\n\
-This flag prevents FUTURE from being spliced out by the garbage collector.\n\
-If FUTURE is not a future, return #F immediately,\n\
-otherwise return #T after the lock has been set.\n\
-Will wait as long as necessary for the lock to be set.")
-{
- PRIMITIVE_HEADER (1);
- {
- fast SCHEME_OBJECT future = (ARG_REF (1));
- if (! (FUTURE_P (future)))
- PRIMITIVE_RETURN (SHARP_F);
- while (1)
- {
- if (INTERRUPT_PENDING_P (INT_Mask))
- signal_interrupt_from_primitive ();
- {
- fast SCHEME_OBJECT lock;
- SWAP_POINTERS ((MEMORY_LOC (future, FUTURE_LOCK)), SHARP_T, lock);
- if (lock == SHARP_F)
- PRIMITIVE_RETURN (SHARP_T);
- }
- Sleep (CONTENTION_DELAY);
- }
- }
-}
-
-DEFINE_PRIMITIVE ("UNLOCK-FUTURE!", Prim_unlock_future, 1, 1,
- "Clear the lock flag on FUTURE.\n\
-If FUTURE is not a future, return #F immediately,\n\
-otherwise return #T after the lock has been cleared.")
-{
- PRIMITIVE_HEADER (1);
- {
- fast SCHEME_OBJECT future = (ARG_REF (1));
- if (! (FUTURE_P (future)))
- PRIMITIVE_RETURN (SHARP_F);
- if (! (Future_Is_Locked (future)))
- error_wrong_type_arg (1);
- MEMORY_SET (future, FUTURE_LOCK, SHARP_F);
- PRIMITIVE_RETURN (SHARP_T);
- }
-}
-
-DEFINE_PRIMITIVE ("FUTURE->VECTOR", Prim_future_to_vector, 1, 1,
- "Return a newly-allocated vector containing FUTURE's elements.
-If FUTURE is not a future, return #F instead.")
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT future = (ARG_REF (1));
- if (! (FUTURE_P (future)))
- PRIMITIVE_RETURN (SHARP_F);
- {
- long length = (VECTOR_LENGTH (future));
- fast SCHEME_OBJECT * scan_source = (MEMORY_LOC (future, 1));
- fast SCHEME_OBJECT * end_source = (scan_source + length);
- SCHEME_OBJECT result =
- (allocate_marked_vector (TC_VECTOR, length, true));
- fast SCHEME_OBJECT * scan_result = (MEMORY_LOC (result, 1));
- while (scan_source < end_source)
- (*scan_result++) = (MEMORY_FETCH (*scan_source++));
- PRIMITIVE_RETURN (result);
- }
- }
-}
-
-DEFINE_PRIMITIVE ("NON-TOUCHING-EQ?", Prim_future_eq, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((ARG_REF (1)) == (ARG_REF (2))));
-}
-\f
-/* MAKE-INITIAL-PROCESS is called to create a small stacklet which
- * will just call the specified thunk and then end the computation
- */
-
-DEFINE_PRIMITIVE ("MAKE-INITIAL-PROCESS", Prim_make_initial_process, 1, 1, 0)
-{
- SCHEME_OBJECT Result;
- long Useful_Length;
- PRIMITIVE_HEADER (1);
-
- Result = MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Free);
- Useful_Length = (3 * CONTINUATION_SIZE) + STACK_ENV_EXTRA_SLOTS + 1;
-
-#ifdef USE_STACKLETS
-
- {
- long Allocated_Length, Waste_Length;
-
- Allocated_Length = (Useful_Length + STACKLET_SLACK + STACKLET_HEADER_SIZE);
- if (Allocated_Length < Default_Stacklet_Size)
- {
- Allocated_Length = Default_Stacklet_Size;
- Waste_Length = ((Allocated_Length + 1) -
- (Useful_Length + STACKLET_HEADER_SIZE));
- }
- else
- {
- Waste_Length = (STACKLET_SLACK + 1);
- }
- Primitive_GC_If_Needed(Allocated_Length + 1);
- Free[STACKLET_LENGTH] =
- MAKE_POINTER_OBJECT (TC_MANIFEST_VECTOR, Allocated_Length);
- Free[STACKLET_REUSE_FLAG] = SHARP_T;
- Free[STACKLET_UNUSED_LENGTH] =
- MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Waste_Length);
- Free += (Allocated_Length + 1) - Useful_Length;
- }
-
-#else /* not USE_STACKLETS */
-
- Free[STACKLET_LENGTH] =
- MAKE_OBJECT (TC_MANIFEST_VECTOR, Useful_Length + STACKLET_HEADER_SIZE - 1);
- Free[STACKLET_REUSE_FLAG] = SHARP_F;
- Free[STACKLET_UNUSED_LENGTH] = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0);
- Free += STACKLET_HEADER_SIZE;
-
-#endif /* USE_STACKLETS */
-
- Free[CONTINUATION_EXPRESSION] = LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK());
- Free[CONTINUATION_RETURN_CODE] =
- MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_INT_MASK);
- Free += CONTINUATION_SIZE;
- Free[CONTINUATION_EXPRESSION] = SHARP_F;
- Free[CONTINUATION_RETURN_CODE] =
- MAKE_OBJECT (TC_RETURN_CODE, RC_INTERNAL_APPLY);
- Free += CONTINUATION_SIZE;
- *Free++ = STACK_FRAME_HEADER;
- *Free++ = (ARG_REF (1));
- Free[CONTINUATION_EXPRESSION] = (ARG_REF (1)); /* For testing & debugging */
- Free[CONTINUATION_RETURN_CODE] =
- MAKE_OBJECT (TC_RETURN_CODE, RC_END_OF_COMPUTATION);
- Free += CONTINUATION_SIZE;
- PRIMITIVE_RETURN (Result);
-}
-\f
-/*
- Absolutely the cheapest future we can make. This includes
- the I/O stuff and whatnot. Notice that the name is required.
-
- (make-cheap-future orig-code user-proc name)
-
-*/
-
-DEFINE_PRIMITIVE ("MAKE-CHEAP-FUTURE", Prim_make_cheap_future, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- fast SCHEME_OBJECT future = (allocate_marked_vector (TC_FUTURE, 10, true));
- FAST_MEMORY_SET (future, FUTURE_IS_DETERMINED, SHARP_F);
- FAST_MEMORY_SET (future, FUTURE_LOCK, SHARP_F);
- FAST_MEMORY_SET (future, FUTURE_QUEUE, (cons (EMPTY_LIST, EMPTY_LIST)));
- FAST_MEMORY_SET (future, FUTURE_PROCESS, (ARG_REF (1)));
- FAST_MEMORY_SET (future, FUTURE_STATUS, SHARP_T);
- FAST_MEMORY_SET (future, FUTURE_ORIG_CODE, (ARG_REF (2)));
- /* Put the I/O system stuff here. */
- FAST_MEMORY_SET
- (future,
- FUTURE_PRIVATE,
- (make_vector
- (1,
- (hunk3_cons
- (SHARP_F,
- (ARG_REF (3)),
- (cons ((LONG_TO_UNSIGNED_FIXNUM (0)),
- (char_pointer_to_string ("")))))),
- true)));
- FAST_MEMORY_SET (future, FUTURE_WAITING_ON, EMPTY_LIST);
- FAST_MEMORY_SET (future, FUTURE_METERING, (New_Future_Number ()));
- FAST_MEMORY_SET (future, FUTURE_USER, SHARP_F);
- PRIMITIVE_RETURN (future);
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: futures.h,v 9.34 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains macros useful for dealing with futures */
-\f
-/* NOTES ON FUTURES, derived from the rest of the interpreter code
-
- ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive
- combinations unless the primitive itself is output in the code stream.
- Therefore, we don't have to explicitly check here that the expression
- register has a primitive in it.
-
- ASSUMPTION: The SYMBOL slot of a VARIABLE does NOT contain a future, nor
- do the cached lexical address slots.
-
- ASSUMPTION: Environment structure, which is created only by the
- interpreter, never contains FUTUREs on its spine.
-
- ASSUMPTION: History objects are never created using futures.
-
- ASSUMPTION: State points, which are created only by the interpreter,
- never contain FUTUREs except possibly as the thunks (which are handled
- by the apply code).
-
- OPTIMIZATIONS (?):
- After a lot of discussion, we decided that variable reference will check
- whether a value stored in the environment is a determined future which
- is marked spliceable. If so, it will splice out the future from the
- environment slot to speed up subsequent references.
-
- EQ? does a normal identity check and only if this fails does it touch the
- arguments. The same thing does not speed up MEMQ or ASSQ in the normal
- case, so it is omitted there.
-
- The following are NOT done, but might be useful later
- (1) Splicing on SET! operations
- (2) Splicing at apply and/or primitive apply
- (3) Splicing all arguments when a primitive errors on any of them
- (4) Splicing within the Arg_n_Type macro rather than after longjmping
- to the error handler.
-
- KNOWN PROBLEMS:
- (1) Garbage collector should be modified to splice out futures. DONE.
-
- (2) Purify should be looked at and we should decide what to do about
- purifying an object with a reference to a future (it should probably
- become constant but not pure).
-
- (3) Look at Impurify and Side-Effect-Impurify to see if futures
- affect them in any way. */
-\f
-/* Data structure definition */
-
-/* The IS_DETERMINED slot has one of the following type of values:
- #F if the value is not yet known;
- #T if the value is known and the garbage collector is free
- to remove the future object in favor of its value everywhere;
- else the value is known, but the GC must leave the future object. */
-
-#define FUTURE_VECTOR_HEADER 0
-#define FUTURE_IS_DETERMINED 1
-#define FUTURE_LOCK 2
-#define FUTURE_VALUE 3 /* if known, else */
-#define FUTURE_QUEUE 3 /* tasks waiting for value */
-#define FUTURE_PROCESS 4
-#define FUTURE_STATUS 5
-#define FUTURE_ORIG_CODE 6
-#define FUTURE_PRIVATE 7
-#define FUTURE_WAITING_ON 8
-#define FUTURE_METERING 9
-#define FUTURE_USER 10
-
-#define Future_Is_Locked(P) \
- ((MEMORY_REF ((P), FUTURE_LOCK)) != SHARP_F)
-
-#define Future_Has_Value(P) \
- ((MEMORY_REF ((P), FUTURE_IS_DETERMINED)) != SHARP_F)
-
-#define Future_Value(P) \
- (MEMORY_REF ((P), FUTURE_VALUE))
-
-#define Future_Spliceable(P) \
- (((MEMORY_REF ((P), FUTURE_IS_DETERMINED)) == SHARP_T) && \
- ((MEMORY_REF ((P), FUTURE_LOCK)) == SHARP_F))
-
-#define Future_Is_Keep_Slot(P) \
- (! (BOOLEAN_P (MEMORY_REF ((P), FUTURE_IS_DETERMINED))))
-
-#ifndef COMPILE_FUTURES
-
-#define TOUCH_IN_PRIMITIVE(P, To_Where) To_Where = (P)
-#define TOUCH_SETUP(object) Microcode_Termination (TERM_TOUCH)
-#define Log_Touch_Of_Future(F) {}
-#define Call_Future_Logging()
-#define Must_Report_References() (false)
-#define FUTURE_VARIABLE_SPLICE(P, Offset, Value)
-
-#else /* COMPILE_FUTURES */
-\f
-/* TOUCH_IN_PRIMITIVE is used by primitives which are not
- strict in an argument but which touch it none the less. */
-
-#define TOUCH_IN_PRIMITIVE(P, To_Where) \
-{ \
- SCHEME_OBJECT Value = (P); \
- while (FUTURE_P (Value)) \
- { \
- if (Future_Has_Value (Value)) \
- { \
- if (Future_Is_Keep_Slot (Value)) \
- { \
- Log_Touch_Of_Future (Value); \
- } \
- Value = (Future_Value (Value)); \
- } \
- else \
- { \
- val_register = Value; \
- PRIMITIVE_ABORT (PRIM_TOUCH); \
- } \
- } \
- (To_Where) = Value; \
-}
-
-#define TOUCH_SETUP(object) \
-{ \
- Save_Cont (); \
- Will_Push (STACK_ENV_EXTRA_SLOTS + 2); \
- STACK_PUSH (object); \
- STACK_PUSH (Get_Fixed_Obj_Slot (System_Scheduler)); \
- STACK_PUSH (STACK_FRAME_HEADER + 1); \
- Pushed (); \
-}
-
-#define FUTURE_VARIABLE_SPLICE(P, Offset, Value) \
-{ \
- while ((FUTURE_P (Value)) && (Future_Spliceable (Value))) \
- { \
- Value = (Future_Value (Value)); \
- MEMORY_SET (P, Offset, Value); \
- } \
-}
-\f
-#ifdef FUTURE_LOGGING
-
-#define Touched_Futures_Vector() (Get_Fixed_Obj_Slot (Touched_Futures))
-
-#define Logging_On() \
- ((Valid_Fixed_Obj_Vector ()) && (Touched_Futures_Vector ()))
-
-/* Log_Touch_Of_Future adds the future which was touched to the vector
- of touched futures about which the scheme portion of the system has
- not yet been informed. */
-
-#define Log_Touch_Of_Future(F) \
-{ \
- if (Logging_On ()) \
- { \
- SCHEME_OBJECT TFV = (Touched_Futures_Vector ()); \
- long Count = \
- ((UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF (TFV, 0))) + 1); \
- (VECTOR_REF (TFV, 0)) = (LONG_TO_UNSIGNED_FIXNUM (Count)); \
- if (Count < (VECTOR_LENGTH (TFV))) \
- (VECTOR_REF (TFV, Count)) = (OBJECT_NEW_TYPE (TC_VECTOR, F)); \
- } \
-}
-
-/* Call_Future_Logging calls a user defined scheme routine if the vector
- of touched futures has a nonzero length. */
-
-#define Must_Report_References() \
- ((Logging_On ()) && \
- ((UNSIGNED_FIXNUM_TO_LONG \
- (VECTOR_REF ((Touched_Futures_Vector ()), 0))) \
- > 0))
-
-#define Call_Future_Logging() \
-{ \
- Will_Push (STACK_ENV_EXTRA_SLOTS + 2); \
- STACK_PUSH (Touched_Futures_Vector ()); \
- STACK_PUSH (Get_Fixed_Obj_Slot (Future_Logger)); \
- STACK_PUSH (STACK_FRAME_HEADER + 1); \
- Pushed (); \
- (Touched_Futures_Vector ()) = SHARP_F; \
- goto Apply_Non_Trapping; \
-}
-
-#else /* not FUTURE_LOGGING */
-
-#define Log_Touch_Of_Future(F) {}
-#define Call_Future_Logging()
-#define Must_Report_References() (false)
-
-#endif /* FUTURE_LOGGING */
-#endif /* COMPILE_FUTURES */
/* -*-C-*-
-$Id: gc.h,v 9.38 2007/01/05 21:19:25 cph Exp $
+$Id: gc.h,v 9.39 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/*
- * Garbage collection related macros of sufficient utility to be
- * included in all compilations.
- */
-\f
-/* GC Types. */
-
-#ifdef HAS_COMPILER_SUPPORT
-#ifndef BAD_TYPES_LETHAL
-#ifndef BAD_TYPES_INNOCUOUS
-#define BAD_TYPES_INNOCUOUS
-#endif /* BAD_TYPES_INNOCUOUS */
-#endif /* BAD_TYPES_LETHAL */
-#endif /* HAS_COMPILER_SUPPORT */
-
-#ifdef BAD_TYPES_INNOCUOUS
-#ifdef BAD_TYPES_LETHAL
-#include "error: gc.h: BAD_TYPES both lethal and innocuous"
-#endif /* BAD_TYPES_LETHAL */
-#else /* not BAD_TYPES_INNOCUOUS */
-#ifndef BAD_TYPES_LETHAL
-#define BAD_TYPES_LETHAL
-#endif /* BAD_TYPES_LETHAL */
-#endif /* BAD_TYPES_INNOCUOUS */
-
-#define GC_Non_Pointer 0
-#define GC_Cell 1
-#define GC_Pair 2
-#define GC_Triple 3
-#define GC_Hunk3 3
-#define GC_Quadruple 4
-#define GC_Hunk4 4
-#define GC_Undefined -1 /* Undefined types */
-#define GC_Special -2 /* Internal GC types */
-#define GC_Vector -3
-#define GC_Compiled -4
-\f
-#ifdef BAD_TYPES_INNOCUOUS
-#define INVALID_TYPE_CODE(TC) GC_Undefined
-
-#else /* not BAD_TYPES_INNOCUOUS */
-
-/* Some C compilers complain if the expression below does not yield
- a value, and Microcode_Termination yields void.
- */
-
-#define INVALID_TYPE_CODE(TC) \
- (outf_fatal ("\nGC_Type_Code: Bad Type code = 0x%02x\n", TC), \
- Microcode_Termination(TERM_INVALID_TYPE_CODE), \
- GC_Undefined)
-
-#endif /* BAD_TYPES_INNOCUOUS */
-
-#define GC_Type_Code(TC) \
- ((GC_Type_Map[TC] != GC_Undefined) ? \
- GC_Type_Map[TC] : \
- (INVALID_TYPE_CODE(TC)))
-
-#define GC_Type(Object) GC_Type_Code(OBJECT_TYPE (Object))
-
-#define GC_Type_Non_Pointer(Object) (GC_Type(Object) == GC_Non_Pointer)
-#define GC_Type_Cell(Object) (GC_Type(Object) == GC_Cell)
-#define GC_Type_List(Object) (GC_Type(Object) == GC_Pair)
-#define GC_Type_Triple(Object) (GC_Type(Object) == GC_Triple)
-#define GC_Type_Quadruple(Object) (GC_Type(Object) == GC_Quadruple)
-#define GC_Type_Undefined(Object) (GC_Type(Object) == GC_Undefined)
-#define GC_Type_Special(Object) (GC_Type(Object) == GC_Special)
-#define GC_Type_Vector(Object) (GC_Type(Object) == GC_Vector)
-#define GC_Type_Compiled(Object) (GC_Type(Object) == GC_Compiled)
-\f
-/* Overflow detection, various cases */
-
-#define GC_ENABLED_P() (INTERRUPT_ENABLED_P (INT_GC))
-
-#define GC_Check(Amount) \
- (((Amount + Free) >= MemTop) && (GC_ENABLED_P ()))
-
-#define Space_Before_GC() \
- ((GC_ENABLED_P ()) \
- ? ((Free <= MemTop) ? (MemTop - Free) : 0) \
- : (Heap_Top - Free))
-
-#define Request_GC(Amount) \
-{ \
- REQUEST_INTERRUPT (INT_GC); \
- GC_Space_Needed = Amount; \
-}
-
-#define SET_MEMTOP(addr) \
-{ \
- MemTop = (addr); \
- COMPILER_SETUP_INTERRUPT (); \
-}
-
-#define SET_STACK_GUARD(addr) \
-{ \
- Stack_Guard = (addr); \
- COMPILER_SETUP_INTERRUPT (); \
-}
+/* GC definitions needed by all GC-like programs. */
+
+#ifndef SCM_GC_H
+#define SCM_GC_H 1
+
+#include "object.h"
+
+typedef enum
+{
+ GC_COMPILED = -4,
+ GC_VECTOR,
+ GC_SPECIAL, /* Internal GC types */
+ GC_UNDEFINED,
+ GC_NON_POINTER,
+ GC_CELL,
+ GC_PAIR,
+ GC_TRIPLE,
+ GC_QUADRUPLE
+} gc_type_t;
+
+#define GC_TYPE_TO_INT(type) ((int) (type))
+#define GC_TYPE(object) (GC_TYPE_CODE (OBJECT_TYPE (object)))
+#define GC_TYPE_CODE gc_type_code
+
+#define GC_TYPE_NON_POINTER(object) ((GC_TYPE (object)) == GC_NON_POINTER)
+#define GC_TYPE_CELL(object) ((GC_TYPE (object)) == GC_CELL)
+#define GC_TYPE_PAIR(object) ((GC_TYPE (object)) == GC_PAIR)
+#define GC_TYPE_TRIPLE(object) ((GC_TYPE (object)) == GC_TRIPLE)
+#define GC_TYPE_QUADRUPLE(object) ((GC_TYPE (object)) == GC_QUADRUPLE)
+#define GC_TYPE_UNDEFINED(object) ((GC_TYPE (object)) == GC_UNDEFINED)
+#define GC_TYPE_SPECIAL(object) ((GC_TYPE (object)) == GC_SPECIAL)
+#define GC_TYPE_VECTOR(object) ((GC_TYPE (object)) == GC_VECTOR)
+#define GC_TYPE_COMPILED(object) ((GC_TYPE (object)) == GC_COMPILED)
+
+typedef enum
+{
+ GC_POINTER_NORMAL,
+ GC_POINTER_COMPILED,
+ GC_POINTER_NOT
+} gc_ptr_type_t;
+
+extern gc_type_t gc_type_map [];
+extern gc_type_t gc_type_code (unsigned int);
+extern gc_ptr_type_t gc_ptr_type (SCHEME_OBJECT);
+extern SCHEME_OBJECT * get_object_address (SCHEME_OBJECT);
+
+#endif /* not SCM_GC_H */
/* -*-C-*-
-$Id: gccode.h,v 9.62 2007/01/05 21:19:25 cph Exp $
+$Id: gccode.h,v 9.63 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
loops over memory. It is only included in a few files, unlike
gc.h which contains general purpose macros and constants. */
+#ifndef SCM_GCCODE_H
+#define SCM_GCCODE_H 1
+
+#include "gc.h"
+#include "cmpgc.h"
+#include "fasl.h"
+
#ifdef ENABLE_DEBUGGING_TOOLS
-#ifndef ENABLE_GC_DEBUGGING_TOOLS
-#define ENABLE_GC_DEBUGGING_TOOLS
-#endif
+# ifndef ENABLE_GC_DEBUGGING_TOOLS
+# define ENABLE_GC_DEBUGGING_TOOLS
+# endif
#endif
\f
-/* A SWITCH on GC types, duplicates information in GC_Type_Map[], but
- exists for efficiency reasons. Macros must be used by convention:
- first Switch_by_GC_Type, then each of the case_ macros (in any
- order). The default: case MUST be included in the switch. */
-
-#define Switch_by_GC_Type(P) \
- switch (OBJECT_TYPE (P))
-
-#define case_simple_Non_Pointer \
- case TC_NULL: \
- case TC_CONSTANT: \
- case TC_RETURN_CODE: \
- case TC_THE_ENVIRONMENT
-
-#define case_Fasload_Non_Pointer \
- case_TC_FIXNUMs: \
- case TC_CHARACTER: \
- case_simple_Non_Pointer
-
-#define case_Non_Pointer \
- case TC_PRIMITIVE: \
- case TC_PCOMB0: \
- case TC_STACK_ENVIRONMENT: \
- case_Fasload_Non_Pointer
-
-/* Missing Non Pointer types (must always be treated specially):
- TC_BROKEN_HEART
- TC_MANIFEST_NM_VECTOR
- TC_MANIFEST_SPECIAL_NM_VECTOR
- TC_REFERENCE_TRAP
- TC_MANIFEST_CLOSURE
- TC_LINKAGE_SECTION
- */
-
-#define case_compiled_entry_point \
- case TC_COMPILED_ENTRY
-
-#define case_Cell \
- case TC_CELL
-
-/* No missing Cell types */
-\f
-#define case_Fasdump_Pair \
- case TC_LIST: \
- case TC_SCODE_QUOTE: \
- case TC_COMBINATION_1: \
- case TC_EXTENDED_PROCEDURE: \
- case TC_PROCEDURE: \
- case TC_DELAY: \
- case TC_DELAYED: \
- case TC_COMMENT: \
- case TC_LAMBDA: \
- case TC_SEQUENCE_2: \
- case TC_PCOMB1: \
- case TC_ACCESS: \
- case TC_DEFINITION: \
- case TC_ASSIGNMENT: \
- case TC_IN_PACKAGE: \
- case TC_LEXPR: \
- case TC_DISJUNCTION: \
- case TC_COMPLEX: \
- case TC_ENTITY: \
- case TC_RATNUM
-
-#define case_Pair \
- case TC_INTERNED_SYMBOL: \
- case TC_UNINTERNED_SYMBOL: \
- case_Fasdump_Pair
-
-/* Missing pair types (must be treated specially):
- TC_WEAK_CONS
- */
-
-#define case_Triple \
- case TC_COMBINATION_2: \
- case TC_EXTENDED_LAMBDA: \
- case TC_HUNK3_A: \
- case TC_HUNK3_B: \
- case TC_CONDITIONAL: \
- case TC_SEQUENCE_3: \
- case TC_PCOMB2
-
-/* Missing triple types (must be treated specially):
- TC_VARIABLE */
-\f
-#define case_Quadruple \
- case TC_QUAD
-
-/* No missing quad types. */
-
-#define case_simple_Vector \
- case TC_NON_MARKED_VECTOR: \
- case TC_VECTOR: \
- case TC_RECORD: \
- case TC_CONTROL_POINT: \
- case TC_COMBINATION: \
- case TC_PCOMB3: \
- case TC_VECTOR_1B: \
- case TC_VECTOR_16B
-
-#define case_Purify_Vector \
- case TC_BIG_FIXNUM: \
- case TC_CHARACTER_STRING: \
- case_simple_Vector
-
-#define case_Vector \
- case TC_ENVIRONMENT: \
- case_Purify_Vector
-
-#define case_Aligned_Vector \
- case TC_COMPILED_CODE_BLOCK: \
- case TC_BIG_FLONUM
-
-/* Missing vector types (must be treated specially):
- TC_FUTURE
- */
-\f
-extern char gc_death_message_buffer [];
-
-extern void
- EXFUN (gc_death, (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *));
-
-/* Assumption: A call to GC_BAD_TYPE is followed by the non-pointer code. */
-
-#ifndef BAD_TYPES_INNOCUOUS
-
-#define GC_BAD_TYPE(name, object) do \
-{ \
- sprintf \
- (gc_death_message_buffer, \
- "%s: bad type code (0x%02lx)", \
- (name), \
- (OBJECT_TYPE (object))); \
- gc_death \
- (TERM_INVALID_TYPE_CODE, \
- gc_death_message_buffer, \
- Scan, \
- To); \
- /*NOTREACHED*/ \
-} while (0)
-
-#else /* BAD_TYPES_INNOCUOUS */
-
-#define GC_BAD_TYPE(name, object) do \
-{ \
- outf_error ("\n%s: bad type code (0x%02lx) 0x%lx", \
- (name), \
- (OBJECT_TYPE (object)), \
- (object)); \
- outf_error (" -- Treating as non-pointer.\n"); \
- /* Fall through */ \
-} while (0)
-
-#endif /* BAD_TYPES_INNOCUOUS */
-\f
-/* Macros for the garbage collector and related programs. */
-
-/* Pointer setup for the GC Type handlers. */
-
-#define GC_Consistency_Check(In_GC) \
-{ \
- if And2 (In_GC, Consistency_Check) \
- { \
- if ((Old >= Highest_Allocated_Address) \
- || (Old < Lowest_Allocated_Address)) \
- { \
- sprintf \
- (gc_death_message_buffer, \
- "setup_internal: out of range pointer (0x%lx)", \
- Temp); \
- gc_death (TERM_EXIT, gc_death_message_buffer, Scan, To); \
- /*NOTREACHED*/ \
- } \
- } \
-}
-
-/* Check whether it has been relocated. */
-
-#define Normal_BH(In_GC, then_what) \
-{ \
- if (BROKEN_HEART_P (* Old)) \
- { \
- (* Scan) = (MAKE_OBJECT_FROM_OBJECTS (Temp, (* Old))); \
- then_what; \
- } \
-}
-
-#define RAW_BH(In_GC, then_what) \
-{ \
- if (BROKEN_HEART_P (* Old)) \
- { \
- (* Scan) = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (* Old))); \
- then_what; \
- } \
-}
-
-#define Setup_Internal(In_GC, Transport_Code, Already_Relocated_Code) \
-{ \
- GC_Consistency_Check (In_GC); \
- if (Old < low_heap) \
- continue; \
- Already_Relocated_Code; \
- New_Address = (MAKE_BROKEN_HEART (To)); \
- Transport_Code; \
-}
-
-#define Setup_Aligned(In_GC, Transport_Code, Already_Relocated_Code) \
-{ \
- GC_Consistency_Check (In_GC); \
- if (Old < low_heap) \
- continue; \
- Already_Relocated_Code; \
- ALIGN_FLOAT (To); \
- New_Address = (MAKE_BROKEN_HEART (To)); \
- Transport_Code; \
-}
-
-#define Setup_Pointer(In_GC, Transport_Code) \
-{ \
- Setup_Internal (In_GC, Transport_Code, Normal_BH (In_GC, continue)); \
-}
-
-#define Pointer_End() \
-{ \
- (* (OBJECT_ADDRESS (Temp))) = New_Address; \
- (* Scan) = (MAKE_OBJECT_FROM_OBJECTS (Temp, New_Address)); \
-}
-
-/* HP sucks the big donkey wong?! (still?) */
-/* HP92453-01 A.09.19 HP C Compiler on HP-UX 9.01 drops the
- first line when "optimizing".
- */
-
-#if defined(hp9000s800) || defined(__hp9000s800)
-SCHEME_OBJECT gccode_HPUX_lossage_bug_fix_fnord; /* ``I'm not dead yet!'' */
-
-#define RAW_POINTER_END() \
-{ \
- gccode_HPUX_lossage_bug_fix_fnord = Temp; \
- (* (SCHEME_ADDR_TO_ADDR (gccode_HPUX_lossage_bug_fix_fnord))) \
- = New_Address; \
- (* Scan) = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (New_Address))); \
-}
-#else /* not hp9000s800 */
-#define RAW_POINTER_END() \
-{ \
- (* (SCHEME_ADDR_TO_ADDR (Temp))) = New_Address; \
- (* Scan) = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (New_Address))); \
-}
-#endif /* hp9000s800 */
-\f
-/* GC Type handlers. These do the actual work. */
+typedef SCHEME_OBJECT * gc_handler_t
+ (SCHEME_OBJECT *, SCHEME_OBJECT);
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
+#define DEFINE_GC_HANDLER(handler_name) \
+SCHEME_OBJECT * \
+handler_name (SCHEME_OBJECT * scan, SCHEME_OBJECT object)
-extern SCHEME_OBJECT gc_object_referenced;
-extern SCHEME_OBJECT gc_objects_referencing;
-extern unsigned long gc_objects_referencing_count;
-extern SCHEME_OBJECT * gc_objects_referencing_scan;
-extern SCHEME_OBJECT * gc_objects_referencing_end;
-
-#define TRANSPORT_ONE_THING(transport_code) \
-{ \
- if ((gc_object_referenced == (*Old)) \
- && (gc_objects_referencing != SHARP_F)) \
- { \
- gc_objects_referencing_count += 1; \
- if (gc_objects_referencing_scan != gc_objects_referencing_end) \
- { \
- UPDATE_GC_OBJECTS_REFERENCING (); \
- (*gc_objects_referencing_scan++) = object_referencing; \
- } \
- } \
- transport_code; \
-}
-
-#define UPDATE_GC_OBJECTS_REFERENCING() \
-{ \
- if (BROKEN_HEART_P (MEMORY_REF (gc_objects_referencing, 0))) \
- { \
- SCHEME_OBJECT new = \
- (MAKE_OBJECT_FROM_OBJECTS \
- (gc_objects_referencing, \
- (MEMORY_REF (gc_objects_referencing, 0)))); \
- gc_objects_referencing_scan = \
- (VECTOR_LOC \
- (new, \
- (gc_objects_referencing_scan \
- - (VECTOR_LOC (gc_objects_referencing, 0))))); \
- gc_objects_referencing_end = \
- (VECTOR_LOC (new, (VECTOR_LENGTH (new)))); \
- gc_objects_referencing = new; \
- } \
-}
-
-#else
-
-#define TRANSPORT_ONE_THING(transport_code) transport_code
+typedef SCHEME_OBJECT gc_tuple_handler_t
+ (SCHEME_OBJECT, unsigned int);
-#endif
-\f
-#define Transport_Cell() \
-{ \
- TRANSPORT_ONE_THING ((*To++) = (*Old)); \
- Pointer_End (); \
-}
-
-#define Transport_Pair() \
-{ \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- TRANSPORT_ONE_THING ((*To++) = (*Old)); \
- Pointer_End (); \
-}
-
-#define Transport_Triple() \
-{ \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- TRANSPORT_ONE_THING ((*To++) = (*Old)); \
- Pointer_End (); \
-}
-
-#define TRANSPORT_RAW_TRIPLE() \
-{ \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- TRANSPORT_ONE_THING ((*To++) = (*Old)); \
- RAW_POINTER_END (); \
-}
-
-#define Transport_Quadruple() \
-{ \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- TRANSPORT_ONE_THING ((*To++) = (*Old)); \
- Pointer_End (); \
-}
-\f
-#ifndef In_Fasdump
+#define DEFINE_GC_TUPLE_HANDLER(handler_name) \
+SCHEME_OBJECT \
+handler_name (SCHEME_OBJECT tuple, unsigned int n_words)
-/* The OBJECT_DATUM below gets the length of the vector.
- (VECTOR_LENGTH (Temp)) cannot be used because Temp does
- not necessarily point to the first word of the object.
- Currently only compiled entry points point to the
- "middle" of vectors. */
+typedef SCHEME_OBJECT gc_vector_handler_t
+ (SCHEME_OBJECT, bool);
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
+#define DEFINE_GC_VECTOR_HANDLER(handler_name) \
+SCHEME_OBJECT \
+handler_name (SCHEME_OBJECT vector, bool align_p)
-extern void EXFUN (check_transport_vector_lossage,
- (SCHEME_OBJECT *, SCHEME_OBJECT *, SCHEME_OBJECT *));
-
-#define CHECK_TRANSPORT_VECTOR_TERMINATION() \
-{ \
- if (! ((To <= Scan) \
- && (((Constant_Space <= To) && (To < Heap_Bottom)) \
- ? ((Constant_Space <= Scan) && (Scan < Heap_Bottom)) \
- : ((Heap_Bottom <= Scan) && (Scan < Heap_Top))))) \
- check_transport_vector_lossage (Scan, Saved_Scan, To); \
- if ((OBJECT_DATUM (*Old)) > 65536) \
- { \
- outf_error ("\nWarning: copying large vector: %ld\n", \
- (OBJECT_DATUM (*Old))); \
- outf_flush_error (); \
- } \
-}
-
-#else /* not ENABLE_GC_DEBUGGING_TOOLS */
-
-#define CHECK_TRANSPORT_VECTOR_TERMINATION()
-
-#endif /* not ENABLE_GC_DEBUGGING_TOOLS */
-
-#define Real_Transport_Vector() \
-{ \
- SCHEME_OBJECT * Saved_Scan; \
- \
- Saved_Scan = Scan; \
- Scan = (To + 1 + (OBJECT_DATUM (* Old))); \
- if ((Consistency_Check) \
- && (Scan > Heap_Top) \
- && (To < Heap_Top) \
- && (To >= Heap_Bottom)) \
- { \
- sprintf \
- (gc_death_message_buffer, \
- "real_transport_vector: vector length too large (%ld)", \
- (OBJECT_DATUM (*Old))); \
- gc_death (TERM_EXIT, gc_death_message_buffer, Saved_Scan, To); \
- } \
- CHECK_TRANSPORT_VECTOR_TERMINATION (); \
- while (To != Scan) \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- Scan = Saved_Scan; \
-}
-\f
-#else /* In_Fasdump */
-
-#define Real_Transport_Vector() \
-{ \
- SCHEME_OBJECT * Saved_Scan; \
- \
- Saved_Scan = Scan; \
- Scan = (To + 1 + (OBJECT_DATUM (*Old))); \
- if (Scan >= Fixes) \
- { \
- Scan = Saved_Scan; \
- NewFree = To; \
- Fixup = Fixes; \
- return (PRIM_INTERRUPT); \
- } \
- while (To != Scan) \
- TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
- Scan = Saved_Scan; \
-}
+typedef SCHEME_OBJECT gc_object_handler_t
+ (SCHEME_OBJECT);
-#endif
+#define DEFINE_GC_OBJECT_HANDLER(handler_name) \
+SCHEME_OBJECT \
+handler_name (SCHEME_OBJECT object)
-#define Transport_Vector() \
-{ \
-Move_Vector: \
- Real_Transport_Vector (); \
- Pointer_End (); \
-}
-
-#define Transport_Future() \
-{ \
- if (! (Future_Spliceable (Temp))) \
- goto Move_Vector; \
- (*Scan) = (Future_Value (Temp)); \
- Scan -= 1; \
-}
-\f
-/* Weak Pointer code. The idea here is to support a post-GC pass which
- removes any objects in the CAR of a WEAK_CONS cell which is no longer
- referenced by other objects in the system.
-
- The idea is to maintain a (C based) list of weak conses in old
- space. The head of this list is the variable Weak_Chain. During
- the normal GC pass, weak cons cells are not copied in the normal
- manner. Instead the following structure is built:
-
- Old Space | New Space
- _______________________ | _______________________
- |Broken | New | | | NULL | Old CAR data |
- |Heart | Location ======|==>| | |
- |_______|_____________| | |______|______________|
- |Old Car| Next in | | | Old CDR component |
- | type | chain | | | |
- |_____________________| | |_____________________|
-
- */
-
-extern SCHEME_OBJECT Weak_Chain;
-
-#define EMPTY_WEAK_CHAIN (OBJECT_NEW_TYPE(TC_NULL, 0))
-
-#define Transport_Weak_Cons() \
-{ \
- long Car_Type = (OBJECT_TYPE (*Old)); \
- (*To++) = (OBJECT_NEW_TYPE (TC_NULL, (*Old))); \
- Old += 1; \
- TRANSPORT_ONE_THING ((*To++) = (*Old)); \
- *Old = (OBJECT_NEW_TYPE (Car_Type, Weak_Chain)); \
- Weak_Chain = Temp; \
- Pointer_End (); \
-}
-
-/* Special versions of the above for DumpLoop in Fasdump. This code
- only differs from the code above in that it must check whether
- there is enough space to remember the fixup. */
-
-#define Fasdump_Setup_Pointer(Extra_Code, BH_Code) \
-{ \
- BH_Code; \
- \
- /* It must be transported to New Space */ \
- \
- New_Address = (MAKE_BROKEN_HEART (To)); \
- if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
- { \
- NewFree = To; \
- Fixup = Fixes; \
- return (PRIM_INTERRUPT); \
- } \
- (*--Fixes) = (* Old); \
- (*--Fixes) = (ADDRESS_TO_DATUM (Old)); \
- Extra_Code; \
-}
-
-#define Fasdump_Setup_Aligned(Extra_Code, BH_Code) \
-{ \
- BH_Code; \
- \
- /* It must be transported to New Space */ \
- \
- ALIGN_FLOAT (To); \
- New_Address = (MAKE_BROKEN_HEART (To)); \
- if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
- { \
- NewFree = To; \
- Fixup = Fixes; \
- return (PRIM_INTERRUPT); \
- } \
- (*--Fixes) = (* Old); \
- (*--Fixes) = (ADDRESS_TO_DATUM (Old)); \
- Extra_Code; \
-}
-
-/* Undefine Symbols */
-
-#define Fasdump_Symbol(global_value) \
-{ \
- (*To++) = (* Old); \
- (*To++) = global_value; \
- Pointer_End (); \
-}
-
-#define Fasdump_Variable() \
-{ \
- (*To++) = (* Old); \
- (*To++) = UNCOMPILED_VARIABLE; \
- (*To++) = SHARP_F; \
- Pointer_End (); \
-}
-
-/* Compiled Code Relocation Utilities */
+typedef SCHEME_OBJECT * gc_precheck_from_t (SCHEME_OBJECT *);
-#include "cmpgc.h"
+#define DEFINE_GC_PRECHECK_FROM(handler_name) \
+SCHEME_OBJECT * \
+handler_name (SCHEME_OBJECT * from)
+
+typedef SCHEME_OBJECT * gc_transport_words_t
+ (SCHEME_OBJECT *, unsigned long, bool);
+
+#define DEFINE_GC_TRANSPORT_WORDS(handler_name) \
+SCHEME_OBJECT * \
+handler_name (SCHEME_OBJECT * from, unsigned long n_words, bool align_p)
+
+typedef bool gc_ignore_object_p_t (SCHEME_OBJECT);
+
+#define DEFINE_GC_IGNORE_OBJECT_P(handler_name) \
+bool \
+handler_name (SCHEME_OBJECT object)
+
+typedef SCHEME_OBJECT gc_raw_address_to_object_t
+ (unsigned int, SCHEME_OBJECT *);
+typedef SCHEME_OBJECT * gc_object_to_raw_address_t (SCHEME_OBJECT);
+typedef SCHEME_OBJECT gc_raw_address_to_cc_entry_t (insn_t *);
+typedef insn_t * gc_cc_entry_to_raw_address_t (SCHEME_OBJECT);
\f
-typedef struct gc_hook_list_s
+typedef struct
{
- void EXFUN ((* hook), (void));
- struct gc_hook_list_s * next;
-} * gc_hook_list;
-
-extern int EXFUN (add_pre_gc_hook, (void (*) (void)));
-extern int EXFUN (add_post_gc_hook, (void (*) (void)));
-extern void EXFUN (run_pre_gc_hooks, (void));
-extern void EXFUN (run_post_gc_hooks, (void));
+ gc_handler_t * handlers [N_TYPE_CODES];
+ gc_tuple_handler_t * tuple_handler;
+ gc_vector_handler_t * vector_handler;
+ gc_object_handler_t * cc_entry_handler;
+ gc_precheck_from_t * precheck_from;
+ gc_transport_words_t * transport_words;
+ gc_ignore_object_p_t * ignore_object_p;
+ gc_raw_address_to_object_t * raw_address_to_object;
+ gc_object_to_raw_address_t * object_to_raw_address;
+ gc_raw_address_to_cc_entry_t * raw_address_to_cc_entry;
+ gc_cc_entry_to_raw_address_t * cc_entry_to_raw_address;
+} gc_table_t;
+
+#define GCT_ENTRY(table, type) (((table)->handlers) [(type)])
+#define GCT_TUPLE(table) ((table)->tuple_handler)
+#define GCT_VECTOR(table) ((table)->vector_handler)
+#define GCT_CC_ENTRY(table) ((table)->cc_entry_handler)
+#define GCT_PRECHECK_FROM(table) ((table)->precheck_from)
+#define GCT_TRANSPORT_WORDS(table) ((table)->transport_words)
+#define GCT_IGNORE_OBJECT_P(table) ((table)->ignore_object_p)
+#define GCT_RAW_ADDRESS_TO_OBJECT(table) ((table)->raw_address_to_object)
+#define GCT_OBJECT_TO_RAW_ADDRESS(table) ((table)->object_to_raw_address)
+#define GCT_RAW_ADDRESS_TO_CC_ENTRY(table) ((table)->raw_address_to_cc_entry)
+#define GCT_CC_ENTRY_TO_RAW_ADDRESS(table) ((table)->cc_entry_to_raw_address)
+
+#define GC_HANDLE_TUPLE(object, n_words) \
+ ((* (GCT_TUPLE (current_gc_table))) ((object), (n_words)))
+
+#define GC_HANDLE_VECTOR(object, align_p) \
+ ((* (GCT_VECTOR (current_gc_table))) ((object), (align_p)))
+
+#define GC_HANDLE_CC_ENTRY(object) \
+ ((* (GCT_CC_ENTRY (current_gc_table))) (object))
+
+#define GC_PRECHECK_FROM(from) \
+ ((* (GCT_PRECHECK_FROM (current_gc_table))) (from))
+
+#define GC_TRANSPORT_WORDS(from, n_words, align_p) \
+ ((* (GCT_TRANSPORT_WORDS (current_gc_table))) ((from), (n_words), (align_p)))
+
+#define GC_RAW_ADDRESS_TO_OBJECT(type, addr) \
+ ((* (GCT_RAW_ADDRESS_TO_OBJECT (current_gc_table))) ((type), (addr)))
+
+#define GC_OBJECT_TO_RAW_ADDRESS(object) \
+ ((* (GCT_OBJECT_TO_RAW_ADDRESS (current_gc_table))) (object))
+
+#define GC_RAW_ADDRESS_TO_CC_ENTRY(addr) \
+ ((* (GCT_RAW_ADDRESS_TO_CC_ENTRY (current_gc_table))) (addr))
+
+#define GC_CC_ENTRY_TO_RAW_ADDRESS(object) \
+ ((* (GCT_CC_ENTRY_TO_RAW_ADDRESS (current_gc_table))) (object))
+
+extern gc_table_t * current_gc_table;
+
+extern gc_handler_t gc_handle_non_pointer;
+extern gc_handler_t gc_handle_cell;
+extern gc_handler_t gc_handle_pair;
+extern gc_handler_t gc_handle_triple;
+extern gc_handler_t gc_handle_quadruple;
+extern gc_handler_t gc_handle_weak_pair;
+extern gc_handler_t gc_handle_cc_entry;
+extern gc_handler_t gc_handle_aligned_vector;
+extern gc_handler_t gc_handle_unaligned_vector;
+extern gc_handler_t gc_handle_broken_heart;
+extern gc_handler_t gc_handle_nmv;
+extern gc_handler_t gc_handle_reference_trap;
+extern gc_handler_t gc_handle_linkage_section;
+extern gc_handler_t gc_handle_manifest_closure;
+extern gc_handler_t gc_handle_undefined;
+
+extern gc_tuple_handler_t gc_tuple;
+extern gc_vector_handler_t gc_vector;
+extern gc_object_handler_t gc_cc_entry;
+extern gc_precheck_from_t gc_precheck_from;
+extern gc_precheck_from_t gc_precheck_from_no_transport;
+extern gc_transport_words_t gc_transport_words;
+extern gc_transport_words_t gc_no_transport_words;
+extern gc_raw_address_to_object_t gc_raw_address_to_object;
+extern gc_object_to_raw_address_t gc_object_to_raw_address;
+extern gc_raw_address_to_cc_entry_t gc_raw_address_to_cc_entry;
+extern gc_cc_entry_to_raw_address_t gc_cc_entry_to_raw_address;
+
+extern void initialize_gc_table (gc_table_t *, bool);
+
+typedef void gc_tospace_allocator_t
+ (unsigned long, SCHEME_OBJECT **, SCHEME_OBJECT **);
+typedef void gc_abort_handler_t (void);
+typedef bool gc_walk_proc_t (SCHEME_OBJECT *, SCHEME_OBJECT *, void *);
+
+extern void initialize_gc
+ (unsigned long, SCHEME_OBJECT **, SCHEME_OBJECT **,
+ gc_tospace_allocator_t *, gc_abort_handler_t * NORETURN);
+
+extern void resize_tospace (unsigned long);
+extern void open_tospace (SCHEME_OBJECT *);
+extern bool tospace_available_p (unsigned long);
+extern void add_to_tospace (SCHEME_OBJECT);
+extern SCHEME_OBJECT read_tospace (SCHEME_OBJECT *);
+extern void write_tospace (SCHEME_OBJECT *, SCHEME_OBJECT);
+extern void increment_tospace_ptr (unsigned long);
+extern SCHEME_OBJECT * get_newspace_ptr (void);
+extern void * tospace_to_newspace (void *);
+extern void * newspace_to_tospace (void *);
+extern bool save_tospace (gc_walk_proc_t *, void *);
+
+extern void initialize_weak_chain (void);
+extern void update_weak_pointers (void);
+
+extern gc_table_t * std_gc_table (void);
+extern void gc_scan_oldspace (SCHEME_OBJECT *, SCHEME_OBJECT *);
+extern void gc_scan_tospace (SCHEME_OBJECT *, SCHEME_OBJECT *);
+
+extern void std_gc_death (const char *, ...)
+ ATTRIBUTE ((__noreturn__, __format__ (__printf__, 1, 2)));
+extern void gc_no_cc_support (void) NORETURN;
+extern void gc_bad_type (SCHEME_OBJECT) NORETURN;
+
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ extern void collect_gc_object_references (SCHEME_OBJECT, SCHEME_OBJECT);
+ extern void initialize_gc_object_references (void);
+ extern void finalize_gc_object_references (void);
+#endif
+
+#endif /* not SCM_GCCODE_H */
/* -*-C-*-
-$Id: gcloop.c,v 9.53 2007/01/05 21:19:25 cph Exp $
+$Id: gcloop.c,v 9.54 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/*
- *
- * This file contains the code for the most primitive part
- * of garbage collection.
- *
- */
+/* Garbage collector core
+
+ This is a one-space copying garbage collector. It's like a
+ two-space collector, except that the heap is copied to temporary
+ memory ("tospace"), then copied back at the end. This design is
+ more complex and slower than a two-space collector, but it has the
+ advantage that tospace can be allocated anywhere in the virtual
+ address space. This matters because our tagging scheme limits the
+ number of address bits we can use (26 on a 32-bit machine), and
+ with this design tospace can be located outside of the addressable
+ range, thus maximizing the usage of addressable memory. This
+ design is similar to that of the older "bchscheme" GC, except that
+ bchscheme allocated its tospace in a file.
+
+ Some terminology:
+
+ "Fromspace" is the allocated portion of the heap that we copy
+ objects from.
+
+ "Tospace" is the temporary memory that we copy objects to.
+
+ "Newspace" is the region of memory into which tospace will be
+ copied after the GC is complete. During the GC we copy objects
+ into tospace, but update pointers to refer to locations in
+ newspace. Since there's a simple relationship between pointers in
+ newspace and pointers in tospace, it's easy to convert between
+ them.
-#include "scheme.h"
+ "Oldspace" is the addressable region of memory. This includes
+ fromspace, and also the stack and constant areas. It is
+ distinguished from fromspace because we can scan anywhere in
+ oldspace, but we copy only from fromspace.
+
+*/
+\f
+#include "object.h"
+#include "outf.h"
#include "gccode.h"
-/* Exports */
+static SCHEME_OBJECT ** p_fromspace_start;
+static SCHEME_OBJECT ** p_fromspace_end;
+static gc_tospace_allocator_t * gc_tospace_allocator;
+static gc_abort_handler_t * gc_abort_handler NORETURN;
+
+static SCHEME_OBJECT * tospace_start;
+static SCHEME_OBJECT * tospace_next;
+static SCHEME_OBJECT * tospace_end;
+static SCHEME_OBJECT * newspace_start;
+static SCHEME_OBJECT * newspace_next;
+static SCHEME_OBJECT * newspace_end;
+
+gc_table_t * current_gc_table;
+static SCHEME_OBJECT * current_scan;
+static SCHEME_OBJECT current_object;
-extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
+#define ADDRESS_IN_FROMSPACE_P(addr) \
+ ((((void *) (addr)) >= ((void *) (*p_fromspace_start))) \
+ && (((void *) (addr)) < ((void *) (*p_fromspace_end))))
-#define GC_Pointer(Code) \
+#define TOSPACE_TO_NEWSPACE(p) (((p) - tospace_start) + newspace_start)
+#define NEWSPACE_TO_TOSPACE(p) (((p) - newspace_start) + tospace_start)
+
+#define READ_TOSPACE(addr) (* (NEWSPACE_TO_TOSPACE (addr)))
+#define WRITE_TOSPACE(addr, obj) ((* (NEWSPACE_TO_TOSPACE (addr))) = (obj))
+
+#define CLOSE_TOSPACE() do \
{ \
- Old = (OBJECT_ADDRESS (Temp)); \
- Code; \
-}
+ tospace_next = 0; \
+ newspace_start = 0; \
+ newspace_next = 0; \
+ newspace_end = 0; \
+} while (false)
-#define GC_RAW_POINTER(Code) \
+#define GUARANTEE_TOSPACE_OPEN() do \
{ \
- Old = (SCHEME_ADDR_TO_ADDR (Temp)); \
- Code; \
-}
+ if (tospace_next == 0) \
+ tospace_closed (); \
+} while (false)
-#define Setup_Pointer_for_GC(Extra_Code) \
+#define GUARANTEE_TOSPACE_CLOSED() do \
{ \
- GC_Pointer (Setup_Pointer (true, Extra_Code)); \
-}
-\f
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ if (tospace_next != 0) \
+ tospace_open (); \
+} while (false)
-#ifndef GC_SCAN_HISTORY_SIZE
-#define GC_SCAN_HISTORY_SIZE 1024
+#ifndef READ_REFERENCE_ADDRESS
+# define READ_REFERENCE_ADDRESS(addr) \
+ (* ((SCHEME_OBJECT **) (addr)))
+# define WRITE_REFERENCE_ADDRESS(ref, addr) \
+ ((* ((SCHEME_OBJECT **) (addr))) = (ref))
#endif
-SCHEME_OBJECT
- * gc_scan_trap = ((SCHEME_OBJECT *) 0),
- * gc_free_trap = ((SCHEME_OBJECT *) 0),
- gc_trap = (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE)),
- * (gc_scan_history [GC_SCAN_HISTORY_SIZE]),
- * (gc_to_history [GC_SCAN_HISTORY_SIZE]);
+static SCHEME_OBJECT * weak_chain;
-SCHEME_OBJECT gc_object_referenced = SHARP_F;
-SCHEME_OBJECT gc_objects_referencing = SHARP_F;
-unsigned long gc_objects_referencing_count;
-SCHEME_OBJECT * gc_objects_referencing_scan;
-SCHEME_OBJECT * gc_objects_referencing_end;
+static void run_gc_loop (SCHEME_OBJECT * , SCHEME_OBJECT **);
+static SCHEME_OBJECT gc_transport_weak_pair (SCHEME_OBJECT);
+static void tospace_closed (void);
+static void tospace_open (void);
-static int gc_scan_history_index;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+# ifndef GC_SCAN_HISTORY_SIZE
+# define GC_SCAN_HISTORY_SIZE 1024
+# endif
+# define INITIALIZE_GC_HISTORY initialize_gc_history
+# define HANDLE_GC_TRAP handle_gc_trap
+# define CHECK_NEWSPACE_SYNC check_newspace_sync
+# define DEBUG_TRANSPORT_ONE_WORD debug_transport_one_word
-#define INITIALIZE_GC_HISTORY() \
-{ \
- gc_scan_history_index = 0; \
- { \
- SCHEME_OBJECT ** scan = gc_scan_history; \
- SCHEME_OBJECT ** end = (scan + GC_SCAN_HISTORY_SIZE); \
- while (scan < end) \
- (*scan++) = ((SCHEME_OBJECT *) 0); \
- } \
- { \
- SCHEME_OBJECT ** scan = gc_to_history; \
- SCHEME_OBJECT ** end = (scan + GC_SCAN_HISTORY_SIZE); \
- while (scan < end) \
- (*scan++) = ((SCHEME_OBJECT *) 0); \
- } \
-}
-
-#define HANDLE_GC_TRAP() \
-{ \
- (gc_scan_history [gc_scan_history_index]) = Scan; \
- (gc_to_history [gc_scan_history_index]) = To; \
- if ((++gc_scan_history_index) == GC_SCAN_HISTORY_SIZE) \
- gc_scan_history_index = 0; \
- if ((Temp == gc_trap) \
- || ((gc_scan_trap != 0) && (Scan >= gc_scan_trap)) \
- || ((gc_free_trap != 0) && (To >= gc_free_trap))) \
- { \
- outf_error ("\nGCLoop: trap.\n"); \
- abort (); \
- } \
-}
+ static unsigned int gc_scan_history_index;
+ static SCHEME_OBJECT * gc_scan_history [GC_SCAN_HISTORY_SIZE];
+ static SCHEME_OBJECT * gc_to_history [GC_SCAN_HISTORY_SIZE];
-#else
+ static SCHEME_OBJECT gc_trap
+ = (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE));
+ static SCHEME_OBJECT * gc_scan_trap = 0;
+ static SCHEME_OBJECT * gc_to_trap = 0;
-#define INITIALIZE_GC_HISTORY()
-#define HANDLE_GC_TRAP()
+ static SCHEME_OBJECT gc_object_referenced = SHARP_F;
+ static SCHEME_OBJECT gc_object_references = SHARP_F;
+ static unsigned long gc_object_references_count;
+ static SCHEME_OBJECT * gc_object_references_scan;
+ static SCHEME_OBJECT * gc_object_references_end;
+ static unsigned long weak_chain_length;
+
+ static void initialize_gc_history (void);
+ static void handle_gc_trap (SCHEME_OBJECT *, SCHEME_OBJECT);
+ static void check_newspace_sync (void);
+ static void debug_transport_one_word (SCHEME_OBJECT, SCHEME_OBJECT *);
+#else
+# define INITIALIZE_GC_HISTORY() do {} while (false)
+# define HANDLE_GC_TRAP(scan, object) do {} while (false)
+# define CHECK_NEWSPACE_SYNC() do {} while (false)
+# define DEBUG_TRANSPORT_ONE_WORD(object, from) do {} while (false)
#endif
\f
+void
+initialize_gc (unsigned long n_words,
+ SCHEME_OBJECT ** pf_start,
+ SCHEME_OBJECT ** pf_end,
+ gc_tospace_allocator_t * allocator,
+ gc_abort_handler_t * abort_handler NORETURN)
+{
+ p_fromspace_start = pf_start;
+ p_fromspace_end = pf_end;
+ gc_tospace_allocator = allocator;
+ gc_abort_handler = abort_handler;
+ CLOSE_TOSPACE ();
+ tospace_start = 0;
+ tospace_end = 0;
+ (*gc_tospace_allocator) (n_words, (&tospace_start), (&tospace_end));
+}
+
+void
+resize_tospace (unsigned long n_words)
+{
+ GUARANTEE_TOSPACE_CLOSED ();
+ (*gc_tospace_allocator) (n_words, (&tospace_start), (&tospace_end));
+}
+
+void
+open_tospace (SCHEME_OBJECT * start)
+{
+ GUARANTEE_TOSPACE_CLOSED ();
+ tospace_next = tospace_start;
+ newspace_start = start;
+ newspace_next = start;
+ newspace_end = (start + (tospace_end - tospace_start));
+}
+
+bool
+save_tospace (gc_walk_proc_t * proc, void * ctx)
+{
+ bool ok;
+
+ GUARANTEE_TOSPACE_OPEN ();
+ CHECK_NEWSPACE_SYNC ();
+ ok = (proc (tospace_start, tospace_next, ctx));
+ CLOSE_TOSPACE ();
+ return (ok);
+}
+
+bool
+tospace_available_p (unsigned long n_words)
+{
+ GUARANTEE_TOSPACE_OPEN ();
+ return ((tospace_end - tospace_next) >= n_words);
+}
+
+void
+add_to_tospace (SCHEME_OBJECT object)
+{
+ GUARANTEE_TOSPACE_OPEN ();
+ (*tospace_next++) = object;
+ newspace_next += 1;
+}
+
+SCHEME_OBJECT
+read_tospace (SCHEME_OBJECT * addr)
+{
+ GUARANTEE_TOSPACE_OPEN ();
+ return (READ_TOSPACE (addr));
+}
+
+void
+write_tospace (SCHEME_OBJECT * addr, SCHEME_OBJECT object)
+{
+ GUARANTEE_TOSPACE_OPEN ();
+ WRITE_TOSPACE (addr, object);
+}
+
+void
+increment_tospace_ptr (unsigned long n_words)
+{
+ GUARANTEE_TOSPACE_OPEN ();
+ tospace_next += n_words;
+ newspace_next += n_words;
+}
+
SCHEME_OBJECT *
-DEFUN (GCLoop,
- (Scan, To_Pointer),
- fast SCHEME_OBJECT * Scan
- AND SCHEME_OBJECT ** To_Pointer)
-{
- fast SCHEME_OBJECT
- * To, * Old, Temp,
- * low_heap, New_Address;
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
- SCHEME_OBJECT object_referencing;
-#endif
+get_newspace_ptr (void)
+{
+ return (newspace_next);
+}
- INITIALIZE_GC_HISTORY ();
- To = * To_Pointer;
- low_heap = Constant_Top;
- for ( ; Scan != To; Scan++)
- {
- Temp = * Scan;
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
- object_referencing = Temp;
-#endif
- HANDLE_GC_TRAP ();
+void *
+tospace_to_newspace (void * addr)
+{
+ return
+ (((addr >= ((void *) tospace_start))
+ && (addr <= ((void *) tospace_end)))
+ ? ((((byte_t *) addr) - ((byte_t *) tospace_start))
+ + ((byte_t *) newspace_start))
+ : addr);
+}
- Switch_by_GC_Type (Temp)
- {
- case TC_BROKEN_HEART:
- if (Scan == (OBJECT_ADDRESS (Temp)))
- {
- *To_Pointer = To;
- return (Scan);
- }
- sprintf (gc_death_message_buffer,
- "gcloop: broken heart (0x%lx) in scan",
- Temp);
- gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
- /*NOTREACHED*/
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += OBJECT_DATUM (Temp);
- break;
+void *
+newspace_to_tospace (void * addr)
+{
+ return
+ (((addr >= ((void *) newspace_start))
+ && (addr <= ((void *) newspace_end)))
+ ? ((((byte_t *) addr) - ((byte_t *) newspace_start))
+ + ((byte_t *) tospace_start))
+ : addr);
+}
\f
- /* Compiled code relocation. */
+#define SIMPLE_HANDLER(name) \
+ (GCT_ENTRY (table, i)) = name; \
+ break
- case TC_LINKAGE_SECTION:
+void
+initialize_gc_table (gc_table_t * table, bool transport_p)
+{
+ unsigned int i;
+ for (i = 0; (i < N_TYPE_CODES); i += 1)
+ switch (gc_type_map[i])
{
- switch (READ_LINKAGE_KIND (Temp))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- /* Assumes that all others are objects of type TC_QUAD without
- their type codes.
- */
-
- fast long count;
-
- Scan++;
- for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
- --count >= 0;
- Scan += 1)
- {
- Temp = (* Scan);
- GC_RAW_POINTER (Setup_Internal (true,
- TRANSPORT_RAW_TRIPLE (),
- RAW_BH (true, continue)));
- }
- Scan -= 1;
- break;
- }
+ case GC_NON_POINTER: SIMPLE_HANDLER (gc_handle_non_pointer);
+ case GC_CELL: SIMPLE_HANDLER (gc_handle_cell);
+ case GC_PAIR: SIMPLE_HANDLER (gc_handle_pair);
+ case GC_TRIPLE: SIMPLE_HANDLER (gc_handle_triple);
+ case GC_QUADRUPLE: SIMPLE_HANDLER (gc_handle_quadruple);
+ case GC_VECTOR: SIMPLE_HANDLER (gc_handle_unaligned_vector);
+ case GC_COMPILED: SIMPLE_HANDLER (gc_handle_cc_entry);
+ case GC_UNDEFINED: SIMPLE_HANDLER (gc_handle_undefined);
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
+ case GC_SPECIAL:
+ switch (i)
{
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * end_scan;
-
- START_OPERATOR_RELOCATION (Scan);
- count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
- word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
- end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
-
- while (--count >= 0)
- {
- Scan = ((SCHEME_OBJECT *) word_ptr);
- word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
- EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
- GC_RAW_POINTER (Setup_Aligned
- (true,
- TRANSPORT_RAW_COMPILED (),
- RAW_COMPILED_BH (true,
- goto next_operator)));
- next_operator:
- STORE_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
- }
- Scan = end_scan;
- END_OPERATOR_RELOCATION (Scan);
- break;
- }
+ case TC_BROKEN_HEART:
+ SIMPLE_HANDLER (gc_handle_broken_heart);
- case CLOSURE_PATTERN_LINKAGE_KIND:
- Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
- break;
+ case TC_REFERENCE_TRAP:
+ SIMPLE_HANDLER (gc_handle_reference_trap);
+
+ case TC_LINKAGE_SECTION:
+ SIMPLE_HANDLER (gc_handle_linkage_section);
+
+ case TC_MANIFEST_CLOSURE:
+ SIMPLE_HANDLER (gc_handle_manifest_closure);
+
+ case TC_MANIFEST_NM_VECTOR:
+ SIMPLE_HANDLER (gc_handle_nmv);
default:
- {
- gc_death (TERM_EXIT,
- "GC: Unknown compiler linkage kind.",
- Scan, Free);
- /*NOTREACHED*/
+ std_gc_death ("unknown GC special type: %#02x\n", i);
+ break;
}
- }
break;
}
+ (GCT_ENTRY (table, TC_WEAK_CONS)) = gc_handle_weak_pair;
+ (GCT_ENTRY (table, TC_BIG_FLONUM)) = gc_handle_aligned_vector;
+ (GCT_ENTRY (table, TC_COMPILED_CODE_BLOCK)) = gc_handle_aligned_vector;
+ /* The next is for backwards compatibility with older bands.
+ This type used to be TC_MANIFEST_SPECIAL_NM_VECTOR. */
+ (GCT_ENTRY (table, 0x2B)) = gc_handle_non_pointer;
+ (GCT_TUPLE (table)) = gc_tuple;
+ (GCT_VECTOR (table)) = gc_vector;
+ (GCT_CC_ENTRY (table)) = gc_cc_entry;
+ if (transport_p)
+ {
+ (GCT_PRECHECK_FROM (table)) = gc_precheck_from;
+ (GCT_TRANSPORT_WORDS (table)) = gc_transport_words;
+ }
+ else
+ {
+ (GCT_PRECHECK_FROM (table)) = gc_precheck_from_no_transport;
+ (GCT_TRANSPORT_WORDS (table)) = gc_no_transport_words;
+ }
+ (GCT_IGNORE_OBJECT_P (table)) = 0;
+ (GCT_RAW_ADDRESS_TO_OBJECT (table)) = gc_raw_address_to_object;
+ (GCT_OBJECT_TO_RAW_ADDRESS (table)) = gc_object_to_raw_address;
+ (GCT_RAW_ADDRESS_TO_CC_ENTRY (table)) = gc_raw_address_to_cc_entry;
+ (GCT_CC_ENTRY_TO_RAW_ADDRESS (table)) = gc_cc_entry_to_raw_address;
+}
+
+gc_table_t *
+std_gc_table (void)
+{
+ static bool initialized_p = false;
+ static gc_table_t table;
+ if (!initialized_p)
+ {
+ initialize_gc_table ((&table), true);
+ initialized_p = true;
+ }
+ return (&table);
+}
+
+void
+gc_scan_oldspace (SCHEME_OBJECT * scan, SCHEME_OBJECT * end)
+{
+ run_gc_loop (scan, (&end));
+}
+
+void
+gc_scan_tospace (SCHEME_OBJECT * scan, SCHEME_OBJECT * end)
+{
+ if (end == 0)
+ run_gc_loop ((NEWSPACE_TO_TOSPACE (scan)), (&tospace_next));
+ else
+ {
+ SCHEME_OBJECT * tend = (NEWSPACE_TO_TOSPACE (end));
+ run_gc_loop ((NEWSPACE_TO_TOSPACE (scan)), (&tend));
+ }
+}
+
+static void
+run_gc_loop (SCHEME_OBJECT * scan, SCHEME_OBJECT ** pend)
+{
+ gc_ignore_object_p_t * ignore_object_p
+ = (GCT_IGNORE_OBJECT_P (current_gc_table));
+ INITIALIZE_GC_HISTORY ();
+ while (scan < (*pend))
+ {
+ SCHEME_OBJECT object = (*scan);
+ HANDLE_GC_TRAP (scan, object);
+ if ((ignore_object_p != 0) && ((*ignore_object_p) (object)))
+ scan += 1;
+ else
+ {
+ current_scan = scan;
+ current_object = object;
+ scan
+ = ((* (GCT_ENTRY (current_gc_table, (OBJECT_TYPE (object)))))
+ (scan, object));
+ }
+ }
+}
\f
- case TC_MANIFEST_CLOSURE:
+DEFINE_GC_TUPLE_HANDLER (gc_tuple)
+{
+ SCHEME_OBJECT * from = (OBJECT_ADDRESS (tuple));
+ SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from));
+ return
+ (OBJECT_NEW_ADDRESS (tuple,
+ ((new_address != 0)
+ ? new_address
+ : (GC_TRANSPORT_WORDS (from, n_words, false)))));
+}
+
+DEFINE_GC_VECTOR_HANDLER (gc_vector)
+{
+ SCHEME_OBJECT * from = (OBJECT_ADDRESS (vector));
+ SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from));
+ return
+ (OBJECT_NEW_ADDRESS (vector,
+ ((new_address != 0)
+ ? new_address
+ : (GC_TRANSPORT_WORDS (from,
+ (1 + (OBJECT_DATUM (*from))),
+ align_p)))));
+}
+
+DEFINE_GC_OBJECT_HANDLER (gc_cc_entry)
+{
+#ifdef CC_SUPPORT_P
+ SCHEME_OBJECT old_block = (cc_entry_to_block (object));
+ SCHEME_OBJECT new_block = (GC_HANDLE_VECTOR (old_block, true));
+ return (CC_ENTRY_NEW_BLOCK (object,
+ (OBJECT_ADDRESS (new_block)),
+ (OBJECT_ADDRESS (old_block))));
+#else
+ gc_no_cc_support ();
+ return (object);
+#endif
+}
+
+DEFINE_GC_PRECHECK_FROM (gc_precheck_from)
+{
+#if 0
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ if (!ADDRESS_IN_MEMORY_BLOCK_P (from))
+ std_gc_death ("out of range pointer: %#lx", ((unsigned long) from));
+#endif
+#endif
+ return
+ ((ADDRESS_IN_FROMSPACE_P (from))
+ ? ((BROKEN_HEART_P (*from))
+ ? (OBJECT_ADDRESS (*from))
+ : 0)
+ : from);
+}
+
+DEFINE_GC_PRECHECK_FROM (gc_precheck_from_no_transport)
+{
+#if 0
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ if (!ADDRESS_IN_MEMORY_BLOCK_P (from))
+ std_gc_death ("out of range pointer: %#lx", ((unsigned long) from));
+#endif
+#endif
+ return (from);
+}
+\f
+DEFINE_GC_TRANSPORT_WORDS (gc_transport_words)
+{
+ SCHEME_OBJECT * from_start = from;
+ SCHEME_OBJECT * from_end = (from_start + n_words);
+ SCHEME_OBJECT * new_address;
+
+ GUARANTEE_TOSPACE_OPEN ();
+ if (align_p)
+ while (!FLOATING_ALIGNED_P (newspace_next))
{
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * area_end;
+ (*tospace_next++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
+ newspace_next += 1;
+ }
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ if (tospace_next >= tospace_end)
+ std_gc_death ("tospace completely filled");
+ {
+ SCHEME_OBJECT * end = (tospace_next + n_words);
+ if (end > tospace_end)
+ std_gc_death ("block overflows tospace: %#lx",
+ ((unsigned long) end));
+ }
+ if (n_words == 0)
+ std_gc_death ("gc_transport_words: attempt to transfer zero words.");
+ if (n_words > 0x10000)
+ {
+ outf_error ("\nWarning: copying large block: %lu\n", n_words);
+ outf_flush_error ();
+ }
+#endif
+ new_address = newspace_next;
+ while (from < from_end)
+ {
+ DEBUG_TRANSPORT_ONE_WORD (current_object, from);
+ (*tospace_next++) = (*from++);
+ newspace_next += 1;
+ }
+ (*from_start) = (MAKE_BROKEN_HEART (new_address));
+ return (new_address);
+}
+
+DEFINE_GC_TRANSPORT_WORDS (gc_no_transport_words)
+{
+ tospace_closed ();
+ return (from);
+}
+\f
+DEFINE_GC_HANDLER (gc_handle_non_pointer)
+{
+ return (scan + 1);
+}
+
+DEFINE_GC_HANDLER (gc_handle_cell)
+{
+ (*scan) = (GC_HANDLE_TUPLE (object, 1));
+ return (scan + 1);
+}
+
+DEFINE_GC_HANDLER (gc_handle_pair)
+{
+ (*scan) = (GC_HANDLE_TUPLE (object, 2));
+ return (scan + 1);
+}
+
+DEFINE_GC_HANDLER (gc_handle_triple)
+{
+ (*scan) = (GC_HANDLE_TUPLE (object, 3));
+ return (scan + 1);
+}
+
+DEFINE_GC_HANDLER (gc_handle_quadruple)
+{
+ (*scan) = (GC_HANDLE_TUPLE (object, 4));
+ return (scan + 1);
+}
+
+DEFINE_GC_HANDLER (gc_handle_weak_pair)
+{
+ SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (OBJECT_ADDRESS (object)));
+ (*scan)
+ = ((new_address != 0)
+ ? (OBJECT_NEW_ADDRESS (object, new_address))
+ : (gc_transport_weak_pair (object)));
+ return (scan + 1);
+}
+
+DEFINE_GC_HANDLER (gc_handle_cc_entry)
+{
+ (*scan) = (GC_HANDLE_CC_ENTRY (object));
+ return (scan + 1);
+}
- START_CLOSURE_RELOCATION (Scan);
- Scan += 1;
- count = (MANIFEST_CLOSURE_COUNT (Scan));
- word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan));
- area_end = ((MANIFEST_CLOSURE_END (Scan, count)) - 1);
+DEFINE_GC_HANDLER (gc_handle_aligned_vector)
+{
+ (*scan) = (GC_HANDLE_VECTOR (object, true));
+ return (scan + 1);
+}
+
+DEFINE_GC_HANDLER (gc_handle_unaligned_vector)
+{
+ (*scan) = (GC_HANDLE_VECTOR (object, false));
+ return (scan + 1);
+}
+
+DEFINE_GC_HANDLER (gc_handle_broken_heart)
+{
+ std_gc_death ("broken heart in scan: %#lx", object);
+ return (scan);
+}
+
+DEFINE_GC_HANDLER (gc_handle_nmv)
+{
+ return (scan + 1 + (OBJECT_DATUM (object)));
+}
- while ((--count) >= 0)
+DEFINE_GC_HANDLER (gc_handle_reference_trap)
+{
+ (*scan) = (((OBJECT_DATUM (object)) <= TRAP_MAX_IMMEDIATE)
+ ? object
+ : (GC_HANDLE_TUPLE (object, 2)));
+ return (scan + 1);
+}
+\f
+SCHEME_OBJECT
+gc_raw_address_to_object (unsigned int type, SCHEME_OBJECT * address)
+{
+ return (MAKE_POINTER_OBJECT (type, address));
+}
+
+SCHEME_OBJECT *
+gc_object_to_raw_address (SCHEME_OBJECT object)
+{
+ return (OBJECT_ADDRESS (object));
+}
+
+SCHEME_OBJECT
+gc_raw_address_to_cc_entry (insn_t * address)
+{
+ return (MAKE_CC_ENTRY (address));
+}
+
+insn_t *
+gc_cc_entry_to_raw_address (SCHEME_OBJECT entry)
+{
+ return (CC_ENTRY_ADDRESS (entry));
+}
+
+DEFINE_GC_HANDLER (gc_handle_linkage_section)
+{
+#ifdef CC_SUPPORT_P
+ unsigned long count = (linkage_section_count (object));
+ scan += 1;
+ switch (linkage_section_type (object))
+ {
+ case LINKAGE_SECTION_TYPE_REFERENCE:
+ case LINKAGE_SECTION_TYPE_ASSIGNMENT:
+ while (count > 0)
{
- Scan = ((SCHEME_OBJECT *) (word_ptr));
- word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
- EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
- GC_RAW_POINTER (Setup_Aligned
- (true,
- TRANSPORT_RAW_COMPILED (),
- RAW_COMPILED_BH (true,
- goto next_closure)));
- next_closure:
- STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
+ WRITE_REFERENCE_ADDRESS
+ ((GC_OBJECT_TO_RAW_ADDRESS
+ (GC_HANDLE_TUPLE
+ ((GC_RAW_ADDRESS_TO_OBJECT
+ (TC_HUNK3,
+ (READ_REFERENCE_ADDRESS (scan)))),
+ 3))),
+ scan);
+ scan += 1;
+ count -= 1;
}
+ break;
- Scan = area_end;
- END_CLOSURE_RELOCATION (Scan);
- break;
+ case LINKAGE_SECTION_TYPE_OPERATOR:
+ case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
+ {
+ DECLARE_RELOCATION_REFERENCE (ref);
+ START_OPERATOR_RELOCATION (scan, ref);
+ while (count > 0)
+ {
+ write_uuo_target
+ ((GC_CC_ENTRY_TO_RAW_ADDRESS
+ (GC_HANDLE_CC_ENTRY
+ (GC_RAW_ADDRESS_TO_CC_ENTRY
+ (READ_UUO_TARGET (scan, ref))))),
+ scan);
+ scan += UUO_LINK_SIZE;
+ count -= 1;
+ }
}
+ break;
- case_compiled_entry_point:
- GC_Pointer (Setup_Aligned (true,
- Transport_Compiled (),
- Compiled_BH (true, goto after_entry)));
- after_entry:
- *Scan = Temp;
- break;
+ default:
+ std_gc_death ("Unknown linkage-section type.");
+ break;
+ }
+ return (scan);
+#else
+ gc_no_cc_support ();
+ return (scan);
+#endif
+}
- case_Cell:
- Setup_Pointer_for_GC(Transport_Cell());
- break;
+DEFINE_GC_HANDLER (gc_handle_manifest_closure)
+{
+#ifdef CC_SUPPORT_P
+#ifdef EMBEDDED_CLOSURE_ADDRS_P
+ DECLARE_RELOCATION_REFERENCE (ref);
+ START_CLOSURE_RELOCATION (scan, ref);
+ scan += 1;
+ {
+ insn_t * start = (compiled_closure_start (scan));
+ unsigned long count = (compiled_closure_count (scan));
+ while (count > 0)
+ {
+ write_compiled_closure_target
+ ((GC_CC_ENTRY_TO_RAW_ADDRESS
+ (GC_HANDLE_CC_ENTRY
+ (GC_RAW_ADDRESS_TO_CC_ENTRY
+ (READ_COMPILED_CLOSURE_TARGET (start, ref))))),
+ start);
+ start = (compiled_closure_next (start));
+ count -= 1;
+ }
+ scan = (skip_compiled_closure_padding (start));
+ }
+ return (scan);
+#else
+ return (compiled_closure_objects (scan + 1));
+#endif
+#else
+ gc_no_cc_support ();
+ return (scan);
+#endif
+}
+
+DEFINE_GC_HANDLER (gc_handle_undefined)
+{
+ gc_bad_type (object);
+ return (scan + 1);
+}
+\f
+/* Weak pairs are supported by adding an extra pass to the GC. During
+ the normal pass, a weak pair is transported to new space, but the
+ car of the pair is marked as a non-pointer so it won't be traced.
+ Then the original weak pair in old space is chained into a list.
+ This work is performed by 'gc_transport_weak_pair'.
+
+ At the end of this pass, we have a list of all of the old weak
+ pairs. Since each weak pair in old space has a broken-heart
+ pointer to the corresponding weak pair in new space, we also have a
+ list of all of the new weak pairs.
+
+ The extra pass then traverses this list, restoring the original
+ type of the object in the car of each pair. Then, if the car is a
+ pointer that hasn't been copied to new space, it is replaced by #F.
+ This work is performed by 'update_weak_pointers'.
+
+ Here is a diagram showing the layout of a weak pair immediately
+ after it is transported to new space. After the normal pass is
+ complete, the only thing that will have changed is that the "old
+ CDR object" will have been updated to point to new space, if it is
+ a pointer object.
+
+
+ weak_chain old space | new space
+ | _______________________ | _______________________
+ | |broken | new | | | | |
+ +=====>|heart | location ======|==>| NULL | old CAR data |
+ |_______|_____________| | |______|______________|
+ |old car| next in | | | |
+ | type | chain | | | old CDR object |
+ |_______|_____________| | |_____________________|
+
+ */
+
+static SCHEME_OBJECT
+gc_transport_weak_pair (SCHEME_OBJECT pair)
+{
+ SCHEME_OBJECT * old_addr = (OBJECT_ADDRESS (pair));
+ SCHEME_OBJECT * new_addr = (GC_TRANSPORT_WORDS (old_addr, 2, false));
+ SCHEME_OBJECT old_car = (READ_TOSPACE (new_addr));
+ SCHEME_OBJECT * caddr;
+
+ /* Don't add pair to chain unless old_car is a pointer into old
+ space. */
+
+ switch (gc_ptr_type (old_car))
+ {
+ case GC_POINTER_NORMAL:
+ caddr = (OBJECT_ADDRESS (old_car));
+ break;
+
+ case GC_POINTER_COMPILED:
+#ifdef CC_SUPPORT_P
+ caddr = (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (old_car)));
+#else
+ gc_no_cc_support ();
+#endif
+ break;
+
+ default:
+ caddr = 0;
+ break;
+ }
+ if ((caddr != 0) && (ADDRESS_IN_FROMSPACE_P (caddr)))
+ {
+ WRITE_TOSPACE (new_addr, (OBJECT_NEW_TYPE (TC_NULL, old_car)));
+ (old_addr[1])
+ = ((weak_chain == 0)
+ ? (MAKE_OBJECT ((OBJECT_TYPE (old_car)), 0))
+ : (MAKE_POINTER_OBJECT ((OBJECT_TYPE (old_car)), weak_chain)));
+ weak_chain = old_addr;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ weak_chain_length += 1;
+#endif
+ }
+ return (OBJECT_NEW_ADDRESS (pair, new_addr));
+}
+
+void
+initialize_weak_chain (void)
+{
+ weak_chain = 0;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ weak_chain_length = 0;
+#endif
+}
+
+void
+update_weak_pointers (void)
+{
+#if 0
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ outf_console ("; **** Weak chain length = %lu\n", weak_chain_length);
+ outf_flush_console ();
+#endif
+#endif
+ while (weak_chain != 0)
+ {
+ SCHEME_OBJECT * new_addr = (OBJECT_ADDRESS (weak_chain[0]));
+ SCHEME_OBJECT obj = (weak_chain[1]);
+ SCHEME_OBJECT old_car
+ = (OBJECT_NEW_TYPE ((OBJECT_TYPE (obj)),
+ (READ_TOSPACE (new_addr))));
+ SCHEME_OBJECT * addr;
- case TC_REFERENCE_TRAP:
- if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
+ switch (gc_ptr_type (old_car))
{
- /* It is a non pointer. */
+ case GC_POINTER_NORMAL:
+ addr = (OBJECT_ADDRESS (old_car));
+ WRITE_TOSPACE (new_addr,
+ ((BROKEN_HEART_P (*addr))
+ ? (MAKE_OBJECT_FROM_OBJECTS (old_car, (*addr)))
+ : SHARP_F));
+ break;
+
+ case GC_POINTER_COMPILED:
+#ifdef CC_SUPPORT_P
+ addr = (cc_entry_address_to_block_address
+ (CC_ENTRY_ADDRESS (old_car)));
+ WRITE_TOSPACE (new_addr,
+ ((BROKEN_HEART_P (*addr))
+ ? (CC_ENTRY_NEW_BLOCK (old_car,
+ (OBJECT_ADDRESS (*addr)),
+ addr))
+ : SHARP_F));
+#else
+ std_gc_death (0, "update_weak_pointers: unsupported compiled code");
+#endif
+ break;
+
+ case GC_POINTER_NOT:
+ std_gc_death ("update_weak_pointers: non-pointer found");
break;
}
- /* Fall Through. */
+ weak_chain = (((OBJECT_DATUM (obj)) == 0) ? 0 : (OBJECT_ADDRESS (obj)));
+ }
+}
+\f
+void
+std_gc_death (const char * format, ...)
+{
+ va_list ap;
- case_Pair:
- Setup_Pointer_for_GC (Transport_Pair ());
- break;
+ va_start (ap, format);
+ outf_fatal ("\n");
+ voutf_fatal (format, ap);
+ outf_fatal ("\n");
+ if (current_scan != 0)
+ {
+ outf_fatal ("scan = 0x%lx", ((unsigned long) current_scan));
+ if (tospace_next != 0)
+ outf_fatal ("; to = 0x%lx", ((unsigned long) tospace_next));
+ outf_fatal ("\n");
+ }
+ va_end (ap);
+ if (gc_abort_handler != 0)
+ (*gc_abort_handler) ();
+ exit (1);
+}
+
+static void
+tospace_closed (void)
+{
+ std_gc_death ("GC transport not allowed here");
+}
+
+static void
+tospace_open (void)
+{
+ if (tospace_next != 0)
+ std_gc_death ("tospace is open, should be closed");
+}
+
+void
+gc_no_cc_support (void)
+{
+ std_gc_death ("No compiled-code support.");
+}
+
+void
+gc_bad_type (SCHEME_OBJECT object)
+{
+ std_gc_death ("bad type code: %#02lx %#lx",
+ (OBJECT_TYPE (object)),
+ object);
+}
\f
- case TC_VARIABLE:
- case_Triple:
- Setup_Pointer_for_GC (Transport_Triple ());
- break;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
- case_Quadruple:
- Setup_Pointer_for_GC (Transport_Quadruple ());
- break;
+static void
+initialize_gc_history (void)
+{
+ gc_scan_history_index = 0;
+ memset (gc_scan_history, 0, (sizeof (gc_scan_history)));
+ memset (gc_to_history, 0, (sizeof (gc_to_history)));
+}
- case_Aligned_Vector:
- GC_Pointer (Setup_Aligned (true,
- goto Move_Vector,
- Normal_BH (true, continue)));
- break;
+static void
+handle_gc_trap (SCHEME_OBJECT * scan, SCHEME_OBJECT object)
+{
+ (gc_scan_history[gc_scan_history_index]) = scan;
+ (gc_to_history[gc_scan_history_index]) = newspace_next;
+ gc_scan_history_index += 1;
+ if (gc_scan_history_index == GC_SCAN_HISTORY_SIZE)
+ gc_scan_history_index = 0;
+ if ((object == gc_trap)
+ || ((gc_scan_trap != 0)
+ && (scan >= gc_scan_trap))
+ || ((gc_to_trap != 0)
+ && (newspace_next != 0)
+ && (newspace_next >= gc_to_trap)))
+ {
+ outf_error ("\nhandle_gc_trap: trap.\n");
+ abort ();
+ }
+}
- case_Vector:
- Setup_Pointer_for_GC (Transport_Vector ());
- break;
+static void
+check_newspace_sync (void)
+{
+ if ((newspace_next - newspace_start)
+ != (tospace_next - tospace_start))
+ std_gc_death ("mismatch between newspace and tospace ptrs: %d/%d",
+ (newspace_next - newspace_start),
+ (tospace_next - tospace_start));
+}
- case TC_FUTURE:
- Setup_Pointer_for_GC (Transport_Future ());
- break;
+void
+collect_gc_object_references (SCHEME_OBJECT object, SCHEME_OBJECT collector)
+{
+ gc_object_referenced = object;
+ gc_object_references = collector;
+}
- case TC_WEAK_CONS:
- Setup_Pointer_for_GC (Transport_Weak_Cons ());
- break;
+static void
+debug_transport_one_word (SCHEME_OBJECT object, SCHEME_OBJECT * from)
+{
+ if ((gc_object_references != SHARP_F)
+ && (gc_object_referenced == (*from)))
+ {
+ gc_object_references_count += 1;
+ if (gc_object_references_scan < gc_object_references_end)
+ (*gc_object_references_scan++) = object;
+ }
+}
+
+void
+initialize_gc_object_references (void)
+{
+ if (gc_object_references != SHARP_F)
+ {
+ /* Temporarily change to non-marked vector. */
+ MEMORY_SET
+ (gc_object_references, 0,
+ (MAKE_OBJECT
+ (TC_MANIFEST_NM_VECTOR,
+ (OBJECT_DATUM (MEMORY_REF (gc_object_references, 0))))));
+ gc_object_references_count = 0;
+ gc_object_references_scan = (VECTOR_LOC (gc_object_references, 1));
+ gc_object_references_end
+ = (VECTOR_LOC (gc_object_references,
+ (VECTOR_LENGTH (gc_object_references))));
+ /* Wipe the table. */
+ VECTOR_SET (gc_object_references, 0, FIXNUM_ZERO);
+ {
+ SCHEME_OBJECT * scan = gc_object_references_scan;
+ while (scan < gc_object_references_end)
+ (*scan++) = SHARP_F;
+ }
+ (*tospace_next++) = gc_object_references;
+ newspace_next += 1;
+ }
+}
- default:
- GC_BAD_TYPE ("gcloop", Temp);
- /* Fall Through */
+void
+finalize_gc_object_references (void)
+{
+ if (gc_object_references != SHARP_F)
+ {
+ SCHEME_OBJECT header = (MEMORY_REF (gc_object_references, 0));
+ if (BROKEN_HEART_P (header))
+ {
+ SCHEME_OBJECT * to_addr
+ = (NEWSPACE_TO_TOSPACE (OBJECT_ADDRESS (header)));
+ SCHEME_OBJECT * scan_to = to_addr;
+ SCHEME_OBJECT * scan_from = (VECTOR_LOC (gc_object_references, 0));
- case_Non_Pointer:
- break;
+ /* Change back to marked vector. */
+ (*scan_to++)
+ = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (OBJECT_DATUM (*to_addr))));
+
+ /* Store the count in the table. */
+ VECTOR_SET (gc_object_references, 0,
+ (ULONG_TO_FIXNUM (gc_object_references_count)));
+
+ /* Make sure tospace copy is up to date. */
+ while (scan_from < gc_object_references_scan)
+ (*scan_to++) = (*scan_from++);
+
+ /* No need to scan the vector's contents, since anything
+ here has already been transported. */
+ }
+ gc_object_references = SHARP_F;
+ gc_object_referenced = SHARP_F;
+ }
+}
- } /* Switch_by_GC_Type */
- } /* For loop */
+#endif /* ENABLE_GC_DEBUGGING_TOOLS */
+\f
+gc_type_t gc_type_map [N_TYPE_CODES] =
+{
+ GC_NON_POINTER, /* TC_NULL,etc */
+ GC_PAIR, /* TC_LIST */
+ GC_NON_POINTER, /* TC_CHARACTER */
+ GC_PAIR, /* TC_SCODE_QUOTE */
+ GC_TRIPLE, /* TC_PCOMB2 */
+ GC_PAIR, /* TC_UNINTERNED_SYMBOL */
+ GC_VECTOR, /* TC_BIG_FLONUM */
+ GC_PAIR, /* TC_COMBINATION_1 */
+ GC_NON_POINTER, /* TC_CONSTANT */
+ GC_PAIR, /* TC_EXTENDED_PROCEDURE */
+ GC_VECTOR, /* TC_VECTOR */
+ GC_NON_POINTER, /* TC_RETURN_CODE */
+ GC_TRIPLE, /* TC_COMBINATION_2 */
+ GC_SPECIAL, /* TC_MANIFEST_CLOSURE */
+ GC_VECTOR, /* TC_BIG_FIXNUM */
+ GC_PAIR, /* TC_PROCEDURE */
+ GC_PAIR, /* TC_ENTITY */
+ GC_PAIR, /* TC_DELAY */
+ GC_VECTOR, /* TC_ENVIRONMENT */
+ GC_PAIR, /* TC_DELAYED */
+ GC_TRIPLE, /* TC_EXTENDED_LAMBDA */
+ GC_PAIR, /* TC_COMMENT */
+ GC_VECTOR, /* TC_NON_MARKED_VECTOR */
+ GC_PAIR, /* TC_LAMBDA */
+ GC_NON_POINTER, /* TC_PRIMITIVE */
+ GC_PAIR, /* TC_SEQUENCE_2 */
+ GC_NON_POINTER, /* TC_FIXNUM */
+ GC_PAIR, /* TC_PCOMB1 */
+ GC_VECTOR, /* TC_CONTROL_POINT */
+ GC_PAIR, /* TC_INTERNED_SYMBOL */
+ GC_VECTOR, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
+ GC_PAIR, /* TC_ACCESS */
+ GC_TRIPLE, /* TC_HUNK3_A */
+ GC_PAIR, /* TC_DEFINITION */
+ GC_SPECIAL, /* TC_BROKEN_HEART */
+ GC_PAIR, /* TC_ASSIGNMENT */
+ GC_TRIPLE, /* TC_HUNK3_B */
+ GC_PAIR, /* TC_IN_PACKAGE */
+ GC_VECTOR, /* TC_COMBINATION */
+ GC_SPECIAL, /* TC_MANIFEST_NM_VECTOR */
+ GC_COMPILED, /* TC_COMPILED_ENTRY */
+ GC_PAIR, /* TC_LEXPR */
+ GC_VECTOR, /* TC_PCOMB3 */
+ GC_UNDEFINED, /* 0x2B */
+ GC_TRIPLE, /* TC_VARIABLE */
+ GC_NON_POINTER, /* TC_THE_ENVIRONMENT */
+ GC_UNDEFINED, /* 0x2E */
+ GC_VECTOR, /* TC_VECTOR_1B,TC_BIT_STRING */
+ GC_NON_POINTER, /* TC_PCOMB0 */
+ GC_VECTOR, /* TC_VECTOR_16B */
+ GC_SPECIAL, /* TC_REFERENCE_TRAP */
+ GC_TRIPLE, /* TC_SEQUENCE_3 */
+ GC_TRIPLE, /* TC_CONDITIONAL */
+ GC_PAIR, /* TC_DISJUNCTION */
+ GC_CELL, /* TC_CELL */
+ GC_PAIR, /* TC_WEAK_CONS */
+ GC_QUADRUPLE, /* TC_QUAD */
+ GC_SPECIAL, /* TC_LINKAGE_SECTION */
+ GC_PAIR, /* TC_RATNUM */
+ GC_NON_POINTER, /* TC_STACK_ENVIRONMENT */
+ GC_PAIR, /* TC_COMPLEX */
+ GC_VECTOR, /* TC_COMPILED_CODE_BLOCK */
+ GC_VECTOR, /* TC_RECORD */
+ GC_UNDEFINED /* 0x3F */
+};
+
+#if (N_TYPE_CODES != 0x40)
+# include "gcloop.c and object.h inconsistent -- gc_type_map"
+#endif
+\f
+gc_type_t
+gc_type_code (unsigned int type_code)
+{
+ return (gc_type_map[type_code]);
+}
+
+gc_ptr_type_t
+gc_ptr_type (SCHEME_OBJECT object)
+{
+ switch (GC_TYPE (object))
+ {
+ case GC_SPECIAL:
+ return
+ (((REFERENCE_TRAP_P (object))
+ && ((OBJECT_DATUM (object)) >= TRAP_MAX_IMMEDIATE))
+ ? GC_POINTER_NORMAL
+ : GC_POINTER_NOT);
- *To_Pointer = To;
- return (To);
+ case GC_CELL:
+ case GC_PAIR:
+ case GC_TRIPLE:
+ case GC_QUADRUPLE:
+ case GC_VECTOR:
+ return (GC_POINTER_NORMAL);
-} /* GCLoop */
+ case GC_COMPILED:
+ return (GC_POINTER_COMPILED);
+ break;
+
+ default:
+ return (GC_POINTER_NOT);
+ }
+}
+
+SCHEME_OBJECT *
+get_object_address (SCHEME_OBJECT object)
+{
+ switch (gc_ptr_type (object))
+ {
+ case GC_POINTER_NORMAL:
+ return (OBJECT_ADDRESS (object));
+
+ case GC_POINTER_COMPILED:
+#ifdef CC_SUPPORT_P
+ return (cc_entry_to_block_address (object));
+#endif
+
+ default:
+ return (0);
+ }
+}
+++ /dev/null
-/* -*-C-*-
-
-$Id: gctype.c,v 9.38 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains the table which maps between Types and GC Types. */
-
-#include "config.h" /* for definition of TYPE_CODE_LENGTH */
-\f
- /*********************************/
- /* Mapping GC_Type to Type_Codes */
- /*********************************/
-
-int GC_Type_Map[MAX_TYPE_CODE + 1] = {
- GC_Non_Pointer, /* TC_NULL,etc */
- GC_Pair, /* TC_LIST */
- GC_Non_Pointer, /* TC_CHARACTER */
- GC_Pair, /* TC_SCODE_QUOTE */
- GC_Triple, /* TC_PCOMB2 */
- GC_Pair, /* TC_UNINTERNED_SYMBOL */
- GC_Vector, /* TC_BIG_FLONUM */
- GC_Pair, /* TC_COMBINATION_1 */
- GC_Non_Pointer, /* TC_CONSTANT */
- GC_Pair, /* TC_EXTENDED_PROCEDURE */
- GC_Vector, /* TC_VECTOR */
- GC_Non_Pointer, /* TC_RETURN_CODE */
- GC_Triple, /* TC_COMBINATION_2 */
- GC_Special, /* TC_MANIFEST_CLOSURE */
- GC_Vector, /* TC_BIG_FIXNUM */
- GC_Pair, /* TC_PROCEDURE */
- GC_Pair, /* TC_ENTITY */
- GC_Pair, /* TC_DELAY */
- GC_Vector, /* TC_ENVIRONMENT */
- GC_Pair, /* TC_DELAYED */
- GC_Triple, /* TC_EXTENDED_LAMBDA */
- GC_Pair, /* TC_COMMENT */
- GC_Vector, /* TC_NON_MARKED_VECTOR */
- GC_Pair, /* TC_LAMBDA */
- GC_Non_Pointer, /* TC_PRIMITIVE */
- GC_Pair, /* TC_SEQUENCE_2 */
- GC_Non_Pointer, /* TC_FIXNUM */
- GC_Pair, /* TC_PCOMB1 */
- GC_Vector, /* TC_CONTROL_POINT */
- GC_Pair, /* TC_INTERNED_SYMBOL */
- GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
- GC_Pair, /* TC_ACCESS */
- GC_Triple, /* TC_HUNK3_A */
- GC_Pair, /* TC_DEFINITION */
- GC_Special, /* TC_BROKEN_HEART */
- GC_Pair, /* TC_ASSIGNMENT */
- GC_Triple, /* TC_HUNK3_B */
- GC_Pair, /* TC_IN_PACKAGE */
-
-/* GC_Type_Map continues on next page */
-\f
-/* GC_Type_Map continued */
-
- GC_Vector, /* TC_COMBINATION */
- GC_Special, /* TC_MANIFEST_NM_VECTOR */
- GC_Compiled, /* TC_COMPILED_ENTRY */
- GC_Pair, /* TC_LEXPR */
- GC_Vector, /* TC_PCOMB3 */
- GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */
- GC_Triple, /* TC_VARIABLE */
- GC_Non_Pointer, /* TC_THE_ENVIRONMENT */
- GC_Vector, /* TC_FUTURE */
- GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */
- GC_Non_Pointer, /* TC_PCOMB0 */
- GC_Vector, /* TC_VECTOR_16B */
- GC_Special, /* TC_REFERENCE_TRAP */
- GC_Triple, /* TC_SEQUENCE_3 */
- GC_Triple, /* TC_CONDITIONAL */
- GC_Pair, /* TC_DISJUNCTION */
- GC_Cell, /* TC_CELL */
- GC_Pair, /* TC_WEAK_CONS */
- GC_Quadruple, /* TC_QUAD */
- GC_Special, /* TC_LINKAGE_SECTION */
- GC_Pair, /* TC_RATNUM */
- GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
- GC_Pair, /* TC_COMPLEX */
- GC_Vector, /* TC_COMPILED_CODE_BLOCK */
- GC_Vector, /* TC_RECORD */
-
-#if (TYPE_CODE_LENGTH == 6)
-
- GC_Undefined /* 0x3F */
-
-#else /* (TYPE_CODE_LENGTH != 6) */
-
- GC_Undefined, /* 0x3F */
- GC_Undefined, /* 0x40 */
- GC_Undefined, /* 0x41 */
- GC_Undefined, /* 0x42 */
- GC_Undefined, /* 0x43 */
- GC_Undefined, /* 0x44 */
- GC_Undefined, /* 0x45 */
- GC_Undefined, /* 0x46 */
- GC_Undefined, /* 0x47 */
- GC_Undefined, /* 0x48 */
- GC_Undefined, /* 0x49 */
- GC_Undefined, /* 0x4A */
- GC_Undefined, /* 0x4B */
- GC_Undefined, /* 0x4C */
- GC_Undefined, /* 0x4D */
- GC_Undefined, /* 0x4E */
- GC_Undefined, /* 0x4F */
- GC_Undefined, /* 0x50 */
- GC_Undefined, /* 0x51 */
- GC_Undefined, /* 0x52 */
- GC_Undefined, /* 0x53 */
- GC_Undefined, /* 0x54 */
-
-/* GC_Type_Map continues on next page */
-\f
-/* GC_Type_Map continued */
-
- GC_Undefined, /* 0x55 */
- GC_Undefined, /* 0x56 */
- GC_Undefined, /* 0x57 */
- GC_Undefined, /* 0x58 */
- GC_Undefined, /* 0x59 */
- GC_Undefined, /* 0x5A */
- GC_Undefined, /* 0x5B */
- GC_Undefined, /* 0x5C */
- GC_Undefined, /* 0x5D */
- GC_Undefined, /* 0x5E */
- GC_Undefined, /* 0x5F */
- GC_Undefined, /* 0x60 */
- GC_Undefined, /* 0x61 */
- GC_Undefined, /* 0x62 */
- GC_Undefined, /* 0x63 */
- GC_Undefined, /* 0x64 */
- GC_Undefined, /* 0x65 */
- GC_Undefined, /* 0x66 */
- GC_Undefined, /* 0x67 */
- GC_Undefined, /* 0x68 */
- GC_Undefined, /* 0x69 */
- GC_Undefined, /* 0x6A */
- GC_Undefined, /* 0x6B */
- GC_Undefined, /* 0x6C */
- GC_Undefined, /* 0x6D */
- GC_Undefined, /* 0x6E */
- GC_Undefined, /* 0x6F */
- GC_Undefined, /* 0x70 */
- GC_Undefined, /* 0x71 */
- GC_Undefined, /* 0x72 */
- GC_Undefined, /* 0x73 */
- GC_Undefined, /* 0x74 */
- GC_Undefined, /* 0x75 */
- GC_Undefined, /* 0x76 */
- GC_Undefined, /* 0x77 */
- GC_Undefined, /* 0x78 */
- GC_Undefined, /* 0x79 */
- GC_Undefined, /* 0x7A */
- GC_Undefined, /* 0x7B */
- GC_Undefined, /* 0x7C */
- GC_Undefined, /* 0x7D */
- GC_Undefined, /* 0x7E */
- GC_Undefined, /* 0x7F */
-\f
- GC_Undefined, /* 0x80 */
- GC_Undefined, /* 0x81 */
- GC_Undefined, /* 0x82 */
- GC_Undefined, /* 0x83 */
- GC_Undefined, /* 0x84 */
- GC_Undefined, /* 0x85 */
- GC_Undefined, /* 0x86 */
- GC_Undefined, /* 0x87 */
- GC_Undefined, /* 0x88 */
- GC_Undefined, /* 0x89 */
- GC_Undefined, /* 0x8A */
- GC_Undefined, /* 0x8B */
- GC_Undefined, /* 0x8C */
- GC_Undefined, /* 0x8D */
- GC_Undefined, /* 0x8E */
- GC_Undefined, /* 0x8F */
- GC_Undefined, /* 0x90 */
- GC_Undefined, /* 0x91 */
- GC_Undefined, /* 0x92 */
- GC_Undefined, /* 0x93 */
- GC_Undefined, /* 0x94 */
- GC_Undefined, /* 0x95 */
- GC_Undefined, /* 0x96 */
- GC_Undefined, /* 0x97 */
- GC_Undefined, /* 0x98 */
- GC_Undefined, /* 0x99 */
- GC_Undefined, /* 0x9A */
- GC_Undefined, /* 0x9B */
- GC_Undefined, /* 0x9C */
- GC_Undefined, /* 0x9D */
- GC_Undefined, /* 0x9E */
- GC_Undefined, /* 0x9F */
- GC_Undefined, /* 0xA0 */
- GC_Undefined, /* 0xA1 */
- GC_Undefined, /* 0xA2 */
- GC_Undefined, /* 0xA3 */
- GC_Undefined, /* 0xA4 */
- GC_Undefined, /* 0xA5 */
- GC_Undefined, /* 0xA6 */
- GC_Undefined, /* 0xA7 */
- GC_Undefined, /* 0xA8 */
- GC_Undefined, /* 0xA9 */
- GC_Undefined, /* 0xAA */
- GC_Undefined, /* 0xAB */
- GC_Undefined, /* 0xAC */
- GC_Undefined, /* 0xAD */
- GC_Undefined, /* 0xAE */
- GC_Undefined, /* 0xAF */
-\f
- GC_Undefined, /* 0xB0 */
- GC_Undefined, /* 0xB1 */
- GC_Undefined, /* 0xB2 */
- GC_Undefined, /* 0xB3 */
- GC_Undefined, /* 0xB4 */
- GC_Undefined, /* 0xB5 */
- GC_Undefined, /* 0xB6 */
- GC_Undefined, /* 0xB7 */
- GC_Undefined, /* 0xB8 */
- GC_Undefined, /* 0xB9 */
- GC_Undefined, /* 0xBA */
- GC_Undefined, /* 0xBB */
- GC_Undefined, /* 0xBC */
- GC_Undefined, /* 0xBD */
- GC_Undefined, /* 0xBE */
- GC_Undefined, /* 0xBF */
- GC_Undefined, /* 0xC0 */
- GC_Undefined, /* 0xC1 */
- GC_Undefined, /* 0xC2 */
- GC_Undefined, /* 0xC3 */
- GC_Undefined, /* 0xC4 */
- GC_Undefined, /* 0xC5 */
- GC_Undefined, /* 0xC6 */
- GC_Undefined, /* 0xC7 */
- GC_Undefined, /* 0xC8 */
- GC_Undefined, /* 0xC9 */
- GC_Undefined, /* 0xCA */
- GC_Undefined, /* 0xCB */
- GC_Undefined, /* 0xCC */
- GC_Undefined, /* 0xCD */
- GC_Undefined, /* 0xCE */
- GC_Undefined, /* 0xCF */
- GC_Undefined, /* 0xD0 */
- GC_Undefined, /* 0xD1 */
- GC_Undefined, /* 0xD2 */
- GC_Undefined, /* 0xD3 */
- GC_Undefined, /* 0xD4 */
- GC_Undefined, /* 0xD5 */
- GC_Undefined, /* 0xD6 */
- GC_Undefined, /* 0xD7 */
- GC_Undefined, /* 0xD8 */
- GC_Undefined, /* 0xD9 */
- GC_Undefined, /* 0xDA */
- GC_Undefined, /* 0xDB */
- GC_Undefined, /* 0xDC */
- GC_Undefined, /* 0xDD */
- GC_Undefined, /* 0xDE */
- GC_Undefined, /* 0xDF */
-\f
- GC_Undefined, /* 0xE0 */
- GC_Undefined, /* 0xE1 */
- GC_Undefined, /* 0xE2 */
- GC_Undefined, /* 0xE3 */
- GC_Undefined, /* 0xE4 */
- GC_Undefined, /* 0xE5 */
- GC_Undefined, /* 0xE6 */
- GC_Undefined, /* 0xE7 */
- GC_Undefined, /* 0xE8 */
- GC_Undefined, /* 0xE9 */
- GC_Undefined, /* 0xEA */
- GC_Undefined, /* 0xEB */
- GC_Undefined, /* 0xEC */
- GC_Undefined, /* 0xED */
- GC_Undefined, /* 0xEE */
- GC_Undefined, /* 0xEF */
- GC_Undefined, /* 0xF0 */
- GC_Undefined, /* 0xF1 */
- GC_Undefined, /* 0xF2 */
- GC_Undefined, /* 0xF3 */
- GC_Undefined, /* 0xF4 */
- GC_Undefined, /* 0xF5 */
- GC_Undefined, /* 0xF6 */
- GC_Undefined, /* 0xF7 */
- GC_Undefined, /* 0xF8 */
- GC_Undefined, /* 0xF9 */
- GC_Undefined, /* 0xFA */
- GC_Undefined, /* 0xFB */
- GC_Undefined, /* 0xFC */
- GC_Undefined, /* 0xFD */
- GC_Undefined, /* 0xFE */
- GC_Undefined /* last */
-#endif /* (TYPE_CODE_LENGTH != 6) */
-
- };
-
-#if (TYPE_CODE_LENGTH == 6)
-
-#if (MAX_TYPE_CODE != 0x3F)
-#include "gctype.c and object.h inconsistent -- GC_Type_Map"
-#endif
-
-#else /* (TYPE_CODE_LENGTH != 6) */
-
-#if (MAX_TYPE_CODE != 0xFF)
-#include "gctype.c and object.h inconsistent -- GC_Type_Map"
-#endif
-
-#endif /* (TYPE_CODE_LENGTH == 6) */
/* -*-C-*-
-$Id: generic.c,v 9.43 2007/01/05 21:19:25 cph Exp $
+$Id: generic.c,v 9.44 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
\f
#define INDIRECT(slot, arity) \
{ \
- PRIMITIVE_CANONICALIZE_CONTEXT (); \
+ canonicalize_primitive_context (); \
Will_Push (STACK_ENV_EXTRA_SLOTS + 1); \
- STACK_PUSH (Get_Fixed_Obj_Slot (slot)); \
- STACK_PUSH (STACK_FRAME_HEADER + arity); \
+ STACK_PUSH (VECTOR_REF (fixed_objects, slot)); \
+ PUSH_APPLY_FRAME_HEADER (arity); \
Pushed (); \
PRIMITIVE_ABORT (PRIM_APPLY); \
/*NOTREACHED*/ \
{ \
PRIMITIVE_HEADER (1); \
{ \
- fast SCHEME_OBJECT x = (ARG_REF (1)); \
+ SCHEME_OBJECT x = (ARG_REF (1)); \
if (FIXNUM_P (x)) \
return (BOOLEAN_TO_OBJECT (test (x))); \
} \
{ \
PRIMITIVE_HEADER (1); \
{ \
- fast SCHEME_OBJECT x = (ARG_REF (1)); \
+ SCHEME_OBJECT x = (ARG_REF (1)); \
if (FIXNUM_P (x)) \
return (long_to_integer ((FIXNUM_TO_LONG (x)) op 1)); \
} \
{ \
PRIMITIVE_HEADER (2); \
{ \
- fast SCHEME_OBJECT x = (ARG_REF (1)); \
- fast SCHEME_OBJECT y = (ARG_REF (2)); \
+ SCHEME_OBJECT x = (ARG_REF (1)); \
+ SCHEME_OBJECT y = (ARG_REF (2)); \
if ((FIXNUM_P (x)) && (FIXNUM_P (y))) \
return (BOOLEAN_TO_OBJECT (test (x, y))); \
} \
{ \
PRIMITIVE_HEADER (2); \
{ \
- fast SCHEME_OBJECT x = (ARG_REF (1)); \
- fast SCHEME_OBJECT y = (ARG_REF (2)); \
+ SCHEME_OBJECT x = (ARG_REF (1)); \
+ SCHEME_OBJECT y = (ARG_REF (2)); \
if ((FIXNUM_P (x)) && (FIXNUM_P (y))) \
return (long_to_integer ((FIXNUM_TO_LONG (x)) op \
(FIXNUM_TO_LONG (y)))); \
+++ /dev/null
-#ifdef BSD
-#ifndef BSD4_1
-#define HAVE_GETPAGESIZE
-#endif
-#endif
-
-#ifndef HAVE_GETPAGESIZE
-
-#include <sys/param.h>
-
-#ifdef EXEC_PAGESIZE
-#define getpagesize() EXEC_PAGESIZE
-#else
-#ifdef NBPG
-#define getpagesize() NBPG * CLSIZE
-#ifndef CLSIZE
-#define CLSIZE 1
-#endif /* no CLSIZE */
-#else /* no NBPG */
-#define getpagesize() NBPC
-#endif /* no NBPG */
-#endif /* no EXEC_PAGESIZE */
-
-#endif /* not HAVE_GETPAGESIZE */
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* $Id: gpio.c,v 1.15 2007/01/05 21:19:25 cph Exp $ */
-
-/* Scheme primitives for GPIO */
-
-#include "scheme.h"
-#include "prims.h"
-#include "ux.h"
-#include "uxio.h"
-
-#include <stdio.h>
-#include <fcntl.h>
-#include <dvio.h>
-\f
-DEFINE_PRIMITIVE ("GPIO-OPEN", Prim_gpio_open, 1, 1, 0)
-{
- int gpio_channel;
-
- PRIMITIVE_HEADER (1);
-
- gpio_channel = (open (STRING_ARG (1), (O_RDWR | O_NDELAY)));
- if (gpio_channel == -1)
- {
- error_external_return();
- }
- if (!(LONG_TO_FIXNUM_P( gpio_channel)))
- {
- /* This is a crock, but guarantees that we can assume fixnum
- in all the other primitives.
- */
- close (gpio_channel);
- error_external_return();
- }
-
- /* Reset interface */
-
- io_reset (gpio_channel);
-
- /* Timeout in 5 sec. */
- io_timeout_ctl (gpio_channel, 5000000);
-
- /* Guarantee exclusive access. */
- io_lock (gpio_channel);
-
-#if 1
- /* Map into address space. */
- io_burst (gpio_channel, 1);
-#endif
-
- /* Set data width to 16 bits. */
- io_width_ctl (gpio_channel, 16);
-
- PRIMITIVE_RETURN( LONG_TO_FIXNUM (gpio_channel));
-}
-
-
-DEFINE_PRIMITIVE ("GPIO-CLOSE", Prim_gpio_close, 1, 1, 0)
-{
- int gpio_channel;
-
- PRIMITIVE_HEADER (1);
-
- gpio_channel = (UNSIGNED_FIXNUM_ARG (1));
-
-#if 1
- io_burst (gpio_channel, 0);
-#endif
-
- io_unlock (gpio_channel);
- close (gpio_channel);
-
- PRIMITIVE_RETURN( long_to_integer( gpio_channel ));
-}
-
-
-DEFINE_PRIMITIVE ("GPIO-READ-STATUS", Prim_gpio_read_status, 1, 1, 0)
-{
- int gpio_channel;
-
- PRIMITIVE_HEADER (1);
-
- gpio_channel = (UNSIGNED_FIXNUM_ARG (1));
-
- PRIMITIVE_RETURN( LONG_TO_FIXNUM( gpio_get_status( gpio_channel)));
-}
-
-
-DEFINE_PRIMITIVE ("GPIO-WRITE-CONTROL", Prim_gpio_write_control, 2, 2, 0)
-{
- int gpio_channel, control_value;
-
- PRIMITIVE_HEADER (2);
-
- gpio_channel = (UNSIGNED_FIXNUM_ARG (1));
- control_value = (UNSIGNED_FIXNUM_ARG (2));
-
- PRIMITIVE_RETURN( LONG_TO_FIXNUM( gpio_set_ctl( gpio_channel, control_value)));
-}
-\f
-/* Both of the following return the number of bytes transferred. */
-
-
-DEFINE_PRIMITIVE ("GPIO-READ-STRING!", Prim_gpio_read_string, 4, 4, 0)
-{
- int gpio_channel, count;
- char *data;
-
- PRIMITIVE_HEADER (4);
-
- gpio_channel = (UNSIGNED_FIXNUM_ARG (1));
- data = ((char *) (STRING_LOC ((ARG_REF (2)), (UNSIGNED_FIXNUM_ARG (3)))));
- count = (UNSIGNED_FIXNUM_ARG (4));
-
- while (1)
- {
- long scr = (read (gpio_channel, data, count));
- if (scr < 0)
- {
- UX_prim_check_errno (syscall_read);
- continue;
- }
- if (scr > count)
- error_external_return ();
- PRIMITIVE_RETURN( LONG_TO_FIXNUM (scr));
- }
-}
-
-
-DEFINE_PRIMITIVE ("GPIO-WRITE-STRING", Prim_gpio_write_string, 4, 4, 0)
-{
- int gpio_channel, count;
- char *data;
-
- PRIMITIVE_HEADER (4);
-
- gpio_channel = (UNSIGNED_FIXNUM_ARG (1));
- data = ((char *) (STRING_LOC ((ARG_REF (2)), (UNSIGNED_FIXNUM_ARG (3)))));
- count = (UNSIGNED_FIXNUM_ARG (4));
-
- while (1)
- {
- long scr = (write (gpio_channel, data, count));
- if (scr < 0)
- {
- UX_prim_check_errno (syscall_write);
- continue;
- }
- if (scr > count)
- error_external_return ();
- PRIMITIVE_RETURN( LONG_TO_FIXNUM (scr));
- }
-}
+++ /dev/null
-/* Everything you wanted to know about your machine and C compiler,
- but didn't know who to ask.
- Author: Steven Pemberton, CWI, Amsterdam; steven@cwi.nl
- Bugfixes and upgrades gratefully received.
-
- Name changed to `hard-params' by Richard Stallman, April 89.
- xmalloc function defined, Richard Stallman, June 89.
- Some changes to make it compile and generate "safer" output
- for compilers that predefine some of these constants by
- Matt Birkholz and the MIT Scheme Team.
-
- Copyright (c) 1988, 1989 Steven Pemberton, CWI, Amsterdam.
- All rights reserved.
-
- COMPILING
- With luck and a following wind, just the following will work:
- cc hard-params.c -o hard-params
-
- If your compiler doesn't support: add flag:
- signed char (eg pcc) -DNO_SC
- unsigned char -DNO_UC
- unsigned short and long -DNO_UI
- signal(), or setjmp/longjmp() -DNO_SIG
-
- Try it first with no flags, and see if you get any errors - you might be
- surprised. (Most non-ANSI compilers need -DNO_SC, though.)
- Some compilers need a -f flag for floating point.
-
- Don't use any optimisation flags: the program may not work if you do.
- Though "while (a+1.0-a-1.0 == 0.0)" may look like "while(1)" to an
- optimiser, to a floating-point unit there's a world of difference.
-
- Some compilers offer various flags for different floating point
- modes; it's worth trying all possible combinations of these.
-
- Add -DID=\"name\" if you want the machine/flags identified in the output.
-
- SYSTEM DEPENDENCIES
- You may possibly need to add some calls to signal() for other sorts of
- exception on your machine than SIGFPE, and SIGOVER. See lines beginning
- #ifdef SIGxxx in main() (and communicate the differences to me!).
-
- If your C preprocessor doesn't have the predefined __FILE__ macro, and
- you want to call this file anything other than hard-params.c, change the
- #define command for __FILE__ accordingly. If it doesn't accept macro
- names at all in #include lines, order a new C compiler. While you're
- waiting for it to arrive, change the last #include in this file (the
- last but one line) accordingly.
-
- OUTPUT
- Run without argument to get the information as English text. If run
- with argument -l (e.g. hard-params -l), output is a series of #define's for
- the ANSI standard limits.h include file, excluding MB_MAX_CHAR. If run
- with argument -f, output is a series of #define's for the ANSI standard
- float.h include file. Flag -v gives verbose output: output includes the
- English text above as C comments. The program exit(0)'s if everything
- went ok, otherwise it exits with a positive number, telling how many
- problems there were.
-
- VERIFYING THE COMPILER
- If, having produced the float.h and limits.h header files, you want to
- verify that the compiler reads them back correctly (there are a lot of
- boundary cases, of course, like minimum and maximum numbers), you can
- recompile hard-params.c with -DVERIFY set (plus the other flags that you used
- when compiling the version that produced the header files). This then
- recompiles the program so that it #includes "limits.h" and "float.h",
- and checks that the constants it finds there are the same as the
- constants it produces. Run the resulting program with hard-params -fl. As of
- this writing, of 21 compiler/flags combinations only 1 compiler has
- passed without error! (The honour goes to 'pcc' on an IBM RT.)
-
- You can also use this option if your compiler already has both files,
- and you want to confirm that this program produces the right results.
-
- TROUBLE SHOOTING.
- This program is now quite trustworthy, and suspicious and wrong output
- may well be caused by bugs in the compiler, not in the program (however
- of course, this is not guaranteed, and no responsibility can be
- accepted, etc.)
-
- The program only works if overflows are ignored by the C system or
- are catchable with signal().
-
- If the program fails to run to completion (often with the error message
- "Unexpected signal at point x"), this often turns out to be a bug in the
- C compiler's run-time system. Check what was about to be printed, and
- try to narrow the problem down.
-
- Another possible problem is that you have compiled the program to produce
- loss-of-precision arithmetic traps. The program cannot cope with these,
- and you should re-compile without them. (They should never be the default).
-
- Make sure you compiled with optimisation turned off.
-
- Output preceded by *** WARNING: identifies behaviour of the C system
- deemed incorrect by the program. Likely problems are that printf or
- scanf don't cope properly with certain boundary numbers. For each float
- and double that is printed, the printed value is checked that it is
- correct by using sscanf to read it back. Care is taken that numbers are
- printed with enough digits to uniquely identify them, and therefore that
- they can be read back identically. If the number read back is different,
- the program prints a warning message. If the two numbers in the warning
- look identical, then printf is more than likely rounding the last
- digit(s) incorrectly. To put you at ease that the two really are
- different, the bit patterns of the two numbers are also printed. The
- difference is very likely in the last bit. Many scanf's read the
- minimum double back as 0.0, and similarly cause overflow when reading
- the maximum double. The program quite ruthlessly declares all these
- behaviours faulty.
-
- The warning that "a cast didn't work" refers to cases like this:
-
- float f;
- #define C 1.234567890123456789
- f= C;
- if (f != (float) C) printf ("Wrong!");
-
- A faulty compiler will widen f to double and ignore the cast to float,
- and because there is more accuracy in a double than a float, fail to
- recognise that they are the same. In the actual case in point, f and C
- are passed as parameters to a function that discovers they are not equal,
- so it's just possible that the error was in the parameter passing,
- not in the cast (see function Validate()).
- For ANSI C, which has float constants, the error message is "constant has
- wrong precision".
-
- REPORTING PROBLEMS
- If the program doesn't work for you for any reason that can't be
- narrowed down to a problem in the C compiler, or it has to be changed in
- order to get it to compile, or it produces suspicious output (like a very
- low maximum float, for instance), please mail the problem and an example
- of the incorrect output to steven@cwi.nl or mcvax!steven.uucp, so that
- improvements can be worked into future versions; mcvax/cwi.nl is the
- European backbone, and is connected to uunet and other fine hosts.
-
- This version of the program is the first to try to catch and diagnose
- bugs in the compiler/run-time system. I would be especially pleased to
- have reports of failures so that I can improve this service.
-
- I apologise unreservedly for the contorted use of the preprocessor...
-
- THE SMALL PRINT
- You may copy and distribute verbatim copies of this source file.
-
- You may modify this source file, and copy and distribute such
- modified versions, provided that you leave the copyright notice
- at the top of the file and also cause the modified file to carry
- prominent notices stating that you changed the files and the date
- of any change; and cause the whole of any work that you distribute
- or publish, that in whole or in part contains or is a derivative of
- this program or any part thereof, to be licensed at no charge to
- all third parties on terms identical to those here.
-
- If you do have a fix to any problem, please send it to me, so that
- other people can have the benefits.
-
- While every effort has been taken to make this program as reliable as
- possible, no responsibility can be taken for the correctness of the
- output, or suitability for any particular use.
-
- ACKNOWLEDGEMENTS
- Many people have given time and ideas to making this program what it is.
- To all of them thanks, and apologies for not mentioning them by name.
-*/
-
-#ifndef __FILE__
-#define __FILE__ "hard-params.c"
-#endif
-
-#ifndef PASS
-#define PASS 1
-#define PASS1 1
-#define VERSION "4.1"
-
-/* Procedure just marks the functions that don't return a result */
-#ifdef Procedure
-#undef Procedure
-#endif
-#define Procedure
-
-#define Vprintf if (V) printf
-
-/* stdc is used in tests like if (stdc) */
-#ifdef __STDC__
-#define stdc 1
-#else
-#define stdc 0
-#endif
-
-/* volatile is used to reduce the chance of optimisation,
- and to prevent variables being put in registers (when setjmp/longjmp
- wouldn't work as we want) */
-#ifndef __STDC__
-#define volatile
-#endif
-
-#include <stdio.h>
-
-#ifdef VERIFY
-#include "limits.h"
-#include "float.h"
-#endif
-
-#ifdef NO_SIG /* There's no signal(), or setjmp/longjmp() */
-
- /* Dummy routines instead */
- int lab=1;
- int setjmp(lab) int lab; { return(0); }
- signal(i, p) int i, (*p)(); {}
-
-#else
-
-#include <signal.h>
-#include <setjmp.h>
-
- jmp_buf lab;
- overflow(sig) int sig; { /* what to do on overflow/underflow */
- signal(sig, overflow);
- longjmp(lab, 1);
- }
-
-#endif /*NO_SIG*/
-
-#define Unexpected(place) if (setjmp(lab)!=0) croak(place)
-
-int V= 0, /* verbose */
- L= 0, /* produce limits.h */
- F= 0, /* produce float.h */
- bugs=0; /* The number of (possible) bugs in the output */
-
-char co[4], oc[4]; /* Comment starter and ender symbols */
-
-int bits_per_byte; /* the number of bits per unit returned by sizeof() */
-
-#ifdef TEST
-/* Set the fp modes on a SUN with 68881 chip, to check that different
- rounding modes etc. get properly detected.
- Compile with additional flag -DTEST, and run with additional parameter
- +hex-number, to set the 68881 mode register to hex-number
-*/
-
-/* Bits 0x30 = rounding mode: */
-#define ROUND_BITS 0x30
-#define TO_NEAREST 0x00
-#define TO_ZERO 0x10
-#define TO_MINUS_INF 0x20
-#define TO_PLUS_INF 0x30 /* The SUN FP user's guide seems to be wrong here */
-
-/* Bits 0xc0 = extended rounding: */
-#define EXT_BITS 0xc0
-#define ROUND_EXTENDED 0x00
-#define ROUND_SINGLE 0x40
-#define ROUND_DOUBLE 0x80
-
-/* Enabled traps: */
-#define EXE_INEX1 0x100
-#define EXE_INEX2 0x200
-#define EXE_DZ 0x400
-#define EXE_UNFL 0x800
-#define EXE_OVFL 0x1000
-#define EXE_OPERR 0x2000
-#define EXE_SNAN 0x4000
-#define EXE_BSUN 0x8000
-
-printmode(new) unsigned new; {
- fpmode_(&new);
- printf("New fp mode:\n");
- printf(" Round toward ");
- switch (new & ROUND_BITS) {
- case TO_NEAREST: printf("nearest"); break;
- case TO_ZERO: printf("zero"); break;
- case TO_MINUS_INF: printf("minus infinity"); break;
- case TO_PLUS_INF: printf("plus infinity"); break;
- default: printf("???"); break;
- }
-
- printf("\n Extended rounding precision: ");
-
- switch (new & EXT_BITS) {
- case ROUND_EXTENDED: printf("extended"); break;
- case ROUND_SINGLE: printf("single"); break;
- case ROUND_DOUBLE: printf("double"); break;
- default: printf("???"); break;
- }
-
- printf("\n Enabled exceptions:");
- if (new & (unsigned) EXE_INEX1) printf(" inex1");
- if (new & (unsigned) EXE_INEX2) printf(" inex2");
- if (new & (unsigned) EXE_DZ) printf(" dz");
- if (new & (unsigned) EXE_UNFL) printf(" unfl");
- if (new & (unsigned) EXE_OVFL) printf(" ovfl");
- if (new & (unsigned) EXE_OPERR) printf(" operr");
- if (new & (unsigned) EXE_SNAN) printf(" snan");
- if (new & (unsigned) EXE_BSUN) printf(" bsun");
- printf("\n");
-}
-
-int setmode(s) char *s; {
- unsigned mode=0, dig;
- char c;
-
- while (*s) {
- c= *s++;
- if (c>='0' && c<='9') dig= c-'0';
- else if (c>='a' && c<='f') dig= c-'a'+10;
- else if (c>='A' && c<='F') dig= c-'A'+10;
- else return 1;
- mode= mode<<4 | dig;
- }
- printmode(mode);
- return 0;
-}
-#else
-int setmode(s) char *s; {
- fprintf(stderr, "Can't set mode: not compiled with TEST\n");
- return(1);
-}
-#endif
-
-croak(place) int place; {
- printf("*** Unexpected signal at point %d\n", place);
- exit(bugs+1); /* An exit isn't essential here, but avoids loops */
-}
-
-/* This is here in case alloca.c is used. That wants to call this. */
-
-char *
-xmalloc(size) unsigned size; {
- char *malloc();
- char *value = malloc(size);
- if (value == 0) {
- fprintf(stderr, "Virtual memory exceeded\n");
- exit(bugs+1);
- }
- return value;
-}
-
-main(argc, argv) int argc; char *argv[]; {
- int dprec, fprec, lprec, basic(), fprop(), dprop(), efprop(), edprop();
- char *malloc();
- unsigned int size;
- long total;
- int i; char *s; int bad;
-
-#ifdef SIGFPE
- signal(SIGFPE, overflow);
-#endif
-#ifdef SIGOVER
- signal(SIGOVER, overflow);
-#endif
-/* Add more calls as necessary */
-
- Unexpected(1);
-
- bad=0;
- for (i=1; i < argc; i++) {
- s= argv[i];
- if (*s == '-') {
- s++;
- while (*s) {
- switch (*(s++)) {
- case 'v': V=1; break;
- case 'l': L=1; break;
- case 'f': F=1; break;
- default: bad=1; break;
- }
- }
- } else if (*s == '+') {
- s++;
- bad= setmode(s);
- } else bad= 1;
- }
- if (bad) {
- fprintf(stderr,
- "Usage: %s [-vlf]\n v=Verbose l=Limits.h f=Float.h\n",
- argv[0]);
- exit(1);
- }
- if (L || F) {
- co[0]= '/'; oc[0]= ' ';
- co[1]= '*'; oc[1]= '*';
- co[2]= ' '; oc[2]= '/';
- co[3]= '\0'; oc[3]= '\0';
- } else {
- co[0]= '\0'; oc[0]= '\0';
- V=1;
- }
-
- if (L) printf("%slimits.h%s\n", co, oc);
- if (F) printf("%sfloat.h%s\n", co, oc);
-#ifdef ID
- printf("%sProduced on %s by hard-params version %s, CWI, Amsterdam%s\n",
- co, ID, VERSION, oc);
-#else
- printf("%sProduced by hard-params version %s, CWI, Amsterdam%s\n",
- co, VERSION, oc);
-#endif
- if (F) printf ("\n#ifndef _FLOAT_H_\n");
-
-#ifdef VERIFY
- printf("%sVerification phase%s\n", co, oc);
-#endif
-
-#ifdef NO_SIG
- Vprintf("%sCompiled without signal(): %s%s\n",
- co,
- "there's nothing that can be done if overflow occurs",
- oc);
-#endif
-#ifdef NO_SC
- Vprintf("%sCompiled without signed char%s\n", co, oc);
-#endif
-#ifdef NO_UC
- Vprintf("%Compiled without unsigned char%s\n", co, oc);
-#endif
-#ifdef NO_UI
- Vprintf("%Compiled without unsigned short or long%s\n", co, oc);
-#endif
-#ifdef __STDC__
- Vprintf("%sCompiler claims to be ANSI C level %d%s\n",
- co, __STDC__, oc);
-#else
- Vprintf("%sCompiler does not claim to be ANSI C%s\n", co, oc);
-#endif
- printf("\n");
- bits_per_byte= basic();
- Vprintf("\n");
- if (F||V) {
- fprec= fprop(bits_per_byte);
- dprec= dprop(bits_per_byte);
- lprec= ldprop(bits_per_byte);
- efprop(fprec, dprec, lprec);
- edprop(fprec, dprec, lprec);
- eldprop(fprec, dprec, lprec);
- }
- if (V) {
- /* An extra goody: the approximate amount of data-space */
- /* Allocate store until no more available */
- size=1<<((bits_per_byte*sizeof(int))-2);
- total=0;
- while (size!=0) {
- while (malloc(size)!=(char *)NULL) total+=(size/2);
- size/=2;
- }
-
- Vprintf("%sMemory mallocatable ~= %ld Kbytes%s\n",
- co, (total+511)/512, oc);
- }
-
- if (F) printf ("\n#endif %snot _FLOAT_H_%s\n", co, oc);
-
- exit(bugs);
-}
-
-Procedure eek_a_bug(problem) char *problem; {
- printf("\n%s*** WARNING: %s%s\n", co, problem, oc);
- bugs++;
-}
-
-Procedure i_define(sort, name, val, req) char *sort, *name; long val, req;
-{
- printf ("\n#ifndef %s%s\n", sort, name);
- if (val >= 0)
- {
- printf("#define %s%s %ld\n", sort, name, val);
- } else
- {
- printf("#define %s%s (%ld)\n", sort, name, val);
- }
- if (val != req)
- {
- printf("%s*** Verify failed for above #define!\n", co);
- printf(" Compiler has %ld for value%s\n\n", req, oc);
- bugs++;
- }
- printf ("#endif %s%s%s%s\n", co, sort, name, oc);
- Vprintf("\n");
-}
-
-#ifndef NO_UI
-
-#ifdef __STDC__
-#define U "U"
-#else
-#define U ""
-#endif
-
-Procedure u_define(sort, name, val, req)
- char *sort, *name; unsigned long val, req;
-{
- printf ("\n#ifndef %s%s\n", sort, name);
- printf("#define %s%s %lu%s\n", sort, name, val, U);
- if (val != req) {
- printf("%s*** Verify failed for above #define!\n", co);
- printf(" Compiler has %lu for value%s\n\n", req, oc);
- bugs++;
- }
- printf ("#endif %s%s%s%s\n", co, sort, name, oc);
- Vprintf("\n");
-}
-#endif
-
-/* Long_double is the longest floating point type available: */
-#ifdef __STDC__
-#define Long_double long double
-#else
-#define Long_double double
-#endif
-
-char *f_rep();
-
-Procedure f_define(sort, name, precision, val, mark)
- char *sort, *name; int precision; Long_double val; char *mark;
-{
- printf ("\n#ifndef %s%s\n", sort, name);
- if (stdc)
- {
- printf("#define %s%s %s%s\n",
- sort, name, f_rep(precision, val), mark);
- } else if (*mark == 'F')
- {
- /* non-ANSI C has no float constants, so cast the constant */
- printf("#define %s%s ((float)%s)\n",
- sort, name, f_rep(precision, val));
- } else
- {
- printf("#define %s%s %s\n", sort, name, f_rep(precision, val));
- }
- printf ("#endif %s%s%s%s\n", co, sort, name, oc);
- Vprintf("\n");
-}
-
-int floor_log(base, x) int base; Long_double x; { /* return floor(log base(x)) */
- int r=0;
- while (x>=base) { r++; x/=base; }
- return r;
-}
-
-int ceil_log(base, x) int base; Long_double x; {
- int r=0;
- while (x>1.0) { r++; x/=base; }
- return r;
-}
-
-int exponent(x, fract, exp) Long_double x; double *fract; int *exp; {
- /* Split x into a fraction and a power of ten;
- returns 0 if x is unusable, 1 otherwise.
- Only used for error messages about faulty output.
- */
- int r=0, neg=0;
- Long_double old;
- *fract=0.0; *exp=0;
- if (x<0.0) {
- x= -x;
- neg= 1;
- }
- if (x==0.0) return 1;
- if (x>=10.0) {
- while (x>=10.0) {
- old=x; r++; x/=10.0;
- if (old==x) return 0;
- }
- } else {
- while (x<1.0) {
- old=x; r--; x*=10.0;
- if (old==x) return 0;
- }
- }
- if (neg) *fract= -x;
- else *fract=x;
- *exp=r;
- return 1;
-}
-
-#define fabs(x) (((x)<0.0)?(-x):(x))
-
-char *f_rep(precision, val) int precision; Long_double val; {
- static char buf[1024];
- char *f1;
- if (sizeof(double) == sizeof(Long_double)) {
- /* Assume they're the same, and use non-stdc format */
- /* This is for stdc compilers using non-stdc libraries */
- f1= "%.*e";
- } else {
- /* It had better support Le then */
- f1= "%.*Le";
- }
- sprintf(buf, f1, precision, val);
- return buf;
-}
-
-Procedure bitpattern(p, size) char *p; int size; {
- char c;
- int i, j;
-
- for (i=1; i<=size; i++) {
- c= *p;
- p++;
- for (j=bits_per_byte-1; j>=0; j--)
- printf("%c", (c>>j)&1 ? '1' : '0');
- if (i!=size) printf(" ");
- }
-}
-
-#define Order(x, px, mode)\
- printf("%s %s ", co, mode); for (i=0; i<sizeof(x); i++) px[i]= c[i]; \
- for (i=1; i<=sizeof(x); i++) { putchar((char)((x>>(bits_per_byte*(sizeof(x)-i)))&mask)); }\
- printf("%s\n", oc);
-
-Procedure endian(bits_per_byte) int bits_per_byte; {
- /*unsigned*/ short s=0;
- /*unsigned*/ int j=0;
- /*unsigned*/ long l=0;
-
- char *ps= (char *) &s,
- *pj= (char *) &j,
- *pl= (char *) &l,
- *c= "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
- unsigned int mask, i;
-
- mask=0;
- for (i=1; i<=bits_per_byte; i++) mask= (mask<<1)|1;
-
- if (V) {
- printf("%sCharacter order:%s\n", co, oc);
- Order(s, ps, "short:");
- Order(j, pj, "int: ");
- Order(l, pl, "long: ");
- }
-}
-
-#ifdef VERIFY
-#ifndef SCHAR_MAX
-#define SCHAR_MAX char_max
-#define SCHAR_MIN char_min
-#endif
-#ifndef UCHAR_MAX
-#define UCHAR_MAX char_max
-#endif
-#else
-#ifdef CHAR_BIT
-#undef CHAR_BIT
-#endif
-#define CHAR_BIT char_bit
-#ifdef CHAR_MAX
-#undef CHAR_MAX
-#endif
-#define CHAR_MAX char_max
-#ifdef CHAR_MIN
-#undef CHAR_MIN
-#endif
-#define CHAR_MIN char_min
-#ifdef SCHAR_MAX
-#undef SCHAR_MAX
-#endif
-#define SCHAR_MAX char_max
-#ifdef SCHAR_MIN
-#undef SCHAR_MIN
-#endif
-#define SCHAR_MIN char_min
-#ifdef UCHAR_MAX
-#undef UCHAR_MAX
-#endif
-#define UCHAR_MAX char_max
-#endif /* not VERIFY */
-
-int cprop() { /* Properties of character */
- volatile char c, char_max, char_min;
- volatile int bits_per_byte, is_signed;
- long char_bit;
-
- Unexpected(2);
-
- /* Calculate number of bits per character *************************/
- c=1; bits_per_byte=0;
- do { c=c<<1; bits_per_byte++; } while(c!=0);
- c= (char)(-1);
- if (((int)c)<0) is_signed=1;
- else is_signed=0;
- Vprintf("%sChar = %d bits, %ssigned%s\n",
- co, (int)sizeof(c)*bits_per_byte, (is_signed?"":"un"), oc);
- char_bit=(long)(sizeof(c)*bits_per_byte);
- if (L) i_define("CHAR", "_BIT", char_bit, (long) CHAR_BIT);
-
- c=0; char_max=0;
- c++;
- if (setjmp(lab)==0) { /* Yields char_max */
- while (c>char_max) {
- char_max=c;
- c++;
- }
- } else {
- Vprintf("%sCharacter overflow generates a trap!%s\n", co, oc);
- }
- c=0; char_min=0;
- c--;
- if (setjmp(lab)==0) { /* Yields char_min */
- while (c<char_min) {
- char_min=c;
- c--;
- }
- }
- Unexpected(3);
-
- if (L) {
- i_define("CHAR", "_MAX", (long) char_max, (long) CHAR_MAX);
- i_define("CHAR", "_MIN", (long) char_min, (long) CHAR_MIN);
- if (is_signed) {
- i_define("SCHAR", "_MAX", (long) char_max,
- (long) SCHAR_MAX);
- i_define("SCHAR", "_MIN", (long) char_min,
- (long) SCHAR_MIN);
- } else {
- i_define("UCHAR", "_MAX", (long) char_max,
- (long) UCHAR_MAX);
- }
-
- if (is_signed) {
-#ifndef NO_UC
- volatile unsigned char c, char_max;
- c=0; char_max=0;
- c++;
- if (setjmp(lab)==0) { /* Yields char_max */
- while (c>char_max) {
- char_max=c;
- c++;
- }
- }
- Unexpected(4);
- i_define("UCHAR", "_MAX", (long) char_max,
- (long) UCHAR_MAX);
-#endif
- } else {
-#ifndef NO_SC /* Define NO_SC if the next line gives a syntax error */
- volatile signed char c, char_max, char_min;
- c=0; char_max=0;
- c++;
- if (setjmp(lab)==0) { /* Yields char_max */
- while (c>char_max) {
- char_max=c;
- c++;
- }
- }
- c=0; char_min=0;
- c--;
- if (setjmp(lab)==0) { /* Yields char_min */
- while (c<char_min) {
- char_min=c;
- c--;
- }
- }
- Unexpected(5);
- i_define("SCHAR", "_MIN", (long) char_min,
- (long) SCHAR_MIN);
- i_define("SCHAR", "_MAX", (long) char_max,
- (long) SCHAR_MAX);
-#endif /* NO_SC */
- }
- }
- return bits_per_byte;
-}
-
-int basic() {
- /* The properties of the basic types.
- Returns number of bits per sizeof unit */
- volatile int bits_per_byte;
-
- bits_per_byte= cprop();
-
- /* Shorts, ints and longs *****************************************/
- Vprintf("%sShort=%d int=%d long=%d float=%d double=%d bits %s\n",
- co,
- (int) sizeof(short)*bits_per_byte,
- (int) sizeof(int)*bits_per_byte,
- (int) sizeof(long)*bits_per_byte,
- (int) sizeof(float)*bits_per_byte,
- (int) sizeof(double)*bits_per_byte, oc);
- if (stdc) {
- Vprintf("%sLong double=%d bits%s\n",
- co, (int) sizeof(Long_double)*bits_per_byte, oc);
- }
- Vprintf("%sChar pointers = %d bits%s%s\n",
- co, (int)sizeof(char *)*bits_per_byte,
- sizeof(char *)>sizeof(int)?" BEWARE! larger than int!":"",
- oc);
- Vprintf("%sInt pointers = %d bits%s%s\n",
- co, (int)sizeof(int *)*bits_per_byte,
- sizeof(int *)>sizeof(int)?" BEWARE! larger than int!":"",
- oc);
- sprop();
- iprop();
- lprop();
- usprop();
- uiprop();
- ulprop();
-
- Unexpected(6);
-
- /* Alignment constants ********************************************/
- Vprintf("%sAlignments used for char=%d short=%d int=%d long=%d%s\n",
- co,
- (int)sizeof(struct{char i1; char c1;})-(int)sizeof(char),
- (int)sizeof(struct{short i2; char c2;})-(int)sizeof(short),
- (int)sizeof(struct{int i3; char c3;})-(int)sizeof(int),
- (int)sizeof(struct{long i4; char c4;})-(int)sizeof(long),
- oc);
-
- /* Ten little endians *********************************************/
-
- endian(bits_per_byte);
-
- /* Pointers *******************************************************/
- if (V) {
- if ("abcd"=="abcd")
- printf("%sStrings are shared%s\n", co, oc);
- else printf("%sStrings are not shared%s\n", co, oc);
- }
-
- return bits_per_byte;
-}
-
-#endif /* ifndef PASS */
-
-/* As I said, I apologise for the contortions below. The functions are
- expanded by the preprocessor twice or three times (for float and double,
- and maybe for long double, and for short, int and long). That way,
- I never make a change to one that I forget to make to the other.
- You can look on it as C's fault for not supporting multi-line macro's.
- This whole file is read 3 times by the preprocessor, with PASSn set for
- n=1, 2 or 3, to decide which parts to reprocess.
-*/
-
-/* #undef on an already undefined thing is (wrongly) flagged as an error
- by some compilers, therefore the #ifdef that follows:
-*/
-#ifdef Number
-#undef Number
-#undef THING
-#undef Thing
-#undef thing
-#undef FPROP
-#undef Fname
-#undef Store
-#undef Sum
-#undef Diff
-#undef Mul
-#undef Div
-#undef Self
-#undef F_check
-#undef Validate
-#undef EPROP
-#undef MARK
-
-#undef F_RADIX
-#undef F_MANT_DIG
-#undef F_DIG
-#undef F_ROUNDS
-#undef F_EPSILON
-#undef F_MIN_EXP
-#undef F_MIN
-#undef F_MIN_10_EXP
-#undef F_MAX_EXP
-#undef F_MAX
-#undef F_MAX_10_EXP
-#endif
-
-#ifdef Integer
-#undef Integer
-#undef INT
-#undef IPROP
-#undef Iname
-#undef UPROP
-#undef Uname
-#undef OK_UI
-
-#undef I_MAX
-#undef I_MIN
-#undef U_MAX
-#endif
-
-#ifdef PASS1
-
-#define Number float
-#define THING "FLOAT"
-#define Thing "Float"
-#define thing "float"
-#define Fname "FLT"
-#define FPROP fprop
-#define Store fStore
-#define Sum fSum
-#define Diff fDiff
-#define Mul fMul
-#define Div fDiv
-#define Self fSelf
-#define F_check fCheck
-#define Validate fValidate
-#define MARK "F"
-
-#define EPROP efprop
-
-#define Integer short
-#define INT "short"
-#define IPROP sprop
-#define Iname "SHRT"
-#ifndef NO_UI
-#define OK_UI 1
-#endif
-
-#define UPROP usprop
-#define Uname "USHRT"
-
-#ifdef VERIFY
-#define I_MAX SHRT_MAX
-#define I_MIN SHRT_MIN
-#define U_MAX USHRT_MAX
-
-#define F_RADIX FLT_RADIX
-#define F_MANT_DIG FLT_MANT_DIG
-#define F_DIG FLT_DIG
-#define F_ROUNDS FLT_ROUNDS
-#define F_EPSILON FLT_EPSILON
-#define F_MIN_EXP FLT_MIN_EXP
-#define F_MIN FLT_MIN
-#define F_MIN_10_EXP FLT_MIN_10_EXP
-#define F_MAX_EXP FLT_MAX_EXP
-#define F_MAX FLT_MAX
-#define F_MAX_10_EXP FLT_MAX_10_EXP
-#endif /* VERIFY */
-
-#endif /* PASS1 */
-
-#ifdef PASS2
-
-#define Number double
-#define THING "DOUBLE"
-#define Thing "Double"
-#define thing "double"
-#define Fname "DBL"
-#define FPROP dprop
-#define Store dStore
-#define Sum dSum
-#define Diff dDiff
-#define Mul dMul
-#define Div dDiv
-#define Self dSelf
-#define F_check dCheck
-#define Validate dValidate
-#define MARK ""
-
-#define EPROP edprop
-
-#define Integer int
-#define INT "int"
-#define IPROP iprop
-#define Iname "INT"
-#define OK_UI 1 /* Unsigned int is always possible */
-
-#define UPROP uiprop
-#define Uname "UINT"
-
-#ifdef VERIFY
-#define I_MAX INT_MAX
-#define I_MIN INT_MIN
-#define U_MAX UINT_MAX
-
-#define F_MANT_DIG DBL_MANT_DIG
-#define F_DIG DBL_DIG
-#define F_EPSILON DBL_EPSILON
-#define F_MIN_EXP DBL_MIN_EXP
-#define F_MIN DBL_MIN
-#define F_MIN_10_EXP DBL_MIN_10_EXP
-#define F_MAX_EXP DBL_MAX_EXP
-#define F_MAX DBL_MAX
-#define F_MAX_10_EXP DBL_MAX_10_EXP
-#endif /* VERIFY */
-
-#endif /* PASS2 */
-
-#ifdef PASS3
-
-#ifdef __STDC__
-#define Number long double
-#endif
-
-#define THING "LONG DOUBLE"
-#define Thing "Long double"
-#define thing "long double"
-#define Fname "LDBL"
-#define FPROP ldprop
-#define Store ldStore
-#define Sum ldSum
-#define Diff ldDiff
-#define Mul ldMul
-#define Div ldDiv
-#define Self ldSelf
-#define F_check ldCheck
-#define Validate ldValidate
-#define MARK "L"
-
-#define EPROP eldprop
-
-#define Integer long
-#define INT "long"
-#define IPROP lprop
-#define Iname "LONG"
-#ifndef NO_UI
-#define OK_UI 1
-#endif
-
-#define UPROP ulprop
-#define Uname "ULONG"
-
-#ifdef VERIFY
-#define I_MAX LONG_MAX
-#define I_MIN LONG_MIN
-#define U_MAX ULONG_MAX
-
-#define F_MANT_DIG LDBL_MANT_DIG
-#define F_DIG LDBL_DIG
-#define F_EPSILON LDBL_EPSILON
-#define F_MIN_EXP LDBL_MIN_EXP
-#define F_MIN LDBL_MIN
-#define F_MIN_10_EXP LDBL_MIN_10_EXP
-#define F_MAX_EXP LDBL_MAX_EXP
-#define F_MAX LDBL_MAX
-#define F_MAX_10_EXP LDBL_MAX_10_EXP
-#endif /* VERIFY */
-
-#endif /* PASS3 */
-
-#ifndef VERIFY
-#define I_MAX int_max
-#define I_MIN int_min
-#define U_MAX int_max
-
-#define F_RADIX f_radix
-#define F_MANT_DIG f_mant_dig
-#define F_DIG f_dig
-#define F_ROUNDS f_rounds
-#define F_EPSILON f_epsilon
-#define F_MIN_EXP f_min_exp
-#define F_MIN f_min
-#define F_MIN_10_EXP f_min_10_exp
-#define F_MAX_EXP f_max_exp
-#define F_MAX f_max
-#define F_MAX_10_EXP f_max_10_exp
-#endif
-
-Procedure IPROP() { /* for short, int, and long */
- volatile Integer newi, int_max, maxeri, int_min, minneri;
- volatile int ibits, ipower, two=2;
-
- /* Calculate max short/int/long ***********************************/
- /* Calculate 2**n-1 until overflow - then use the previous value */
-
- newi=1; int_max=0;
-
- if (setjmp(lab)==0) { /* Yields int_max */
- for(ipower=0; newi>int_max; ipower++) {
- int_max=newi;
- newi=newi*two+1;
- }
- Vprintf("%sOverflow of a%s %s does not generate a trap%s\n",
- co, INT[0]=='i'?"n":"", INT, oc);
- } else {
- Vprintf("%sOverflow of a%s %s generates a trap%s\n",
- co, INT[0]=='i'?"n":"", INT, oc);
- }
- Unexpected(7);
-
- /* Minimum value: assume either two's or one's complement *********/
- int_min= -int_max;
- if (setjmp(lab)==0) { /* Yields int_min */
- if (int_min-1 < int_min) int_min--;
- }
- Unexpected(8);
-
- /* Now for those daft Cybers: */
-
- maxeri=0; newi=int_max;
-
- if (setjmp(lab)==0) { /* Yields maxeri */
- for(ibits=ipower; newi>maxeri; ibits++) {
- maxeri=newi;
- newi=newi+newi+1;
- }
- }
- Unexpected(9);
-
- minneri= -maxeri;
- if (setjmp(lab)==0) { /* Yields minneri */
- if (minneri-1 < minneri) minneri--;
- }
- Unexpected(10);
-
- Vprintf("%sMaximum %s = %ld (= 2**%d-1)%s\n",
- co, INT, (long)int_max, ipower, oc);
- Vprintf("%sMinimum %s = %ld%s\n", co, INT, (long)int_min, oc);
-
- if (L) i_define(Iname, "_MAX", (long) int_max, (long) I_MAX);
- if (L) i_define(Iname, "_MIN", (long) int_min, (long) I_MIN);
-
- if (maxeri>int_max) {
- Vprintf("%sThere is a larger %s, %ld (= 2**%d-1), %s %s%s\n",
- co, INT, (long)maxeri, ibits,
- "but only for addition, not multiplication",
- "(I smell a Cyber!)",
- oc);
- }
-
- if (minneri<int_min) {
- Vprintf("%sThere is a smaller %s, %ld, %s %s%s\n",
- co, INT, (long)minneri,
- "but only for addition, not multiplication",
- "(I smell a Cyber!)",
- oc);
- }
-}
-
-Procedure UPROP () { /* unsigned short/int/long */
-#ifdef OK_UI
- volatile unsigned Integer int_max, newi, two;
- newi=1; int_max=0; two=2;
-
- if (setjmp(lab)==0) { /* Yields int_max */
- while(newi>int_max) {
- int_max=newi;
- newi=newi*two+1;
- }
- }
- Unexpected(11);
- Vprintf("%sMaximum unsigned %s = %lu%s\n",
- co, INT, (unsigned long) int_max, oc);
- if (L) u_define(Uname, "_MAX", (unsigned long) int_max,
- (unsigned long) U_MAX);
-#endif
-}
-
-
-#ifdef Number
-
-/* These routines are intended to defeat any attempt at optimisation
- or use of extended precision, and to defeat faulty narrowing casts:
-*/
-Procedure Store(a, b) Number a, *b; { *b=a; }
-Number Sum(a, b) Number a, b; { Number r; Store(a+b, &r); return (r); }
-Number Diff(a, b) Number a, b; { Number r; Store(a-b, &r); return (r); }
-Number Mul(a, b) Number a, b; { Number r; Store(a*b, &r); return (r); }
-Number Div(a, b) Number a, b; { Number r; Store(a/b, &r); return (r); }
-Number Self(a) Number a; { Number r; Store(a, &r); return (r); }
-
-Procedure F_check(precision, val1) int precision; Long_double val1; {
- /* You don't think I'm going to go to all the trouble of writing
- a program that works out what all sorts of values are, only to
- have printf go and print the wrong values out, do you?
- No, you're right, so this function tries to see if printf
- has written the right value, by reading it back again.
- This introduces a new problem of course: suppose printf writes
- the correct value, and scanf reads it back wrong... oh well.
- But I'm adamant about this: the precision given is enough
- to uniquely identify the printed number, therefore I insist
- that sscanf read the number back identically. Harsh yes, but
- sometimes you've got to be cruel to be kind.
- */
- Long_double new1;
- Number val, new, diff;
- double rem;
- int e;
- char *rep;
- char *f2;
-
- if (sizeof(double) == sizeof(Long_double)) {
- /* Assume they're the same, and use non-stdc format */
- /* This is for stdc compilers using non-stdc libraries */
- f2= "%le"; /* Input */
- } else {
- /* It had better support Le then */
- f2= "%Le";
- }
- val= val1;
- rep= f_rep(precision, (Long_double) val);
- if (setjmp(lab)==0) {
- sscanf(rep, f2, &new1);
- } else {
- eek_a_bug("sscanf caused a trap");
- printf("%s scanning: %s format: %s%s\n\n", co, rep, f2, oc);
- Unexpected(12);
- return;
- }
-
- if (setjmp(lab)==0) { /* See if new is usable */
- new= new1;
- if (new != 0.0) {
- diff= val/new - 1.0;
- if (diff < 0.1) diff= 1.0;
- /* That should be enough to generate a trap */
- }
- } else {
- eek_a_bug("sscanf returned an unusable number");
- printf("%s scanning: %s with format: %s%s\n\n",
- co, rep, f2, oc);
- Unexpected(13);
- return;
- }
-
- Unexpected(14);
- if (new != val) {
- eek_a_bug("Possibly bad output from printf above");
- if (!exponent(val, &rem, &e)) {
- printf("%s but value was an unusable number%s\n\n",
- co, oc);
- return;
- }
- printf("%s expected value around %.*fe%d, bit pattern:\n ",
- co, precision, rem, e);
- bitpattern((char *) &val, sizeof(val));
- printf ("%s\n", oc);
- printf("%s sscanf gave %s, bit pattern:\n ",
- co, f_rep(precision, (Long_double) new));
- bitpattern((char *) &new, sizeof(new));
- printf ("%s\n", oc);
- printf("%s difference= %s%s\n\n",
- co, f_rep(precision, (Long_double) (val-new)), oc);
- }
-}
-
-Procedure Validate(prec, val, req, same) int prec, same; Long_double val, req; {
- Unexpected(15);
- if (!same) {
- printf("%s*** Verify failed for above #define!\n", co);
- if (setjmp(lab) == 0) { /* for the case that req == nan */
- printf(" Compiler has %s for value%s\n",
- f_rep(prec, req), oc);
- } else {
- printf(" Compiler has %s for value%s\n",
- "an unusable number", oc);
- }
- if (setjmp(lab) == 0) {
- F_check(prec, (Long_double) req);
- } /*else forget it*/
- if (setjmp(lab) == 0) {
- if (req > 0.0 && val > 0.0) {
- printf("%s difference= %s%s\n",
- co, f_rep(prec, val-req), oc);
- }
- } /*else forget it*/
- Unexpected(16);
- printf("\n");
- bugs++;
- } else if (val != req) {
- if (stdc) {
- printf("%s*** Verify failed for above #define!\n", co);
- printf(" Constant has the wrong precision%s\n",
- oc);
- bugs++;
- } else eek_a_bug("the cast didn't work");
- printf("\n");
- }
-}
-
-int FPROP(bits_per_byte) int bits_per_byte; {
- /* Properties of floating types, using algorithms by Cody and Waite
- from MA Malcolm, as modified by WM Gentleman and SB Marovich.
- Further extended by S Pemberton.
-
- Returns the number of digits in the fraction.
- */
-
- volatile int i, f_radix, iexp, irnd, mrnd, f_rounds, f_mant_dig,
- iz, k, inf, machep, f_max_exp, f_min_exp, mx, negeps,
- mantbits, digs, f_dig, trap,
- hidden, normal, f_min_10_exp, f_max_10_exp;
- volatile Number a, b, base, basein, basem1, f_epsilon, epsneg,
- f_max, newxmax, f_min, xminner, y, y1, z, z1, z2;
-
- Unexpected(17);
-
- Vprintf("%sPROPERTIES OF %s:%s\n", co, THING, oc);
-
- /* Base and size of mantissa **************************************/
- /* First repeatedly double until adding 1 has no effect. */
- /* For instance, if base is 10, with 3 significant digits */
- /* it will try 1, 2, 4, 8, ... 512, 1024, and stop there, */
- /* since 1024 is only representable as 1020. */
- a=1.0;
- if (setjmp(lab)==0) { /* inexact trap? */
- do { a=Sum(a, a); }
- while (Diff(Diff(Sum(a, 1.0), a), 1.0) == 0.0);
- } else {
- fprintf(stderr, "*** Program got loss-of-precision trap!\n");
- /* And supporting those is just TOO much trouble! */
- exit(bugs+1);
- }
- Unexpected(18);
- /* Now double until you find a number that can be added to the */
- /* above number. For 1020 this is 8 or 16, depending whether the */
- /* result is rounded or truncated. */
- /* In either case the result is 1030. 1030-1020= the base, 10. */
- b=1.0;
- do { b=Sum(b, b); } while ((base=Diff(Sum(a, b), a)) == 0.0);
- f_radix=base;
- Vprintf("%sBase = %d%s\n", co, f_radix, oc);
-
- /* Sanity check; if base<2, I can't guarantee the rest will work */
- if (f_radix < 2) {
- eek_a_bug("Function return or parameter passing faulty? (This is a guess.)");
- printf("\n");
- return(0);
- }
-
-#ifdef PASS1 /* only for FLT */
- if (F) i_define("FLT", "_RADIX", (long) f_radix, (long) F_RADIX);
-#endif
-
- /* Now the number of digits precision: */
- f_mant_dig=0; b=1.0;
- do { f_mant_dig++; b=Mul(b, base); }
- while (Diff(Diff(Sum(b,1.0),b),1.0) == 0.0);
- f_dig=floor_log(10, (Long_double)(b/base)) + (base==10?1:0);
- Vprintf("%sSignificant base digits = %d %s %d %s%s\n",
- co, f_mant_dig, "(= at least", f_dig, "decimal digits)", oc);
- if (F) i_define(Fname, "_MANT_DIG", (long) f_mant_dig,
- (long) F_MANT_DIG);
- if (F) i_define(Fname, "_DIG", (long) f_dig, (long) F_DIG);
- digs= ceil_log(10, (Long_double)b); /* the number of digits to printf */
-
- /* Rounding *******************************************************/
- basem1=Diff(base, 0.5);
- if (Diff(Sum(a, basem1), a) != 0.0) {
- if (f_radix == 2) basem1=0.375;
- else basem1=1.0;
- if (Diff(Sum(a, basem1), a) != 0.0) irnd=2; /* away from 0 */
- else irnd=1; /* to nearest */
- } else irnd=0; /* towards 0 */
-
- basem1=Diff(base, 0.5);
-
- if (Diff(Diff(-a, basem1), -a) != 0.0) {
- if (f_radix == 2) basem1=0.375;
- else basem1=1.0;
- if (Diff(Diff(-a, basem1), -a) != 0.0) mrnd=2; /* away from 0*/
- else mrnd=1; /* to nearest */
- } else mrnd=0; /* towards 0 */
-
- f_rounds=4; /* Unknown rounding */
- if (irnd==0 && mrnd==0) f_rounds=0; /* zero = chops */
- if (irnd==1 && mrnd==1) f_rounds=1; /* nearest */
- if (irnd==2 && mrnd==0) f_rounds=2; /* +inf */
- if (irnd==0 && mrnd==2) f_rounds=3; /* -inf */
-
- if (f_rounds != 4) {
- Vprintf("%sArithmetic rounds towards ", co);
- switch (f_rounds) {
- case 0: Vprintf("zero (i.e. it chops)"); break;
- case 1: Vprintf("nearest"); break;
- case 2: Vprintf("+infinity"); break;
- case 3: Vprintf("-infinity"); break;
- default: Vprintf("???"); break;
- }
- Vprintf("%s\n", oc);
- } else { /* Hmm, try to give some help here: */
- Vprintf("%sArithmetic rounds oddly: %s\n", co, oc);
- Vprintf("%s Negative numbers %s%s\n",
- co, mrnd==0 ? "towards zero" :
- mrnd==1 ? "to nearest" :
- "away from zero",
- oc);
- Vprintf("%s Positive numbers %s%s\n",
- co, irnd==0 ? "towards zero" :
- irnd==1 ? "to nearest" :
- "away from zero",
- oc);
- }
- /* An extra goody */
- if (f_radix == 2 && f_rounds == 1) {
- if (Diff(Sum(a, 1.0), a) != 0.0) {
- Vprintf("%s Tie breaking rounds up%s\n", co, oc);
- } else if (Diff(Sum(a, 3.0), a) == 4.0) {
- Vprintf("%s Tie breaking rounds to even%s\n", co, oc);
- } else {
- Vprintf("%s Tie breaking rounds down%s\n", co, oc);
- }
- }
-#ifdef PASS1 /* only for FLT */
- if (F) i_define("FLT", "_ROUNDS", (long) f_rounds, (long) F_ROUNDS);
-#endif
-
- /* Various flavours of epsilon ************************************/
- negeps=f_mant_dig+f_mant_dig;
- basein=1.0/base;
- a=1.0;
- for(i=1; i<=negeps; i++) a*=basein;
-
- b=a;
- while (Diff(Diff(1.0, a), 1.0) == 0.0) {
- a*=base;
- negeps--;
- }
- negeps= -negeps;
- Vprintf("%sSmallest x such that 1.0-base**x != 1.0 = %d%s\n",
- co, negeps, oc);
-
- epsneg=a;
- if ((f_radix!=2) && irnd) {
- /* a=(a*(1.0+a))/(1.0+1.0); => */
- a=Div(Mul(a, Sum(1.0, a)), Sum(1.0, 1.0));
- /* if ((1.0-a)-1.0 != 0.0) epsneg=a; => */
- if (Diff(Diff(1.0, a), 1.0) != 0.0) epsneg=a;
- }
- Vprintf("%sSmall x such that 1.0-x != 1.0 = %s%s\n",
- co, f_rep(digs, (Long_double) epsneg), oc);
- /* it may not be the smallest */
- if (V) F_check(digs, (Long_double) epsneg);
- Unexpected(19);
-
- machep= -f_mant_dig-f_mant_dig;
- a=b;
- while (Diff(Sum(1.0, a), 1.0) == 0.0) { a*=base; machep++; }
- Vprintf("%sSmallest x such that 1.0+base**x != 1.0 = %d%s\n",
- co, machep, oc);
-
- f_epsilon=a;
- if ((f_radix!=2) && irnd) {
- /* a=(a*(1.0+a))/(1.0+1.0); => */
- a=Div(Mul(a, Sum(1.0, a)), Sum(1.0, 1.0));
- /* if ((1.0+a)-1.0 != 0.0) f_epsilon=a; => */
- if (Diff(Sum(1.0, a), 1.0) != 0.0) f_epsilon=a;
- }
- Vprintf("%sSmallest x such that 1.0+x != 1.0 = %s%s\n",
- co, f_rep(digs, (Long_double) f_epsilon), oc);
- /* Possible loss of precision warnings here from non-stdc compilers: */
- if (F) f_define(Fname, "_EPSILON", digs, (Long_double) f_epsilon, MARK);
- if (V || F) F_check(digs, (Long_double) f_epsilon);
- Unexpected(20);
- if (F) Validate(digs, (Long_double) f_epsilon, (Long_double) F_EPSILON,
- f_epsilon == Self(F_EPSILON));
- Unexpected(21);
-
- /* Extra chop info *************************************************/
- if (f_rounds == 0) {
- if (Diff(Mul(Sum(1.0,f_epsilon),1.0),1.0) != 0.0) {
- Vprintf("%sAlthough arithmetic chops, it uses guard digits%s\n", co, oc);
- }
- }
-
- /* Size of and minimum normalised exponent ************************/
- y=0; i=0; k=1; z=basein; z1=(1.0+f_epsilon)/base;
-
- /* Coarse search for the largest power of two */
- if (setjmp(lab)==0) { /* for underflow trap */ /* Yields i, k, y, y1 */
- do {
- y=z; y1=z1;
- z=Mul(y,y); z1=Mul(z1, y);
- a=Mul(z,1.0);
- z2=Div(z1,y);
- if (z2 != y1) break;
- if ((Sum(a,a) == 0.0) || (fabs(z) >= y)) break;
- i++;
- k+=k;
- } while(1);
- } else {
- Vprintf("%s%s underflow generates a trap%s\n", co, Thing, oc);
- }
- Unexpected(22);
-
- if (f_radix != 10) {
- iexp=i+1; /* for the sign */
- mx=k+k;
- } else {
- iexp=2;
- iz=f_radix;
- while (k >= iz) { iz*=f_radix; iexp++; }
- mx=iz+iz-1;
- }
-
- /* Fine tune starting with y and y1 */
- if (setjmp(lab)==0) { /* for underflow trap */ /* Yields k, f_min */
- do {
- f_min=y; z1=y1;
- y=Div(y,base); y1=Div(y1,base);
- a=Mul(y,1.0);
- z2=Mul(y1,base);
- if (z2 != z1) break;
- if ((Sum(a,a) == 0.0) || (fabs(y) >= f_min)) break;
- k++;
- } while (1);
- }
- Unexpected(23);
-
- f_min_exp=(-k)+1;
-
- if ((mx <= k+k-3) && (f_radix != 10)) { mx+=mx; iexp+=1; }
- Vprintf("%sNumber of bits used for exponent = %d%s\n", co, iexp, oc);
- Vprintf("%sMinimum normalised exponent = %d%s\n", co, f_min_exp, oc);
- if (F) i_define(Fname, "_MIN_EXP", (long) f_min_exp, (long) F_MIN_EXP);
-
- if (setjmp(lab)==0) {
- Vprintf("%sMinimum normalised positive number = %s%s\n",
- co, f_rep(digs, (Long_double) f_min), oc);
- } else {
- eek_a_bug("printf can't print the smallest normalised number");
- printf("\n");
- }
- Unexpected(24);
- /* Possible loss of precision warnings here from non-stdc compilers: */
- if (setjmp(lab) == 0) {
- if (F) f_define(Fname, "_MIN", digs, (Long_double) f_min, MARK);
- if (V || F) F_check(digs, (Long_double) f_min);
- } else {
- eek_a_bug("xxx_MIN caused a trap");
- printf("\n");
- }
-
- if (setjmp(lab) == 0) {
- if (F) Validate(digs, (Long_double) f_min, (Long_double) F_MIN,
- f_min == Self(F_MIN));
- } else {
- printf("%s*** Verify failed for above #define!\n %s %s\n\n",
- co, "Compiler has an unusable number for value", oc);
- bugs++;
- }
- Unexpected(25);
-
- a=1.0; f_min_10_exp=0;
- while (a > f_min*10.0) { a/=10.0; f_min_10_exp--; }
- if (F) i_define(Fname, "_MIN_10_EXP", (long) f_min_10_exp,
- (long) F_MIN_10_EXP);
-
- /* Minimum exponent ************************************************/
- if (setjmp(lab)==0) { /* for underflow trap */ /* Yields xminner */
- do {
- xminner=y;
- y=Div(y,base);
- a=Mul(y,1.0);
- if ((Sum(a,a) == 0.0) || (fabs(y) >= xminner)) break;
- } while (1);
- }
- Unexpected(26);
-
- if (xminner != 0.0 && xminner != f_min) {
- normal= 0;
- Vprintf("%sThe smallest numbers are not kept normalised%s\n",
- co, oc);
- if (setjmp(lab)==0) {
- Vprintf("%sSmallest unnormalised positive number = %s%s\n",
- co, f_rep(digs, (Long_double) xminner), oc);
- if (V) F_check(digs, (Long_double) xminner);
- } else {
- eek_a_bug("printf can't print the smallest unnormalised number.");
- printf("\n");
- }
- Unexpected(27);
- } else {
- normal= 1;
- Vprintf("%sThe smallest numbers are normalised%s\n", co, oc);
- }
-
- /* Maximum exponent ************************************************/
- f_max_exp=2; f_max=1.0; newxmax=base+1.0;
- inf=0; trap=0;
- while (f_max<newxmax) {
- f_max=newxmax;
- if (setjmp(lab) == 0) { /* Yields inf, f_max_exp */
- newxmax=Mul(newxmax, base);
- } else {
- trap=1;
- break;
- }
- if (Div(newxmax, base) != f_max) {
- inf=1; /* ieee infinity */
- break;
- }
- f_max_exp++;
- }
- Unexpected(28);
- if (trap) {
- Vprintf("%s%s overflow generates a trap%s\n", co, Thing, oc);
- }
-
- if (inf) Vprintf("%sThere is an 'infinite' value%s\n", co, oc);
- Vprintf("%sMaximum exponent = %d%s\n", co, f_max_exp, oc);
- if (F) i_define(Fname, "_MAX_EXP", (long) f_max_exp, (long) F_MAX_EXP);
-
- /* Largest number ***************************************************/
- f_max=Diff(1.0, epsneg);
- if (Mul(f_max,1.0) != f_max) f_max=Diff(1.0, Mul(base,epsneg));
- for (i=1; i<=f_max_exp; i++) f_max=Mul(f_max, base);
-
- if (setjmp(lab)==0) {
- Vprintf("%sMaximum number = %s%s\n",
- co, f_rep(digs, (Long_double) f_max), oc);
- } else {
- eek_a_bug("printf can't print the largest double.");
- printf("\n");
- }
- if (setjmp(lab)==0) {
- /* Possible loss of precision warnings here from non-stdc compilers: */
- if (F) f_define(Fname, "_MAX", digs, (Long_double) f_max, MARK);
- if (V || F) F_check(digs, (Long_double) f_max);
- } else {
- eek_a_bug("xxx_MAX caused a trap");
- printf("\n");
- }
- if (setjmp(lab)==0) {
- if (F) Validate(digs, (Long_double) f_max, (Long_double) F_MAX,
- f_max == Self(F_MAX));
- } else {
- printf("%s*** Verify failed for above #define!\n %s %s\n\n",
- co, "Compiler has an unusable number for value", oc);
- bugs++;
- }
- Unexpected(29);
-
- a=1.0; f_max_10_exp=0;
- while (a < f_max/10.0) { a*=10.0; f_max_10_exp++; }
- if (F) i_define(Fname, "_MAX_10_EXP", (long) f_max_10_exp,
- (long) F_MAX_10_EXP);
-
- /* Hidden bit + sanity check ****************************************/
- if (f_radix != 10) {
- hidden=0;
- mantbits=floor_log(2, (Long_double)f_radix)*f_mant_dig;
- if (mantbits+iexp == (int)sizeof(Number)*bits_per_byte) {
- hidden=1;
- Vprintf("%sArithmetic uses a hidden bit%s\n", co, oc);
- } else if (mantbits+iexp+1 == (int)sizeof(Number)*bits_per_byte) {
- Vprintf("%sArithmetic doesn't use a hidden bit%s\n",
- co, oc);
- } else {
- printf("\n%s%s\n %s %s %s!%s\n\n",
- co,
- "*** Something fishy here!",
- "Exponent size + mantissa size doesn't match",
- "with the size of a", thing,
- oc);
- }
- if (hidden && f_radix == 2 && f_max_exp+f_min_exp==3) {
- Vprintf("%sIt looks like %s length IEEE format%s\n",
- co, f_mant_dig==24 ? "single" :
- f_mant_dig==53 ? "double" :
- f_mant_dig >53 ? "extended" :
- "some", oc);
- if (f_rounds != 1 || normal) {
- Vprintf("%s though ", co);
- if (f_rounds != 1) {
- Vprintf("the rounding is unusual");
- if (normal) Vprintf(" and ");
- }
- if (normal) Vprintf("the normalisation is unusual");
- Vprintf("%s\n", oc);
- }
- } else {
- Vprintf("%sIt doesn't look like IEEE format%s\n",
- co, oc);
- }
- }
- printf("\n"); /* regardless of verbosity */
- return f_mant_dig;
-}
-
-Procedure EPROP(fprec, dprec, lprec) int fprec, dprec, lprec; {
- /* See if expressions are evaluated in extended precision.
- Some compilers optimise even if you don't want it,
- and then this function fails to produce the right result.
- We try to diagnose this if it happens.
- */
- volatile int eprec;
- volatile double a, b, base, old;
- volatile Number d, oldd, dbase, one, zero;
- volatile int bad=0;
-
- /* Size of mantissa **************************************/
- a=1.0;
- if (setjmp(lab) == 0) { /* Yields nothing */
- do { old=a; a=a+a; }
- while ((((a+1.0)-a)-1.0) == 0.0 && a>old);
- } else bad=1;
- if (a <= old) bad=1;
-
- if (!bad) {
- b=1.0;
- if (setjmp(lab) == 0) { /* Yields nothing */
- do { old=b; b=b+b; }
- while ((base=((a+b)-a)) == 0.0 && b>old);
- if (b <= old) bad=1;
- } else bad=1;
- }
-
- if (!bad) {
- eprec=0; d=1.0; dbase=base; one=1.0; zero=0.0;
- if (setjmp(lab) == 0) { /* Yields nothing */
- do { eprec++; oldd=d; d=d*dbase; }
- while ((((d+one)-d)-one) == zero && d>oldd);
- if (d <= oldd) bad=1;
- } else bad=1;
- }
-
- Unexpected(30);
-
- if (bad) {
- Vprintf("%sCan't determine precision for %s expressions:\n%s%s\n",
- co, thing, " check that you compiled without optimisation!",
- oc);
- } else if (eprec==dprec) {
- Vprintf("%s%s expressions are evaluated in double precision%s\n",
- co, Thing, oc);
- } else if (eprec==fprec) {
- Vprintf("%s%s expressions are evaluated in float precision%s\n",
- co, Thing, oc);
- } else if (eprec==lprec) {
- Vprintf("%s%s expressions are evaluated in long double precision%s\n",
- co, Thing, oc);
- } else {
- Vprintf("%s%s expressions are evaluated in a %s %s %d %s%s\n",
- co, Thing, eprec>dprec ? "higher" : "lower",
- "precision than double,\n using",
- eprec, "base digits",
- oc);
- }
-}
-
-#else /* Number */
-
-#ifdef FPROP
-/* ARGSUSED */
-int FPROP(bits_per_byte) int bits_per_byte; {
- return 0;
-}
-#endif
-#ifdef EPROP
-/* ARGSUSED */
-Procedure EPROP(fprec, dprec, lprec) int fprec, dprec, lprec; {}
-#endif
-
-#endif /* ifdef Number */
-
-#ifdef PASS3
-#undef PASS
-#endif
-
-#ifdef PASS2
-#undef PASS2
-#define PASS3 1
-#endif
-
-#ifdef PASS1
-#undef PASS1
-#define PASS2 1
-#endif
-
-/* If your C compiler doesn't accept the next #include,
- replace __FILE__ with the file name - and get a new C compiler... */
-
-#ifdef PASS
-#include __FILE__
-#endif
-
/* -*-C-*-
-$Id: history.h,v 9.36 2007/01/05 21:19:25 cph Exp $
+$Id: history.h,v 9.37 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define HISTORY_UNMARK(object) (object) &=~ HISTORY_MARK_MASK
#define HISTORY_MARKED_P(object) (((object) & HISTORY_MARK_MASK) != 0)
-/* Save_History places a restore history frame on the stack. Such a
- frame consists of a normal continuation frame plus a pointer to the
- stacklet on which the last restore history is located and the
- offset within that stacklet. If the last restore history is in
- this stacklet then the history pointer is #F to signify this. If
- there is no previous restore history then the history pointer is #F
- and the offset is 0. */
-
-#define Save_History(Return_Code) \
-{ \
- STACK_PUSH \
- ((Prev_Restore_History_Stacklet == NULL) \
- ? SHARP_F \
- : (MAKE_POINTER_OBJECT \
- (TC_CONTROL_POINT, Prev_Restore_History_Stacklet))); \
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (Prev_Restore_History_Offset)); \
- exp_register \
- = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register)); \
- Store_Return (Return_Code); \
- Save_Cont (); \
- history_register \
- = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History))); \
-}
-\f
-/* History manipulation in the interpreter. */
+#define READ_DUMMY_HISTORY() VECTOR_REF (fixed_objects, DUMMY_HISTORY)
-#ifndef DISABLE_HISTORY
-
-#define New_Subproblem(expression, environment) \
-{ \
- history_register \
- = (OBJECT_ADDRESS (history_register [HIST_NEXT_SUBPROBLEM])); \
- HISTORY_MARK (history_register [HIST_MARK]); \
- { \
- SCHEME_OBJECT * Rib \
- = (OBJECT_ADDRESS (history_register [HIST_RIB])); \
- HISTORY_MARK (Rib [RIB_MARK]); \
- (Rib [RIB_ENV]) = (environment); \
- (Rib [RIB_EXP]) = (expression); \
- } \
-}
-
-#define Reuse_Subproblem(expression, environment) \
-{ \
- SCHEME_OBJECT * Rib = (OBJECT_ADDRESS (history_register [HIST_RIB])); \
- HISTORY_MARK (Rib [RIB_MARK]); \
- (Rib [RIB_ENV]) = (environment); \
- (Rib [RIB_EXP]) = (expression); \
-}
-
-#define New_Reduction(expression, environment) \
-{ \
- fast SCHEME_OBJECT * Rib = \
- (OBJECT_ADDRESS \
- (FAST_MEMORY_REF ((history_register [HIST_RIB]), \
- RIB_NEXT_REDUCTION))); \
- (history_register [HIST_RIB]) = \
- (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Rib)); \
- (Rib [RIB_ENV]) = (environment); \
- (Rib [RIB_EXP]) = (expression); \
- HISTORY_UNMARK (Rib [RIB_MARK]); \
-}
-
-#define End_Subproblem() \
-{ \
- HISTORY_UNMARK (history_register [HIST_MARK]); \
- history_register \
- = (OBJECT_ADDRESS (history_register [HIST_PREV_SUBPROBLEM])); \
-}
-
-#else /* DISABLE_HISTORY */
-
-#define New_Subproblem(Expr, Env) {}
-#define Reuse_Subproblem(Expr, Env) {}
-#define New_Reduction(Expr, Env) {}
-#define End_Subproblem() {}
-
-#endif /* DISABLE_HISTORY */
-\f
-/* History manipulation for the compiled code interface. */
+#define SAVE_HISTORY_LENGTH (2 + CONTINUATION_SIZE)
+#define SAVE_HISTORY save_history
+#define RESET_HISTORY reset_history
#ifndef DISABLE_HISTORY
+# define NEW_SUBPROBLEM new_subproblem
+# define REUSE_SUBPROBLEM reuse_subproblem
+# define NEW_REDUCTION new_reduction
+# define END_SUBPROBLEM end_subproblem
+# define COMPILER_NEW_SUBPROBLEM compiler_new_subproblem
+# define COMPILER_NEW_REDUCTION compiler_new_reduction
+# define COMPILER_END_SUBPROBLEM end_subproblem
+#else
+# define NEW_SUBPROBLEM(exp, env) do {} while (false)
+# define REUSE_SUBPROBLEM(exp, env) do {} while (false)
+# define NEW_REDUCTION(exp, env) do {} while (false)
+# define END_SUBPROBLEM() do {} while (false)
+# define COMPILER_NEW_REDUCTION() do {} while (false)
+# define COMPILER_NEW_SUBPROBLEM() do {} while (false)
+# define COMPILER_END_SUBPROBLEM() do {} while (false)
+#endif
-#define Compiler_New_Reduction() \
-{ \
- New_Reduction \
- (SHARP_F, \
- (MAKE_OBJECT (TC_RETURN_CODE, RC_POP_FROM_COMPILED_CODE))); \
-}
-
-#define Compiler_New_Subproblem() \
-{ \
- New_Subproblem \
- (SHARP_F, \
- (MAKE_OBJECT (TC_RETURN_CODE, RC_POP_FROM_COMPILED_CODE))); \
-}
-
-#define Compiler_End_Subproblem End_Subproblem
-
-#else /* DISABLE_HISTORY */
-
-#define Compiler_New_Reduction()
-#define Compiler_New_Subproblem()
-#define Compiler_End_Subproblem()
+extern SCHEME_OBJECT * history_register;
+extern unsigned long prev_restore_history_offset;
+
+extern void reset_history (void);
+extern SCHEME_OBJECT * make_dummy_history (void);
+extern void save_history (unsigned long);
+extern bool restore_history (SCHEME_OBJECT);
+extern void stop_history (void);
+extern void new_subproblem (SCHEME_OBJECT, SCHEME_OBJECT);
+extern void reuse_subproblem (SCHEME_OBJECT, SCHEME_OBJECT);
+extern void new_reduction (SCHEME_OBJECT, SCHEME_OBJECT);
+extern void end_subproblem (void);
+extern void compiler_new_subproblem (void);
+extern void compiler_new_reduction (void);
-#endif /* DISABLE_HISTORY */
/* -*-C-*-
-$Id: hooks.c,v 9.68 2007/01/05 21:19:25 cph Exp $
+$Id: hooks.c,v 9.69 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
#include "winder.h"
#include "history.h"
+
+static SCHEME_OBJECT allocate_control_point (unsigned long, bool);
+static void with_new_interrupt_mask (unsigned long);
+
+/* This is a kludge to compensate for the interpreter popping
+ a primitive's frame off the stack after it returns. */
+#define UN_POP_PRIMITIVE_FRAME(n) (stack_pointer = (STACK_LOC (-(n))))
\f
-DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2,
- "(PROCEDURE LIST-OF-ARGS)\n\
-Invoke PROCEDURE on the arguments contained in list-of-ARGS.")
+DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, "(PROCEDURE ARG-LIST)\n\
+Invokes PROCEDURE on the arguments in ARG-LIST.")
{
- SCHEME_OBJECT procedure;
- SCHEME_OBJECT argument_list;
- fast long number_of_args;
PRIMITIVE_HEADER (2);
-
- procedure = (ARG_REF (1));
- argument_list = (ARG_REF (2));
- /* Since this primitive must pop its own frame off and push a new
- frame on the stack, it has to be careful. Its own stack frame is
- needed if an error or GC is required. So these checks are done
- first (at the cost of traversing the argument list twice), then
- the primitive's frame is popped, and finally the new frame is
- constructed.
-
- Originally this code tried to be clever by copying the argument
- list into a linear (vector-like) form, so as to avoid the
- overhead of traversing the list twice. Unfortunately, the
- overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed)
- is sufficiently high that it probably makes up for the time saved.
- */
{
- fast SCHEME_OBJECT scan_list, scan_list_trail;
- TOUCH_IN_PRIMITIVE (argument_list, scan_list);
- if (! (PAIR_P (scan_list)))
- number_of_args = 0;
- else
+ SCHEME_OBJECT procedure = (ARG_REF (1));
+ SCHEME_OBJECT args = (ARG_REF (2));
+ unsigned long n_args = 0;
+
+ /* Since this primitive must pop its own frame off and push a new
+ frame on the stack, it has to be careful. Its own stack frame
+ is needed if an error or GC is required. So these checks are
+ done first (at the cost of traversing the argument list twice),
+ then the primitive's frame is popped, and finally the new frame
+ is constructed. */
+
{
- number_of_args = 1;
- scan_list_trail = scan_list;
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
- while (true)
- {
- if (scan_list == scan_list_trail)
- error_bad_range_arg (2);
- if (! (PAIR_P (scan_list)))
- break;
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
- if (scan_list == scan_list_trail)
- error_bad_range_arg (2);
- if (! (PAIR_P (scan_list)))
+ SCHEME_OBJECT p1 = args;
+ SCHEME_OBJECT p2 = p1;
+
+ while (PAIR_P (p1))
{
- number_of_args += 1;
- break;
+ p1 = (PAIR_CDR (p1));
+ n_args += 1;
+ if (p1 == p2)
+ error_bad_range_arg (2);
+ if (!PAIR_P (p1))
+ break;
+
+ p1 = (PAIR_CDR (p1));
+ n_args += 1;
+ if (p1 == p2)
+ error_bad_range_arg (2);
+ if (!PAIR_P (p1))
+ break;
+
+ p2 = (PAIR_CDR (p2));
}
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
- scan_list_trail = (PAIR_CDR (scan_list_trail));
- number_of_args += 2;
- }
+ if (!EMPTY_LIST_P (p1))
+ error_wrong_type_arg (2);
}
- if (!EMPTY_LIST_P (scan_list))
- error_wrong_type_arg (2);
- }
-\f
-#ifdef USE_STACKLETS
- /* This is conservative: if the number of arguments is large enough
- the Will_Push below may try to allocate space on the heap for the
- stack frame. */
- Primitive_GC_If_Needed
- (New_Stacklet_Size (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
-#endif /* USE_STACKLETS */
-
-#ifdef USE_STACKLETS
- POP_PRIMITIVE_FRAME (2);
- Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
-#else
- /* Don't use Will_Push for this -- if the length of the list is too
- large to fit on the stack, it could cause Scheme to terminate. */
- if ((sp_register - (number_of_args + STACK_ENV_EXTRA_SLOTS + 1))
- <= Stack_Guard)
- error_bad_range_arg (2);
- POP_PRIMITIVE_FRAME (2);
-#endif
- {
- fast long i;
- fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
- fast SCHEME_OBJECT scan_list;
- TOUCH_IN_PRIMITIVE (argument_list, scan_list);
- for (i = number_of_args; (i > 0); i -= 1)
+
+ if (!CAN_PUSH_P (n_args + 2))
+ error_bad_range_arg (2);
+ POP_PRIMITIVE_FRAME (2);
+
{
-#ifdef LOSING_PARALLEL_PROCESSOR
- /* This half-measure should be replaced by some kind of lock
- or something else that guarantees that the code will win. */
- /* Check for abominable case of someone bashing the arg list. */
- if (! (PAIR_P (scan_list)))
+ SCHEME_OBJECT p1 = args;
+ SCHEME_OBJECT * sp = (STACK_LOC (-n_args));
+ SCHEME_OBJECT * s1 = sp;
+ while (s1 != stack_pointer)
+ {
+ (STACK_LOCATIVE_POP (s1)) = (PAIR_CAR (p1));
+ p1 = (PAIR_CDR (p1));
+ }
+ stack_pointer = sp;
+ }
+
+#ifdef CC_SUPPORT_P
+ if (CC_ENTRY_P (STACK_REF (n_args)))
{
- /* Re-push the primitive's frame. */
- STACK_PUSH (argument_list);
- STACK_PUSH (procedure);
- error_bad_range_arg (2);
+ long code = (apply_compiled_from_primitive (n_args, procedure));
+ if (code != PRIM_DONE)
+ PRIMITIVE_ABORT (code);
+ UN_POP_PRIMITIVE_FRAME (2);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-#endif /* LOSING_PARALLEL_PROCESSOR */
- (*scan_stack++) = (PAIR_CAR (scan_list));
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
- }
- }
- sp_register = (STACK_LOC (- number_of_args));
- STACK_PUSH (procedure);
- STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
-#ifdef USE_STACKLETS
- Pushed ();
#endif
- if (COMPILED_CODE_ADDRESS_P (STACK_REF (number_of_args + 2)))
- {
- extern SCHEME_OBJECT EXFUN (apply_compiled_from_primitive, (int));
- PRIMITIVE_RETURN (apply_compiled_from_primitive (2));
+ STACK_PUSH (procedure);
+ PUSH_APPLY_FRAME_HEADER (n_args);
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- return (0);
}
\f
-/* CALL-WITH-CURRENT-CONTINUATION
-
- Implementation detail: in addition to setting aside the old
- stacklet on a catch, the new stacklet is cleared and a return
- code is placed at the base of the (now clear) stack indicating
- that a return back through here requires restoring the stacklet.
- The current enabled interrupts are also saved in the old stacklet.
-
- >>> Temporarily (maybe) the act of doing a CATCH will disable any
- >>> return hook that may be in the stack.
- */
+/* CALL-WITH-CURRENT-CONTINUATION creates a control point (a pointer
+ to the current stack) and passes it to PROCEDURE as its only
+ argument. The inverse operation, typically called THROW, is
+ performed by using the control point as you would a procedure. The
+ control point accepts one argument that is returned as the value of
+ the call to this primitive. The control point may be reused as
+ often as desired since the stack will be copied on every throw. */
-#ifdef USE_STACKLETS
-
-#define CWCC_STACK_SIZE() (2 * Default_Stacklet_Size)
-#define NON_REENTRANT_RC_RESTORE RC_RESTORE_DONT_COPY_HISTORY
-#define NON_REENTRANT_FLAG SHARP_T
-
-#else /* not USE_STACKLETS */
-
-#define CWCC_STACK_SIZE() \
- ((Stack_Top - sp_register) + STACKLET_HEADER_SIZE \
- + CONTINUATION_SIZE + HISTORY_SIZE)
-
-/* When there are no stacklets, the two versions of CWCC are identical. */
-
-#define NON_REENTRANT_RC_RESTORE RC_RESTORE_HISTORY
-#define NON_REENTRANT_FLAG SHARP_F
-
-#endif /* USE_STACKLETS */
-
-void
-DEFUN (CWCC, (return_code, reuse_flag, receiver),
- long return_code
- AND SCHEME_OBJECT reuse_flag
- AND SCHEME_OBJECT receiver)
+DEFINE_PRIMITIVE ("CALL-WITH-CURRENT-CONTINUATION", Prim_catch, 1, 1,
+ "(PROCEDURE)\n\
+Invoke PROCEDURE with a copy of the current control stack.")
{
- SCHEME_OBJECT control_point;
-
- Primitive_GC_If_Needed (CWCC_STACK_SIZE ());
- POP_PRIMITIVE_FRAME (1);
- if (Return_Hook_Address != NULL)
- {
- (* Return_Hook_Address) = Old_Return_Code;
- Return_Hook_Address = NULL;
- }
-\f
- /* Tail recursion hacking in CWCC.
- If the current stack contains only a frame to restore
- another control point that looks like the result of CWCC,
- then there is no need to push anything else on the stack
- or cons anything on the heap.
-
- This hackery would be considerably simpler if the interrupt
- mask and history information were kept explicitly instead
- of implicitly (pushed with appropriate restore return codes).
- */
-
- if (((STACK_LOC (CONTINUATION_SIZE)) == (Get_End_Of_Stacklet ()))
- && ((OBJECT_DATUM (STACK_REF (CONTINUATION_RETURN_CODE)))
- == RC_JOIN_STACKLETS))
+ PRIMITIVE_HEADER (1);
+ canonicalize_primitive_context ();
{
- control_point = (STACK_REF (CONTINUATION_EXPRESSION));
+ SCHEME_OBJECT procedure = (ARG_REF (1));
+ SCHEME_OBJECT cp;
- if (((OBJECT_TYPE (control_point)) == TC_CONTROL_POINT)
- && ((reuse_flag == SHARP_F)
- || ((MEMORY_REF (control_point, STACKLET_REUSE_FLAG))
- == SHARP_F)))
- {
- SCHEME_OBJECT * prev_stack
- = (MEMORY_LOC (control_point,
- (STACKLET_HEADER_SIZE
- + (OBJECT_DATUM (MEMORY_REF
- (control_point,
- STACKLET_UNUSED_LENGTH))))));
- SCHEME_OBJECT * ret_ptr
- = (STACK_LOCATIVE_OFFSET (prev_stack,
- (CONTINUATION_SIZE
- + CONTINUATION_RETURN_CODE)));
-
- if ((ret_ptr
- <= (VECTOR_LOC (control_point, (VECTOR_LENGTH (control_point)))))
- && ((OBJECT_DATUM (STACK_LOCATIVE_REFERENCE
- (prev_stack,
- CONTINUATION_RETURN_CODE)))
- == RC_RESTORE_INT_MASK))
- {
- long ret_code = (OBJECT_DATUM (*ret_ptr));
+ /* Optimization: if the current stack consists only of an
+ RC_JOIN_STACKLETS frame, there's no need to create a new
+ control point. */
- if ((ret_code == RC_RESTORE_HISTORY) || (ret_code == return_code))
+ if (((STACK_LOC (1 + CONTINUATION_SIZE)) == STACK_BOTTOM)
+ && (CHECK_RETURN_CODE (RC_JOIN_STACKLETS, 1))
+ && (CONTROL_POINT_P (CONT_EXP (1))))
+ {
+ cp = (CONT_EXP (1));
+ history_register = (OBJECT_ADDRESS (READ_DUMMY_HISTORY ()));
+ POP_PRIMITIVE_FRAME (1);
+ STACK_RESET ();
+ }
+ else
+ {
+ cp = (allocate_control_point ((CONTINUATION_SIZE
+ + HISTORY_SIZE
+ + (STACK_N_PUSHED - 1)),
+ true));
+ POP_PRIMITIVE_FRAME (1);
+
+ SAVE_HISTORY (RC_RESTORE_HISTORY);
+ preserve_interrupt_mask ();
+ prev_restore_history_offset = 0;
{
- history_register
- = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)));
- STACK_RESET ();
- /* Will_Push(3); */
- STACK_PUSH (control_point);
- STACK_PUSH (receiver);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
- /* Pushed(); */
-
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
+ SCHEME_OBJECT * scan = (control_point_start (cp));
+ while (STACK_N_PUSHED > 0)
+ (*scan++) = (STACK_POP ());
}
- }
- }
- }
-\f
- /*
- Put down frames to restore history and interrupts so that these
- operations will be performed on a throw.
- */
- Will_Push (HISTORY_SIZE);
- Save_History (return_code);
- Pushed ();
- preserve_interrupt_mask ();
- /* There is no history to use since the
- last control point was formed.
- */
- Prev_Restore_History_Stacklet = NULL;
- Prev_Restore_History_Offset = 0;
-
-#ifdef USE_STACKLETS
- {
- control_point = (Get_Current_Stacklet ());
- Allocate_New_Stacklet (3);
- }
-#else /* not USE_STACKLETS */
- {
- fast long n_words = (Stack_Top - sp_register);
- control_point = (allocate_marked_vector
- (TC_CONTROL_POINT,
- (n_words + (STACKLET_HEADER_SIZE - 1)),
- false));
- FAST_MEMORY_SET (control_point, STACKLET_REUSE_FLAG, reuse_flag);
- FAST_MEMORY_SET (control_point,
- STACKLET_UNUSED_LENGTH,
- (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)));
- {
- fast SCHEME_OBJECT * scan =
- (MEMORY_LOC (control_point, STACKLET_HEADER_SIZE));
- while ((n_words--) > 0)
- (*scan++) = (STACK_POP ());
- }
- if (Consistency_Check && (sp_register != Stack_Top))
- Microcode_Termination (TERM_BAD_STACK);
- CLEAR_INTERRUPT (INT_Stack_Overflow);
- STACK_RESET ();
- Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_JOIN_STACKLETS);
- exp_register = control_point;
- Save_Cont ();
- Pushed ();
- }
-#endif /* USE_STACKLETS */
+#ifdef ENABLE_DEBUGGING_TOOLS
+ if (STACK_N_PUSHED != 0)
+ Microcode_Termination (TERM_BAD_STACK);
+#endif
- /* we just cleared the stack so there MUST be room */
- /* Will_Push(3); */
- STACK_PUSH (control_point);
- STACK_PUSH (receiver);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
- /* Pushed(); */
+ CLEAR_INTERRUPT (INT_Stack_Overflow);
+ STACK_RESET ();
+ SET_RC (RC_JOIN_STACKLETS);
+ SET_EXP (cp);
+ SAVE_CONT ();
+ }
+ STACK_PUSH (cp);
+ STACK_PUSH (procedure);
+ PUSH_APPLY_FRAME_HEADER (1);
+ }
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
-}
-\f
-/* (CALL-WITH-CURRENT-CONTINUATION PROCEDURE)
-
- Creates a control point (a pointer to the current stack) and passes
- it to PROCEDURE as its only argument. The inverse operation,
- typically called THROW, is performed by using the control point as
- you would a procedure. A control point accepts one argument which
- is then returned as the value of the CATCH which created the
- control point. If the reuse flag of the stacklet is clear then the
- control point may be reused as often as desired since the stack
- will be copied on every throw. The user level CATCH is built on
- this primitive but is not the same, since it handles dynamic state
- while the primitive does not; it assumes that the microcode sets
- and clears the appropriate reuse flags for copying.
-*/
-
-DEFINE_PRIMITIVE ("CALL-WITH-CURRENT-CONTINUATION", Prim_catch, 1, 1,
- "(RECEIVER)\n\
-Invoke RECEIVER with a reentrant copy of the current control stack.")
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
- CWCC (RC_RESTORE_HISTORY, SHARP_F, (ARG_REF (1)));
- /*NOTREACHED*/
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION",
- Prim_non_reentrant_catch, 1, 1,
- "(RECEIVER)\n\
-Invoke RECEIVER with a non-reentrant copy of the current control stack.")
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT();
- CWCC (NON_REENTRANT_RC_RESTORE, NON_REENTRANT_FLAG, (ARG_REF (1)));
- /*NOTREACHED*/
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
the stack is never restored.
WITHIN-CONTROL-POINT clears the current stack, pushes a frame
that restores control-point when THUNK returns, and sets up
- an apply frame for THUNK.
- */
+ an apply frame for THUNK. */
DEFINE_PRIMITIVE ("WITHIN-CONTROL-POINT", Prim_within_control_point, 2, 2,
"(CONTROL-POINT THUNK)\n\
SCHEME_OBJECT control_point, thunk;
PRIMITIVE_HEADER (2);
- PRIMITIVE_CANONICALIZE_CONTEXT();
+ canonicalize_primitive_context();
CHECK_ARG (1, CONTROL_POINT_P);
control_point = (ARG_REF (1));
thunk = (ARG_REF (2));
- /* This KNOWS the direction of stack growth. */
- sp_register = (Get_End_Of_Stacklet ());
+ stack_pointer = STACK_BOTTOM;
/* We've discarded the history with the stack contents. */
- Prev_Restore_History_Stacklet = NULL;
- Prev_Restore_History_Offset = 0;
+ prev_restore_history_offset = 0;
CLEAR_INTERRUPT (INT_Stack_Overflow);
Will_Push (CONTINUATION_SIZE);
- exp_register = control_point;
- Store_Return (RC_JOIN_STACKLETS);
- Save_Cont ();
+ SET_EXP (control_point);
+ SET_RC (RC_JOIN_STACKLETS);
+ SAVE_CONT ();
Pushed ();
Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
STACK_PUSH (thunk);
- STACK_PUSH (STACK_FRAME_HEADER);
+ PUSH_APPLY_FRAME_HEADER (0);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
+static SCHEME_OBJECT
+allocate_control_point (unsigned long n, bool gc_p)
+{
+ SCHEME_OBJECT cp
+ = (allocate_marked_vector (TC_CONTROL_POINT, (n + 2), gc_p));
+ VECTOR_SET (cp, 0, SHARP_F);
+ VECTOR_SET (cp, 1, (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)));
+ return (cp);
+}
+
+SCHEME_OBJECT *
+control_point_start (SCHEME_OBJECT cp)
+{
+ return (VECTOR_LOC (cp, 2));
+}
+
+SCHEME_OBJECT *
+control_point_end (SCHEME_OBJECT cp)
+{
+ return (VECTOR_LOC (cp, (VECTOR_LENGTH (cp))));
+}
+
+void
+unpack_control_point (SCHEME_OBJECT cp)
+{
+ WHEN_DEBUGGING
+ ({
+ if (!CONTROL_POINT_P (cp))
+ Microcode_Termination (TERM_BAD_STACK);
+ });
+ {
+ SCHEME_OBJECT * scan_from = (control_point_end (cp));
+ SCHEME_OBJECT * end_from = (control_point_start (cp));
+
+ stack_pointer = STACK_BOTTOM;
+ CLEAR_INTERRUPT (INT_Stack_Overflow);
+ STACK_CHECK (end_from - scan_from);
+
+ while (scan_from > end_from)
+ STACK_PUSH (*--scan_from);
+ }
+ STACK_RESET ();
+}
+\f
DEFINE_PRIMITIVE ("ERROR-PROCEDURE", Prim_error_procedure, 3, 3,
"(MESSAGE IRRITANTS ENVIRONMENT)\nSignal an error.")
{
PRIMITIVE_HEADER (3);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
{
- fast SCHEME_OBJECT message = (ARG_REF (1));
- fast SCHEME_OBJECT irritants = (ARG_REF (2));
- fast SCHEME_OBJECT environment = (ARG_REF (3));
+ SCHEME_OBJECT message = (ARG_REF (1));
+ SCHEME_OBJECT irritants = (ARG_REF (2));
+ SCHEME_OBJECT environment = (ARG_REF (3));
/* This is done outside the Will_Push because the space for it
is guaranteed by the interpreter before it gets here.
If done inside, this could break when using stacklets. */
back_out_of_primitive ();
Will_Push (HISTORY_SIZE + STACK_ENV_EXTRA_SLOTS + 4);
- Stop_History ();
+ stop_history ();
/* Stepping should be cleared here! */
STACK_PUSH (environment);
STACK_PUSH (irritants);
STACK_PUSH (message);
- STACK_PUSH (Get_Fixed_Obj_Slot (Error_Procedure));
- STACK_PUSH (STACK_FRAME_HEADER + 3);
+ STACK_PUSH (VECTOR_REF (fixed_objects, Error_Procedure));
+ PUSH_APPLY_FRAME_HEADER (3);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
Evaluate SCODE-EXPRESSION in ENVIRONMENT.")
{
PRIMITIVE_HEADER (2);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
CHECK_ARG (2, ENVIRONMENT_P);
{
- fast SCHEME_OBJECT expression = (ARG_REF (1));
- fast SCHEME_OBJECT environment = (ARG_REF (2));
+ SCHEME_OBJECT expression = (ARG_REF (1));
+ SCHEME_OBJECT environment = (ARG_REF (2));
POP_PRIMITIVE_FRAME (2);
- env_register = environment;
- exp_register = expression;
+ SET_ENV (environment);
+ SET_EXP (expression);
}
PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
/*NOTREACHED*/
PRIMITIVE_HEADER (1);
CHECK_ARG (1, PROMISE_P);
{
- fast SCHEME_OBJECT thunk = (ARG_REF (1));
- fast SCHEME_OBJECT State = (MEMORY_REF (thunk, THUNK_SNAPPED));
+ SCHEME_OBJECT thunk = (ARG_REF (1));
+ SCHEME_OBJECT State = (MEMORY_REF (thunk, THUNK_SNAPPED));
if (State == SHARP_T)
PRIMITIVE_RETURN (MEMORY_REF (thunk, THUNK_VALUE));
else if (State == FIXNUM_ZERO)
{
/* New-style thunk used by compiled code. */
- PRIMITIVE_CANONICALIZE_CONTEXT();
+ canonicalize_primitive_context ();
POP_PRIMITIVE_FRAME (1);
Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Store_Return (RC_SNAP_NEED_THUNK);
- exp_register = thunk;
- Save_Cont ();
+ SET_RC (RC_SNAP_NEED_THUNK);
+ SET_EXP (thunk);
+ SAVE_CONT ();
STACK_PUSH (MEMORY_REF (thunk, THUNK_VALUE));
- STACK_PUSH (STACK_FRAME_HEADER);
+ PUSH_APPLY_FRAME_HEADER (0);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
else
{
/* Old-style thunk used by interpreted code. */
- PRIMITIVE_CANONICALIZE_CONTEXT();
+ canonicalize_primitive_context ();
POP_PRIMITIVE_FRAME (1);
Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_SNAP_NEED_THUNK);
- exp_register = thunk;
- Save_Cont ();
+ SET_RC (RC_SNAP_NEED_THUNK);
+ SET_EXP (thunk);
+ SAVE_CONT ();
Pushed ();
- env_register = (FAST_MEMORY_REF (thunk, THUNK_ENVIRONMENT));
- exp_register = (FAST_MEMORY_REF (thunk, THUNK_PROCEDURE));
+ SET_ENV (MEMORY_REF (thunk, THUNK_ENVIRONMENT));
+ SET_EXP (MEMORY_REF (thunk, THUNK_PROCEDURE));
PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
/*NOTREACHED*/
PRIMITIVE_RETURN (UNSPECIFIC);
{
PRIMITIVE_HEADER (4);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
- guarantee_state_point ();
+ canonicalize_primitive_context ();
{
SCHEME_OBJECT old_point;
if ((ARG_REF (1)) == SHARP_F)
- old_point = Current_State_Point;
+ old_point = current_state_point;
else
{
CHECK_ARG (1, STATE_SPACE_P);
- old_point =
- (FAST_MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
+ old_point = (MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
}
{
SCHEME_OBJECT new_point =
(allocate_marked_vector (TC_VECTOR, STATE_POINT_LENGTH, true));
SCHEME_OBJECT during_thunk = (ARG_REF (3));
- FAST_MEMORY_SET
- (new_point, STATE_POINT_TAG, (Get_Fixed_Obj_Slot (State_Point_Tag)));
- FAST_MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, (ARG_REF (2)));
- FAST_MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, (ARG_REF (4)));
- FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, old_point);
- FAST_MEMORY_SET
+ MEMORY_SET (new_point, STATE_POINT_TAG,
+ (VECTOR_REF (fixed_objects, State_Point_Tag)));
+ MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, (ARG_REF (2)));
+ MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, (ARG_REF (4)));
+ MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, old_point);
+ MEMORY_SET
(new_point,
STATE_POINT_DISTANCE_TO_ROOT,
- (1 + (FAST_MEMORY_REF (old_point, STATE_POINT_DISTANCE_TO_ROOT))));
+ (1 + (MEMORY_REF (old_point, STATE_POINT_DISTANCE_TO_ROOT))));
POP_PRIMITIVE_FRAME (4);
Will_Push((2 * CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 1));
/* Push a continuation to go back to the current state after the
body is evaluated */
- exp_register = old_point;
- Store_Return (RC_RESTORE_TO_STATE_POINT);
- Save_Cont ();
+ SET_EXP (old_point);
+ SET_RC (RC_RESTORE_TO_STATE_POINT);
+ SAVE_CONT ();
/* Push a stack frame which will call the body after we have moved
into the new state point */
STACK_PUSH (during_thunk);
- STACK_PUSH (STACK_FRAME_HEADER);
+ PUSH_APPLY_FRAME_HEADER (0);
/* Push the continuation to go with the stack frame */
- exp_register = SHARP_F;
- Store_Return (RC_INTERNAL_APPLY);
- Save_Cont ();
+ SET_EXP (SHARP_F);
+ SET_RC (RC_INTERNAL_APPLY);
+ SAVE_CONT ();
Pushed ();
Translate_To_Point (new_point);
/*NOTREACHED*/
"(STATE-POINT)\nRestore the dynamic state to STATE-POINT.")
{
PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
CHECK_ARG (1, STATE_POINT_P);
{
SCHEME_OBJECT state_point = (ARG_REF (1));
{
PRIMITIVE_HEADER (1);
{
- fast SCHEME_OBJECT new_point =
+ SCHEME_OBJECT new_point =
(allocate_marked_vector (TC_VECTOR, STATE_POINT_LENGTH, true));
- FAST_MEMORY_SET
- (new_point, STATE_POINT_TAG, (Get_Fixed_Obj_Slot (State_Point_Tag)));
- FAST_MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, SHARP_F);
- FAST_MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, SHARP_F);
- FAST_MEMORY_SET
+ MEMORY_SET (new_point, STATE_POINT_TAG,
+ (VECTOR_REF (fixed_objects, State_Point_Tag)));
+ MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, SHARP_F);
+ MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, SHARP_F);
+ MEMORY_SET
(new_point, STATE_POINT_DISTANCE_TO_ROOT, (LONG_TO_UNSIGNED_FIXNUM (0)));
if ((ARG_REF (1)) == SHARP_F)
{
- FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, SHARP_F);
- Current_State_Point = new_point;
+ MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, SHARP_F);
+ current_state_point = new_point;
PRIMITIVE_RETURN (SHARP_F);
}
else
{
- fast SCHEME_OBJECT new_space =
+ SCHEME_OBJECT new_space =
(allocate_marked_vector (TC_VECTOR, STATE_SPACE_LENGTH, true));
- FAST_MEMORY_SET
- (new_space, STATE_SPACE_TAG, (Get_Fixed_Obj_Slot (State_Space_Tag)));
- FAST_MEMORY_SET (new_space, STATE_SPACE_NEAREST_POINT, new_point);
- FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, new_space);
+ MEMORY_SET (new_space, STATE_SPACE_TAG,
+ (VECTOR_REF (fixed_objects, State_Space_Tag)));
+ MEMORY_SET (new_space, STATE_SPACE_NEAREST_POINT, new_point);
+ MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, new_space);
PRIMITIVE_RETURN (new_space);
}
}
{
PRIMITIVE_HEADER (1);
- guarantee_state_point ();
if ((ARG_REF (1)) == SHARP_F)
- PRIMITIVE_RETURN (Current_State_Point);
+ PRIMITIVE_RETURN (current_state_point);
CHECK_ARG (1, STATE_SPACE_P);
PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
}
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STATE_POINT_P);
{
- fast SCHEME_OBJECT state_point = (ARG_REF (1));
- fast SCHEME_OBJECT state_space = (Find_State_Space (state_point));
- fast SCHEME_OBJECT result;
+ SCHEME_OBJECT state_point = (ARG_REF (1));
+ SCHEME_OBJECT state_space = (Find_State_Space (state_point));
+ SCHEME_OBJECT result;
if (state_space == SHARP_F)
{
- guarantee_state_point ();
- result = Current_State_Point;
- Current_State_Point = state_point;
+ result = current_state_point;
+ current_state_point = state_point;
}
else
{
should clear the corresponding interrupt bit.")
{
PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (FETCH_INTERRUPT_MASK ()));
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (GET_INT_MASK));
}
DEFINE_PRIMITIVE ("SET-INTERRUPT-ENABLES!", Prim_set_interrupt_enables, 1, 1,
{
PRIMITIVE_HEADER (1);
{
- long previous = (FETCH_INTERRUPT_MASK ());
- SET_INTERRUPT_MASK ((arg_integer (1)) & INT_Mask);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (previous));
+ unsigned long previous = GET_INT_MASK;
+ SET_INTERRUPT_MASK ((arg_ulong_integer (1)) & INT_Mask);
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (previous));
}
}
See `get-interrupt-enables' for more information on interrupts.")
{
PRIMITIVE_HEADER (1);
- CLEAR_INTERRUPT ((arg_integer (1)) & INT_Mask);
+ CLEAR_INTERRUPT ((arg_ulong_integer (1)) & INT_Mask);
PRIMITIVE_RETURN (UNSPECIFIC);
}
-DEFINE_PRIMITIVE ("DISABLE-INTERRUPTS!", Prim_disable_interrupts, 1, 1,
+DEFINE_PRIMITIVE ("DISABLE-INTERRUPTS!", Prim_disable_interrupts, 1, 1,
"(INTERRUPT-MASK)\n\
Disables the interrupts specified in INTERRUPT-MASK by clearing the\n\
corresponding bits in the interrupt mask. Returns previous mask value.\n\
{
PRIMITIVE_HEADER (1);
{
- fast long previous = (FETCH_INTERRUPT_MASK ());
- SET_INTERRUPT_MASK (previous &~ ((arg_integer (1)) & INT_Mask));
- PRIMITIVE_RETURN (LONG_TO_FIXNUM (previous));
+ unsigned long previous = GET_INT_MASK;
+ SET_INTERRUPT_MASK (previous &~ ((arg_ulong_integer (1)) & INT_Mask));
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (previous));
}
}
{
PRIMITIVE_HEADER (1);
{
- fast long previous = (FETCH_INTERRUPT_MASK ());
- SET_INTERRUPT_MASK (previous | ((arg_integer (1)) & INT_Mask));
- PRIMITIVE_RETURN (LONG_TO_FIXNUM (previous));
+ unsigned long previous = GET_INT_MASK;
+ SET_INTERRUPT_MASK (previous | ((arg_ulong_integer (1)) & INT_Mask));
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (previous));
}
}
See `get-interrupt-enables' for more information on interrupts.")
{
PRIMITIVE_HEADER (1);
- REQUEST_INTERRUPT ((arg_integer (1)) & INT_Mask);
+ REQUEST_INTERRUPT ((arg_ulong_integer (1)) & INT_Mask);
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
identified by the continuation parser.")
{
PRIMITIVE_HEADER (LEXPR);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
{
- long nargs = (LEXPR_N_ARGUMENTS ());
+ unsigned long nargs = GET_LEXPR_ACTUALS;
if (nargs < 2)
signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
{
SCHEME_OBJECT thunk = (STACK_POP ());
- STACK_PUSH (STACK_FRAME_HEADER + (nargs - 2));
- env_register = THE_NULL_ENV;
- exp_register = SHARP_F;
- Store_Return (RC_INTERNAL_APPLY);
- Save_Cont ();
+ PUSH_APPLY_FRAME_HEADER (nargs - 2);
+ SET_ENV (THE_NULL_ENV);
+ SET_EXP (SHARP_F);
+ SET_RC (RC_INTERNAL_APPLY);
+ SAVE_CONT ();
Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
STACK_PUSH (thunk);
- STACK_PUSH (STACK_FRAME_HEADER);
+ PUSH_APPLY_FRAME_HEADER (0);
Pushed ();
}
}
By convention, MARKER1 is a tag identifying the kind of marker,\n\
and MARKER2 is data identifying the marker instance.")
{
- SCHEME_OBJECT thunk;
PRIMITIVE_HEADER (3);
-
- thunk = (ARG_REF (1));
-
- if ((COMPILED_CODE_ADDRESS_P (STACK_REF (3)))
- && (COMPILED_CODE_ADDRESS_P (thunk)))
- {
- extern SCHEME_OBJECT EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
-
- (void) STACK_POP ();
- return (compiled_with_stack_marker (thunk));
- }
- else
{
- PRIMITIVE_CANONICALIZE_CONTEXT ();
-
- (void) STACK_POP ();
- STACK_PUSH (MAKE_OBJECT (TC_RETURN_CODE, RC_STACK_MARKER));
- Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
- STACK_PUSH (thunk);
- STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- return (0);
+ SCHEME_OBJECT thunk = (ARG_REF (1));
+#ifdef CC_SUPPORT_P
+ if ((CC_ENTRY_P (STACK_REF (3))) && (CC_ENTRY_P (thunk)))
+ {
+ (void) STACK_POP ();
+ compiled_with_stack_marker (thunk);
+ UN_POP_PRIMITIVE_FRAME (3);
+ }
+ else
+#endif
+ {
+ canonicalize_primitive_context ();
+ (void) STACK_POP ();
+ STACK_PUSH (MAKE_RETURN_CODE (RC_STACK_MARKER));
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
+ STACK_PUSH (thunk);
+ PUSH_APPLY_FRAME_HEADER (0);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ }
}
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
-static SCHEME_OBJECT
-DEFUN (with_new_interrupt_mask, (new_mask), unsigned long new_mask)
-{
- SCHEME_OBJECT receiver = (ARG_REF (2));
-
- if ((COMPILED_CODE_ADDRESS_P (STACK_REF (2)))
- && (COMPILED_CODE_ADDRESS_P (receiver)))
- {
- extern SCHEME_OBJECT
- EXFUN (compiled_with_interrupt_mask, (unsigned long,
- SCHEME_OBJECT,
- unsigned long));
- unsigned long current_mask = (FETCH_INTERRUPT_MASK ());
-
- POP_PRIMITIVE_FRAME (2);
- SET_INTERRUPT_MASK (new_mask);
-
- PRIMITIVE_RETURN
- (compiled_with_interrupt_mask (current_mask, receiver, new_mask));
- }
- else
- {
- PRIMITIVE_CANONICALIZE_CONTEXT ();
- POP_PRIMITIVE_FRAME (2);
- preserve_interrupt_mask ();
- Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
- STACK_PUSH (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
- STACK_PUSH (receiver);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
- Pushed ();
- SET_INTERRUPT_MASK (new_mask);
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- return (0);
- }
-}
-
DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2,
"(MASK RECEIVER)\n\
Set the interrupt mask to MASK for the duration of the call to RECEIVER.\n\
RECEIVER is passed the old interrupt mask as its argument.")
{
PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN (with_new_interrupt_mask (INT_Mask & (arg_integer (1))));
+ with_new_interrupt_mask (INT_Mask & (arg_integer (1)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED",
- Prim_with_interrupts_reduced, 2, 2,
- "(MASK RECEIVER)\n\
-Like `with-interrupt-mask', but only disables interrupts.")
+DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED", Prim_with_interrupts_reduced,
+ 2, 2, "(MASK RECEIVER)\n\
+Like WITH-INTERRUPT-MASK, but only disables interrupts.")
{
unsigned long old_mask, new_mask;
PRIMITIVE_HEADER (2);
- old_mask = (FETCH_INTERRUPT_MASK ());
- new_mask = (INT_Mask & (arg_integer (1)));
- PRIMITIVE_RETURN (with_new_interrupt_mask ((new_mask > old_mask) ?
- new_mask :
- (new_mask & old_mask)));
+ old_mask = GET_INT_MASK;
+ new_mask = (INT_Mask & (arg_ulong_integer (1)));
+ with_new_interrupt_mask
+ ((new_mask > old_mask) ? new_mask : (new_mask & old_mask));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+static void
+with_new_interrupt_mask (unsigned long new_mask)
+{
+ SCHEME_OBJECT receiver = (ARG_REF (2));
+
+#ifdef CC_SUPPORT_P
+ if ((CC_ENTRY_P (STACK_REF (2))) && (CC_ENTRY_P (receiver)))
+ {
+ unsigned long current_mask = GET_INT_MASK;
+ POP_PRIMITIVE_FRAME (2);
+ compiled_with_interrupt_mask (current_mask, receiver, new_mask);
+ UN_POP_PRIMITIVE_FRAME (2);
+ SET_INTERRUPT_MASK (new_mask);
+ }
+ else
+#endif
+ {
+ canonicalize_primitive_context ();
+ POP_PRIMITIVE_FRAME (2);
+ preserve_interrupt_mask ();
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
+ STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_MASK));
+ STACK_PUSH (receiver);
+ PUSH_APPLY_FRAME_HEADER (1);
+ Pushed ();
+ SET_INTERRUPT_MASK (new_mask);
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ }
}
\f
/* History */
SCHEME_OBJECT
-initialize_history ()
+initialize_history (void)
{
/* Dummy History Structure */
- history_register = (Make_Dummy_History ());
+ history_register = (make_dummy_history ());
return
- (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, (Make_Dummy_History ())));
+ (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, (make_dummy_history ())));
}
DEFINE_PRIMITIVE ("SET-CURRENT-HISTORY!", Prim_set_current_history, 1, 1,
Set the interpreter's history object to HISTORY.")
{
PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
CHECK_ARG (1, HUNK3_P);
- val_register = (*history_register);
+ SET_VAL (*history_register);
#ifndef DISABLE_HISTORY
history_register = (OBJECT_ADDRESS (ARG_REF (1)));
#else
- history_register = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)));
+ history_register = (OBJECT_ADDRESS (READ_DUMMY_HISTORY ()));
#endif
POP_PRIMITIVE_FRAME (1);
PRIMITIVE_ABORT (PRIM_POP_RETURN);
"(THUNK)\nExecute THUNK with the interpreter's history OFF.")
{
PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
{
SCHEME_OBJECT thunk = (ARG_REF (1));
/* Remove one reduction from the history before saving it */
SCHEME_OBJECT * rib = first_rib;
while (1)
{
- fast SCHEME_OBJECT * next_rib =
+ SCHEME_OBJECT * next_rib =
(OBJECT_ADDRESS (rib [RIB_NEXT_REDUCTION]));
if (next_rib == first_rib)
break;
}
}
POP_PRIMITIVE_FRAME (1);
- Stop_History ();
+ stop_history ();
Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
STACK_PUSH (thunk);
- STACK_PUSH (STACK_FRAME_HEADER);
+ PUSH_APPLY_FRAME_HEADER (0);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
}
}
\f
-/* Miscellaneous State */
-
-DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0, 0,
- "()\nReturn the current deep fluid bindings.")
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (Fluid_Bindings);
-}
-
-DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1, 1,
- "(FLUID-BINDINGS-ALIST)\n\
-Set the current deep fluid bindings alist to FLUID-BINDINGS-ALIST.")
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, APPARENT_LIST_P);
- {
- SCHEME_OBJECT old_bindings = Fluid_Bindings;
- Fluid_Bindings = (ARG_REF (1));
- PRIMITIVE_RETURN (old_bindings);
- }
-}
-
DEFINE_PRIMITIVE ("GET-FIXED-OBJECTS-VECTOR",
Prim_get_fixed_objects_vector, 0, 0,
- "()\nReturn the fixed objects vector (TM).")
+ "()\n\
+Return the fixed objects vector (TM).")
{
PRIMITIVE_HEADER (0);
- if (Valid_Fixed_Obj_Vector ())
- PRIMITIVE_RETURN (Get_Fixed_Obj_Slot (Me_Myself));
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (fixed_objects);
}
-#ifndef SET_FIXED_OBJ_HOOK
-# define SET_FIXED_OBJ_HOOK(vector) Fixed_Objects = (vector)
-#endif
-
DEFINE_PRIMITIVE ("SET-FIXED-OBJECTS-VECTOR!",
Prim_set_fixed_objects_vector, 1, 1,
- "(NEW-FOV)\nSet the fixed objects vector (TM) to NEW-FOV.")
+ "(NEW-FOV)\n\
+Set the fixed objects vector (TM) to NEW-FOV.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, VECTOR_P);
{
- fast SCHEME_OBJECT vector = (ARG_REF (1));
- if ((VECTOR_LENGTH (vector)) < NFixed_Objects)
+ SCHEME_OBJECT old = fixed_objects;
+ SCHEME_OBJECT new = (ARG_REF (1));
+ if ((VECTOR_LENGTH (new)) < N_FIXED_OBJECTS)
error_bad_range_arg (1);
- {
- SCHEME_OBJECT result =
- ((Valid_Fixed_Obj_Vector ())
- ? (Get_Fixed_Obj_Slot (Me_Myself))
- : SHARP_F);
- SET_FIXED_OBJ_HOOK (vector);
- Set_Fixed_Obj_Slot (Me_Myself, vector);
- PRIMITIVE_RETURN (result);
- }
+ fixed_objects = new;
+ PRIMITIVE_RETURN (old);
}
}
/* -*-C-*-
-$Id: hppacach.c,v 1.17 2007/01/05 21:19:25 cph Exp $
+$Id: hppacach.c,v 1.18 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
printf ("\toff_count\t%ld\n", info->off_count);
printf ("\tloop\t\t%ld association%s per entry.",
info->loop, ((info->loop == 1) ? "" : "s"));
-
+
print_cst ((info->conf.bits.cst));
print_sel ((info->conf.bits.psel), "p-sel", "P%sTLB", "purge");
info->off_base, info->off_stride, info->off_count,
info->loop);
- return;
+ return;
}
\f
void
/* -*-C-*-
-$Id: hunk.c,v 9.33 2007/01/05 21:19:25 cph Exp $
+$Id: hunk.c,v 9.34 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
\f
SCHEME_OBJECT
-DEFUN (hunk3_cons,
- (cxr0, cxr1, cxr2),
- SCHEME_OBJECT cxr0
- AND SCHEME_OBJECT cxr1
- AND SCHEME_OBJECT cxr2)
+hunk3_cons (SCHEME_OBJECT cxr0,
+ SCHEME_OBJECT cxr1,
+ SCHEME_OBJECT cxr2)
{
Primitive_GC_If_Needed (3);
(*Free++) = cxr0;
PRIMITIVE_HEADER (3);
CHECK_ARG (1, HUNK3_P);
{
- fast SCHEME_OBJECT hunk3 = (ARG_REF (1));
- fast long index = (arg_index_integer (2, 3));
- fast SCHEME_OBJECT object = (ARG_REF (3));
- SIDE_EFFECT_IMPURIFY (hunk3, object);
+ SCHEME_OBJECT hunk3 = (ARG_REF (1));
+ long index = (arg_index_integer (2, 3));
+ SCHEME_OBJECT object = (ARG_REF (3));
MEMORY_SET (hunk3, index, object);
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
#define ARG_GC_TRIPLE(arg_number) \
- (((GC_Type (ARG_REF (arg_number))) == GC_Triple) \
+ ((GC_TYPE_TRIPLE (ARG_REF (arg_number))) \
? (ARG_REF (arg_number)) \
: ((error_wrong_type_arg (arg_number)), ((SCHEME_OBJECT) 0)))
{
SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
SCHEME_OBJECT object = (ARG_REF (2));
- SIDE_EFFECT_IMPURIFY (hunk3, object);
MEMORY_SET (hunk3, 0, object);
}
PRIMITIVE_RETURN (UNSPECIFIC);
{
SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
SCHEME_OBJECT object = (ARG_REF (2));
- SIDE_EFFECT_IMPURIFY (hunk3, object);
MEMORY_SET (hunk3, 1, object);
}
PRIMITIVE_RETURN (UNSPECIFIC);
{
SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
SCHEME_OBJECT object = (ARG_REF (2));
- SIDE_EFFECT_IMPURIFY (hunk3, object);
MEMORY_SET (hunk3, 2, object);
}
PRIMITIVE_RETURN (UNSPECIFIC);
+++ /dev/null
-/* -*-C-*-
-
-$Id: image.c,v 9.39 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "scheme.h"
-#include "prims.h"
-#include "array.h"
-#include <math.h>
-\f
-void
-arg_image (arg_number, nrows, ncols, array)
- int arg_number;
- long * nrows;
- long * ncols;
- REAL ** array;
-{
- fast SCHEME_OBJECT argument = (ARG_REF (arg_number));
- fast SCHEME_OBJECT rest;
- fast SCHEME_OBJECT first;
- fast SCHEME_OBJECT second;
- fast SCHEME_OBJECT third;
- if (! (PAIR_P (argument))) goto loser;
- first = (PAIR_CAR (argument));
- if (! (UNSIGNED_FIXNUM_P (first))) goto loser;
- rest = (PAIR_CDR (argument));
- if (! (PAIR_P (rest))) goto loser;
- second = (PAIR_CAR (rest));
- if (! (UNSIGNED_FIXNUM_P (second))) goto loser;
- rest = (PAIR_CDR (rest));
- if (! (PAIR_P (rest))) goto loser;
- third = (PAIR_CAR (rest));
- if (! (ARRAY_P (third))) goto loser;
- if (!EMPTY_LIST_P (PAIR_CDR (rest))) goto loser;
- (*nrows) = (UNSIGNED_FIXNUM_TO_LONG (first));
- (*ncols) = (UNSIGNED_FIXNUM_TO_LONG (second));
- (*array) = (ARRAY_CONTENTS (third));
- return;
- loser:
- error_bad_range_arg (arg_number);
- /* NOTREACHED */
-}
-
-#define MAKE_IMAGE(nrows, ncols, array) \
- (cons ((LONG_TO_UNSIGNED_FIXNUM (nrows)), \
- (cons ((LONG_TO_UNSIGNED_FIXNUM (ncols)), \
- (cons ((array), EMPTY_LIST))))))
-\f
-static int
-read_byte (fp)
- fast FILE * fp;
-{
- int result = (getc (fp));
- if (ferror (fp))
- error_external_return ();
- return (result);
-}
-
-static int
-read_word (fp)
- fast FILE * fp;
-{
- int result = (getw (fp));
- if (ferror (fp))
- error_external_return ();
- return (result);
-}
-
-static void
-write_word (fp, datum)
- fast FILE * fp;
- int datum;
-{
- if ((putw (datum, fp)) != 0)
- error_external_return ();
- return;
-}
-
-static int
-read_2bint (fp)
- fast FILE * fp;
-{
- int msd = (getc (fp));
- if (ferror (fp))
- error_external_return ();
- {
- int lsd = (getc (fp));
- if (ferror (fp))
- error_external_return ();
- {
- int result = ((msd << 8) | lsd);
- return (((result & (1 << 15)) == 0) ? result : ((-1 << 16) | result));
- }
- }
-}
-
-static void
-write_2bint (fp, datum)
- fast FILE * fp;
- int datum;
-{
- if (((putc (((datum >> 8) & 0xFF), fp)) == EOF) ||
- ((putc ((datum & 0xFF), fp)) == EOF))
- error_external_return ();
- return;
-}
-
-
-DEFINE_PRIMITIVE ("IMAGE-READ-ASCII", Prim_read_image_ascii, 1, 1, 0)
-{
- fast FILE * fp;
- long nrows, ncols;
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- if ( (fp = fopen((STRING_ARG (1)), "r")) == NULL)
- error_bad_range_arg (1);
- fscanf (fp, "%d %d \n", (&nrows), (&ncols));
- if ((ferror (fp)) || ((ncols > 512) || (nrows > 512)))
- { printf("read-image-ascii-file: problem with rows,cols \n");
- error_bad_range_arg (1); }
- {
- fast long length = (nrows * ncols);
- SCHEME_OBJECT array = (allocate_array (length));
- fast REAL * scan = (ARRAY_CONTENTS (array));
- while ((length--) > 0)
- { long number;
- fscanf (fp, "%d", (&number));
- if (ferror (fp))
- error_external_return ();
- (*scan++) = ((REAL) number);
- }
- if ((fclose (fp)) != 0) error_external_return ();
- PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
- }
-}
-
-DEFINE_PRIMITIVE ("IMAGE-READ-2BINT", Prim_read_image_2bint, 1, 1, 0)
-{
- FILE *fp, *fopen();
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- if ( ( fp = (fopen((STRING_ARG (1)), "r")) ) == NULL)
- error_bad_range_arg (1);
- {
- int nrows = (read_word (fp));
- int ncols = (read_word (fp));
- fast long length = (nrows * ncols);
- SCHEME_OBJECT array = (allocate_array (length));
- fast REAL * scan = (ARRAY_CONTENTS (array));
- while ((length--) > 0)
- (*scan++) = ((REAL) (read_2bint (fp)));
- if ((fclose (fp)) != 0)
- error_external_return ();
- PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
- }
-}
-
-DEFINE_PRIMITIVE ("IMAGE-READ-CTSCAN", Prim_read_image_ctscan, 1, 1, 0)
-{
- fast FILE * fp;
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- fp = (fopen((STRING_ARG (1)), "r"));
- if (fp == ((FILE *) 0))
- error_bad_range_arg (1);
- Primitive_GC_If_Needed (BYTES_TO_WORDS (512 * (sizeof (int))));
- {
- int nrows = 512;
- int ncols = 512;
- SCHEME_OBJECT array = (allocate_array (nrows * ncols));
- REAL * Array = (ARRAY_CONTENTS (array));
- fast int * Widths = ((int *) Free);
- fast int i;
- /* Discard header */
- for (i = 0; (i < 2048); i += 1)
- (void) read_byte (fp);
- for (i = 0; (i < 512); i += 1)
- (Widths [i]) = (read_2bint (fp));
- for (i = 0; (i < (nrows * ncols)); i += 1)
- (Array [i]) = 0;
- for (i = 0; (i < 512); i += 1)
- {
- fast int array_index = ((i * 512) + (256 - (Widths [i])));
- fast int m;
- for (m = 0; (m < (2 * (Widths [i]))); m += 1)
- (Array [array_index + m]) = ((REAL) (read_2bint (fp)));
- }
- /* CTSCAN images are upside down */
-#if (REAL_IS_DEFINED_DOUBLE != 0)
- ALIGN_FLOAT (Free);
- Free += 1;
-#endif
- Primitive_GC_If_Needed (512 * REAL_SIZE);
- Image_Mirror_Upside_Down (Array, nrows, ncols, ((REAL *) Free));
- if ((fclose (fp)) != 0)
- error_external_return ();
- PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
- }
-}
-
-
-DEFINE_PRIMITIVE ("IMAGE-READ-CBIN", Prim_read_image_cbin, 1, 1, 0)
-{
- fast FILE * fp;
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- fp = (fopen ((STRING_ARG (1)), "r"));
- if (fp == ((FILE *) 0))
- error_bad_range_arg (1);
- {
- int nrows = (read_word (fp));
- int ncols = (read_word (fp));
- long length = (nrows * ncols);
- SCHEME_OBJECT array = (allocate_array (length));
- fast REAL * scan = (ARRAY_CONTENTS (array));
- while ((length--) > 0)
- (*scan++) = (read_word (fp));
- if ((fclose (fp)) != 0)
- error_external_return ();
- PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
- }
-}
-
-\f
-Image_Mirror_Upside_Down (Array,nrows,ncols,Temp_Row)
- REAL * Array;
- long nrows;
- long ncols;
- REAL * Temp_Row;
-{ int i;
- REAL *M_row, *N_row;
- for (i=0;i<(nrows/2);i++) {
- M_row = Array + (i * ncols);
- N_row = Array + (((nrows-1)-i) * ncols);
- C_Array_Copy(N_row, Temp_Row, ncols);
- C_Array_Copy(M_row, N_row, ncols);
- C_Array_Copy(Temp_Row, M_row, ncols);
- }
-}
-
-/* The following does not work, to be fixed. */
-DEFINE_PRIMITIVE ("IMAGE-DOUBLE-TO-FLOAT!", Prim_image_double_to_float, 1, 1, 0)
-{
- long Length;
- long i,j;
- long allocated_cells;
- long nrows, ncols;
- SCHEME_OBJECT array;
- double *Array, *From_Here;
- fast double temp_value_cell;
- float *To_Here;
- PRIMITIVE_HEADER (1);
- arg_image (1, (&nrows), (&ncols), (&array));
- Array = ((double *) (ARRAY_CONTENTS (array)));
- From_Here = Array;
- To_Here = ((float *) (Array));
- Length = nrows * ncols;
-
- for (i=0;i<Length;i++) {
- temp_value_cell = *From_Here;
- From_Here++;
- *To_Here = ((float) temp_value_cell);
- To_Here++;
- }
- /* and now SIDE-EFFECT the ARRAY_HEADER */
- SET_VECTOR_LENGTH (array, ((Length * FLOAT_SIZE) + 1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-
-DEFINE_PRIMITIVE ("SUBIMAGE-COPY!", Prim_subimage_copy, 12, 12, 0)
-{
- long r1, c1, r2, c2, at1r, at1c, at2r, at2c, mr, mc;
- REAL * x;
- REAL * y;
- void subimage_copy ();
- PRIMITIVE_HEADER (12);
- CHECK_ARG (3, ARRAY_P); /* image array 1 = source array */
- CHECK_ARG (6, ARRAY_P); /* image array 2 = destination array */
- r1 = (arg_nonnegative_integer (1));
- c1 = (arg_nonnegative_integer (2));
- if ((r1 * c1) != (ARRAY_LENGTH (ARG_REF (3))))
- error_bad_range_arg (3);
- x = (ARRAY_CONTENTS (ARG_REF (3)));
- r2 = arg_nonnegative_integer (4);
- c2 = arg_nonnegative_integer (5);
- if ((r2 * c2) != (ARRAY_LENGTH (ARG_REF (6))))
- error_bad_range_arg (6);
- y = (ARRAY_CONTENTS (ARG_REF (6)));
- at1r = (arg_nonnegative_integer (7));
- at1c = (arg_nonnegative_integer (8));
- at2r = (arg_nonnegative_integer (9));
- at2c = (arg_nonnegative_integer (10));
- mr = (arg_nonnegative_integer (11));
- mc = (arg_nonnegative_integer (12));
- if (((at1r + mr) > r1) || ((at1c + mc) > c1))
- error_bad_range_arg (7);
- if (((at2r + mr) > r2) || ((at2c + mc) > c2))
- error_bad_range_arg (9);
- subimage_copy (x, y, r1, c1, r2, c2, at1r, at1c, at2r, at2c, mr, mc);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-subimage_copy (x,y, r1,c1,r2,c2, at1r,at1c,at2r,at2c, mr,mc)
- REAL *x,*y;
- long r1,c1,r2,c2, at1r,at1c,at2r,at2c, mr,mc;
-{ long i,j;
- REAL *xrow,*yrow;
-
- xrow = x + at1r*c1 + at1c;
- yrow = y + at2r*c2 + at2c; /* A(i,j)--->Array[i*ncols+j] */
-
- for (i=0; i<mr; i++) {
- for (j=0; j<mc; j++) yrow[j] = xrow[j];
- xrow = xrow + c1;
- yrow = yrow + c2;
- }
-}
-
-/* image-operation-2
- groups together procedures that use 2 image-arrays
- (usually side-effecting the 2nd image, but not necessarily) */
-
-DEFINE_PRIMITIVE ("IMAGE-OPERATION-2!", Prim_image_operation_2, 5,5, 0)
-{ long rows, cols, nn, opcode;
- REAL *x,*y;
- void image_laplacian();
- PRIMITIVE_HEADER (5);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, FIXNUM_P); /* rows */
- CHECK_ARG (3, FIXNUM_P); /* cols */
- CHECK_ARG (4, ARRAY_P); /* image array 1 */
- CHECK_ARG (5, ARRAY_P); /* image array 2 */
-
- x = ARRAY_CONTENTS(ARG_REF(4));
- y = ARRAY_CONTENTS(ARG_REF(5));
- rows = arg_nonnegative_integer(2);
- cols = arg_nonnegative_integer(3);
- nn = rows*cols;
- if (nn != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
- if (nn != ARRAY_LENGTH(ARG_REF(5))) error_bad_range_arg(5);
-
- opcode = arg_nonnegative_integer(1);
-
- if (opcode==1)
- image_laplacian(x,y,rows,cols); /* result in y */
- else if (opcode==2)
- error_bad_range_arg(1); /* illegal opcode */
- else
- error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* Laplacian form [4,-1,-1,-1,-1]/4
- A(i,j) --> Array[i*ncols + j]
- With no knowledge outside boundary,
- assume laplace(edge-point)=0.0 (no wrap-around, no artificial bndry) */
-void
-image_laplacian (x,y, nrows,ncols)
- REAL *x, *y;
- long nrows, ncols;
-{ long i,j, nrows1, ncols1;
- nrows1=nrows-1; ncols1=ncols-1;
- /* no need todo anything for 1-point image */
- if ((nrows<2)||(ncols<2))
- return;
- /* */
- i=0;j=0; y[i*ncols+j] = 0.0; /* NE corner */
- i=0;j=ncols1; y[i*ncols+j] = 0.0; /* NW corner */
- i=nrows1;j=0; y[i*ncols+j] = 0.0; /* SE corner */
- i=nrows1;j=ncols1; y[i*ncols+j] = 0.0; /* SW corner */
- i=0; for (j=1;j<ncols1;j++) y[i*ncols+j] = 0.0; /* NORTH row */
- i=nrows1; for (j=1;j<ncols1;j++) y[i*ncols+j] = 0.0; /* SOUTH row */
- j=0; for (i=1;i<nrows1;i++) y[i*ncols+j] = 0.0; /* EAST column */
- j=ncols1; for (i=1;i<nrows1;i++) y[i*ncols+j] = 0.0; /* WEST column */
- /* */
- for (i=1;i<nrows1;i++)
- for (j=1;j<ncols1;j++)
- y[i*ncols+j] =
- x[i*ncols+j] -
- ((x[i*ncols+(j-1)] +
- x[i*ncols+(j+1)] +
- x[(i-1)*ncols+j] +
- x[(i+1)*ncols+j])
- / 4);
- return;
-}
-\f
-DEFINE_PRIMITIVE ("IMAGE-DOUBLE-BY-INTERPOLATION", Prim_image_double_by_interpolation, 1, 1, 0)
-{ long nrows, ncols, Length;
- SCHEME_OBJECT Parray;
- REAL *Array, *To_Here;
- SCHEME_OBJECT Result, array;
- PRIMITIVE_HEADER (1);
- arg_image (1, (&nrows), (&ncols), (&Parray));
- Array = (ARRAY_CONTENTS (Parray));
- array = (allocate_array (4 * nrows * ncols));
- Result = (MAKE_IMAGE (nrows, ncols, array));
-
- Array = ARRAY_CONTENTS(Parray);
- C_image_double_by_interpolation
- (Array, (ARRAY_CONTENTS(array)), nrows, ncols);
- PRIMITIVE_RETURN(Result);
-}
-
-/* double image by linear interpolation.
- ---new_array must be 4 times as long ---
- A(i,j) --> Array[i*ncols + j]
- magnification in a south-east direction
- (i.e. replication of pixels in South-East corner) */
-C_image_double_by_interpolation (array, new_array, nrows, ncols)
- REAL *array, *new_array;
- long nrows, ncols;
-{ long i,j, nrows1, ncols1, nrows2, ncols2;
- nrows1=nrows-1; ncols1=ncols-1;
- nrows2=2*nrows; ncols2=2*ncols;
- /* no need todo anything for 1-point image */
- if ((nrows<2)||(ncols<2)) return(1);
- i=nrows1; for (j=0;j<ncols1;j++) /* SOUTH row */
- { new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
- new_array[(2*i+1)*ncols2+(2*j)] = array[i*ncols+j];
- new_array[(2*i)*ncols2+(2*j)+1] =
- ((array[i*ncols+j]+array[i*ncols+j+1]) / 2);
- new_array[(2*i+1)*ncols2+(2*j)+1] = new_array[(2*i)*ncols2+(2*j)+1];
- }
- j=ncols1; for (i=0;i<nrows1;i++) /* WEST column */
- { new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
- new_array[(2*i)*ncols2+(2*j)+1] = array[i*ncols+j];
- new_array[(2*i+1)*ncols2+(2*j)] =
- ((array[i*ncols+j]+array[(i+1)*ncols+j]) / 2);
- new_array[(2*i+1)*ncols2+(2*j)+1] = new_array[(2*i+1)*ncols2+(2*j)];
- }
- i=nrows1;j=ncols1; { /* SW corner */
- new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
- new_array[(2*i)*ncols2+(2*j)+1] = array[i*ncols+j];
- new_array[(2*i+1)*ncols2+(2*j)] = array[i*ncols+j];
- new_array[(2*i+1)*ncols2+(2*j)+1] = array[i*ncols+j];
- }
- /* */
- for (i=0;i<nrows1;i++)
- for (j=0;j<ncols1;j++) { /* interior of image */
- new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
- new_array[(2*i)*ncols2+(2*j)+1] =
- ((array[i*ncols+j]+array[i*ncols+j+1]) / 2);
- new_array[(2*i+1)*ncols2+(2*j)] =
- ((array[i*ncols+j]+array[(i+1)*ncols+j]) / 2);
- new_array[(2*i+1)*ncols2+(2*j)+1] =
- ((array[i*ncols+j] +
- array[i*ncols+j+1] +
- array[(i+1)*ncols+j] +
- array[(i+1)*ncols+j+1])
- / 4);
- }
-}
-\f
-DEFINE_PRIMITIVE ("IMAGE-MAKE-RING", Prim_image_make_ring, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- {
- long nrows = (arg_nonnegative_integer (1));
- long ncols = (arg_nonnegative_integer (2));
- long Length = (nrows * ncols);
- long high_cycle =
- (arg_index_integer (4, ((min ((nrows / 2), (ncols / 2))) + 1)));
- long low_cycle = (arg_index_integer (3, (high_cycle + 1)));
- SCHEME_OBJECT Ring_Array_Result = (allocate_array (Length));
- SCHEME_OBJECT Result = (MAKE_IMAGE (nrows, ncols, Ring_Array_Result));
- REAL * Ring_Array = (ARRAY_CONTENTS (Ring_Array_Result));
- C_Image_Make_Ring (Ring_Array, nrows, ncols, low_cycle, high_cycle);
- PRIMITIVE_RETURN (Result);
- }
-}
-
-C_Image_Make_Ring (Ring_Array, nrows, ncols, low_cycle, high_cycle)
- REAL *Ring_Array;
- long nrows, ncols, low_cycle, high_cycle;
-{ long Square_LC=low_cycle*low_cycle, Square_HC=high_cycle*high_cycle;
- long i, j, m, n, radial_cycle;
- long nrows2=nrows/2, ncols2=ncols/2;
- for (i=0; i<nrows; i++) {
- for (j=0; j<ncols; j++) {
- m = ((i<nrows2) ? i : (nrows-i));
- n = ((j<ncols2) ? j : (ncols-j));
- radial_cycle = (m*m)+(n*n);
- if ( (radial_cycle<Square_LC) || (radial_cycle>Square_HC))
- Ring_Array[i*ncols+j] = 0;
- else Ring_Array[i*ncols+j] = 1;
- }}
-}
-\f
-/* Periodic-shift without side-effects for code simplicity. */
-
-DEFINE_PRIMITIVE ("IMAGE-PERIODIC-SHIFT", Prim_image_periodic_shift, 3, 3, 0)
-{
- long nrows;
- long ncols;
- REAL * Array;
- PRIMITIVE_HEADER (3);
- {
- SCHEME_OBJECT Parray;
- arg_image (1, (&nrows), (&ncols), (&Parray));
- Array = (ARRAY_CONTENTS (Parray));
- }
- {
- long ver_shift = ((arg_integer (2)) % nrows);
- long hor_shift = ((arg_integer (3)) % ncols);
- SCHEME_OBJECT array = (allocate_array (nrows * ncols));
- SCHEME_OBJECT Result = (MAKE_IMAGE (nrows, ncols, array));
- C_Image_Periodic_Shift
- (Array,
- (ARRAY_CONTENTS (array)),
- nrows,
- ncols,
- ver_shift,
- hor_shift);
- PRIMITIVE_RETURN (Result);
- }
-}
-
-/* ASSUMES ((hor_shift < nrows) && (ver_shift < ncols)) */
-
-C_Image_Periodic_Shift(Array, New_Array, nrows, ncols, ver_shift, hor_shift)
- REAL *Array, *New_Array; long nrows, ncols, hor_shift, ver_shift;
-{ long i, j, ver_index, hor_index;
- REAL *To_Here;
- To_Here = New_Array;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- ver_index = (i+ver_shift) % nrows;
- if (ver_index<0) ver_index = nrows+ver_index; /* wrapping around */
- hor_index = (j+hor_shift) % ncols;
- if (hor_index<0) hor_index = ncols+hor_index;
- *To_Here++ = Array[ver_index*ncols + hor_index];
- }}
-}
-\f
-/* Rotations and stuff */
-
-DEFINE_PRIMITIVE ("IMAGE-TRANSPOSE!", Prim_image_transpose, 4,4, 0)
-{ long rows, cols;
- REAL *x, *y;
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, FIXNUM_P); /* rows */
- CHECK_ARG (2, FIXNUM_P); /* cols */
- CHECK_ARG (3, ARRAY_P); /* image array 1 */
- CHECK_ARG (4, ARRAY_P); /* image array 2, empty for rows=cols */
-
- rows = arg_nonnegative_integer(1);
- cols = arg_nonnegative_integer(2);
- x = (ARRAY_CONTENTS (ARG_REF(3)));
- y = (ARRAY_CONTENTS (ARG_REF(4)));
-
- if (rows==cols) /* square image ==> ignore argument 4 */
- Image_Fast_Transpose (x, rows);
- else
- Image_Transpose (x, y, rows, cols);
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("IMAGE-ROTATE-90CLW!", Prim_image_rotate_90clw, 1, 1, 0)
-{
- long nrows;
- long ncols;
- REAL * Array;
- long Length;
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT Parray;
- arg_image (1, (&nrows), (&ncols), (&Parray));
- Array = (ARRAY_CONTENTS (Parray));
- }
- Length = (nrows * ncols);
-#if (REAL_IS_DEFINED_DOUBLE != 0)
- ALIGN_FLOAT (Free);
- Free += 1;
-#endif
- Primitive_GC_If_Needed (Length * REAL_SIZE);
- {
- REAL * Temp_Array = ((REAL *) Free);
- Image_Rotate_90clw (Array, Temp_Array, nrows, ncols);
- C_Array_Copy (Temp_Array, Array, Length);
- }
- {
- SCHEME_OBJECT argument = (ARG_REF (1));
- SET_PAIR_CAR (argument, (LONG_TO_UNSIGNED_FIXNUM (ncols)));
- SET_PAIR_CAR ((PAIR_CDR (argument)), (LONG_TO_UNSIGNED_FIXNUM (nrows)));
- PRIMITIVE_RETURN (argument);
- }
-}
-\f
-DEFINE_PRIMITIVE ("IMAGE-ROTATE-90CCLW!", Prim_image_rotate_90cclw, 1, 1, 0)
-{
- long nrows;
- long ncols;
- REAL * Array;
- long Length;
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT Parray;
- arg_image (1, (&nrows), (&ncols), (&Parray));
- Array = (ARRAY_CONTENTS (Parray));
- }
- Length = (nrows * ncols);
-#if (REAL_IS_DEFINED_DOUBLE != 0)
- ALIGN_FLOAT (Free);
- Free += 1;
-#endif
- Primitive_GC_If_Needed (Length * REAL_SIZE);
- {
- REAL * Temp_Array = ((REAL *) Free);
- Image_Rotate_90cclw (Array, Temp_Array, nrows, ncols);
- C_Array_Copy (Temp_Array, Array, Length);
- }
- {
- SCHEME_OBJECT argument = (ARG_REF (1));
- SET_PAIR_CAR (argument, (LONG_TO_UNSIGNED_FIXNUM (ncols)));
- SET_PAIR_CAR ((PAIR_CDR (argument)), (LONG_TO_UNSIGNED_FIXNUM (nrows)));
- PRIMITIVE_RETURN (argument);
- }
-}
-
-DEFINE_PRIMITIVE ("IMAGE-MIRROR!", Prim_image_mirror, 1, 1, 0)
-{
- long nrows;
- long ncols;
- REAL * Array;
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT Parray;
- arg_image (1, (&nrows), (&ncols), (&Parray));
- Array = (ARRAY_CONTENTS (Parray));
- }
- C_Mirror_Image (Array, nrows, ncols); /* side-effecting... */
- PRIMITIVE_RETURN (ARG_REF (1));
-}
-\f
-
-/* C routines referred to above */
-
-/* IMAGE_FAST_TRANSPOSE
- A(i,j) <-> A(j,i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j]
- convention:= fix row & go by columns .
- UNWRAP is a bijection from the compact plane to the compact interval. */
-
-Image_Fast_Transpose (Array, nrows) /* for square images */
- REAL *Array;
- long nrows;
-{ long i, j;
- long from, to;
- REAL temp;
- for (i=0;i<nrows;i++) {
- for (j=i;j<nrows;j++) {
- from = i*nrows + j;
- to = j*nrows + i; /* (columns transposed-image) = ncols */
- temp = Array[from];
- Array[from] = Array[to];
- Array[to] = temp;
- }}
-}
-
-/* IMAGE_TRANSPOSE
- A(i,j) -> B(j,i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j]
- convention:= fix row & go by columns .
- UNWRAP is a bijection from the compact plane to the compact interval. */
-
-Image_Transpose (Array, New_Array, nrows, ncols)
- REAL *Array, *New_Array;
- long nrows, ncols;
-{ long i, j;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- /* (columns transposed-image) = nrows */
- New_Array[j*nrows + i] = Array[i*ncols + j];
- }}
-}
-
-/* IMAGE_ROTATE_90CLW
- A(i,j) <-> A(j, (nrows-1)-i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j]
- convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval. */
-
-Image_Rotate_90clw (Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array;
- long nrows, ncols;
-{ long i, j;
-
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- /* (columns rotated_image) =nrows */
- Rotated_Array[(j*nrows) + ((nrows-1)-i)] = Array[i*ncols+j];
- }}
-}
-\f
-/* ROTATION 90degrees COUNTER-CLOCK-WISE:
- A(i,j) <-> A((nrows-1)-j, i) . (minus 1 because we start from 0).
- UNWRAP: A(i,j) ----> Array[i*ncols + j]
- because of convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval. */
-
-Image_Rotate_90cclw (Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array;
- long nrows, ncols;
-{ long i, j;
- fast long from_index, to_index;
- long Length=nrows*ncols;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- from_index = i*ncols +j;
- /* (columns rotated-image) = nrows */
- to_index = ((ncols-1)-j)*nrows + i;
- Rotated_Array[to_index] = Array[from_index];
- }}
-}
-
-/* IMAGE_MIRROR:
- A(i,j) <-> A(i, (ncols-1)-j) [ The -1 is there because we count from 0] .
- A(i,j) -------> Array[i*ncols + j] fix row, read column convention. */
-
-C_Mirror_Image (Array, nrows, ncols)
- REAL *Array;
- long nrows, ncols;
-{ long i, j;
- long ncols2=ncols/2, Length=nrows*ncols;
- REAL temp;
- long from, to;
-
- for (i=0; i<Length; i += ncols) {
- for (j=0; j<ncols2; j++) { /* DO NOT UNDO the reflections */
- from = i + j; /* i is really i*nrows */
- to = i + (ncols-1)-j;
- temp = Array[from];
- Array[from] = Array[to];
- Array[to] = temp;
- }}
-}
-
-/* IMAGE_ROTATE_90CLW_MIRROR:
- A(i,j) <-> A(j, i)
- this should be identical to image_transpose (see above).
- UNWRAP: A(i,j) ----> Array[i*ncols + j]
- because of convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval. */
-
-C_Rotate_90clw_Mirror_Image (Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array;
- long nrows, ncols;
-{ long i, j;
- long from, to, Length=nrows*ncols;
-
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- from = i*ncols +j;
- /* the columns of the rotated image are nrows! */
- to = j*nrows +i;
- Rotated_Array[to] = Array[from];
- }}
-}
-\f
-DEFINE_PRIMITIVE ("SQUARE-IMAGE-TIME-REVERSE!", Prim_square_image_time_reverse, 2,2, 0)
-{ long i, rows;
- REAL *a;
- void square_image_time_reverse();
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, ARRAY_P);
- CHECK_ARG (2, FIXNUM_P);
- a = ARRAY_CONTENTS(ARG_REF(1));
- rows = arg_nonnegative_integer(2);
- if ((rows*rows) != ARRAY_LENGTH(ARG_REF(1))) error_bad_range_arg(1);
- square_image_time_reverse(a,rows);
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* Square Image Time reverse
- is combination of one-dimensional time-reverse
- row-wise and column-wise.
- It can be done slightly more efficiently than below. */
-
-void
-square_image_time_reverse (x,rows)
- REAL *x;
- long rows;
-{ long i,cols;
- REAL *xrow, *yrow;
- void C_Array_Time_Reverse();
- cols = rows; /* square image */
-
- xrow = x;
- for (i=0; i<rows; i++) /* row-wise */
- { C_Array_Time_Reverse(xrow,cols);
- xrow = xrow + cols; }
-
- Image_Fast_Transpose(x, rows);
-
- xrow = x;
- for (i=0; i<rows; i++) /* column-wise */
- { C_Array_Time_Reverse(xrow,cols);
- xrow = xrow + cols; }
-
- Image_Fast_Transpose(x, rows);
-}
-\f
-/* cs-images */
-
-/* operation-1
- groups together procedures that operate on 1 cs-image-array
- (side-effecting the image) */
-
-DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-1!", Prim_cs_image_operation_1, 3,3, 0)
-{ long rows, opcode;
- REAL *a;
- void cs_image_magnitude(), cs_image_real_part(), cs_image_imag_part();
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, FIXNUM_P); /* rows */
- CHECK_ARG (3, ARRAY_P); /* input and output image array */
-
- a = ARRAY_CONTENTS(ARG_REF(3));
- rows = arg_nonnegative_integer(2); /* square images only */
- if ((rows*rows) != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(1);
- opcode = arg_nonnegative_integer(1);
-
- if (opcode==1)
- cs_image_magnitude(a,rows);
- else if (opcode==2)
- cs_image_real_part(a,rows);
- else if (opcode==3)
- cs_image_imag_part(a,rows);
- else
- error_bad_range_arg(3); /* illegal opcode */
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-
-void
-cs_array_real_part (a,n)
- REAL *a;
- long n;
-{ long i,n2; /* works both for even and odd length */
- n2 = n/2;
- for (i=n2+1;i<n;i++) a[i] = a[n-i]; /* copy real values into place */
- /* even signal */
-}
-
-void
-cs_array_imag_part (a,n)
- REAL *a;
- long n;
-{ long i,n2;
- n2 = n/2; /* integer division truncates down */
- for (i=n2+1; i<n; i++) /* works both for even and odd length */
- { a[n-i] = a[i]; /* copy imaginary values into place */
- a[i] = (-a[i]); } /* odd signal */
- a[0] = 0.0;
- if (2*n2 == n) /* even length, n2 is real only */
- a[n2] = 0.0;
-}
-\f
-/* From now on (below), assume that cs-images (rows=cols)
- have always EVEN LENGTH which is true when they come from FFTs */
-
-/* In the following 3 time-reverse the bottom half rows
- is done to match the frequencies of complex-images
- coming from cft2d.
- Also transpose is needed to match frequencies identically
-
- #|
- ;; Scrabling of frequencies in cs-images
-
- ;; start from real image 4x4
-
- ;; rft2d is a cs-image
- (3.5 .375 -2.75 1.875 -.25 0. 0. -.25 -.25 -.125 0. .125
- .25 .25 0. 0.)
-
- ;; cft2d transposed
- ;; real
- 3.5 .375 -2.75 .375
- -.25 0. 0. -.25 ; same as cs-image
- -.25 -.125 0. -.125
- -.25 -.25 0. 0. ; row3 = copy 1 + time-reverse
- ;; imag
- 0. 1.875 0. -1.875
- .25 .25 0. 0. ; same as cs-image
- 0. .125 0. -.125
- -.25 0. 0. -.25 ; row 3 = copy 1 + negate + time-reverse
- |#
-
- */
-
-void
-cs_image_magnitude (x,rows)
- REAL *x;
- long rows;
-{ long i,j, cols, n,n2, nj; /* result = real ordinary image */
- REAL *xrow, *yrow;
- cols = rows; /* input cs-image is square */
- n = rows;
- n2 = n/2;
-
- xrow = x;
- cs_array_magnitude(xrow, n); /* row 0 is cs-array */
- xrow = x + n2*cols;
- cs_array_magnitude(xrow, n); /* row n2 is cs-array */
-
- xrow = x + cols; /* real part */
- yrow = x + (rows-1)*cols; /* imag part */
- for (i=1; i<n2; i++) {
- xrow[ 0] = (REAL) sqrt((double) xrow[ 0]*xrow[ 0] + yrow[ 0]*yrow[ 0]);
- xrow[n2] = (REAL) sqrt((double) xrow[n2]*xrow[n2] + yrow[n2]*yrow[n2]);
- yrow[ 0] = xrow[ 0];
- yrow[n2] = xrow[n2];
- for (j=1; j<n2; j++) {
- nj = n-j;
- xrow[ j] = (REAL) sqrt((double) xrow[ j]*xrow[ j] + yrow[ j]*yrow[ j]);
- xrow[nj] = (REAL) sqrt((double) xrow[nj]*xrow[nj] + yrow[nj]*yrow[nj]);
- yrow[j] = xrow[nj];
- yrow[nj] = xrow[ j]; /* Bottom rows: copy (even) and time-reverse */
- }
- xrow = xrow + cols;
- yrow = yrow - cols; }
- Image_Fast_Transpose(x, n);
-}
-\f
-void
-cs_image_real_part (x,rows)
- REAL *x;
- long rows;
-{ long i,j,cols, n,n2;
- REAL *xrow, *yrow;
- void cs_array_real_part();
- cols = rows; /* square image */
- n = rows;
- n2 = n/2;
-
- xrow = x;
- cs_array_real_part(xrow, n); /* row 0 is cs-array */
- xrow = x + n2*cols;
- cs_array_real_part(xrow, n); /* row n2 is cs-array */
-
- xrow = x + cols; /* real part */
- yrow = x + (rows-1)*cols; /* imag part */
- for (i=1; i<n2; i++) {
- /* copy real part into imaginary's place (even) */
- yrow[0] = xrow[0];
- for (j=1; j<n; j++)
- yrow[j] = xrow[n-j]; /* Bottom rows: copy and time-reverse */
- xrow = xrow + cols;
- yrow = yrow - cols; }
- Image_Fast_Transpose(x, n);
-}
-
-void
-cs_image_imag_part (x,rows)
- REAL *x;
- long rows;
-{ long i,j,cols, n,n2, nj;
- REAL *xrow, *yrow;
- void cs_array_imag_part();
- cols = rows; /* square image */
- n = rows;
- n2 = n/2;
-
- xrow = x;
- cs_array_imag_part(xrow, n); /* row 0 is cs-array */
- xrow = x + n2*cols;
- cs_array_imag_part(xrow, n); /* row n2 is cs-array */
-
- xrow = x + cols; /* real part */
- yrow = x + (rows-1)*cols; /* imag part */
- for (i=1; i<n2; i++) {
- xrow[0] = yrow[0]; /* copy the imaginary part into real's place */
- xrow[n2] = yrow[n2];
- yrow[0] = (-yrow[0]); /* negate (odd) */
- yrow[n2] = (-yrow[n2]);
- for (j=1;j<n2; j++) {
- nj = n-j;
- xrow[j] = yrow[j]; /* copy the imaginary part into real's place */
- xrow[nj] = yrow[nj];
- /* Bottom rows: negate (odd) and time-reverse */
- yrow[j] = (-xrow[nj]);
- yrow[nj] = (-xrow[j]); }
- xrow = xrow + cols;
- yrow = yrow - cols; }
- Image_Fast_Transpose(x, n);
-}
-\f
-/* cs-image-operation-2
- groups together procedures that use 2 cs-image-arrays
- (usually side-effecting the 2nd image, but not necessarily) */
-
-DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-2!", Prim_cs_image_operation_2, 4, 4, 0)
-{ long rows, nn, opcode;
- REAL *x,*y;
- void cs_image_multiply_into_second_one();
- PRIMITIVE_HEADER (4);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, FIXNUM_P); /* rows */
- CHECK_ARG (3, ARRAY_P); /* image array 1 */
- CHECK_ARG (4, ARRAY_P); /* image array 2 */
-
- x = ARRAY_CONTENTS(ARG_REF(3));
- y = ARRAY_CONTENTS(ARG_REF(4));
- rows = arg_nonnegative_integer(2); /* square images only */
- nn = rows*rows;
- if (nn != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- if (nn != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
-
- opcode = arg_nonnegative_integer(1);
-
- if (opcode==1)
- cs_image_multiply_into_second_one(x,y,rows); /* result in y */
- else if (opcode==2)
- error_bad_range_arg(1); /* illegal opcode */
- else
- error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void
-cs_image_multiply_into_second_one (x,y, rows)
- REAL *x,*y;
- long rows;
-{ long i,j,cols, n,n2;
- REAL *xrow,*yrow, *xrow_r, *xrow_i, *yrow_r, *yrow_i, temp;
- cols = rows; /* square image */
- n = rows;
- n2 = n/2;
-
- xrow= x; yrow= y;
- cs_array_multiply_into_second_one(xrow,yrow, n,n2); /* row 0 */
-
- xrow= x+n2*cols; yrow= y+n2*cols;
- cs_array_multiply_into_second_one(xrow,yrow, n,n2); /* row n2 */
-
- xrow_r= x+cols; yrow_r= y+cols;
- xrow_i= x+(n-1)*cols; yrow_i= y+(n-1)*cols;
- for (i=1; i<n2; i++) {
- for (j=0; j<n; j++) {
- temp = xrow_r[j]*yrow_r[j] - xrow_i[j]*yrow_i[j]; /* real part */
- yrow_i[j] = xrow_r[j]*yrow_i[j] + xrow_i[j]*yrow_r[j]; /* imag part */
- yrow_r[j] = temp; }
- xrow_r= xrow_r+cols; yrow_r= yrow_r+cols;
- xrow_i= xrow_i-cols; yrow_i= yrow_i-cols;
- }
-}
-\f
-/* cs-image-operation-2x! is just like cs-image-operation-2!
- but takes an additional flonum argument. */
-
-DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-2x!", Prim_cs_image_operation_2x, 5, 5, 0)
-{ long rows, nn, opcode;
- REAL *x,*y, flonum_arg;
- void cs_image_divide_into_z();
- PRIMITIVE_HEADER (5);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, FIXNUM_P); /* rows */
- CHECK_ARG (3, ARRAY_P); /* image array 1 */
- CHECK_ARG (4, ARRAY_P); /* image array 2 */
- flonum_arg = (arg_real (5));
-
- x = ARRAY_CONTENTS(ARG_REF(3));
- y = ARRAY_CONTENTS(ARG_REF(4));
- rows = arg_nonnegative_integer(2); /* square images only */
- nn = rows*rows;
- if (nn != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- if (nn != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
-
- opcode = arg_nonnegative_integer(1);
-
- if (opcode==1)
- cs_image_divide_into_z( x,y, x, rows, flonum_arg); /* result in x */
- else if (opcode==2)
- cs_image_divide_into_z( x,y, y, rows, flonum_arg); /* result in y */
- else
- error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* The convention for inf values in division 1/0 is just like in arrays */
-
-void
-cs_image_divide_into_z (x,y, z, rows, inf)
- REAL *x,*y,*z, inf; /* z can be either x or y */
- long rows;
-{ long i,j,cols, n,n2;
- REAL temp, radius;
- REAL *ar_,*ai_, *br_,*bi_, *zr_,*zi_; /* Letters a,b correspond to x,y */
- REAL *xrow,*yrow,*zrow;
- cols = rows; /* square image */
- n = rows;
- n2 = n/2;
-
- xrow= x; yrow= y; zrow= z;
- cs_array_divide_into_z( xrow,yrow, zrow, n,n2, inf); /* row 0 */
-
- xrow= x+n2*cols; yrow= y+n2*cols; zrow= z+n2*cols;
- cs_array_divide_into_z( xrow,yrow, zrow, n,n2, inf); /* row n2 */
-
- ar_= x+cols; br_= y+cols; zr_= z+cols;
- ai_= x+(n-1)*cols; bi_= y+(n-1)*cols; zi_= z+(n-1)*cols;
- for (i=1; i<n2; i++) {
- for (j=0; j<n; j++) {
- /* b^2 denominator = real^2 + imag^2 */
- radius = br_[j]*br_[j] + bi_[j]*bi_[j];
-
- if (radius == 0.0) {
- if (ar_[j] == 0.0) zr_[j] = 1.0;
- else zr_[j] = ar_[j] * inf;
- if (ai_[j] == 0.0) zi_[j] = 1.0;
- else zi_[j] = ai_[j] * inf; }
- else {
- temp = ar_[j]*br_[j] + ai_[j]*bi_[j];
- zi_[j] = (ai_[j]*br_[j] - ar_[j]*bi_[j]) / radius; /* imag part */
- zr_[j] = temp / radius; /* real part */
- }}
- ar_= ar_+cols; br_= br_+cols; zr_= zr_+cols;
- ai_= ai_-cols; bi_= bi_-cols; zi_= zi_-cols;
- }
-}
-\f
-/* operation-3
- groups together procedures that use 3 cs-image-arrays
- (usually side-effecting the 3rd image, but not necessarily) */
-
-DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-3!", Prim_cs_image_operation_3, 5, 5, 0)
-{ long rows, nn, opcode;
- REAL *x,*y,*z;
- void tr_complex_image_to_cs_image();
- PRIMITIVE_HEADER (5);
- CHECK_ARG (1, FIXNUM_P); /* operation opcode */
- CHECK_ARG (2, FIXNUM_P); /* rows */
- CHECK_ARG (3, ARRAY_P); /* image array 1 */
- CHECK_ARG (4, ARRAY_P); /* image array 2 */
- CHECK_ARG (5, ARRAY_P); /* image array 3 */
-
- x = ARRAY_CONTENTS(ARG_REF(3));
- y = ARRAY_CONTENTS(ARG_REF(4));
- z = ARRAY_CONTENTS(ARG_REF(5));
- rows = arg_nonnegative_integer(2); /* square images only */
- nn = rows*rows;
- if (nn != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
- if (nn != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
- if (nn != ARRAY_LENGTH(ARG_REF(5))) error_bad_range_arg(5);
-
- opcode = arg_nonnegative_integer(1);
-
- if (opcode==1)
- tr_complex_image_to_cs_image(x,y, z,rows); /* result in z */
- else if (opcode==2)
- error_bad_range_arg(1); /* illegal opcode */
- else
- error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* x and y must be ALREADY TRANSPOSED real and imaginary parts */
-void
-tr_complex_image_to_cs_image (x,y, z,rows)
- REAL *x,*y,*z;
- long rows;
-{ long i,j,cols, n,n2, n2_1_n;
- REAL *xrow, *yrow, *zrow;
- cols = rows; /* square image */
- n = rows;
- n2 = n/2;
-
- xrow= x; yrow= y; zrow= z;
- for (j=0; j<=n2; j++)
- /* real part of row 0 (cs-array) */
- zrow[j] = xrow[j];
- for (j=n2+1; j<n; j++)
- /* imag part of row 0 */
- zrow[j] = yrow[n-j];
- xrow= x+n2*cols; yrow= y+n2*cols; zrow= z+n2*cols;
- for (j=0; j<=n2; j++)
- /* real part of row n2 (cs-array) */
- zrow[j] = xrow[j];
- for (j=n2+1; j<n; j++)
- /* imag part of row n2 */
- zrow[j] = yrow[n-j];
- xrow= x+cols; zrow= z+cols; n2_1_n = (n2-1)*cols;
- for (j=0; j<n2_1_n; j++)
- /* real rows 1,2,..,n2-1 */
- zrow[j] = xrow[j];
- yrow= y+(n2-1)*cols;
- /* imag rows n2+1,n2+2,... */
- zrow= z+(n2+1)*cols;
- for (i=1; i<n2; i++) {
- for (j=0; j<n; j++) zrow[j] = yrow[j];
- zrow = zrow + cols;
- yrow = yrow - cols;
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: image.h,v 9.29 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-\f
-extern Image_Fast_Transpose ();
-/* REAL * Array;
- long nrows;
- OPTIMIZATION for square images */
-
-extern Image_Transpose ();
-/* REAL * Array;
- REAL * New_Array;
- long nrows;
- long ncols; */
-
-extern Image_Rotate_90clw ();
-/* REAL * Array;
- REAL * Rotated_Array;
- long nrows;
- long ncols; */
-
-extern Image_Rotate_90cclw ();
-/* REAL * Array;
- REAL * Rotated_Array;
- long nrows;
- long ncols; */
-
-extern Image_Mirror ();
-/* REAL * Array;
- long nrows;
- long ncols; */
-
-extern Image_Mirror_Upside_Down ();
-/* REAL * Array;
- long nrows;
- long ncols;
- REAL * Temp_Row; */
-
-extern Image_Rotate_90clw_Mirror ();
-/* REAL * Array;
- REAL * Rotated_Array;
- long nrows;
- long ncols; */
-
-extern Image_Draw_Magnify_N_Times_With_Offset_Scale ();
-extern Image_Draw_Magnify_N_Times_With_Offset_Scale_Only ();
+++ /dev/null
-/* -*-C-*-
-
-$Id: intercom.c,v 9.38 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Single-processor simulation of locking, propagating, and
- communicating stuff. */
-\f
-#include "scheme.h"
-#include "prims.h"
-#include "locks.h"
-#include "zones.h"
-
-#ifndef COMPILE_FUTURES
-#include "Error: intercom.c is useless without COMPILE_FUTURES"
-#endif
-
-/* (GLOBAL-INTERRUPT LEVEL WORK TEST)
-
- There are 4 global interrupt levels, level 0 (highest priority)
- being reserved for GC. See const.h for details of the dist-
- ribution of these bits with respect to local interrupt levels.
-
- Force all other processors to begin executing WORK (an interrupt
- handler [procedure of two arguments]) provided that TEST returns
- true. TEST is supplied to allow this primitive to be restarted if it
- is unable to begin because another processor wins the race to
- generate a global interrupt and makes it no longer necessary that
- this processor generate one (TEST receives no arguments). This
- primitive returns the value of the call to TEST (i.e. non-#!FALSE if
- the interrupt was really generated), and returns only after all other
- processors have begun execution of WORK (or TEST returns false).
-*/
-\f
-DEFINE_PRIMITIVE ("GLOBAL-INTERRUPT", Prim_send_global_interrupt, 3, 3, 0)
-{
- long Which_Level;
- SCHEME_OBJECT work;
- SCHEME_OBJECT test;
- long Saved_Zone;
- PRIMITIVE_HEADER (3);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
- Which_Level = (arg_index_integer (1, 4));
- work = (ARG_REF (2)); /* Why is this being ignored? -- CPH */
- test = (ARG_REF (3));
- Save_Time_Zone (Zone_Global_Int);
- POP_PRIMITIVE_FRAME (3);
- Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Store_Return (RC_FINISH_GLOBAL_INT);
- exp_register = (LONG_TO_UNSIGNED_FIXNUM (Which_Level));
- Save_Cont ();
- STACK_PUSH (test);
- STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
- Restore_Time_Zone ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
-}
-
-SCHEME_OBJECT
-Global_Int_Part_2 (Which_Level, Do_It)
- SCHEME_OBJECT Which_Level;
- SCHEME_OBJECT Do_It;
-{
- return (Do_It);
-}
-\f
-DEFINE_PRIMITIVE ("PUT-WORK", Prim_put_work, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
- if (EMPTY_LIST_P (queue))
- {
- queue = (cons (EMPTY_LIST, EMPTY_LIST));
- Set_Fixed_Obj_Slot (The_Work_Queue, queue);
- }
- {
- SCHEME_OBJECT queue_tail = (PAIR_CDR (queue));
- SCHEME_OBJECT new_entry = (cons ((ARG_REF (1)), EMPTY_LIST));
- SET_PAIR_CDR (queue, new_entry);
- if (EMPTY_LIST_P (queue_tail))
- SET_PAIR_CAR (queue, new_entry);
- else
- SET_PAIR_CDR (queue_tail, new_entry);
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("PUT-WORK-IN-FRONT", Prim_put_work_in_front, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
- if (EMPTY_LIST_P (queue))
- {
- queue = (cons (EMPTY_LIST, EMPTY_LIST));
- Set_Fixed_Obj_Slot (The_Work_Queue, queue);
- }
- {
- SCHEME_OBJECT queue_head = (PAIR_CAR (queue));
- SCHEME_OBJECT new_entry = (cons ((ARG_REF (1)), queue_head));
- SET_PAIR_CAR (queue, new_entry);
- if (EMPTY_LIST_P (queue_head))
- SET_PAIR_CDR (queue, new_entry);
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("DRAIN-WORK-QUEUE!", Prim_drain_queue, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- {
- SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
- Set_Fixed_Obj_Slot (The_Work_Queue, EMPTY_LIST);
- PRIMITIVE_RETURN ((!EMPTY_LIST_P (queue)) ? (PAIR_CAR (queue)) : EMPTY_LIST);
- }
-}
-
-DEFINE_PRIMITIVE ("PEEK-AT-WORK-QUEUE", Prim_peek_queue, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- {
- fast SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
- if (EMPTY_LIST_P (queue))
- PRIMITIVE_RETURN (EMPTY_LIST);
- /* Reverse the queue and return it.
- (Why is it being reversed? -- cph) */
- {
- fast SCHEME_OBJECT this_pair = (PAIR_CAR (queue));
- fast SCHEME_OBJECT result = EMPTY_LIST;
- while (!EMPTY_LIST_P (this_pair))
- {
- result = (cons ((PAIR_CAR (this_pair)), result));
- this_pair = (PAIR_CDR (this_pair));
- }
- PRIMITIVE_RETURN (result);
- }
- }
-}
-\f
-DEFINE_PRIMITIVE ("GET-WORK", Prim_get_work, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT thunk = (ARG_REF (1));
- /* This gets this primitive's code which is in the expression register. */
- SCHEME_OBJECT primitive = (Registers[REGBLOCK_PRIMITIVE]);
- SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
- SCHEME_OBJECT queue_head =
- ((EMPTY_LIST_P (queue)) ? EMPTY_LIST : (PAIR_CAR (queue)));
- if (EMPTY_LIST_P (queue_head))
- {
- if (thunk == SHARP_F)
- {
- fprintf (stderr,
- "\nNo work available, but some has been requested!\n");
- Microcode_Termination (TERM_EXIT);
- }
- PRIMITIVE_CANONICALIZE_CONTEXT ();
- POP_PRIMITIVE_FRAME (1);
- Will_Push ((2 * (STACK_ENV_EXTRA_SLOTS + 1)) + 1 + CONTINUATION_SIZE);
- /* When the thunk returns, call the primitive again.
- If there's still no work, we lose. */
- STACK_PUSH (SHARP_F);
- STACK_PUSH (primitive);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
- exp_register = SHARP_F;
- Store_Return (RC_INTERNAL_APPLY);
- Save_Cont ();
- /* Invoke the thunk. */
- STACK_PUSH (thunk);
- STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- }
- {
- SCHEME_OBJECT result = (PAIR_CAR (queue_head));
- queue_head = (PAIR_CDR (queue_head));
- SET_PAIR_CAR (queue, queue_head);
- if (EMPTY_LIST_P (queue_head))
- SET_PAIR_CDR (queue, EMPTY_LIST);
- PRIMITIVE_RETURN (result);
- }
- }
-}
-\f
-DEFINE_PRIMITIVE ("AWAIT-SYNCHRONY", Prim_await_sync, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, PAIR_P);
- if (! (FIXNUM_P (PAIR_CDR (ARG_REF (1)))))
- error_bad_range_arg (1);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("N-INTERPRETERS", Prim_n_interps, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
-}
-
-DEFINE_PRIMITIVE ("MY-PROCESSOR-NUMBER", Prim_my_proc, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
-}
-
-DEFINE_PRIMITIVE ("MY-INTERPRETER-NUMBER", Prim_my_interp_number, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
-}
-
-DEFINE_PRIMITIVE ("ZERO-ZONES", Prim_zero_zones, 0, 0, 0)
-{
- long i;
- PRIMITIVE_HEADER (0);
-#ifdef METERING
- for (i=0; i < Max_Meters; i++)
- {
- Time_Meters[i] = 0;
- }
-
- Old_Time = (OS_process_clock ());
-#endif
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* These are really used by GC on a true parallel machine */
-
-DEFINE_PRIMITIVE ("GC-NEEDED?", Prim_gc_needed, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((Free + GC_Space_Needed) >= MemTop));
-}
-
-DEFINE_PRIMITIVE ("SLAVE-GC-BEFORE-SYNC", Prim_slave_before, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("SLAVE-GC-AFTER-SYNC", Prim_slave_after, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("MASTER-GC-BEFORE-SYNC", Prim_master_before, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("MASTER-GC-LOOP", Prim_master_gc, 1, 1, 0)
-{
- static SCHEME_OBJECT gc_prim = SHARP_F;
- extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
- PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT();
- /* This primitive caches the Scheme object for the garbage collector
- primitive so that it does not have to perform a potentially
- expensive search each time. */
- if (gc_prim == SHARP_F)
- gc_prim = (make_primitive ("GARBAGE-COLLECT", 1));
- {
- SCHEME_OBJECT argument = (ARG_REF (1));
- POP_PRIMITIVE_FRAME (1);
- Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
- STACK_PUSH (argument);
- STACK_PUSH (gc_prim);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- }
-}
/* -*-C-*-
-$Id: intern.c,v 9.66 2007/01/12 03:45:55 cph Exp $
+$Id: intern.c,v 9.67 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
#include "trap.h"
-
-#ifdef STDC_HEADERS
-# include <string.h>
-#else
- extern int EXFUN (strlen, (const char *));
-#endif
\f
-/* Hashing strings */
-
/* The FNV hash, short for Fowler/Noll/Vo in honor of its creators. */
-static unsigned int
-DEFUN (string_hash, (length, string),
- unsigned long length AND
- CONST char * string)
+static uint32_t
+string_hash (uint32_t length, const char * string)
{
- CONST unsigned char * scan = ((unsigned char *) string);
- CONST unsigned char * end = (scan + length);
- unsigned int result = 0x811c9dc5;
+ const unsigned char * scan = ((const unsigned char *) string);
+ const unsigned char * end = (scan + length);
+ uint32_t result = 2166136261U;
while (scan < end)
- result = ((result * 0x1000193) + (*scan++));
- return (result & ((unsigned int) BIGGEST_FIXNUM));
+ result = ((result * 16777619U) + (*scan++));
+#if (BIGGEST_FIXNUM >= 0xFFFFFFFF)
+ return (result);
+#else
+ return (result & ((uint32_t) BIGGEST_FIXNUM));
+#endif
}
static SCHEME_OBJECT *
-DEFUN (find_symbol_internal, (length, string),
- unsigned long length AND
- CONST char * string)
+find_symbol_internal (unsigned long length, const char * string)
{
- SCHEME_OBJECT obarray = (Get_Fixed_Obj_Slot (OBArray));
+ SCHEME_OBJECT obarray = (VECTOR_REF (fixed_objects, OBARRAY));
SCHEME_OBJECT * bucket
- = (MEMORY_LOC (obarray,
- (((string_hash (length, string))
- % (VECTOR_LENGTH (obarray)))
- + 1)));
- while (!EMPTY_LIST_P (*bucket))
+ = (VECTOR_LOC (obarray,
+ ((string_hash (length, string))
+ % (VECTOR_LENGTH (obarray)))));
+ while (true)
{
- SCHEME_OBJECT symbol = (PAIR_CAR (*bucket));
- SCHEME_OBJECT name = (FAST_MEMORY_REF (symbol, SYMBOL_NAME));
- if (((STRING_LENGTH (name)) == length)
- && ((memcmp ((STRING_LOC (name, 0)), string, length)) == 0))
- return (PAIR_CAR_LOC (*bucket));
- bucket = (PAIR_CDR_LOC (*bucket));
+ SCHEME_OBJECT list = (*bucket);
+ if (PAIR_P (list))
+ {
+ SCHEME_OBJECT symbol = (PAIR_CAR (list));
+ SCHEME_OBJECT name = (MEMORY_REF (symbol, SYMBOL_NAME));
+ if (((STRING_LENGTH (name)) == length)
+ && ((memcmp ((STRING_POINTER (name)), string, length)) == 0))
+ return (PAIR_CAR_LOC (list));
+ }
+ else
+ return (bucket);
+ bucket = (PAIR_CDR_LOC (list));
}
- return (bucket);
-}
-\f
-CONST char *
-DEFUN (arg_symbol, (n), int n)
-{
- CHECK_ARG (n, SYMBOL_P);
- return (STRING_POINTER (FAST_MEMORY_REF ((ARG_REF (n)), SYMBOL_NAME)));
-}
-
-CONST char *
-DEFUN (arg_interned_symbol, (n), int n)
-{
- CHECK_ARG (n, SYMBOL_P);
- return (STRING_POINTER (FAST_MEMORY_REF ((ARG_REF (n)), SYMBOL_NAME)));
-}
-
-SCHEME_OBJECT
-DEFUN (find_symbol, (length, string),
- unsigned long length AND
- CONST char * string)
-{
- SCHEME_OBJECT result = (* (find_symbol_internal (length, string)));
- return ((EMPTY_LIST_P (result)) ? SHARP_F : result);
}
static SCHEME_OBJECT
-DEFUN (make_symbol, (string, cell),
- SCHEME_OBJECT string AND
- SCHEME_OBJECT * cell)
+make_symbol (SCHEME_OBJECT string, SCHEME_OBJECT * cell)
{
Primitive_GC_If_Needed (4);
{
SCHEME_OBJECT symbol = (MAKE_POINTER_OBJECT (TC_INTERNED_SYMBOL, Free));
- (Free[SYMBOL_NAME]) = string;
- (Free[SYMBOL_GLOBAL_VALUE]) = UNBOUND_OBJECT;
Free += 2;
+ MEMORY_SET (symbol, SYMBOL_NAME, string);
+ MEMORY_SET (symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
(*cell) = (cons (symbol, EMPTY_LIST));
return (symbol);
}
}
SCHEME_OBJECT
-DEFUN (memory_to_symbol, (length, string),
- unsigned long length AND
- CONST char * string)
+find_symbol (unsigned long length, const char * string)
+{
+ SCHEME_OBJECT * cell = (find_symbol_internal (length, string));
+ return ((INTERNED_SYMBOL_P (*cell)) ? (*cell) : SHARP_F);
+}
+\f
+SCHEME_OBJECT
+memory_to_symbol (unsigned long length, const void * string)
{
SCHEME_OBJECT * cell = (find_symbol_internal (length, string));
return
- ((EMPTY_LIST_P (*cell))
- ? (make_symbol ((memory_to_string (length, string)), cell))
- : (*cell));
+ ((INTERNED_SYMBOL_P (*cell))
+ ? (*cell)
+ : (make_symbol ((memory_to_string (length, string)), cell)));
}
SCHEME_OBJECT
-DEFUN (char_pointer_to_symbol, (string), CONST char * string)
+char_pointer_to_symbol (const char * string)
{
return (memory_to_symbol ((strlen (string)), string));
}
SCHEME_OBJECT
-DEFUN (string_to_symbol, (string), SCHEME_OBJECT string)
+string_to_symbol (SCHEME_OBJECT string)
{
SCHEME_OBJECT * cell
= (find_symbol_internal ((STRING_LENGTH (string)),
(STRING_POINTER (string))));
- return ((EMPTY_LIST_P (*cell)) ? (make_symbol (string, cell)) : (*cell));
+ return ((INTERNED_SYMBOL_P (*cell))
+ ? (*cell)
+ : (make_symbol (string, cell)));
}
SCHEME_OBJECT
-DEFUN (intern_symbol, (symbol), SCHEME_OBJECT symbol)
+intern_symbol (SCHEME_OBJECT symbol)
{
- SCHEME_OBJECT name = (FAST_MEMORY_REF (symbol, SYMBOL_NAME));
+ SCHEME_OBJECT name = (MEMORY_REF (symbol, SYMBOL_NAME));
SCHEME_OBJECT * cell
- = (find_symbol_internal ((STRING_LENGTH (name)), (STRING_POINTER (name))));
- if (!EMPTY_LIST_P (*cell))
+ = (find_symbol_internal ((STRING_LENGTH (name)),
+ (STRING_POINTER (name))));
+ if (INTERNED_SYMBOL_P (*cell))
return (*cell);
else
{
return (result);
}
}
+
+const char *
+arg_symbol (int n)
+{
+ CHECK_ARG (n, SYMBOL_P);
+ return (STRING_POINTER (MEMORY_REF ((ARG_REF (n)), SYMBOL_NAME)));
+}
+
+const char *
+arg_interned_symbol (int n)
+{
+ CHECK_ARG (n, SYMBOL_P);
+ return (STRING_POINTER (MEMORY_REF ((ARG_REF (n)), SYMBOL_NAME)));
+}
\f
DEFINE_PRIMITIVE ("FIND-SYMBOL", Prim_find_symbol, 1, 1,
- "(FIND-SYMBOL STRING)\n\
-Returns the symbol whose name is STRING, or #F if no such symbol exists.")
+ "(STRING)\n\
+Returns the symbol named STRING, or #F if no such symbol exists.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
{
SCHEME_OBJECT string = (ARG_REF (1));
- PRIMITIVE_RETURN
- (find_symbol ((STRING_LENGTH (string)), (STRING_POINTER (string))));
+ PRIMITIVE_RETURN (find_symbol ((STRING_LENGTH (string)),
+ (STRING_POINTER (string))));
}
}
DEFINE_PRIMITIVE ("STRING->SYMBOL", Prim_string_to_symbol, 1, 1,
- "(STRING->SYMBOL STRING)\n\
-Returns the symbol whose name is STRING, constructing a new symbol if needed.")
+ "(STRING)\n\
+Returns the interned symbol named STRING, constructing a new symbol\n\
+if needed.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
}
DEFINE_PRIMITIVE ("STRING-HASH", Prim_string_hash, 1, 1,
- "(STRING-HASH STRING)\n\
-Return a hash value for a string. This uses the hashing\n\
-algorithm for interning symbols. It is intended for use by\n\
-the reader in creating interned symbols.")
+ "(STRING)\n\
+Returns the hash value for STRING, using the hashing algorithm for\n\
+interning symbols.")
+
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
{
SCHEME_OBJECT string = (ARG_REF (1));
PRIMITIVE_RETURN
- (LONG_TO_UNSIGNED_FIXNUM (string_hash ((STRING_LENGTH (string)),
- (STRING_POINTER (string)))));
+ (ULONG_TO_FIXNUM (string_hash ((STRING_LENGTH (string)),
+ (STRING_POINTER (string)))));
}
}
DEFINE_PRIMITIVE ("STRING-HASH-MOD", Prim_string_hash_mod, 2, 2,
- "(STRING-HASH-MOD STRING DENOMINATOR)\n\
+ "(STRING DENOMINATOR)\n\
DENOMINATOR must be a nonnegative integer.\n\
Equivalent to (MODULO (STRING-HASH STRING) DENOMINATOR).")
{
{
SCHEME_OBJECT string = (ARG_REF (1));
PRIMITIVE_RETURN
- (LONG_TO_UNSIGNED_FIXNUM
- ((string_hash ((STRING_LENGTH (string)),
- (STRING_POINTER (string))))
- % (arg_ulong_integer (2))));
+ (ULONG_TO_FIXNUM ((string_hash ((STRING_LENGTH (string)),
+ (STRING_POINTER (string))))
+ % (arg_ulong_integer (2))));
}
}
/* -*-C-*-
-$Id: interp.c,v 9.105 2007/01/22 08:43:09 riastradh Exp $
+$Id: interp.c,v 9.106 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* The interpreter */
#include "scheme.h"
-#include "locks.h"
#include "trap.h"
#include "lookup.h"
#include "winder.h"
#include "history.h"
-#include "cmpint.h"
-#include "zones.h"
-#include "prmcon.h"
-extern PTR EXFUN (obstack_chunk_alloc, (size_t size));
-extern void EXFUN (free, (PTR ptr));
+extern void * obstack_chunk_alloc (size_t);
#define obstack_chunk_free free
-extern void EXFUN (back_out_of_primitive_internal, (void));
-extern void EXFUN (preserve_signal_mask, (void));
-extern long EXFUN (enter_compiled_expression, (void));
-extern long EXFUN (apply_compiled_procedure, (void));
-extern long EXFUN (return_to_compiled_code, (void));
+extern void preserve_signal_mask (void);
\f
/* In order to make the interpreter tail recursive (i.e.
* to avoid calling procedures and thus saving unnecessary
* passing style as follows. At every point where you would
* call EVAL to handle a sub-form, you put a jump back to
* do_expression. Now, if there was code after the call to
- * EVAL you first push a "return code" (using Save_Cont) on
+ * EVAL you first push a "return code" (using SAVE_CONT) on
* the stack and move the code that used to be after the
* call down into the part of this file after the tag
* pop_return.
\f
#define SIGNAL_INTERRUPT(Masked_Code) \
{ \
- Setup_Interrupt (Masked_Code); \
+ setup_interrupt (Masked_Code); \
goto perform_application; \
}
#define PREPARE_POP_RETURN_INTERRUPT(Return_Code, Contents_of_Val) \
{ \
SCHEME_OBJECT temp = (Contents_of_Val); \
- Store_Return (Return_Code); \
- Save_Cont (); \
- Store_Return (RC_RESTORE_VALUE); \
- exp_register = temp; \
- Save_Cont (); \
+ SET_RC (Return_Code); \
+ SAVE_CONT (); \
+ SET_RC (RC_RESTORE_VALUE); \
+ SET_EXP (temp); \
+ SAVE_CONT (); \
}
#define PREPARE_APPLY_INTERRUPT() \
{ \
- exp_register = SHARP_F; \
+ SET_EXP (SHARP_F); \
PREPARE_POP_RETURN_INTERRUPT \
- (RC_INTERNAL_APPLY_VAL, (STACK_REF (STACK_ENV_FUNCTION))); \
+ (RC_INTERNAL_APPLY_VAL, (APPLY_FRAME_PROCEDURE ())); \
}
-#define APPLICATION_ERROR(N) \
+#define APPLICATION_ERROR(code) do \
{ \
- exp_register = SHARP_F; \
- Store_Return (RC_INTERNAL_APPLY_VAL); \
- val_register = (STACK_REF (STACK_ENV_FUNCTION)); \
- POP_RETURN_ERROR (N); \
-}
+ SET_EXP (SHARP_F); \
+ SET_RC (RC_INTERNAL_APPLY_VAL); \
+ SAVE_CONT (); \
+ SET_VAL (APPLY_FRAME_PROCEDURE ()); \
+ Do_Micro_Error (code, true); \
+ goto internal_apply; \
+} while (0)
#define IMMEDIATE_GC(N) \
{ \
- Request_GC (N); \
+ REQUEST_GC (N); \
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); \
}
#define EVAL_GC_CHECK(Amount) \
{ \
- if (GC_Check (Amount)) \
+ if (GC_NEEDED_P (Amount)) \
{ \
PREPARE_EVAL_REPEAT (); \
IMMEDIATE_GC (Amount); \
} \
}
-#define PREPARE_EVAL_REPEAT() \
+#define PREPARE_EVAL_REPEAT() do \
{ \
Will_Push (CONTINUATION_SIZE + 1); \
- STACK_PUSH (env_register); \
- Store_Return (RC_EVAL_ERROR); \
- Save_Cont (); \
+ PUSH_ENV (); \
+ SET_RC (RC_EVAL_ERROR); \
+ SAVE_CONT (); \
Pushed (); \
-}
+} while (0)
-#define EVAL_ERROR(Err) \
+#define EVAL_ERROR(code) do \
{ \
- Do_Micro_Error (Err, 0); \
+ Do_Micro_Error (code, false); \
goto internal_apply; \
-}
+} while (0)
-#define POP_RETURN_ERROR(Err) \
+#define POP_RETURN_ERROR(code) do \
{ \
- Do_Micro_Error (Err, 1); \
+ SAVE_CONT (); \
+ Do_Micro_Error (code, true); \
goto internal_apply; \
-}
+} while (0)
-#define BACK_OUT_AFTER_PRIMITIVE back_out_of_primitive_internal
+#define PROCEED_AFTER_PRIMITIVE() SET_PRIMITIVE (SHARP_F)
\f
-#define REDUCES_TO(expression) \
+#define REDUCES_TO(expression) do \
{ \
- exp_register = (expression); \
- New_Reduction (exp_register, env_register); \
+ SET_EXP (expression); \
+ NEW_REDUCTION (GET_EXP, GET_ENV); \
goto do_expression; \
-}
+} while (0)
-#define REDUCES_TO_NTH(n) REDUCES_TO (FAST_MEMORY_REF (exp_register, (n)))
+#define REDUCES_TO_NTH(n) REDUCES_TO (MEMORY_REF (GET_EXP, (n)))
-#define DO_NTH_THEN(Return_Code, n) \
+#define DO_NTH_THEN(Return_Code, n) do \
{ \
- Store_Return (Return_Code); \
- Save_Cont (); \
- exp_register = (FAST_MEMORY_REF (exp_register, (n))); \
- New_Subproblem (exp_register, env_register); \
+ SET_RC (Return_Code); \
+ SAVE_CONT (); \
+ SET_EXP (MEMORY_REF (GET_EXP, (n))); \
+ NEW_SUBPROBLEM (GET_EXP, GET_ENV); \
goto do_expression; \
-}
+} while (0)
#define PUSH_NTH_THEN(Return_Code, n) \
-{ \
- Store_Return (Return_Code); \
- Save_Cont (); \
- exp_register = (FAST_MEMORY_REF (exp_register, (n))); \
- New_Subproblem (exp_register, env_register); \
+ SET_RC (Return_Code); \
+ SAVE_CONT (); \
+ SET_EXP (MEMORY_REF (GET_EXP, (n))); \
+ NEW_SUBPROBLEM (GET_EXP, GET_ENV); \
Pushed (); \
- goto do_expression; \
-}
+ goto do_expression
-#define DO_ANOTHER_THEN(Return_Code, N) \
+#define DO_ANOTHER_THEN(Return_Code, N) do \
{ \
- Store_Return (Return_Code); \
- Save_Cont (); \
- exp_register = (FAST_MEMORY_REF (exp_register, (N))); \
- Reuse_Subproblem (exp_register, env_register); \
+ SET_RC (Return_Code); \
+ SAVE_CONT (); \
+ SET_EXP (MEMORY_REF (GET_EXP, (N))); \
+ REUSE_SUBPROBLEM (GET_EXP, GET_ENV); \
goto do_expression; \
-}
+} while (0)
#ifdef COMPILE_STEPPER
#define FETCH_EVAL_TRAPPER() \
- (MEMORY_REF ((Get_Fixed_Obj_Slot (Stepper_State)), HUNK_CXR0))
+ (MEMORY_REF ((VECTOR_REF (fixed_objects, STEPPER_STATE)), HUNK_CXR0))
#define FETCH_APPLY_TRAPPER() \
- (MEMORY_REF ((Get_Fixed_Obj_Slot (Stepper_State)), HUNK_CXR1))
+ (MEMORY_REF ((VECTOR_REF (fixed_objects, STEPPER_STATE)), HUNK_CXR1))
#define FETCH_RETURN_TRAPPER() \
- (MEMORY_REF ((Get_Fixed_Obj_Slot (Stepper_State)), HUNK_CXR2))
+ (MEMORY_REF ((VECTOR_REF (fixed_objects, STEPPER_STATE)), HUNK_CXR2))
#endif /* COMPILE_STEPPER */
\f
-/* Macros for handling FUTUREs */
-
-#ifdef COMPILE_FUTURES
-
-/* ARG_TYPE_ERROR handles the error returns from primitives which type
- check their arguments and restarts them or suspends if the argument
- is a future. */
-
-#define ARG_TYPE_ERROR(Arg_No, Err_No) \
-{ \
- SCHEME_OBJECT * Arg \
- = (& (STACK_REF ((Arg_No - 1) + STACK_ENV_FIRST_ARG))); \
- SCHEME_OBJECT Orig_Arg = (*Arg); \
- if (OBJECT_TYPE (*Arg) != TC_FUTURE) \
- POP_RETURN_ERROR (Err_No); \
- while (((OBJECT_TYPE (*Arg)) == TC_FUTURE) \
- && (Future_Has_Value (*Arg))) \
- { \
- if (Future_Is_Keep_Slot (*Arg)) \
- Log_Touch_Of_Future (*Arg); \
- (*Arg) = Future_Value (*Arg); \
- } \
- if ((OBJECT_TYPE (*Arg)) != TC_FUTURE) \
- goto Apply_Non_Trapping; \
- TOUCH_SETUP (*Arg); \
- (*Arg) = Orig_Arg; \
- goto Apply_Non_Trapping; \
-}
-
-/* APPLY_FUTURE_CHECK is called at apply time to guarantee that
- certain objects (the procedure itself, and its LAMBDA components
- for user defined procedures) are not futures. */
-
-#define APPLY_FUTURE_CHECK(Name, Object) \
-{ \
- SCHEME_OBJECT * Arg = (& (Object)); \
- SCHEME_OBJECT Orig_Answer = (*Arg); \
- while ((OBJECT_TYPE (*Arg)) == TC_FUTURE) \
- { \
- if (Future_Has_Value (*Arg)) \
- { \
- if (Future_Is_Keep_Slot (*Arg)) \
- Log_Touch_Of_Future (*Arg); \
- (*Arg) = (Future_Value (*Arg)); \
- } \
- else \
- { \
- PREPARE_APPLY_INTERRUPT (); \
- TOUCH_SETUP (*Arg); \
- (*Arg) = Orig_Answer; \
- goto internal_apply; \
- } \
- } \
- Name = (*Arg); \
-}
-\f
-/* POP_RETURN_VAL_CHECK suspends the process if the value calculated
- by a recursive call to EVAL is an undetermined future. */
-
-#define POP_RETURN_VAL_CHECK() \
-{ \
- SCHEME_OBJECT Orig_Val = val_register; \
- while ((OBJECT_TYPE (val_register)) == TC_FUTURE) \
- { \
- if (Future_Has_Value (val_register)) \
- { \
- if (Future_Is_Keep_Slot (val_register)) \
- Log_Touch_Of_Future (val_register); \
- val_register = (Future_Value (val_register)); \
- } \
- else \
- { \
- Save_Cont (); \
- Will_Push (CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 2)); \
- Store_Return (RC_RESTORE_VALUE); \
- exp_register = Orig_Val; \
- Save_Cont (); \
- STACK_PUSH (val_register); \
- STACK_PUSH (Get_Fixed_Obj_Slot (System_Scheduler)); \
- STACK_PUSH (STACK_FRAME_HEADER + 1); \
- Pushed (); \
- goto internal_apply; \
- } \
- } \
-}
-
-/* This saves stuff unnecessarily in most cases.
- For example, when dispatch_code is PRIM_APPLY, val_register,
- env_register, exp_register, and ret_register are undefined. */
-
-#define LOG_FUTURES() \
-{ \
- if (Must_Report_References ()) \
- { \
- Save_Cont (); \
- Will_Push (CONTINUATION_SIZE + 2); \
- STACK_PUSH (val_register); \
- STACK_PUSH (env_register); \
- Store_Return (RC_REPEAT_DISPATCH); \
- exp_register = (LONG_TO_FIXNUM (CODE_MAP (dispatch_code))); \
- Save_Cont (); \
- Pushed (); \
- Call_Future_Logging (); \
- } \
-}
-
-#else /* not COMPILE_FUTURES */
-
-#define POP_RETURN_VAL_CHECK()
-#define APPLY_FUTURE_CHECK(Name, Object) Name = (Object)
-#define ARG_TYPE_ERROR(Arg_No, Err_No) POP_RETURN_ERROR (Err_No)
-#define LOG_FUTURES()
-
-#endif /* not COMPILE_FUTURES */
-\f
-/* Notes on repeat_dispatch:
-
- The codes used (values of dispatch_code) are divided into two
- groups: those for which the primitive has already backed out, and
- those for which the back out code has not yet been executed, and is
- therefore executed below.
-
- Under most circumstances the distinction is moot, but if there are
- futures in the system, and future touches must be logged, the code
- must be set up to "interrupt" the dispatch, and proceed it later.
- The primitive back out code must be done before the furure is
- logged, so all of these codes are split into two versions: one set
- before doing the back out, and another afterwards. */
-
-/* This is assumed to be larger (in absolute value) than any
- PRIM_<mumble> and ERR_<mumble>. */
-#define PRIM_BIAS_AMOUNT 1000
-
-#if (MAX_ERROR >= PRIM_BIAS_AMOUNT)
-# include "Inconsistency: errors.h and interp.c"
-#endif
-
-#define CODE_MAP(code) \
- (((code) < 0) \
- ? ((code) - PRIM_BIAS_AMOUNT) \
- : ((code) + PRIM_BIAS_AMOUNT))
-
-#define CODE_UNMAP(code) \
- (((code) < 0) \
- ? ((code) + PRIM_BIAS_AMOUNT) \
- : ((code) - PRIM_BIAS_AMOUNT))
-
-#define CODE_MAPPED_P(code) \
- (((code) < (-PRIM_BIAS_AMOUNT)) \
- || ((code) >= PRIM_BIAS_AMOUNT))
-
-#define PROCEED_AFTER_PRIMITIVE() \
-{ \
- (Registers[REGBLOCK_PRIMITIVE]) = SHARP_F; \
- LOG_FUTURES (); \
-}
-\f
/* The EVAL/APPLY yin/yang */
interpreter_state_t interpreter_state = NULL_INTERPRETER_STATE;
void
-DEFUN (bind_interpreter_state, (s), interpreter_state_t s)
+bind_interpreter_state (interpreter_state_t s)
{
(s -> previous_state) = interpreter_state;
(s -> nesting_level) =
}
void
-DEFUN (unbind_interpreter_state, (s), interpreter_state_t s)
+unbind_interpreter_state (interpreter_state_t s)
{
interpreter_state = s;
{
- long old_mask = (FETCH_INTERRUPT_MASK ());
+ unsigned long old_mask = GET_INT_MASK;
SET_INTERRUPT_MASK (0);
dstack_set_position (s -> dstack_position);
SET_INTERRUPT_MASK (old_mask);
}
void
-DEFUN (abort_to_interpreter, (argument), int argument)
+abort_to_interpreter (int argument)
{
if (interpreter_state == NULL_INTERPRETER_STATE)
{
outf_fatal ("abort_to_interpreter: Interpreter not set up.\n");
termination_init_error ();
}
-
+
interpreter_throw_argument = argument;
{
- long old_mask = (FETCH_INTERRUPT_MASK ());
+ unsigned long old_mask = GET_INT_MASK;
SET_INTERRUPT_MASK (0);
dstack_set_position (interpreter_catch_dstack_position);
SET_INTERRUPT_MASK (old_mask);
}
int
-DEFUN_VOID (abort_to_interpreter_argument)
+abort_to_interpreter_argument (void)
{
return (interpreter_throw_argument);
}
\f
void
-DEFUN (Interpret, (pop_return_p), int pop_return_p)
+Interpret (void)
{
long dispatch_code;
struct interpreter_state_s new_state;
/* Primitives jump back here for errors, requests to evaluate an
expression, apply a function, or handle an interrupt request. On
errors or interrupts they leave their arguments on the stack, the
- primitive itself in exp_register. The code should do a primitive
+ primitive itself in GET_EXP. The code should do a primitive
backout in these cases, but not in others (apply, eval, etc.),
since the primitive itself will have left the state of the
interpreter ready for operation. */
bind_interpreter_state (&new_state);
dispatch_code = (setjmp (interpreter_catch_env));
preserve_signal_mask ();
- Set_Time_Zone (Zone_Working);
- repeat_dispatch:
switch (dispatch_code)
{
+ case 0:
+ break;
+
case PRIM_APPLY:
PROCEED_AFTER_PRIMITIVE ();
- case CODE_MAP (PRIM_APPLY):
goto internal_apply;
case PRIM_NO_TRAP_APPLY:
PROCEED_AFTER_PRIMITIVE ();
- case CODE_MAP (PRIM_NO_TRAP_APPLY):
goto Apply_Non_Trapping;
+ case PRIM_APPLY_INTERRUPT:
+ PROCEED_AFTER_PRIMITIVE ();
+ PREPARE_APPLY_INTERRUPT ();
+ SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
+
case PRIM_DO_EXPRESSION:
- val_register = exp_register;
+ SET_VAL (GET_EXP);
PROCEED_AFTER_PRIMITIVE ();
- case CODE_MAP (PRIM_DO_EXPRESSION):
- REDUCES_TO (val_register);
+ REDUCES_TO (GET_VAL);
case PRIM_NO_TRAP_EVAL:
- val_register = exp_register;
+ SET_VAL (GET_EXP);
PROCEED_AFTER_PRIMITIVE ();
- case CODE_MAP (PRIM_NO_TRAP_EVAL):
- New_Reduction (val_register, env_register);
+ NEW_REDUCTION (GET_VAL, GET_ENV);
goto eval_non_trapping;
- case 0: /* first time */
- if (pop_return_p)
- goto pop_return;
- else
- break; /* fall into eval */
-
case PRIM_POP_RETURN:
PROCEED_AFTER_PRIMITIVE ();
- case CODE_MAP (PRIM_POP_RETURN):
goto pop_return;
case PRIM_NO_TRAP_POP_RETURN:
PROCEED_AFTER_PRIMITIVE ();
- case CODE_MAP (PRIM_NO_TRAP_POP_RETURN):
goto pop_return_non_trapping;
- case PRIM_REENTER:
- BACK_OUT_AFTER_PRIMITIVE ();
- LOG_FUTURES ();
- case CODE_MAP (PRIM_REENTER):
- goto perform_application;
-
- case PRIM_TOUCH:
- {
- SCHEME_OBJECT temp = val_register;
- BACK_OUT_AFTER_PRIMITIVE ();
- val_register = temp;
- LOG_FUTURES ();
- }
- /* fall through */
- case CODE_MAP (PRIM_TOUCH):
- TOUCH_SETUP (val_register);
- goto internal_apply;
-
case PRIM_INTERRUPT:
- BACK_OUT_AFTER_PRIMITIVE ();
- LOG_FUTURES ();
- /* fall through */
- case CODE_MAP (PRIM_INTERRUPT):
- Save_Cont ();
+ back_out_of_primitive ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case ERR_ARG_1_WRONG_TYPE:
- BACK_OUT_AFTER_PRIMITIVE ();
- LOG_FUTURES ();
- /* fall through */
- case CODE_MAP (ERR_ARG_1_WRONG_TYPE):
- ARG_TYPE_ERROR (1, ERR_ARG_1_WRONG_TYPE);
+ back_out_of_primitive ();
+ Do_Micro_Error (ERR_ARG_1_WRONG_TYPE, true);
+ goto internal_apply;
case ERR_ARG_2_WRONG_TYPE:
- BACK_OUT_AFTER_PRIMITIVE ();
- LOG_FUTURES ();
- /* fall through */
- case CODE_MAP (ERR_ARG_2_WRONG_TYPE):
- ARG_TYPE_ERROR (2, ERR_ARG_2_WRONG_TYPE);
+ back_out_of_primitive ();
+ Do_Micro_Error (ERR_ARG_2_WRONG_TYPE, true);
+ goto internal_apply;
case ERR_ARG_3_WRONG_TYPE:
- BACK_OUT_AFTER_PRIMITIVE ();
- LOG_FUTURES ();
- /* fall through */
- case CODE_MAP (ERR_ARG_3_WRONG_TYPE):
- ARG_TYPE_ERROR (3, ERR_ARG_3_WRONG_TYPE);
+ back_out_of_primitive ();
+ Do_Micro_Error (ERR_ARG_3_WRONG_TYPE, true);
+ goto internal_apply;
default:
- {
- if (!CODE_MAPPED_P (dispatch_code))
- {
- BACK_OUT_AFTER_PRIMITIVE ();
- LOG_FUTURES ();
- }
- else
- dispatch_code = (CODE_UNMAP (dispatch_code));
- POP_RETURN_ERROR (dispatch_code);
- }
+ back_out_of_primitive ();
+ Do_Micro_Error (dispatch_code, true);
+ goto internal_apply;
}
do_expression:
-#if 0
- if (Eval_Debug)
- {
- Print_Expression (exp_register, "Eval, expression");
- outf_console ("\n");
- }
-#endif
-
- /* exp_register has an Scode item in it that should be evaluated and
- the result left in val_register.
+ /* GET_EXP has an Scode item in it that should be evaluated and the
+ result left in GET_VAL.
A "break" after the code for any operation indicates that all
processing for this operation has been completed, and the next
macro. This indicates that the value of the current Scode item
is the value returned when the new expression is evaluated.
Therefore no new continuation is created and processing continues
- at do_expression with the new expression in exp_register.
+ at do_expression with the new expression in GET_EXP.
Finally, an operation can terminate with a DO_NTH_THEN macro.
This indicates that another expression must be evaluated and them
some additional processing will be performed before the value of
this S-Code item available. Thus a new continuation is created
- and placed on the stack (using Save_Cont), the new expression is
- placed in the exp_register, and processing continues at
- do_expression. */
+ and placed on the stack (using SAVE_CONT), the new expression is
+ placed in the GET_EXP, and processing continues at do_expression.
+ */
/* Handling of Eval Trapping.
-
+
If we are handling traps and there is an Eval Trap set, turn off
all trapping and then go to internal_apply to call the user
supplied eval hook with the expression to be evaluated and the
environment. */
#ifdef COMPILE_STEPPER
- if (Trapping
+ if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_EVAL_TRAPPER ()) != SHARP_F))
{
- Stop_Trapping ();
+ trapping = false;
Will_Push (4);
- STACK_PUSH (env_register);
- STACK_PUSH (exp_register);
+ PUSH_ENV ();
+ PUSH_EXP ();
STACK_PUSH (FETCH_EVAL_TRAPPER ());
- STACK_PUSH (STACK_FRAME_HEADER + 2);
+ PUSH_APPLY_FRAME_HEADER (2);
Pushed ();
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
eval_non_trapping:
- Eval_Ucode_Hook ();
- switch (OBJECT_TYPE (exp_register))
- {
- default:
-#if 0
- EVAL_ERROR (ERR_UNDEFINED_USER_TYPE);
-#else
- /* fall through to self evaluating. */
+#ifdef EVAL_UCODE_HOOK
+ EVAL_UCODE_HOOK ();
#endif
-
+ switch (OBJECT_TYPE (GET_EXP))
+ {
case TC_BIG_FIXNUM: /* The self evaluating items */
case TC_BIG_FLONUM:
case TC_CHARACTER_STRING:
case TC_VECTOR:
case TC_VECTOR_16B:
case TC_VECTOR_1B:
- val_register = exp_register;
+ default:
+ SET_VAL (GET_EXP);
break;
case TC_ACCESS:
case TC_ASSIGNMENT:
Will_Push (CONTINUATION_SIZE + 1);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
PUSH_NTH_THEN (RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE);
case TC_BROKEN_HEART:
case TC_COMBINATION:
{
- long length = ((VECTOR_LENGTH (exp_register)) - 1);
-#ifdef USE_STACKLETS
- /* Finger */
- EVAL_GC_CHECK (New_Stacklet_Size (length + 2 + CONTINUATION_SIZE));
-#endif /* USE_STACKLETS */
+ long length = ((VECTOR_LENGTH (GET_EXP)) - 1);
Will_Push (length + 2 + CONTINUATION_SIZE);
- sp_register = (STACK_LOC (-length));
+ stack_pointer = (STACK_LOC (-length));
STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length));
/* The finger: last argument number */
Pushed ();
if (length == 0)
{
- STACK_PUSH (STACK_FRAME_HEADER); /* Frame size */
+ PUSH_APPLY_FRAME_HEADER (0); /* Frame size */
DO_NTH_THEN (RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
- STACK_PUSH (env_register);
+ PUSH_ENV ();
DO_NTH_THEN (RC_COMB_SAVE_VALUE, (length + 1));
}
case TC_COMBINATION_1:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
DO_NTH_THEN (RC_COMB_1_PROCEDURE, COMB_1_ARG_1);
case TC_COMBINATION_2:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
DO_NTH_THEN (RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2);
case TC_COMMENT:
case TC_CONDITIONAL:
Will_Push (CONTINUATION_SIZE + 1);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
PUSH_NTH_THEN (RC_CONDITIONAL_DECIDE, COND_PREDICATE);
+#ifdef CC_SUPPORT_P
case TC_COMPILED_ENTRY:
- {
- SCHEME_OBJECT compiled_expression = exp_register;
- execute_compiled_setup ();
- exp_register = compiled_expression;
- dispatch_code = (enter_compiled_expression ());
- goto return_from_compiled_code;
- }
+ dispatch_code = (enter_compiled_expression ());
+ goto return_from_compiled_code;
+#endif
case TC_DEFINITION:
Will_Push (CONTINUATION_SIZE + 1);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
PUSH_NTH_THEN (RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE);
case TC_DELAY:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
- val_register = (MAKE_POINTER_OBJECT (TC_DELAYED, Free));
- (Free[THUNK_ENVIRONMENT]) = env_register;
- (Free[THUNK_PROCEDURE]) = (FAST_MEMORY_REF (exp_register, DELAY_OBJECT));
+ SET_VAL (MAKE_POINTER_OBJECT (TC_DELAYED, Free));
+ (Free[THUNK_ENVIRONMENT]) = GET_ENV;
+ (Free[THUNK_PROCEDURE]) = (MEMORY_REF (GET_EXP, DELAY_OBJECT));
Free += 2;
break;
case TC_DISJUNCTION:
Will_Push (CONTINUATION_SIZE + 1);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
PUSH_NTH_THEN (RC_DISJUNCTION_DECIDE, OR_PREDICATE);
case TC_EXTENDED_LAMBDA:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
- val_register = (MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free));
- (Free[PROCEDURE_LAMBDA_EXPR]) = exp_register;
- (Free[PROCEDURE_ENVIRONMENT]) = env_register;
+ SET_VAL (MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free));
+ (Free[PROCEDURE_LAMBDA_EXPR]) = GET_EXP;
+ (Free[PROCEDURE_ENVIRONMENT]) = GET_ENV;
Free += 2;
break;
-#ifdef COMPILE_FUTURES
- case TC_FUTURE:
- if (Future_Has_Value (exp_register))
- {
- SCHEME_OBJECT Future = exp_register;
- if (Future_Is_Keep_Slot (Future))
- Log_Touch_Of_Future (Future);
- REDUCES_TO_NTH (FUTURE_VALUE);
- }
- PREPARE_EVAL_REPEAT ();
- Will_Push (STACK_ENV_EXTRA_SLOTS+2);
- STACK_PUSH (exp_register); /* Arg: FUTURE object */
- STACK_PUSH (Get_Fixed_Obj_Slot (System_Scheduler));
- STACK_PUSH (STACK_FRAME_HEADER+1);
- Pushed ();
- goto internal_apply;
-#endif
-
case TC_IN_PACKAGE:
Will_Push (CONTINUATION_SIZE);
PUSH_NTH_THEN (RC_EXECUTE_IN_PACKAGE_CONTINUE, IN_PACKAGE_ENVIRONMENT);
case TC_LAMBDA:
case TC_LEXPR:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
- val_register = (MAKE_POINTER_OBJECT (TC_PROCEDURE, Free));
- (Free[PROCEDURE_LAMBDA_EXPR]) = exp_register;
- (Free[PROCEDURE_ENVIRONMENT]) = env_register;
+ SET_VAL (MAKE_POINTER_OBJECT (TC_PROCEDURE, Free));
+ (Free[PROCEDURE_LAMBDA_EXPR]) = GET_EXP;
+ (Free[PROCEDURE_ENVIRONMENT]) = GET_ENV;
Free += 2;
break;
case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
EVAL_ERROR (ERR_EXECUTE_MANIFEST_VECTOR);
case TC_PCOMB0:
much will be on the stack if we back out of the primitive. */
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- exp_register = (OBJECT_NEW_TYPE (TC_PRIMITIVE, exp_register));
+ SET_EXP (OBJECT_NEW_TYPE (TC_PRIMITIVE, GET_EXP));
goto primitive_internal_apply;
case TC_PCOMB1:
case TC_PCOMB2:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
DO_NTH_THEN (RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT);
case TC_PCOMB3:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
DO_NTH_THEN (RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT);
case TC_SCODE_QUOTE:
- val_register = (FAST_MEMORY_REF (exp_register, SCODE_QUOTE_OBJECT));
+ SET_VAL (MEMORY_REF (GET_EXP, SCODE_QUOTE_OBJECT));
break;
case TC_SEQUENCE_2:
Will_Push (CONTINUATION_SIZE + 1);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
PUSH_NTH_THEN (RC_SEQ_2_DO_2, SEQUENCE_1);
case TC_SEQUENCE_3:
Will_Push (CONTINUATION_SIZE + 1);
- STACK_PUSH (env_register);
+ PUSH_ENV ();
PUSH_NTH_THEN (RC_SEQ_3_DO_2, SEQUENCE_1);
case TC_THE_ENVIRONMENT:
- val_register = env_register;
+ SET_VAL (GET_ENV);
break;
case TC_VARIABLE:
{
- long temp;
-
- Set_Time_Zone (Zone_Lookup);
- temp = (lookup_variable (env_register, exp_register, (&val_register)));
- if (temp == PRIM_DONE)
- goto pop_return;
-
- /* Back out of the evaluation. */
-
- Set_Time_Zone (Zone_Working);
- if (temp == PRIM_INTERRUPT)
+ SCHEME_OBJECT val = GET_VAL;
+ long temp = (lookup_variable (GET_ENV, GET_EXP, (&val)));
+ if (temp != PRIM_DONE)
{
- PREPARE_EVAL_REPEAT ();
- SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
+ /* Back out of the evaluation. */
+ if (temp == PRIM_INTERRUPT)
+ {
+ PREPARE_EVAL_REPEAT ();
+ SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
+ }
+ EVAL_ERROR (temp);
}
- EVAL_ERROR (temp);
+ SET_VAL (val);
}
-
- SITE_EXPRESSION_DISPATCH_HOOK ();
}
/* Now restore the continuation saved during an earlier part of the
pop_return:
#ifdef COMPILE_STEPPER
- if (Trapping
+ if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_RETURN_TRAPPER ()) != SHARP_F))
{
Will_Push (3);
- Stop_Trapping ();
- STACK_PUSH (val_register);
+ trapping = false;
+ PUSH_VAL ();
STACK_PUSH (FETCH_RETURN_TRAPPER ());
- STACK_PUSH (STACK_FRAME_HEADER + 1);
+ PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
pop_return_non_trapping:
- Pop_Return_Ucode_Hook ();
- Restore_Cont ();
- if (Consistency_Check && ((OBJECT_TYPE (ret_register)) != TC_RETURN_CODE))
+#ifdef POP_RETURN_UCODE_HOOK
+ POP_RETURN_UCODE_HOOK ();
+#endif
+ RESTORE_CONT ();
+#ifdef ENABLE_DEBUGGING_TOOLS
+ if (!RETURN_CODE_P (GET_RET))
{
- STACK_PUSH (val_register); /* For possible stack trace */
- Save_Cont ();
+ PUSH_VAL (); /* For possible stack trace */
+ SAVE_CONT ();
Microcode_Termination (TERM_BAD_STACK);
}
-#if 0
- if (Eval_Debug)
- {
- Print_Return ("pop_return, return code");
- Print_Expression (val_register, "pop_return, value");
- outf_console ("\n");
- }
#endif
/* Dispatch on the return code. A BREAK here will cause
common occurrence.
*/
- switch (OBJECT_DATUM (ret_register))
+ switch (OBJECT_DATUM (GET_RET))
{
case RC_COMB_1_PROCEDURE:
- env_register = (STACK_POP ());
- STACK_PUSH (val_register); /* Arg. 1 */
+ POP_ENV ();
+ PUSH_VAL (); /* Arg. 1 */
STACK_PUSH (SHARP_F); /* Operator */
- STACK_PUSH (STACK_FRAME_HEADER + 1);
+ PUSH_APPLY_FRAME_HEADER (1);
Finished_Eventual_Pushing (CONTINUATION_SIZE);
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_FIRST_OPERAND:
- env_register = (STACK_POP ());
- STACK_PUSH (val_register);
- STACK_PUSH (env_register);
+ POP_ENV ();
+ PUSH_VAL ();
+ PUSH_ENV ();
DO_ANOTHER_THEN (RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
case RC_COMB_2_PROCEDURE:
- env_register = (STACK_POP ());
- STACK_PUSH (val_register); /* Arg 1, just calculated */
+ POP_ENV ();
+ PUSH_VAL (); /* Arg 1, just calculated */
STACK_PUSH (SHARP_F); /* Function */
- STACK_PUSH (STACK_FRAME_HEADER + 2);
+ PUSH_APPLY_FRAME_HEADER (2);
Finished_Eventual_Pushing (CONTINUATION_SIZE);
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_2_FN);
case RC_COMB_APPLY_FUNCTION:
- End_Subproblem ();
+ END_SUBPROBLEM ();
goto internal_apply_val;
case RC_COMB_SAVE_VALUE:
{
long Arg_Number;
- env_register = (STACK_POP ());
+ POP_ENV ();
Arg_Number = ((OBJECT_DATUM (STACK_REF (STACK_COMB_FINGER))) - 1);
- (STACK_REF (STACK_COMB_FIRST_ARG + Arg_Number)) = val_register;
+ (STACK_REF (STACK_COMB_FIRST_ARG + Arg_Number)) = GET_VAL;
(STACK_REF (STACK_COMB_FINGER))
= (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number));
/* DO NOT count on the type code being NMVector here, since
the stack parser may create them with #F here! */
if (Arg_Number > 0)
{
- STACK_PUSH (env_register);
+ PUSH_ENV ();
DO_ANOTHER_THEN
(RC_COMB_SAVE_VALUE, ((COMB_ARG_1_SLOT - 1) + Arg_Number));
}
/* Frame Size */
- STACK_PUSH (FAST_MEMORY_REF (exp_register, 0));
+ STACK_PUSH (MEMORY_REF (GET_EXP, 0));
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
+#ifdef CC_SUPPORT_P
+
#define DEFINE_COMPILER_RESTART(return_code, entry) \
case return_code: \
{ \
- extern long EXFUN (entry, (void)); \
- compiled_code_restart (); \
dispatch_code = (entry ()); \
goto return_from_compiled_code; \
}
DEFINE_COMPILER_RESTART
(RC_COMP_INTERRUPT_RESTART, comp_interrupt_restart);
- DEFINE_COMPILER_RESTART
- (RC_COMP_LOOKUP_APPLY_RESTART, comp_lookup_apply_restart);
-
- DEFINE_COMPILER_RESTART
- (RC_COMP_REFERENCE_RESTART, comp_reference_restart);
-
- DEFINE_COMPILER_RESTART
- (RC_COMP_ACCESS_RESTART, comp_access_restart);
-
- DEFINE_COMPILER_RESTART
- (RC_COMP_UNASSIGNED_P_RESTART, comp_unassigned_p_restart);
-
- DEFINE_COMPILER_RESTART
- (RC_COMP_UNBOUND_P_RESTART, comp_unbound_p_restart);
-
- DEFINE_COMPILER_RESTART
- (RC_COMP_ASSIGNMENT_RESTART, comp_assignment_restart);
-
- DEFINE_COMPILER_RESTART
- (RC_COMP_DEFINITION_RESTART, comp_definition_restart);
-
- DEFINE_COMPILER_RESTART
- (RC_COMP_SAFE_REFERENCE_RESTART, comp_safe_reference_restart);
-
DEFINE_COMPILER_RESTART
(RC_COMP_LOOKUP_TRAP_RESTART, comp_lookup_trap_restart);
(RC_COMP_ERROR_RESTART, comp_error_restart);
case RC_REENTER_COMPILED_CODE:
- compiled_code_restart ();
dispatch_code = (return_to_compiled_code ());
goto return_from_compiled_code;
+#endif
+
case RC_CONDITIONAL_DECIDE:
- POP_RETURN_VAL_CHECK ();
- End_Subproblem ();
- env_register = (STACK_POP ());
+ END_SUBPROBLEM ();
+ POP_ENV ();
REDUCES_TO_NTH
- ((val_register == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT);
+ ((GET_VAL == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT);
case RC_DISJUNCTION_DECIDE:
/* Return predicate if it isn't #F; else do ALTERNATIVE */
- POP_RETURN_VAL_CHECK ();
- End_Subproblem ();
- env_register = (STACK_POP ());
- if (val_register != SHARP_F)
+ END_SUBPROBLEM ();
+ POP_ENV ();
+ if (GET_VAL != SHARP_F)
goto pop_return;
REDUCES_TO_NTH (OR_ALTERNATIVE);
case RC_EVAL_ERROR:
/* Should be called RC_REDO_EVALUATION. */
- env_register = (STACK_POP ());
- REDUCES_TO (exp_register);
+ POP_ENV ();
+ REDUCES_TO (GET_EXP);
case RC_EXECUTE_ACCESS_FINISH:
{
- long Result;
- SCHEME_OBJECT value;
-
- POP_RETURN_VAL_CHECK ();
- value = val_register;
- if (ENVIRONMENT_P (val_register))
+ SCHEME_OBJECT val;
+ long code;
+
+ if (!ENVIRONMENT_P (GET_VAL))
+ POP_RETURN_ERROR (ERR_BAD_FRAME);
+ code = (lookup_variable (GET_VAL,
+ (MEMORY_REF (GET_EXP, ACCESS_NAME)),
+ (&val)));
+ if (code == PRIM_DONE)
+ SET_VAL (val);
+ else if (code == PRIM_INTERRUPT)
{
- Result
- = (lookup_variable
- (value,
- (FAST_MEMORY_REF (exp_register, ACCESS_NAME)),
- (&val_register)));
- if (Result == PRIM_DONE)
- {
- End_Subproblem ();
- break;
- }
- if (Result != PRIM_INTERRUPT)
- {
- val_register = value;
- POP_RETURN_ERROR (Result);
- }
- PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_ACCESS_FINISH, value);
+ PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_ACCESS_FINISH, GET_VAL);
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
- val_register = value;
- POP_RETURN_ERROR (ERR_BAD_FRAME);
+ else
+ POP_RETURN_ERROR (code);
}
+ END_SUBPROBLEM ();
+ break;
case RC_EXECUTE_ASSIGNMENT_FINISH:
{
- long temp;
- SCHEME_OBJECT value;
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (set_serializer);
-#endif
-
- value = val_register;
- Set_Time_Zone (Zone_Lookup);
- env_register = (STACK_POP ());
- temp
- = (assign_variable
- (env_register,
- (MEMORY_REF (exp_register, ASSIGN_NAME)),
- value,
- (&val_register)));
- if (temp == PRIM_DONE)
- {
- End_Subproblem ();
- Set_Time_Zone (Zone_Working);
- break;
- }
- Set_Time_Zone (Zone_Working);
- STACK_PUSH (env_register);
- if (temp != PRIM_INTERRUPT)
+ SCHEME_OBJECT old_val;
+ long code;
+
+ POP_ENV ();
+ code = (assign_variable (GET_ENV,
+ (MEMORY_REF (GET_EXP, ASSIGN_NAME)),
+ GET_VAL,
+ (&old_val)));
+ if (code == PRIM_DONE)
+ SET_VAL (old_val);
+ else
{
- val_register = value;
- POP_RETURN_ERROR (temp);
+ PUSH_ENV ();
+ if (code == PRIM_INTERRUPT)
+ {
+ PREPARE_POP_RETURN_INTERRUPT
+ (RC_EXECUTE_ASSIGNMENT_FINISH, GET_VAL);
+ SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
+ }
+ else
+ POP_RETURN_ERROR (code);
}
- PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_ASSIGNMENT_FINISH, value);
- SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
+ END_SUBPROBLEM ();
+ break;
case RC_EXECUTE_DEFINITION_FINISH:
{
- SCHEME_OBJECT name = (FAST_MEMORY_REF (exp_register, DEFINE_NAME));
- SCHEME_OBJECT value = val_register;
+ SCHEME_OBJECT name = (MEMORY_REF (GET_EXP, DEFINE_NAME));
+ SCHEME_OBJECT value = GET_VAL;
long result;
- env_register = (STACK_POP ());
- result = (define_variable (env_register, name, value));
+ POP_ENV ();
+ result = (define_variable (GET_ENV, name, value));
if (result == PRIM_DONE)
{
- End_Subproblem ();
- val_register = name;
+ END_SUBPROBLEM ();
+ SET_VAL (name);
break;
}
- STACK_PUSH (env_register);
+ PUSH_ENV ();
if (result == PRIM_INTERRUPT)
{
PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_DEFINITION_FINISH,
value);
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
- val_register = value;
+ SET_VAL (value);
POP_RETURN_ERROR (result);
}
case RC_EXECUTE_IN_PACKAGE_CONTINUE:
- POP_RETURN_VAL_CHECK ();
- if (ENVIRONMENT_P (val_register))
+ if (ENVIRONMENT_P (GET_VAL))
{
- End_Subproblem ();
- env_register = val_register;
+ END_SUBPROBLEM ();
+ SET_ENV (GET_VAL);
REDUCES_TO_NTH (IN_PACKAGE_EXPRESSION);
}
POP_RETURN_ERROR (ERR_BAD_FRAME);
-#ifdef COMPILE_FUTURES
- case RC_FINISH_GLOBAL_INT:
- val_register = (Global_Int_Part_2 (exp_register, val_register));
- break;
-#endif
-
case RC_HALT:
Microcode_Termination (TERM_TERM_HANDLER);
/* This just reinvokes the handler */
SCHEME_OBJECT info = (STACK_REF (0));
SCHEME_OBJECT handler = SHARP_F;
- Save_Cont ();
- if (Valid_Fixed_Obj_Vector ())
- handler = (Get_Fixed_Obj_Slot (Trap_Handler));
+ SAVE_CONT ();
+ if (VECTOR_P (fixed_objects))
+ handler = (VECTOR_REF (fixed_objects, TRAP_HANDLER));
if (handler == SHARP_F)
{
outf_fatal ("There is no trap handler for recovery!\n");
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (info);
STACK_PUSH (handler);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
+ PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
}
goto internal_apply;
/* internal_apply, the core of the application mechanism.
-
+
Branch here to perform a function application.
-
+
At this point the top of the stack contains an application
frame which consists of the following elements (see sdata.h):
- A header specifying the frame length.
- A procedure.
- The actual (evaluated) arguments.
-
+
No registers (except the stack pointer) are meaning full at
this point. Before interrupts or errors are processed, some
registers are cleared to avoid holding onto garbage if a
case RC_INTERNAL_APPLY_VAL:
internal_apply_val:
- STACK_REF (STACK_ENV_FUNCTION) = val_register;
+ (APPLY_FRAME_PROCEDURE ()) = GET_VAL;
case RC_INTERNAL_APPLY:
internal_apply:
#ifdef COMPILE_STEPPER
- if (Trapping
+ if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_APPLY_TRAPPER ()) != SHARP_F))
{
- long Count = (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
+ unsigned long frame_size = (APPLY_FRAME_SIZE ());
(* (STACK_LOC (0))) = (FETCH_APPLY_TRAPPER ());
- STACK_PUSH (STACK_FRAME_HEADER + Count);
- Stop_Trapping ();
+ PUSH_APPLY_FRAME_HEADER (frame_size);
+ trapping = false;
}
#endif /* COMPILE_STEPPER */
Apply_Non_Trapping:
- if ((PENDING_INTERRUPTS ()) != 0)
+ if (PENDING_INTERRUPTS_P)
{
- long interrupts = (PENDING_INTERRUPTS ());
+ unsigned long interrupts = (PENDING_INTERRUPTS ());
PREPARE_APPLY_INTERRUPT ();
SIGNAL_INTERRUPT (interrupts);
}
perform_application:
- Apply_Ucode_Hook ();
+#ifdef APPLY_UCODE_HOOK
+ APPLY_UCODE_HOOK ();
+#endif
{
- SCHEME_OBJECT Function;
- SCHEME_OBJECT orig_proc;
-
- APPLY_FUTURE_CHECK (Function, (STACK_REF (STACK_ENV_FUNCTION)));
- orig_proc = Function;
+ SCHEME_OBJECT Function = (APPLY_FRAME_PROCEDURE ());
apply_dispatch:
switch (OBJECT_TYPE (Function))
{
case TC_ENTITY:
{
- long nargs = (STACK_POP ());
- long nactuals = (OBJECT_DATUM (nargs));
+ unsigned long frame_size = (APPLY_FRAME_SIZE ());
SCHEME_OBJECT data = (MEMORY_REF (Function, ENTITY_DATA));
-
- /* Will_Pushed omitted since frame must be contiguous.
- combination code must ensure one more slot. */
-
- /* This code assumes that adding 1 to nactuals takes care
- of everything, including type code, etc. */
-
if ((VECTOR_P (data))
- && (nactuals < ((long) (VECTOR_LENGTH (data))))
- && ((VECTOR_REF (data, nactuals)) != SHARP_F)
+ && (frame_size < (VECTOR_LENGTH (data)))
+ && ((VECTOR_REF (data, frame_size)) != SHARP_F)
&& ((VECTOR_REF (data, 0))
- == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
+ == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG))))
{
- SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals));
- if ((Function == orig_proc) && (nproc != Function))
- {
- Function = nproc;
- STACK_PUSH (nargs);
- STACK_REF (STACK_ENV_FUNCTION) = nproc;
- goto apply_dispatch;
- }
- else
- {
- Function = orig_proc;
- STACK_REF (STACK_ENV_FUNCTION - 1) = orig_proc;
- }
+ Function = (VECTOR_REF (data, frame_size));
+ (APPLY_FRAME_PROCEDURE ()) = Function;
+ goto apply_dispatch;
}
-
- STACK_PUSH (FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
- STACK_PUSH (nargs + 1);
+
+ (STACK_REF (0)) = (MEMORY_REF (Function, ENTITY_OPERATOR));
+ PUSH_APPLY_FRAME_HEADER (frame_size);
/* This must be done to prevent an infinite push loop by
an entity whose handler is the entity itself or some
other such loop. Of course, it will die if stack overflow
interrupts are disabled. */
- Stack_Check (sp_register);
+ STACK_CHECK (0);
goto internal_apply;
}
case TC_PROCEDURE:
{
- long nargs = (OBJECT_DATUM (STACK_POP ()));
- Function = (FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR));
+ unsigned long frame_size = (APPLY_FRAME_SIZE ());
+ Function = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR));
{
- SCHEME_OBJECT formals;
+ SCHEME_OBJECT formals
+ = (MEMORY_REF (Function, LAMBDA_FORMALS));
- APPLY_FUTURE_CHECK
- (formals, (FAST_MEMORY_REF (Function, LAMBDA_FORMALS)));
- if ((nargs != ((long) (VECTOR_LENGTH (formals))))
+ if ((frame_size != (VECTOR_LENGTH (formals)))
&& (((OBJECT_TYPE (Function)) != TC_LEXPR)
- || (nargs < ((long) (VECTOR_LENGTH (formals))))))
- {
- STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
- APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
+ || (frame_size < (VECTOR_LENGTH (formals)))))
+ APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
-#if 0
- if (Eval_Debug)
+ if (GC_NEEDED_P (frame_size + 1))
{
- Print_Expression
- ((LONG_TO_UNSIGNED_FIXNUM (nargs)),
- "APPLY: Number of arguments");
- outf_console ("\n");
- }
-#endif
- if (GC_Check (nargs + 1))
- {
- STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
PREPARE_APPLY_INTERRUPT ();
- IMMEDIATE_GC (nargs + 1);
+ IMMEDIATE_GC (frame_size + 1);
}
{
- SCHEME_OBJECT * scan = Free;
- SCHEME_OBJECT temp
- = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
- (*scan++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, nargs));
- while ((--nargs) >= 0)
- (*scan++) = (STACK_POP ());
- Free = scan;
- env_register = temp;
- REDUCES_TO (FAST_MEMORY_REF (Function, LAMBDA_SCODE));
+ SCHEME_OBJECT * end = (Free + 1 + frame_size);
+ SCHEME_OBJECT env
+ = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, Free));
+ (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, frame_size));
+ (void) STACK_POP ();
+ while (Free < end)
+ (*Free++) = (STACK_POP ());
+ SET_ENV (env);
+ REDUCES_TO (MEMORY_REF (Function, LAMBDA_SCODE));
}
}
case TC_CONTROL_POINT:
- if ((OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)))
- != STACK_ENV_FIRST_ARG)
+ if ((APPLY_FRAME_SIZE ()) != 2)
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- val_register = (STACK_REF (STACK_ENV_FIRST_ARG));
- Our_Throw (0, Function);
- Apply_Stacklet_Backout ();
- Our_Throw_Part_2();
+ SET_VAL (* (APPLY_FRAME_ARGS ()));
+ unpack_control_point (Function);
+ RESET_HISTORY ();
goto pop_return;
/* After checking the number of arguments, remove the
frame header since primitives do not expect it.
-
+
NOTE: This code must match the application code which
follows primitive_internal_apply. */
case TC_PRIMITIVE:
+ if (!IMPLEMENTED_PRIMITIVE_P (Function))
+ APPLICATION_ERROR (ERR_UNIMPLEMENTED_PRIMITIVE);
{
- long nargs;
+ unsigned long n_args = (APPLY_FRAME_N_ARGS ());
- if (!IMPLEMENTED_PRIMITIVE_P (Function))
- APPLICATION_ERROR (ERR_UNIMPLEMENTED_PRIMITIVE);
/* Note that the first test below will fail for lexpr
primitives. */
- nargs
- = ((OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)))
- - (STACK_ENV_FIRST_ARG - 1));
- if (nargs != (PRIMITIVE_ARITY (Function)))
+ if (n_args != (PRIMITIVE_ARITY (Function)))
{
if ((PRIMITIVE_ARITY (Function)) != LEXPR_PRIMITIVE_ARITY)
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- (Registers[REGBLOCK_LEXPR_ACTUALS])
- = ((SCHEME_OBJECT) nargs);
- }
- sp_register = (STACK_LOC (STACK_ENV_FIRST_ARG));
- exp_register = Function;
- APPLY_PRIMITIVE_FROM_INTERPRETER (val_register, Function);
- POP_PRIMITIVE_FRAME (nargs);
- if (Must_Report_References ())
- {
- exp_register = val_register;
- Store_Return (RC_RESTORE_VALUE);
- Save_Cont ();
- Call_Future_Logging ();
+ SET_LEXPR_ACTUALS (n_args);
}
+ stack_pointer = (APPLY_FRAME_ARGS ());
+ SET_EXP (Function);
+ APPLY_PRIMITIVE_FROM_INTERPRETER (Function);
+ POP_PRIMITIVE_FRAME (n_args);
goto pop_return;
}
{
SCHEME_OBJECT lambda;
SCHEME_OBJECT temp;
- long nargs;
- long nparams;
- long formals;
- long params;
- long auxes;
+ unsigned long nargs;
+ unsigned long nparams;
+ unsigned long formals;
+ unsigned long params;
+ unsigned long auxes;
long rest_flag;
long size;
long i;
SCHEME_OBJECT * scan;
- nargs = ((OBJECT_DATUM (STACK_POP ())) - STACK_FRAME_HEADER);
-#if 0
- if (Eval_Debug)
- {
- Print_Expression
- ((LONG_TO_UNSIGNED_FIXNUM (nargs + STACK_FRAME_HEADER)),
- "APPLY: Number of arguments");
- outf_console ("\n");
- }
-#endif
-
- lambda = (FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR));
- APPLY_FUTURE_CHECK
- (Function, (FAST_MEMORY_REF (lambda, ELAMBDA_NAMES)));
+ nargs = (POP_APPLY_FRAME_HEADER ());
+ lambda = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR));
+ Function = (MEMORY_REF (lambda, ELAMBDA_NAMES));
nparams = ((VECTOR_LENGTH (Function)) - 1);
- APPLY_FUTURE_CHECK (Function, (Get_Count_Elambda (lambda)));
+ Function = (Get_Count_Elambda (lambda));
formals = (Elambda_Formals_Count (Function));
params = ((Elambda_Opts_Count (Function)) + formals);
rest_flag = (Elambda_Rest_Flag (Function));
if ((nargs < formals) || (!rest_flag && (nargs > params)))
{
- STACK_PUSH (STACK_FRAME_HEADER + nargs);
+ PUSH_APPLY_FRAME_HEADER (nargs);
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
/* size includes the procedure slot, but not the header. */
size = (params + rest_flag + auxes + 1);
- if (GC_Check
+ if (GC_NEEDED_P
(size + 1
+ ((nargs > params)
? (2 * (nargs - params))
: 0)))
{
- STACK_PUSH (STACK_FRAME_HEADER + nargs);
+ PUSH_APPLY_FRAME_HEADER (nargs);
PREPARE_APPLY_INTERRUPT ();
IMMEDIATE_GC
(size + 1
}
Free = scan;
- env_register = temp;
+ SET_ENV (temp);
REDUCES_TO (Get_Body_Elambda (lambda));
}
+#ifdef CC_SUPPORT_P
case TC_COMPILED_ENTRY:
{
- apply_compiled_setup
- (STACK_ENV_EXTRA_SLOTS
- + (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER))));
+ guarantee_cc_return (1 + (APPLY_FRAME_SIZE ()));
dispatch_code = (apply_compiled_procedure ());
return_from_compiled_code:
switch (dispatch_code)
{
case PRIM_DONE:
- {
- compiled_code_done ();
- goto pop_return;
- }
+ goto pop_return;
case PRIM_APPLY:
- {
- compiler_apply_procedure
- (STACK_ENV_EXTRA_SLOTS
- + (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER))));
- goto internal_apply;
- }
+ goto internal_apply;
case PRIM_INTERRUPT:
- {
- compiled_error_backout ();
- Save_Cont ();
- SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
- }
+ SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case PRIM_APPLY_INTERRUPT:
- {
- apply_compiled_backout ();
- PREPARE_APPLY_INTERRUPT ();
- SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
- }
+ PREPARE_APPLY_INTERRUPT ();
+ SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case ERR_INAPPLICABLE_OBJECT:
-
- /* This error code means that
- apply_compiled_procedure was called on an object
- which is not a compiled procedure, or it was
- called in a system without compiler support.
-
- Fall through... */
-
case ERR_WRONG_NUMBER_OF_ARGUMENTS:
- {
- apply_compiled_backout ();
- APPLICATION_ERROR (dispatch_code);
- }
-
- case ERR_EXECUTE_MANIFEST_VECTOR:
- {
- /* This error code means that
- enter_compiled_expression was called in a
- system without compiler support. This is a
- kludge! */
- execute_compiled_backout ();
- val_register
- = (OBJECT_NEW_TYPE (TC_COMPILED_ENTRY, exp_register));
- POP_RETURN_ERROR (dispatch_code);
- }
-
- case ERR_INAPPLICABLE_CONTINUATION:
- {
- /* This error code means that
- return_to_compiled_code saw a non-continuation
- on the stack, or was called in a system without
- compiler support. */
- exp_register = SHARP_F;
- Store_Return (RC_REENTER_COMPILED_CODE);
- POP_RETURN_ERROR (dispatch_code);
- }
+ APPLICATION_ERROR (dispatch_code);
default:
- compiled_error_backout ();
POP_RETURN_ERROR (dispatch_code);
}
}
+#endif
default:
APPLICATION_ERROR (ERR_INAPPLICABLE_OBJECT);
}
case RC_MOVE_TO_ADJACENT_POINT:
- /* exp_register contains the space in which we are moving */
+ /* GET_EXP contains the space in which we are moving */
{
long From_Count;
SCHEME_OBJECT Thunk;
SCHEME_OBJECT Current = STACK_REF (TRANSLATE_FROM_POINT);
STACK_REF (TRANSLATE_FROM_DISTANCE)
= (LONG_TO_UNSIGNED_FIXNUM (From_Count - 1));
- Thunk = (FAST_MEMORY_REF (Current, STATE_POINT_AFTER_THUNK));
+ Thunk = (MEMORY_REF (Current, STATE_POINT_AFTER_THUNK));
New_Location
- = (FAST_MEMORY_REF (Current, STATE_POINT_NEARER_POINT));
+ = (MEMORY_REF (Current, STATE_POINT_NEARER_POINT));
(STACK_REF (TRANSLATE_FROM_POINT)) = New_Location;
if ((From_Count == 1)
&& ((STACK_REF (TRANSLATE_TO_DISTANCE))
== (LONG_TO_UNSIGNED_FIXNUM (0))))
- sp_register = (STACK_LOC (4));
+ stack_pointer = (STACK_LOC (4));
else
- Save_Cont ();
+ SAVE_CONT ();
}
else
{
To_Location = (STACK_REF (TRANSLATE_TO_POINT));
for (i = 0; (i < To_Count); i += 1)
To_Location
- = (FAST_MEMORY_REF (To_Location, STATE_POINT_NEARER_POINT));
- Thunk = (FAST_MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK));
+ = (MEMORY_REF (To_Location, STATE_POINT_NEARER_POINT));
+ Thunk = (MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK));
New_Location = To_Location;
(STACK_REF (TRANSLATE_TO_DISTANCE))
= (LONG_TO_UNSIGNED_FIXNUM (To_Count));
if (To_Count == 0)
- sp_register = (STACK_LOC (4));
+ stack_pointer = (STACK_LOC (4));
else
- Save_Cont ();
+ SAVE_CONT ();
}
- if (exp_register != SHARP_F)
+ if (GET_EXP != SHARP_F)
{
- MEMORY_SET (exp_register, STATE_SPACE_NEAREST_POINT, New_Location);
+ MEMORY_SET (GET_EXP, STATE_SPACE_NEAREST_POINT, New_Location);
}
else
- Current_State_Point = New_Location;
+ current_state_point = New_Location;
Will_Push (2);
STACK_PUSH (Thunk);
- STACK_PUSH (STACK_FRAME_HEADER);
+ PUSH_APPLY_FRAME_HEADER (0);
Pushed ();
goto internal_apply;
}
case RC_INVOKE_STACK_THREAD:
/* Used for WITH_THREADED_STACK primitive. */
Will_Push (3);
- STACK_PUSH (val_register); /* Value calculated by thunk. */
- STACK_PUSH (exp_register);
- STACK_PUSH (STACK_FRAME_HEADER+1);
+ PUSH_VAL (); /* Value calculated by thunk. */
+ PUSH_EXP ();
+ PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
goto internal_apply;
case RC_JOIN_STACKLETS:
- Our_Throw (1, exp_register);
- Join_Stacklet_Backout ();
- Our_Throw_Part_2 ();
+ unpack_control_point (GET_EXP);
break;
case RC_NORMAL_GC_DONE:
- val_register = exp_register;
+ SET_VAL (GET_EXP);
/* Paranoia */
- if (GC_Space_Needed < 0)
- GC_Space_Needed = 0;
- if (GC_Check (GC_Space_Needed))
+ if (GC_NEEDED_P (gc_space_needed))
termination_gc_out_of_space ();
- GC_Space_Needed = 0;
- EXIT_CRITICAL_SECTION ({ Save_Cont (); });
- End_GC_Hook ();
+ gc_space_needed = 0;
+ EXIT_CRITICAL_SECTION ({ SAVE_CONT (); });
break;
case RC_PCOMB1_APPLY:
- End_Subproblem ();
- STACK_PUSH (val_register); /* Argument value */
+ END_SUBPROBLEM ();
+ PUSH_VAL (); /* Argument value */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- exp_register = (FAST_MEMORY_REF (exp_register, PCOMB1_FN_SLOT));
+ SET_EXP (MEMORY_REF (GET_EXP, PCOMB1_FN_SLOT));
primitive_internal_apply:
#ifdef COMPILE_STEPPER
- if (Trapping
+ if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_APPLY_TRAPPER ()) != SHARP_F))
{
- /* Does this work in the stacklet case?
- We may have a non-contiguous frame. -- Jinx */
Will_Push (3);
- STACK_PUSH (exp_register);
+ PUSH_EXP ();
STACK_PUSH (FETCH_APPLY_TRAPPER ());
- STACK_PUSH
- (STACK_FRAME_HEADER + 1 + (PRIMITIVE_N_PARAMETERS (exp_register)));
+ PUSH_APPLY_FRAME_HEADER (1 + (PRIMITIVE_N_PARAMETERS (GET_EXP)));
Pushed ();
- Stop_Trapping ();
+ trapping = false;
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
3) We don't need to worry about unimplemented primitives because
unimplemented primitives will cause an error at invocation. */
{
- SCHEME_OBJECT primitive = exp_register;
- APPLY_PRIMITIVE_FROM_INTERPRETER (val_register, primitive);
+ SCHEME_OBJECT primitive = GET_EXP;
+ APPLY_PRIMITIVE_FROM_INTERPRETER (primitive);
POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
- if (Must_Report_References ())
- {
- exp_register = val_register;
- Store_Return (RC_RESTORE_VALUE);
- Save_Cont ();
- Call_Future_Logging ();
- }
break;
}
case RC_PCOMB2_APPLY:
- End_Subproblem ();
- STACK_PUSH (val_register); /* Value of arg. 1 */
+ END_SUBPROBLEM ();
+ PUSH_VAL (); /* Value of arg. 1 */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- exp_register = (FAST_MEMORY_REF (exp_register, PCOMB2_FN_SLOT));
+ SET_EXP (MEMORY_REF (GET_EXP, PCOMB2_FN_SLOT));
goto primitive_internal_apply;
case RC_PCOMB2_DO_1:
- env_register = (STACK_POP ());
- STACK_PUSH (val_register); /* Save value of arg. 2 */
+ POP_ENV ();
+ PUSH_VAL (); /* Save value of arg. 2 */
DO_ANOTHER_THEN (RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
case RC_PCOMB3_APPLY:
- End_Subproblem ();
- STACK_PUSH (val_register); /* Save value of arg. 1 */
+ END_SUBPROBLEM ();
+ PUSH_VAL (); /* Save value of arg. 1 */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- exp_register = (FAST_MEMORY_REF (exp_register, PCOMB3_FN_SLOT));
+ SET_EXP (MEMORY_REF (GET_EXP, PCOMB3_FN_SLOT));
goto primitive_internal_apply;
case RC_PCOMB3_DO_1:
{
SCHEME_OBJECT Temp = (STACK_POP ()); /* Value of arg. 3 */
- env_register = (STACK_POP ());
+ POP_ENV ();
STACK_PUSH (Temp); /* Save arg. 3 again */
- STACK_PUSH (val_register); /* Save arg. 2 */
+ PUSH_VAL (); /* Save arg. 2 */
DO_ANOTHER_THEN (RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
}
case RC_PCOMB3_DO_2:
- env_register = (STACK_REF (0));
- STACK_PUSH (val_register); /* Save value of arg. 3 */
+ SET_ENV (STACK_REF (0));
+ PUSH_VAL (); /* Save value of arg. 3 */
DO_ANOTHER_THEN (RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
case RC_POP_RETURN_ERROR:
case RC_RESTORE_VALUE:
- val_register = exp_register;
- break;
-
- case RC_PRIMITIVE_CONTINUE:
- val_register = (continue_primitive ());
+ SET_VAL (GET_EXP);
break;
- case RC_REPEAT_DISPATCH:
- dispatch_code = (FIXNUM_TO_LONG (exp_register));
- env_register = (STACK_POP ());
- val_register = (STACK_POP ());
- Restore_Cont ();
- goto repeat_dispatch;
-
/* The following two return codes are both used to restore a
saved history object. The difference is that the first does
not copy the history object while the second does. In both
- cases, the exp_register contains the history object and the
+ cases, the GET_EXP contains the history object and the
next item to be popped off the stack contains the offset back
- to the previous restore history return code.
-
- ASSUMPTION: History objects are never created using futures. */
+ to the previous restore history return code. */
case RC_RESTORE_DONT_COPY_HISTORY:
{
- SCHEME_OBJECT Stacklet;
-
- Prev_Restore_History_Offset = (OBJECT_DATUM (STACK_POP ()));
- Stacklet = (STACK_POP ());
- history_register = (OBJECT_ADDRESS (exp_register));
- if (Prev_Restore_History_Offset == 0)
- Prev_Restore_History_Stacklet = 0;
- else if (Stacklet == SHARP_F)
- Prev_Restore_History_Stacklet = 0;
- else
- Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (Stacklet));
+ prev_restore_history_offset = (OBJECT_DATUM (STACK_POP ()));
+ (void) STACK_POP ();
+ history_register = (OBJECT_ADDRESS (GET_EXP));
break;
}
case RC_RESTORE_HISTORY:
{
- SCHEME_OBJECT Stacklet;
-
- if (!Restore_History (exp_register))
+ if (!restore_history (GET_EXP))
{
- Save_Cont ();
+ SAVE_CONT ();
Will_Push (CONTINUATION_SIZE);
- exp_register = val_register;
- Store_Return (RC_RESTORE_VALUE);
- Save_Cont ();
+ SET_EXP (GET_VAL);
+ SET_RC (RC_RESTORE_VALUE);
+ SAVE_CONT ();
Pushed ();
- IMMEDIATE_GC ((Free > MemTop) ? 0 : ((MemTop - Free) + 1));
- }
- Prev_Restore_History_Offset = (OBJECT_DATUM (STACK_POP ()));
- Stacklet = (STACK_POP ());
- if (Prev_Restore_History_Offset == 0)
- Prev_Restore_History_Stacklet = 0;
- else
- {
- if (Stacklet == SHARP_F)
- {
- Prev_Restore_History_Stacklet = 0;
- ((Get_End_Of_Stacklet ()) [-Prev_Restore_History_Offset])
- = (MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY));
- }
- else
- {
- Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (Stacklet));
- (Prev_Restore_History_Stacklet [-Prev_Restore_History_Offset])
- = (MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY));
- }
+ IMMEDIATE_GC (HEAP_AVAILABLE);
}
+ prev_restore_history_offset = (OBJECT_DATUM (STACK_POP ()));
+ (void) STACK_POP ();
+ if (prev_restore_history_offset > 0)
+ (STACK_LOCATIVE_REFERENCE (STACK_BOTTOM,
+ (-prev_restore_history_offset)))
+ = (MAKE_RETURN_CODE (RC_RESTORE_HISTORY));
break;
}
- case RC_RESTORE_FLUIDS:
- Fluid_Bindings = exp_register;
- break;
-
case RC_RESTORE_INT_MASK:
- SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (exp_register));
- if (GC_Check (0))
- Request_GC (0);
- if ((PENDING_INTERRUPTS ()) != 0)
+ SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (GET_EXP));
+ if (GC_NEEDED_P (0))
+ REQUEST_GC (0);
+ if (PENDING_INTERRUPTS_P)
{
- Store_Return (RC_RESTORE_VALUE);
- exp_register = val_register;
- Save_Cont ();
+ SET_RC (RC_RESTORE_VALUE);
+ SET_EXP (GET_VAL);
+ SAVE_CONT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
break;
case RC_STACK_MARKER:
/* Frame consists of the return code followed by two objects.
- The first object has already been popped into exp_register,
+ The first object has already been popped into GET_EXP,
so just pop the second argument. */
- sp_register = (STACK_LOCATIVE_OFFSET (sp_register, 1));
+ stack_pointer = (STACK_LOCATIVE_OFFSET (stack_pointer, 1));
break;
case RC_RESTORE_TO_STATE_POINT:
{
- SCHEME_OBJECT Where_To_Go = exp_register;
+ SCHEME_OBJECT Where_To_Go = GET_EXP;
Will_Push (CONTINUATION_SIZE);
- /* Restore the contents of val_register after moving to point */
- exp_register = val_register;
- Store_Return (RC_RESTORE_VALUE);
- Save_Cont ();
+ /* Restore the contents of GET_VAL after moving to point */
+ SET_EXP (GET_VAL);
+ SET_RC (RC_RESTORE_VALUE);
+ SAVE_CONT ();
Pushed ();
Translate_To_Point (Where_To_Go);
break; /* We never get here.... */
}
case RC_SEQ_2_DO_2:
- End_Subproblem ();
- env_register = (STACK_POP ());
+ END_SUBPROBLEM ();
+ POP_ENV ();
REDUCES_TO_NTH (SEQUENCE_2);
case RC_SEQ_3_DO_2:
- env_register = (STACK_REF (0));
+ SET_ENV (STACK_REF (0));
DO_ANOTHER_THEN (RC_SEQ_3_DO_3, SEQUENCE_2);
case RC_SEQ_3_DO_3:
- End_Subproblem ();
- env_register = (STACK_POP ());
+ END_SUBPROBLEM ();
+ POP_ENV ();
REDUCES_TO_NTH (SEQUENCE_3);
case RC_SNAP_NEED_THUNK:
/* Don't snap thunk twice; evaluation of the thunk's body might
have snapped it already. */
- if ((MEMORY_REF (exp_register, THUNK_SNAPPED)) == SHARP_T)
- val_register = (MEMORY_REF (exp_register, THUNK_VALUE));
+ if ((MEMORY_REF (GET_EXP, THUNK_SNAPPED)) == SHARP_T)
+ SET_VAL (MEMORY_REF (GET_EXP, THUNK_VALUE));
else
{
- MEMORY_SET (exp_register, THUNK_SNAPPED, SHARP_T);
- MEMORY_SET (exp_register, THUNK_VALUE, val_register);
+ MEMORY_SET (GET_EXP, THUNK_SNAPPED, SHARP_T);
+ MEMORY_SET (GET_EXP, THUNK_VALUE, GET_VAL);
}
break;
- case RC_AFTER_MEMORY_UPDATE:
- case RC_BAD_INTERRUPT_CONTINUE:
- case RC_COMPLETE_GC_DONE:
- case RC_RESTARTABLE_EXIT:
- case RC_RESTART_EXECUTION:
- case RC_RESTORE_CONTINUATION:
- case RC_RESTORE_STEPPER:
- case RC_POP_FROM_COMPILED_CODE:
- POP_RETURN_ERROR (ERR_INAPPLICABLE_CONTINUATION);
-
- SITE_RETURN_DISPATCH_HOOK ();
-
default:
POP_RETURN_ERROR (ERR_INAPPLICABLE_CONTINUATION);
}
/* -*-C-*-
-$Id: interp.h,v 9.52 2007/01/05 21:19:25 cph Exp $
+$Id: interp.h,v 9.53 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
/* Definitions used by the interpreter and some utilities. */
-\f
-#define env_register (Registers[REGBLOCK_ENV])
-#define val_register (Registers[REGBLOCK_VAL])
-#define exp_register (Registers[REGBLOCK_EXPR])
-#define ret_register (Registers[REGBLOCK_RETURN])
-#define Store_Return(P) ret_register = (MAKE_OBJECT (TC_RETURN_CODE, (P)))
+#ifndef SCM_INTERP_H
+#define SCM_INTERP_H 1
-/* Note: Save_Cont must match the definitions in sdata.h */
+#include "object.h"
+#include "stack.h"
+\f
+/* Note: SAVE_CONT must match the definitions in sdata.h */
-#define Save_Cont() \
+#define SAVE_CONT() do \
{ \
- STACK_PUSH (exp_register); \
- STACK_PUSH (ret_register); \
-}
+ PUSH_EXP (); \
+ PUSH_RET (); \
+} while (0)
-#define Restore_Cont() \
+#define RESTORE_CONT() do \
{ \
- ret_register = (STACK_POP ()); \
- exp_register = (STACK_POP ()); \
-}
+ POP_RET (); \
+ POP_EXP (); \
+} while (0)
-#define Stop_Trapping() Trapping = 0
+#define CONT_RC(offset) (OBJECT_DATUM (CONT_RET (offset)))
+#define CONT_RET(offset) (STACK_REF ((offset) + CONTINUATION_RETURN_CODE))
+#define CONT_EXP(offset) (STACK_REF ((offset) + CONTINUATION_EXPRESSION))
+
+#define PUSH_APPLY_FRAME_HEADER(n_args) \
+ STACK_PUSH (MAKE_OBJECT (0, ((n_args) + 1)))
+
+#define POP_APPLY_FRAME_HEADER() APPLY_FRAME_HEADER_N_ARGS (STACK_POP ())
+#define APPLY_FRAME_HEADER_N_ARGS(header) ((OBJECT_DATUM (header)) - 1)
+#define APPLY_FRAME_SIZE() (OBJECT_DATUM (STACK_REF (0)))
+#define APPLY_FRAME_N_ARGS() (APPLY_FRAME_HEADER_N_ARGS (STACK_REF (0)))
+#define APPLY_FRAME_PROCEDURE() (STACK_REF (1))
+#define APPLY_FRAME_ARGS(sp) (STACK_LOC (2))
+#define APPLY_FRAME_END(sp) (STACK_LOC (1 + (APPLY_FRAME_SIZE ())))
+
+#define CHECK_RETURN_CODE(code, offset) \
+ ((CONT_RET (offset)) == (MAKE_RETURN_CODE (code)))
/* Saving history is required for C_call_scheme to work correctly
- because the recursive call to Interpret() can rotate the history.
- */
+ because the recursive call to Interpret() can rotate the history. */
-#define APPLY_PRIMITIVE_FROM_INTERPRETER(location, primitive) \
+#define APPLY_PRIMITIVE_FROM_INTERPRETER(primitive) do \
{ \
SCHEME_OBJECT * APFI_saved_history = history_register; \
- PRIMITIVE_APPLY ((location), (primitive)); \
+ PRIMITIVE_APPLY (primitive); \
history_register = APFI_saved_history; \
-}
+} while (0)
\f
/* Stack manipulation */
{ \
SCHEME_OBJECT * Will_Push_Limit; \
\
- Internal_Will_Push ((N)); \
+ STACK_CHECK (N); \
Will_Push_Limit = (STACK_LOC (- (N)))
#define Pushed() \
- if (sp_register < Will_Push_Limit) \
+ if (STACK_LOCATIVE_LESS_P (stack_pointer, Will_Push_Limit)) \
{ \
Stack_Death (); \
} \
#else
-#define Will_Push Internal_Will_Push
+#define Will_Push(N) STACK_CHECK (N)
#define Pushed()
#endif
may use less. M in Finished_Eventual_Pushing is the amount not yet
pushed. */
-#define Will_Eventually_Push Internal_Will_Push
+#define Will_Eventually_Push(N) STACK_CHECK (N)
#define Finished_Eventual_Pushing(M)
-
-/* Primitive stack operations:
- These operations hide the direction of stack growth.
- `Throw' in "stack.h", `Allocate_New_Stacklet' in "utils.c",
- `apply', `cwcc' and friends in "hooks.c", and possibly other stuff,
- depend on the direction in which the stack grows. */
-
-#define STACK_LOCATIVE_DECREMENT(locative) (-- (locative))
-#define STACK_LOCATIVE_INCREMENT(locative) ((locative) ++)
-#define STACK_LOCATIVE_OFFSET(locative, offset) ((locative) + (offset))
-#define STACK_LOCATIVE_REFERENCE(locative, offset) ((locative) [(offset)])
-#define STACK_LOCATIVE_DIFFERENCE(x, y) ((x) - (y))
-
-#define STACK_LOCATIVE_PUSH(locative) (* (STACK_LOCATIVE_DECREMENT (locative)))
-#define STACK_LOCATIVE_POP(locative) (* (STACK_LOCATIVE_INCREMENT (locative)))
-
-#define STACK_PUSH(object) (STACK_LOCATIVE_PUSH (sp_register)) = (object)
-#define STACK_POP() (STACK_LOCATIVE_POP (sp_register))
-#define STACK_LOC(offset) (STACK_LOCATIVE_OFFSET (sp_register, (offset)))
-#define STACK_REF(offset) (STACK_LOCATIVE_REFERENCE (sp_register, (offset)))
\f
/* Primitive utility macros */
#ifndef ENABLE_DEBUGGING_TOOLS
-
-#define PRIMITIVE_APPLY PRIMITIVE_APPLY_INTERNAL
-
+# define PRIMITIVE_APPLY PRIMITIVE_APPLY_INTERNAL
#else
-
-#define PRIMITIVE_APPLY(loc, primitive) \
- (loc) = (primitive_apply_internal (primitive))
-extern SCHEME_OBJECT EXFUN (primitive_apply_internal, (SCHEME_OBJECT));
-
+ extern void primitive_apply_internal (SCHEME_OBJECT);
+# define PRIMITIVE_APPLY primitive_apply_internal
#endif
-#define PRIMITIVE_APPLY_INTERNAL(loc, primitive) \
+#define PRIMITIVE_APPLY_INTERNAL(primitive) do \
{ \
- PTR PRIMITIVE_APPLY_INTERNAL_position = dstack_position; \
- (Registers[REGBLOCK_PRIMITIVE]) = (primitive); \
- (loc) \
- = ((* (Primitive_Procedure_Table [PRIMITIVE_NUMBER (primitive)])) \
- ()); \
+ void * PRIMITIVE_APPLY_INTERNAL_position = dstack_position; \
+ SET_PRIMITIVE (primitive); \
+ SET_VAL \
+ ((* (Primitive_Procedure_Table [PRIMITIVE_NUMBER (primitive)])) \
+ ()); \
/* If the primitive failed to unwind the dynamic stack, lose. */ \
if (PRIMITIVE_APPLY_INTERNAL_position != dstack_position) \
{ \
(PRIMITIVE_NAME (primitive))); \
Microcode_Termination (TERM_EXIT); \
} \
- (Registers[REGBLOCK_PRIMITIVE]) = SHARP_F; \
-}
+ SET_PRIMITIVE (SHARP_F); \
+} while (0)
-#define POP_PRIMITIVE_FRAME(arity) sp_register = (STACK_LOC (arity))
+#define POP_PRIMITIVE_FRAME(arity) (stack_pointer = (STACK_LOC (arity)))
typedef struct interpreter_state_s * interpreter_state_t;
{
interpreter_state_t previous_state;
unsigned int nesting_level;
- PTR dstack_position;
+ void * dstack_position;
jmp_buf catch_env;
int throw_argument;
};
#define interpreter_catch_dstack_position interpreter_state->dstack_position
#define interpreter_catch_env interpreter_state->catch_env
#define interpreter_throw_argument interpreter_state->throw_argument
-#define NULL_INTERPRETER_STATE ((interpreter_state_t) NULL)
+#define NULL_INTERPRETER_STATE ((interpreter_state_t) 0)
-extern void EXFUN (abort_to_interpreter, (int argument));
-extern int EXFUN (abort_to_interpreter_argument, (void));
+extern void abort_to_interpreter (int) NORETURN;
+extern int abort_to_interpreter_argument (void);
extern interpreter_state_t interpreter_state;
-extern void EXFUN (bind_interpreter_state, (interpreter_state_t));
-extern void EXFUN (unbind_interpreter_state, (interpreter_state_t));
+extern void bind_interpreter_state (interpreter_state_t);
+extern void unbind_interpreter_state (interpreter_state_t);
+
+#endif /* not SCM_INTERP_H */
/* -*-C-*-
-$Id: intext.c,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: intext.c,v 1.10 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include "ansidecl.h"
-#include "dstack.h"
#include "intext.h"
-extern void EXFUN (preserve_signal_mask, (void));
+extern void preserve_signal_mask (void);
struct interruptable_extent * current_interruptable_extent;
void
-DEFUN_VOID (initialize_interruptable_extent)
+initialize_interruptable_extent (void)
{
current_interruptable_extent = 0;
}
void
-DEFUN_VOID (reset_interruptable_extent)
+reset_interruptable_extent (void)
{
current_interruptable_extent = 0;
}
struct interruptable_extent *
-DEFUN_VOID (enter_interruptable_extent)
+enter_interruptable_extent (void)
{
- PTR position = dstack_position;
+ void * position = dstack_position;
struct interruptable_extent * frame;
/* Inside the interrupt handler, the signal mask will be different.
Push a winding frame that will restore it to its current value.
be a problem for some applications. */
int
-DEFUN_VOID (enter_interruption_extent)
+enter_interruption_extent (void)
{
if ((current_interruptable_extent == 0)
|| (current_interruptable_extent -> interrupted))
}
void
-DEFUN_VOID (exit_interruption_extent)
+exit_interruption_extent (void)
{
longjmp ((current_interruptable_extent -> control_point), 1);
}
/* -*-C-*-
-$Id: intext.h,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: intext.h,v 1.10 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#ifndef SCM_INTEXT_H
#define SCM_INTEXT_H
-#include "ansidecl.h"
#include "dstack.h"
struct interruptable_extent
{
- PTR position;
+ void * position;
jmp_buf control_point;
int interrupted;
};
extern struct interruptable_extent * current_interruptable_extent;
-extern void EXFUN (initialize_interruptable_extent, (void));
-extern void EXFUN (reset_interruptable_extent, (void));
-extern struct interruptable_extent * EXFUN
- (enter_interruptable_extent, (void));
-extern int EXFUN (enter_interruption_extent, (void));
-extern void EXFUN (exit_interruption_extent, (void));
+extern void initialize_interruptable_extent (void);
+extern void reset_interruptable_extent (void);
+extern struct interruptable_extent * enter_interruptable_extent (void);
+extern int enter_interruption_extent (void);
+extern void exit_interruption_extent (void);
#define INTERRUPTABLE_EXTENT(result, expression) \
{ \
/* -*-C-*-
-$Id: intprm.c,v 1.14 2007/01/05 21:19:25 cph Exp $
+$Id: intprm.c,v 1.15 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
-#include "zones.h"
\f
#define INTEGER_TEST(test) \
{ \
PRIMITIVE_HEADER (1); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (test (ARG_REF (1)))); \
}
#define INTEGER_COMPARISON(comparison) \
{ \
PRIMITIVE_HEADER (2); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
CHECK_ARG (2, INTEGER_P); \
PRIMITIVE_RETURN \
DEFINE_PRIMITIVE ("INTEGER-GREATER?", Prim_integer_greater_p, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, INTEGER_P);
CHECK_ARG (2, INTEGER_P);
PRIMITIVE_RETURN
#define INTEGER_BINARY_OPERATION(operator) \
{ \
PRIMITIVE_HEADER (2); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
CHECK_ARG (2, INTEGER_P); \
PRIMITIVE_RETURN (operator ((ARG_REF (1)), (ARG_REF (2)))); \
#define INTEGER_UNARY_OPERATION(operator) \
{ \
PRIMITIVE_HEADER (1); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
PRIMITIVE_RETURN (operator (ARG_REF (1))); \
}
SCHEME_OBJECT quotient;
SCHEME_OBJECT remainder;
PRIMITIVE_HEADER (2);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, INTEGER_P);
CHECK_ARG (2, INTEGER_P);
if (integer_divide ((ARG_REF (1)), (ARG_REF (2)), ("ient), (&remainder)))
{ \
SCHEME_OBJECT result; \
PRIMITIVE_HEADER (2); \
- Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
CHECK_ARG (2, INTEGER_P); \
result = (operator ((ARG_REF (1)), (ARG_REF (2)))); \
{
PRIMITIVE_HEADER (1);
{
- fast SCHEME_OBJECT integer = (ARG_REF (1));
+ SCHEME_OBJECT integer = (ARG_REF (1));
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (INTEGER_P (integer)));
}
}
DEFINE_PRIMITIVE ("INTEGER->FLONUM", Prim_integer_to_flonum, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, INTEGER_P);
{
- fast SCHEME_OBJECT integer = (ARG_REF (1));
- fast long control = (arg_index_integer (2, 4));
+ SCHEME_OBJECT integer = (ARG_REF (1));
+ long control = (arg_index_integer (2, 4));
if (FIXNUM_P (integer))
{
long X = (FIXNUM_TO_LONG (integer));
DEFINE_PRIMITIVE ("INTEGER-SHIFT-LEFT", Prim_integer_shift_left, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, INTEGER_P);
{
SCHEME_OBJECT n = (ARG_REF (1));
}
static unsigned int
-DEFUN (list_to_integer_producer, (context), PTR context)
+list_to_integer_producer (void * context)
{
SCHEME_OBJECT * digits = context;
unsigned int digit = (UNSIGNED_FIXNUM_TO_LONG (PAIR_CAR (*digits)));
Converts the list to an integer. NEGATIVE? specifies the sign.")
{
PRIMITIVE_HEADER (3);
- Set_Time_Zone (Zone_Math);
CHECK_ARG (1, PAIR_P);
{
SCHEME_OBJECT digits = (ARG_REF (1));
/* -*-C-*-
-$Id: intrpt.h,v 1.26 2007/01/05 21:19:25 cph Exp $
+$Id: intrpt.h,v 1.27 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Interrupt bits -- scanned from LSB (1) to MSB (16) */
-#define INT_Stack_Overflow 0x0001 /* Local interrupt */
-#define INT_Global_GC 0x0002
-#define INT_GC 0x0004 /* Local interrupt */
-#define INT_Global_1 0x0008
-#define INT_Character 0x0010 /* Local interrupt */
-#define INT_AFTER_GC 0x0020 /* Local interrupt */
-#define INT_Timer 0x0040 /* Local interrupt */
-#define INT_Global_3 0x0080
-#define INT_Suspend 0x0100 /* Local interrupt */
+#define INT_Stack_Overflow 0x0001UL /* Local interrupt */
+#define INT_Global_GC 0x0002UL
+#define INT_GC 0x0004UL /* Local interrupt */
+#define INT_Global_1 0x0008UL
+#define INT_Character 0x0010UL /* Local interrupt */
+#define INT_AFTER_GC 0x0020UL /* Local interrupt */
+#define INT_Timer 0x0040UL /* Local interrupt */
+#define INT_Global_3 0x0080UL
+#define INT_Suspend 0x0100UL /* Local interrupt */
/* Descartes profiling interrupts */
-#define INT_IPPB_Flush 0x0200 /* Local interrupt */
-#define INT_IPPB_Extend 0x0400 /* Local interrupt */
-#define INT_PCBPB_Flush 0x0800 /* Local interrupt */
-#define INT_PCBPB_Extend 0x1000 /* Local interrupt */
-#define INT_HCBPB_Flush 0x2000 /* Local interrupt */
-#define INT_HCBPB_Extend 0x4000 /* Local interrupt */
+#define INT_IPPB_Flush 0x0200UL /* Local interrupt */
+#define INT_IPPB_Extend 0x0400UL /* Local interrupt */
+#define INT_PCBPB_Flush 0x0800UL /* Local interrupt */
+#define INT_PCBPB_Extend 0x1000UL /* Local interrupt */
+#define INT_HCBPB_Flush 0x2000UL /* Local interrupt */
+#define INT_HCBPB_Extend 0x4000UL /* Local interrupt */
-#define INT_Step_CC 0x8000
+#define INT_Step_CC 0x8000UL
#define INT_Global_Mask (INT_Global_GC | INT_Global_1 | INT_Global_3)
-#define Global_GC_Level 0x1
-#define Global_1_Level 0x3
-#define Global_3_Level 0x7
-#define MAX_INTERRUPT_NUMBER 0xF /* 2^15 = INT_Step_CC */
+#define Global_GC_Level 0x1UL
+#define Global_1_Level 0x3UL
+#define Global_3_Level 0x7UL
+#define MAX_INTERRUPT_NUMBER 0xFUL /* 2^15 = INT_Step_CC */
-#define INT_Mask ((1 << (MAX_INTERRUPT_NUMBER + 1)) - 1)
+#define INT_Mask ((1UL << (MAX_INTERRUPT_NUMBER + 1)) - 1)
\f
/* Utility macros. */
-#define PENDING_INTERRUPTS() \
- ((FETCH_INTERRUPT_MASK ()) & (FETCH_INTERRUPT_CODE ()))
-
-#define INTERRUPT_QUEUED_P(mask) (((FETCH_INTERRUPT_CODE ()) & (mask)) != 0)
-
-#define INTERRUPT_ENABLED_P(mask) (((FETCH_INTERRUPT_MASK ()) & (mask)) != 0)
-
+#define PENDING_INTERRUPTS() (GET_INT_MASK & GET_INT_CODE)
+#define PENDING_INTERRUPTS_P ((PENDING_INTERRUPTS ()) != 0)
+#define INTERRUPT_QUEUED_P(mask) ((GET_INT_CODE & (mask)) != 0)
+#define INTERRUPT_ENABLED_P(mask) ((GET_INT_MASK & (mask)) != 0)
#define INTERRUPT_PENDING_P(mask) (((PENDING_INTERRUPTS ()) & (mask)) != 0)
#define COMPILER_SETUP_INTERRUPT() do \
{ \
- (Registers[REGBLOCK_MEMTOP]) = \
+ SET_MEMTOP \
(((PENDING_INTERRUPTS ()) != 0) \
- ? ((SCHEME_OBJECT) -1) \
- : (INTERRUPT_ENABLED_P (INT_GC)) \
- ? ((SCHEME_OBJECT) (ADDR_TO_SCHEME_ADDR (MemTop))) \
- : ((SCHEME_OBJECT) (ADDR_TO_SCHEME_ADDR (Heap_Top)))); \
- (Registers[REGBLOCK_STACK_GUARD]) = \
+ ? memory_block_start \
+ : (GC_ENABLED_P ()) \
+ ? heap_alloc_limit \
+ : heap_end); \
+ SET_STACK_GUARD \
((INTERRUPT_ENABLED_P (INT_Stack_Overflow)) \
- ? ((SCHEME_OBJECT) (ADDR_TO_SCHEME_ADDR (Stack_Guard))) \
- : ((SCHEME_OBJECT) (ADDR_TO_SCHEME_ADDR (Stack_Bottom)))); \
+ ? stack_guard \
+ : STACK_TOP); \
} while (0)
-#define FETCH_INTERRUPT_MASK() ((long) (Registers[REGBLOCK_INT_MASK]))
-
-#define SET_INTERRUPT_MASK(mask) \
+#define SET_INTERRUPT_MASK(mask) do \
{ \
GRAB_INTERRUPT_REGISTERS (); \
- (Registers[REGBLOCK_INT_MASK]) = ((SCHEME_OBJECT) (mask)); \
+ SET_INT_MASK (mask); \
COMPILER_SETUP_INTERRUPT (); \
RELEASE_INTERRUPT_REGISTERS (); \
-}
-
-#define FETCH_INTERRUPT_CODE() ((long) (Registers[REGBLOCK_INT_CODE]))
+} while (0)
-#define REQUEST_INTERRUPT(code) \
+#define REQUEST_INTERRUPT(code) do \
{ \
GRAB_INTERRUPT_REGISTERS (); \
- (Registers[REGBLOCK_INT_CODE]) = \
- ((SCHEME_OBJECT) ((FETCH_INTERRUPT_CODE ()) | (code))); \
+ SET_INT_CODE (GET_INT_CODE | (code)); \
COMPILER_SETUP_INTERRUPT (); \
RELEASE_INTERRUPT_REGISTERS (); \
-}
+} while (0)
-#define CLEAR_INTERRUPT_NOLOCK(code) \
+#define CLEAR_INTERRUPT_NOLOCK(code) do \
{ \
- (Registers[REGBLOCK_INT_CODE]) = \
- ((SCHEME_OBJECT) ((FETCH_INTERRUPT_CODE ()) &~ (code))); \
+ SET_INT_CODE (GET_INT_CODE &~ (code)); \
COMPILER_SETUP_INTERRUPT (); \
-}
+} while (0)
-#define CLEAR_INTERRUPT(code) \
+#define CLEAR_INTERRUPT(code) do \
{ \
GRAB_INTERRUPT_REGISTERS (); \
CLEAR_INTERRUPT_NOLOCK (code); \
RELEASE_INTERRUPT_REGISTERS (); \
-}
+} while (0)
-#define INITIALIZE_INTERRUPTS() \
+#define INITIALIZE_INTERRUPTS(mask) do \
{ \
GRAB_INTERRUPT_REGISTERS (); \
- (Registers[REGBLOCK_INT_MASK]) = ((SCHEME_OBJECT) INT_Mask); \
- (Registers[REGBLOCK_INT_CODE]) = ((SCHEME_OBJECT) 0); \
+ SET_INT_MASK (mask); \
+ SET_INT_CODE (0); \
COMPILER_SETUP_INTERRUPT (); \
RELEASE_INTERRUPT_REGISTERS (); \
-}
+} while (0)
#if defined(__OS2__) || defined(__WIN32__)
extern void OS_grab_interrupt_registers (void);
/* -*-C-*-
-$Id: liarc.h,v 1.28 2007/04/17 06:02:10 cph Exp $
+$Id: liarc.h,v 1.29 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#ifndef LIARC_INCLUDED
-#define LIARC_INCLUDED
+#ifndef SCM_LIARC_H_INCLUDED
+#define SCM_LIARC_H_INCLUDED 1
#ifndef MIT_SCHEME
-#define MIT_SCHEME
+# define MIT_SCHEME
#endif
-\f
-#include <stdio.h>
+
#include "config.h"
#include "dstack.h"
-#include "default.h"
+#include "types.h"
+#include "const.h"
#include "object.h"
#include "sdata.h"
-#include "types.h"
#include "errors.h"
-#include "const.h"
+#include "stack.h"
#include "interp.h"
-#include "prim.h"
-#include "cmpgc.h"
-#include "cmpintmd.h"
-#include "trap.h"
#include "outf.h"
#include "extern.h"
+#include "prim.h"
+#include "cmpint.h"
+#include "trap.h"
-#ifdef __STDC__
-# define USE_STDARG
-# include <stdarg.h>
-#else
-# include <varargs.h>
-#endif /* __STDC__ */
-
+extern SCHEME_OBJECT * sp_register;
+\f
#ifndef COMPILE_FOR_STATIC_LINKING
-#ifndef COMPILE_FOR_DYNAMIC_LOADING
-#define COMPILE_FOR_DYNAMIC_LOADING
-#endif
+# ifndef COMPILE_FOR_DYNAMIC_LOADING
+# define COMPILE_FOR_DYNAMIC_LOADING 1
+# endif
#endif
#ifdef __GNUC__
/* Add attributes to avoid warnings from -Wall for unreferenced labels */
# define DEFLABEL(name) name : __attribute__((unused))
-#else /* not __GNUC__ */
+#else
# define DEFLABEL(name) name :
-#endif /* __GNUC__ */
-
-/* #define USE_GLOBAL_VARIABLES */
-
-#ifdef LIARC_IN_MICROCODE
-#define USE_GLOBAL_VARIABLES
#endif
-#define USE_SHORTCKT_JUMP
-
-extern PTR dstack_position;
-extern SCHEME_OBJECT * Free;
-extern SCHEME_OBJECT * sp_register;
-extern SCHEME_OBJECT Registers [];
-
union machine_word_u
{
SCHEME_OBJECT Obj;
};
typedef union machine_word_u machine_word;
-
typedef unsigned long entry_count_t;
-\f
-#define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT))
-#define ADDRESS_UNITS_PER_FLOAT (sizeof (double))
-#ifdef HEAP_IN_LOW_MEMORY
-#define CLOSURE_ENTRY_DELTA ADDRESS_UNITS_PER_OBJECT
-#else /* not HEAP_IN_LOW_MEMORY */
-#define CLOSURE_ENTRY_DELTA 1
-#endif /* HEAP_IN_LOW_MEMORY */
+#define ADDRESS_UNITS_PER_OBJECT SIZEOF_SCHEME_OBJECT
+#define ADDRESS_UNITS_PER_FLOAT (sizeof (double))
+
+#define CLOSURE_ENTRY_DELTA 1
#undef FIXNUM_TO_LONG
#define FIXNUM_TO_LONG(source) \
#define LONG_TO_ADDRESS(source) (DATUM_TO_ADDRESS (source))
-#define C_STRING_TO_SCHEME_STRING(len,str) \
- (MEMORY_TO_STRING ((len), (unsigned char *) str))
+#define C_STRING_TO_SCHEME_STRING(len, str) \
+ (MEMORY_TO_STRING ((len), ((const byte_t *) (str))))
+
+#define C_SYM_INTERN(len, str) \
+ (MEMORY_TO_SYMBOL ((len), ((const byte_t *) (str))))
-#define C_SYM_INTERN(len,str) \
- (MEMORY_TO_SYMBOL ((len), ((CONST char *) str)))
+#define MAKE_PRIMITIVE_PROCEDURE(name, arity) (MAKE_PRIMITIVE (name, arity))
-#define MAKE_PRIMITIVE_PROCEDURE(name,arity) (MAKE_PRIMITIVE (name, arity))
+#define WRITE_LABEL_DESCRIPTOR(entry, code_word, offset) \
+ ((entry[-1]) = (MAKE_LABEL_DESCRIPTOR ((code_word), (offset))))
-#define MAKE_LINKER_HEADER(kind,count) \
+#define MAKE_LABEL_DESCRIPTOR(code_word, offset) \
+ ((insn_t) (((offset) << 17) | (code_word)))
+
+#define MAKE_LINKER_HEADER(kind, count) \
(OBJECT_NEW_TYPE (TC_FIXNUM, \
- (MAKE_LINKAGE_SECTION_HEADER ((kind), (count)))))
+ (make_linkage_section_marker ((kind), (count)))))
#define ALLOCATE_VECTOR(len) (MAKE_VECTOR ((len), SHARP_F, true))
#define ALLOCATE_RECORD(len) \
(OBJECT_NEW_TYPE (TC_RECORD, (ALLOCATE_VECTOR (len))))
-#define RECORD_SET(rec,off,val) VECTOR_SET(rec,off,val)
+#define RECORD_SET(rec, off, val) VECTOR_SET ((rec), (off), (val))
-#define INLINE_DOUBLE_TO_FLONUM(src,tgt) do \
+#define INLINE_DOUBLE_TO_FLONUM(src, tgt) do \
{ \
double num = (src); \
SCHEME_OBJECT * val; \
ALIGN_FLOAT (Rhp); \
val = Rhp; \
Rhp += (1 + (BYTES_TO_WORDS (sizeof (double)))); \
- * val = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \
- (BYTES_TO_WORDS (sizeof (double))))); \
+ (*val) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \
+ (BYTES_TO_WORDS (sizeof (double))))); \
(* ((double *) (val + 1))) = num; \
(tgt) = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (val))); \
-} while (0)
+} while (false)
-#define MAKE_RATIO(num,den) \
- (OBJECT_NEW_TYPE (TC_RATNUM, (CONS (num, den))))
+#define MAKE_RATIO(num, den) \
+ (OBJECT_NEW_TYPE (TC_RATNUM, (CONS ((num), (den)))))
-#define MAKE_COMPLEX(real,imag) \
- (OBJECT_NEW_TYPE (TC_COMPLEX, (CONS (real, imag))))
+#define MAKE_COMPLEX(real, imag) \
+ (OBJECT_NEW_TYPE (TC_COMPLEX, (CONS ((real), (imag)))))
-#define CC_BLOCK_TO_ENTRY(block,offset) \
+#define CC_BLOCK_TO_ENTRY(block, offset) \
(MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, \
((OBJECT_ADDRESS (block)) + (offset))))
-#define INDEX_FIXNUM_P(arg) ((FIXNUM_P(arg)) && (FIXNUM_TO_LONG(arg)>=0))
+#define INDEX_FIXNUM_P(arg) ((FIXNUM_P(arg)) && (FIXNUM_TO_ULONG_P (arg)))
\f
-#ifdef USE_GLOBAL_VARIABLES
+#ifdef LIARC_IN_MICROCODE
-#define Rvl val_register
+#define Rvl (Registers[REGBLOCK_VAL])
#define Rhp Free
#define Rrb Registers
-#define Rsp sp_register
+#define Rsp stack_pointer
#define DECLARE_VARIABLES() int unused_variable_to_keep_C_happy
-#define UNCACHE_VARIABLES() do {} while (0)
-#define CACHE_VARIABLES() do {} while (0)
-
-#else /* not USE_GLOBAL_VARIABLES */
+#define UNCACHE_VARIABLES() do {} while (false)
+#define CACHE_VARIABLES() do {} while (false)
-#define REGISTER register
+#else /* !LIARC_IN_MICROCODE */
#define Rrb Registers
-#ifdef HEAP_IN_LOW_MEMORY
-
-#define DECLARE_VARIABLES() \
-REGISTER SCHEME_OBJECT Rvl = val_register; \
-REGISTER SCHEME_OBJECT * Rhp = Free; \
-REGISTER SCHEME_OBJECT * Rsp = sp_register
-
-#define DECLARE_VARIABLES_FOR_DATA()
-
-#else
-
#undef MEMBASE
#define MEMBASE lcl_membase
#define DECLARE_VARIABLES() \
-REGISTER SCHEME_OBJECT Rvl = val_register; \
-REGISTER SCHEME_OBJECT * Rhp = Free; \
-REGISTER SCHEME_OBJECT * Rsp = sp_register; \
-REGISTER SCHEME_OBJECT * lcl_membase = memory_base
+ SCHEME_OBJECT Rvl = GET_VAL; \
+ SCHEME_OBJECT * Rhp = Free; \
+ SCHEME_OBJECT * Rsp = stack_pointer; \
+ SCHEME_OBJECT * lcl_membase = memory_base
#define DECLARE_VARIABLES_FOR_DATA() \
-REGISTER SCHEME_OBJECT * lcl_membase = memory_base
-
-#endif
+ SCHEME_OBJECT * lcl_membase = memory_base
#define DECLARE_VARIABLES_FOR_OBJECT()
#define UNCACHE_VARIABLES() do \
{ \
- sp_register = Rsp; \
+ stack_pointer = Rsp; \
Free = Rhp; \
- val_register = Rvl; \
-} while (0)
+ SET_VAL (Rvl); \
+} while (false)
#define CACHE_VARIABLES() do \
{ \
- Rvl = val_register; \
+ Rvl = GET_VAL; \
Rhp = Free; \
- Rsp = sp_register; \
-} while (0)
+ Rsp = stack_pointer; \
+} while (false)
+
+#endif /* !LIARC_IN_MICROCODE */
+\f
+#ifdef ENABLE_DEBUGGING_TOOLS
+
+#define JUMP(destination) do \
+{ \
+ SCHEME_OBJECT * JUMP_new_pc = (destination); \
+ assert (JUMP_new_pc != 0); \
+ Rpc = JUMP_new_pc; \
+ goto perform_dispatch; \
+} while (false)
-#endif /* USE_GLOBAL_VARIABLES */
+#else
#define JUMP(destination) do \
{ \
Rpc = (destination); \
goto perform_dispatch; \
-} while(0)
+} while (false)
-#define JUMP_EXECUTE_CHACHE(label) \
- JUMP ((SCHEME_OBJECT *) (current_block[label]))
+#endif
#define POP_RETURN() goto pop_return
-\f
-#define INVOKE_PRIMITIVE_DECLS \
- SCHEME_OBJECT primitive; \
- long primitive_nargs;
-#define INVOKE_PRIMITIVE(prim, nargs) do \
-{ \
- primitive = (prim); \
- primitive_nargs = (nargs); \
- goto invoke_primitive; \
-} while (0)
+#define INVOKE_PRIMITIVE_DECLS
+#define INVOKE_PRIMITIVE_TARGET
-#define INVOKE_PRIMITIVE_TARGET \
-DEFLABEL (invoke_primitive) \
+#define INVOKE_PRIMITIVE(prim, nargs) do \
{ \
- SCHEME_OBJECT * destination; \
+ SCHEME_OBJECT * IPdest; \
\
UNCACHE_VARIABLES (); \
- PRIMITIVE_APPLY (val_register, primitive); \
- POP_PRIMITIVE_FRAME (primitive_nargs); \
- destination = (OBJECT_ADDRESS (STACK_POP ())); \
+ PRIMITIVE_APPLY (prim); \
+ POP_PRIMITIVE_FRAME (nargs); \
+ IPdest = (OBJECT_ADDRESS (STACK_POP ())); \
CACHE_VARIABLES (); \
- JUMP (destination); \
-}
-\f
-#define INVOKE_INTERFACE_DECLS \
- int utlarg_code; \
- long utlarg_1; \
- long utlarg_2; \
- long utlarg_3; \
- long utlarg_4;
-
-#define INVOKE_INTERFACE_0(code) do \
-{ \
- utlarg_code = (code); \
- goto invoke_interface_0; \
-} while (0)
+ JUMP (IPdest); \
+} while (false)
-#define INVOKE_INTERFACE_1(code, one) do \
-{ \
- utlarg_code = (code); \
- utlarg_1 = ((long) (one)); \
- goto invoke_interface_1; \
-} while (0)
+#define INVOKE_INTERFACE_DECLS
+#define INVOKE_INTERFACE_TARGET_0
+#define INVOKE_INTERFACE_TARGET_1
+#define INVOKE_INTERFACE_TARGET_2
+#define INVOKE_INTERFACE_TARGET_3
+#define INVOKE_INTERFACE_TARGET_4
-#define INVOKE_INTERFACE_2(code, one, two) do \
-{ \
- utlarg_code = (code); \
- utlarg_1 = ((long) (one)); \
- utlarg_2 = ((long) (two)); \
- goto invoke_interface_2; \
-} while (0)
+#define INVOKE_INTERFACE_0(code) \
+ INVOKE_INTERFACE_4 (code, 0, 0, 0, 0)
-#define INVOKE_INTERFACE_3(code, one, two, three) do \
-{ \
- utlarg_code = (code); \
- utlarg_1 = ((long) (one)); \
- utlarg_2 = ((long) (two)); \
- utlarg_3 = ((long) (three)); \
- goto invoke_interface_3; \
-} while (0)
+#define INVOKE_INTERFACE_1(code, one) \
+ INVOKE_INTERFACE_4 (code, one, 0, 0, 0)
+
+#define INVOKE_INTERFACE_2(code, one, two) \
+ INVOKE_INTERFACE_4 (code, one, two, 0, 0)
+
+#define INVOKE_INTERFACE_3(code, one, two, three) \
+ INVOKE_INTERFACE_4 (code, one, two, three, 0)
#define INVOKE_INTERFACE_4(code, one, two, three, four) do \
{ \
- utlarg_code = (code); \
- utlarg_1 = ((long) (one)); \
- utlarg_2 = ((long) (two)); \
- utlarg_3 = ((long) (three)); \
- utlarg_4 = ((long) (four)); \
- goto invoke_interface_4; \
-} while (0)
-
-#define INVOKE_INTERFACE_TARGET_0 \
-DEFLABEL (invoke_interface_0) \
- utlarg_1 = 0; \
- INVOKE_INTERFACE_TARGET_1
-
-#define INVOKE_INTERFACE_TARGET_1 \
-DEFLABEL (invoke_interface_1) \
- utlarg_2 = 0; \
- INVOKE_INTERFACE_TARGET_2
-
-#define INVOKE_INTERFACE_TARGET_2 \
-DEFLABEL (invoke_interface_2) \
- utlarg_3 = 0; \
- INVOKE_INTERFACE_TARGET_3
-
-#define INVOKE_INTERFACE_TARGET_3 \
-DEFLABEL (invoke_interface_3) \
- utlarg_4 = 0; \
- INVOKE_INTERFACE_TARGET_4
-
-#define INVOKE_INTERFACE_TARGET_4 \
-DEFLABEL (invoke_interface_4) \
-{ \
- SCHEME_OBJECT * destination; \
+ SCHEME_OBJECT * IICdest; \
\
UNCACHE_VARIABLES (); \
- destination = (invoke_utility (utlarg_code, utlarg_1, utlarg_2, \
- utlarg_3, utlarg_4)); \
+ IICdest \
+ = (invoke_utility ((code), \
+ ((unsigned long) (one)), \
+ ((unsigned long) (two)), \
+ ((unsigned long) (three)), \
+ ((unsigned long) (four)))); \
CACHE_VARIABLES (); \
- JUMP (destination); \
-}
+ JUMP (IICdest); \
+} while (false)
\f
#define MAX_BIT_SHIFT DATUM_LENGTH
#define RIGHT_SHIFT_UNSIGNED(source, number) \
-(((number) > MAX_BIT_SHIFT) \
- ? 0 \
- : ((((unsigned long) (source)) & DATUM_MASK) \
- >> (number)))
+ (((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((((unsigned long) (source)) & DATUM_MASK) >> (number)))
#define RIGHT_SHIFT(source, number) \
-(((number) > MAX_BIT_SHIFT) \
- ? 0 \
- : ((source) >> (number)))
+ (((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((source) >> (number)))
#define LEFT_SHIFT(source, number) \
-(((number) > MAX_BIT_SHIFT) \
- ? 0 \
- : ((source) << (number)))
+ (((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((source) << (number)))
#define FIXNUM_LSH(source, number) \
-(((number) >= 0) \
- ? (LEFT_SHIFT (source, number)) \
- : (RIGHT_SHIFT_UNSIGNED (source, (- (number)))))
+ (((number) >= 0) \
+ ? (LEFT_SHIFT (source, number)) \
+ : (RIGHT_SHIFT_UNSIGNED (source, (- (number)))))
#define FIXNUM_REMAINDER(source1, source2) \
-(((source2) > 0) \
- ? (((source1) >= 0) \
- ? ((source1) % (source2)) \
- : (- ((- (source1)) % (source2)))) \
- : (((source1) >= 0) \
- ? ((source1) % (- (source2))) \
- : (- ((- (source1)) % (- (source2))))))
+ (((source2) > 0) \
+ ? (((source1) >= 0) \
+ ? ((source1) % (source2)) \
+ : (- ((- (source1)) % (source2)))) \
+ : (((source1) >= 0) \
+ ? ((source1) % (- (source2))) \
+ : (- ((- (source1)) % (- (source2))))))
#define FIXNUM_QUOTIENT(source1, source2) \
-(((source2) > 0) \
- ? (((source1) >= 0) \
- ? ((source1) / (source2)) \
- : (- ((- (source1)) / (source2)))) \
- : (((source1) >= 0) \
- ? (- ((source1) / (- (source2)))) \
- : ((- (source1)) / (- (source2)))))
+ (((source2) > 0) \
+ ? (((source1) >= 0) \
+ ? ((source1) / (source2)) \
+ : (- ((- (source1)) / (source2)))) \
+ : (((source1) >= 0) \
+ ? (- ((source1) / (- (source2)))) \
+ : ((- (source1)) / (- (source2)))))
#define INTERRUPT_CHECK(code, entry_point) do \
{ \
- if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
- INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \
-} while (0)
+ if (((long) Rhp) >= ((long) GET_MEMTOP)) \
+ INVOKE_INTERFACE_1 (code, (¤t_block[entry_point])); \
+} while (false)
#define DLINK_INTERRUPT_CHECK(code, entry_point) do \
{ \
- if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
- INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], Rdl); \
-} while (0)
-
-#define CLOSURE_HEADER(offset) do \
-{ \
- SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) Rpc[1]); \
- current_block = (entry - offset); \
- *--Rsp = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, Rpc)); \
-} while (0)
+ if (((long) Rhp) >= ((long) GET_MEMTOP)) \
+ INVOKE_INTERFACE_2 (code, (¤t_block[entry_point]), Rdl); \
+} while (false)
#define CLOSURE_INTERRUPT_CHECK(code) do \
{ \
- if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
+ if (((long) Rhp) >= ((long) GET_MEMTOP)) \
INVOKE_INTERFACE_0 (code); \
-} while (0)
+} while (false)
+
+#define CLOSURE_HEADER(offset) do \
+{ \
+ SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) (Rpc[1])); \
+ current_block = (entry - offset); \
+ (*--Rsp) = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, Rpc)); \
+} while (false)
\f
/* Linking and initialization */
+typedef int liarc_decl_code_t (void);
+typedef int liarc_decl_data_t (void);
+typedef SCHEME_OBJECT * liarc_code_proc_t (SCHEME_OBJECT *, entry_count_t);
+typedef SCHEME_OBJECT * liarc_data_proc_t (entry_count_t);
+typedef SCHEME_OBJECT liarc_object_proc_t (void);
+
struct liarc_code_S
{
const char * name;
entry_count_t nentries;
- SCHEME_OBJECT * EXFUN ((* code), (SCHEME_OBJECT *, entry_count_t));
+ liarc_code_proc_t * code;
};
struct liarc_data_S
{
const char * name;
- SCHEME_OBJECT * EXFUN ((* data), (entry_count_t));
+ liarc_data_proc_t * data;
};
#define DECLARE_SUBCODE(name, nentries, code) do \
{ \
- int result \
- = (declare_compiled_code (name, nentries, NO_SUBBLOCKS, code)); \
+ int result = (declare_compiled_code_ns (name, nentries, code)); \
if (result != 0) \
return (result); \
-} while (0)
+} while (false)
#define DECLARE_SUBDATA(name, data) do \
{ \
- int result = (declare_compiled_data (name, NO_SUBBLOCKS, data)); \
+ int result = (declare_compiled_data_ns (name, data)); \
if (result != 0) \
return (result); \
-} while (0)
+} while (false)
#define DECLARE_SUBCODE_MULTIPLE(code_array) do \
{ \
- int result = \
- declare_compiled_code_mult (((sizeof (code_array)) \
- / (sizeof (struct liarc_code_S))), \
- (& code_array[0])); \
+ int result \
+ = (declare_compiled_code_mult \
+ (((sizeof (code_array)) / (sizeof (struct liarc_code_S))), \
+ code_array)); \
if (result != 0) \
return (result); \
-} while (0)
+} while (false)
#define DECLARE_SUBDATA_MULTIPLE(data_array) do \
{ \
- int result = \
- declare_compiled_data_mult (((sizeof (data_array)) \
- / (sizeof (struct liarc_data_S))), \
- (& data_array[0])); \
+ int result \
+ = (declare_compiled_data_mult \
+ (((sizeof (data_array)) / (sizeof (struct liarc_data_S))), \
+ data_array)); \
if (result != 0) \
return (result); \
-} while (0)
+} while (false)
\f
#ifndef COMPILE_FOR_DYNAMIC_LOADING
#else /* COMPILE_FOR_DYNAMIC_LOADING */
#define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \
-int EXFUN (decl_code, (void)); \
-SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, entry_count_t)); \
+liarc_decl_code_t decl_code; \
+liarc_code_proc_t code; \
static int \
-DEFUN_VOID (dload_initialize_code) \
+dload_initialize_code (void) \
{ \
return (declare_compiled_code (name, nentries, decl_code, code)); \
}
#define DECLARE_COMPILED_DATA(name, decl_data, data) \
-int EXFUN (decl_data, (void)); \
-SCHEME_OBJECT * EXFUN (data, (entry_count_t)); \
+liarc_decl_data_t decl_data; \
+liarc_data_proc_t data; \
static int \
-DEFUN_VOID (dload_initialize_data) \
+dload_initialize_data (void) \
{ \
return (declare_compiled_data (name, decl_data, data)); \
}
#define DECLARE_COMPILED_DATA_NS(name, data) \
-SCHEME_OBJECT * EXFUN (data, (entry_count_t)); \
+liarc_data_proc_t data; \
static int \
-DEFUN_VOID (dload_initialize_data) \
+dload_initialize_data (void) \
{ \
return (declare_compiled_data_ns (name, data)); \
}
#define DECLARE_DATA_OBJECT(name, data) \
-SCHEME_OBJECT EXFUN (data, (void)); \
+liarc_object_proc_t data; \
static int \
-DEFUN_VOID (dload_initialize_data) \
+dload_initialize_data (void) \
{ \
return (declare_data_object (name, data)); \
}
#define DECLARE_DYNAMIC_INITIALIZATION(name) \
char * \
-DEFUN_VOID (dload_initialize_file) \
+dload_initialize_file (void) \
{ \
- int result = (dload_initialize_code ()); \
- if (result != 0) \
- return ((char *) NULL); \
- result = (dload_initialize_data ()); \
- if (result != 0) \
- return ((char *) NULL); \
- else \
- return (name); \
+ return \
+ ((((dload_initialize_code ()) == 0) \
+ && ((dload_initialize_data ()) == 0)) \
+ ? name \
+ : 0); \
}
#define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name) \
char * \
-DEFUN_VOID (dload_initialize_file) \
+dload_initialize_file (void) \
{ \
- int result = (dload_initialize_data ()); \
- if (result != 0) \
- return ((char *) NULL); \
- else \
- return (name); \
+ return (((dload_initialize_data ()) == 0) ? name : 0); \
}
#endif /* COMPILE_FOR_DYNAMIC_LOADING */
\f
-#ifdef USE_STDARG
-# define RCONSM_TYPE(frob) SCHEME_OBJECT EXFUN (frob, (int, SCHEME_OBJECT DOTS))
-#else /* not USE_STDARG */
-# define RCONSM_TYPE(frob) SCHEME_OBJECT frob ()
-#endif /* USE_STDARG */
-
-extern RCONSM_TYPE(rconsm);
-
-extern int
- EXFUN (multiply_with_overflow, (long, long, long *)),
- EXFUN (declare_compiled_code,
- (char *,
- entry_count_t,
- int EXFUN ((*), (void)),
- SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *, entry_count_t)))),
- EXFUN (declare_compiled_data,
- (char *,
- int EXFUN ((*), (void)),
- SCHEME_OBJECT * EXFUN ((*), (entry_count_t)))),
- EXFUN (declare_compiled_data_ns,
- (char *,
- SCHEME_OBJECT * EXFUN ((*), (entry_count_t)))),
- EXFUN (declare_data_object,
- (char *,
- SCHEME_OBJECT EXFUN ((*), (void)))),
- EXFUN (declare_compiled_code_mult, (unsigned, CONST struct liarc_code_S *)),
- EXFUN (declare_compiled_data_mult, (unsigned, CONST struct liarc_data_S *)),
- EXFUN (NO_SUBBLOCKS, (void));
-
-extern SCHEME_OBJECT
- EXFUN (initialize_subblock, (char *)),
- * EXFUN (invoke_utility, (int, long, long, long, long)),
- EXFUN (unstackify,
- (unsigned char * prog, unsigned long, entry_count_t dispatch_base));
-
-extern double
- EXFUN (acos, (double)),
- EXFUN (asin, (double)),
- EXFUN (atan, (double)),
- EXFUN (ceil, (double)),
- EXFUN (cos, (double)),
- EXFUN (exp, (double)),
- EXFUN (floor, (double)),
- EXFUN (log, (double)),
- EXFUN (sin, (double)),
- EXFUN (sqrt, (double)),
- EXFUN (tan, (double)),
- EXFUN (double_truncate, (double)),
- EXFUN (atan2, (double, double));
+extern SCHEME_OBJECT initialize_subblock (const char *);
+
+extern SCHEME_OBJECT * invoke_utility
+ (unsigned int, unsigned long, unsigned long, unsigned long, unsigned long);
+
+extern int declare_compiled_code
+ (const char *, entry_count_t, liarc_decl_code_t *, liarc_code_proc_t *);
+
+extern int declare_compiled_code_ns
+ (const char *, entry_count_t, liarc_code_proc_t *);
+
+extern int declare_compiled_data
+ (const char *, liarc_decl_data_t *, liarc_data_proc_t *);
+
+extern int declare_compiled_data_ns (const char *, liarc_data_proc_t *);
+extern int declare_data_object (const char *, liarc_object_proc_t *);
+extern int declare_compiled_code_mult (unsigned, const struct liarc_code_S *);
+extern int declare_compiled_data_mult (unsigned, const struct liarc_data_S *);
+
+extern SCHEME_OBJECT unstackify (unsigned char *, size_t, entry_count_t);
+
+extern int multiply_with_overflow (long, long, long *);
#define DOUBLE_ACOS acos
#define DOUBLE_ASIN asin
#define DOUBLE_EXP exp
#define DOUBLE_FLOOR floor
#define DOUBLE_LOG log
-#define DOUBLE_ROUND(dx) (double_truncate ((dx < 0) ? (dx - 0.5) : (dx + 0.5)))
#define DOUBLE_SIN sin
#define DOUBLE_SQRT sqrt
#define DOUBLE_TAN tan
#define DOUBLE_TRUNCATE double_truncate
+#define DOUBLE_ROUND double_round
#define DOUBLE_ATAN2 atan2
-\f
-#ifdef __GNUC__
-# if defined(hp9000s800) || defined(__hp9000s800)
-# define BUG_GCC_LONG_CALLS
-# endif
-#endif
-#ifndef BUG_GCC_LONG_CALLS
-
-extern SCHEME_OBJECT EXFUN (memory_to_string, (unsigned long, CONST void *));
-extern SCHEME_OBJECT EXFUN (memory_to_symbol, (unsigned long, CONST char *));
-extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
-extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
-extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
-extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
-extern SCHEME_OBJECT EXFUN (digit_string_to_integer,
- (Boolean, unsigned long, unsigned char *));
-extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string,
- (unsigned long, unsigned long, unsigned char *));
-extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
-extern SCHEME_OBJECT EXFUN (memory_to_uninterned_symbol,
- (unsigned long, unsigned char *));
+#define MAKE_PRIMITIVE(str, arity) \
+ (make_primitive (((const char *) (str)), ((int) (arity))))
#define MEMORY_TO_STRING memory_to_string
-#define MEMORY_TO_SYMBOL(len,str) memory_to_symbol (len, str)
-#define MAKE_VECTOR(len,init,flag) make_vector (((long) len), init, flag)
+#define MEMORY_TO_SYMBOL memory_to_symbol
+#define MAKE_VECTOR make_vector
#define CONS cons
#define RCONSM rconsm
#define DOUBLE_TO_FLONUM double_to_flonum
#define LONG_TO_INTEGER long_to_integer
-#define DIGIT_STRING_TO_INTEGER(sgn,len,str) \
- digit_string_to_integer(sgn, ((unsigned long) len), ((unsigned char *) str))
-#define DIGIT_STRING_TO_BIT_STRING(blen,len,str) \
- digit_string_to_bit_string(((unsigned long) blen), \
- ((unsigned long) len), \
- ((unsigned char *) str))
-#define MAKE_PRIMITIVE(str,arity) \
- make_primitive (((char *) str), ((int) arity))
#define C_TO_UNINTERNED_SYMBOL memory_to_uninterned_symbol
+#define DIGIT_STRING_TO_INTEGER digit_string_to_integer
+#define DIGIT_STRING_TO_BIT_STRING digit_string_to_bit_string
-#else /* GCC on Spectrum has a strange bug so do thing differently .... */
-
-extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [11])), ());
-
-#define MEMORY_TO_STRING \
- ((SCHEME_OBJECT EXFUN ((*), (unsigned long, unsigned char *))) \
- (constructor_kludge[0]))
-
-#define MEMORY_TO_SYMBOL \
- ((SCHEME_OBJECT EXFUN ((*), (unsigned long, unsigned char *))) \
- (constructor_kludge[1]))
-
-#define MAKE_VECTOR \
- ((SCHEME_OBJECT EXFUN ((*), (unsigned long, SCHEME_OBJECT, Boolean))) \
- (constructor_kludge[2]))
-
-#define CONS \
- ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, SCHEME_OBJECT))) \
- (constructor_kludge[3]))
-
-#define RCONSM \
- ((RCONSM_TYPE ((*))) (constructor_kludge[4]))
-
-#define DOUBLE_TO_FLONUM \
- ((SCHEME_OBJECT EXFUN ((*), (double))) (constructor_kludge[5]))
-
-#define LONG_TO_INTEGER \
- ((SCHEME_OBJECT EXFUN ((*), (long))) (constructor_kludge[6]))
-
-#define DIGIT_STRING_TO_INTEGER \
- ((SCHEME_OBJECT EXFUN ((*), (Boolean, unsigned long, char *))) \
- (constructor_kludge[7]))
-
-#define DIGIT_STRING_TO_BIT_STRING \
- ((SCHEME_OBJECT EXFUN ((*), (unsigned long, unsigned long, char *))) \
- (constructor_kludge[8]))
-
-#define MAKE_PRIMITIVE \
- ((SCHEME_OBJECT EXFUN ((*), (char *, int))) (constructor_kludge[9]))
+extern SCHEME_OBJECT rconsm (unsigned int, SCHEME_OBJECT, ...);
+extern SCHEME_OBJECT memory_to_uninterned_symbol (unsigned long, const void *);
-#define C_TO_UNINTERNED_SYMBOL \
- ((SCHEME_OBJECT EXFUN ((*), (unsigned long, char *))) \
- (constructor_kludge[10]))
+extern SCHEME_OBJECT digit_string_to_integer
+ (bool, unsigned long, const char *);
-#endif /* BUG_GCC_LONG_CALLS */
+extern SCHEME_OBJECT digit_string_to_bit_string
+ (unsigned long, unsigned long, const char *);
-#endif /* LIARC_INCLUDED */
+#endif /* !SCM_LIARC_H_INCLUDED */
/* -*-C-*-
-$Id: list.c,v 9.37 2007/01/05 21:19:25 cph Exp $
+$Id: list.c,v 9.38 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
\f
-DEFINE_PRIMITIVE ("PAIR?", Prim_pair, 1, 1,
+DEFINE_PRIMITIVE ("PAIR?", Prim_pair, 1, 1,
"(object)\n\
Returns #t if object is a pair; otherwise returns #f.\
")
{
- fast SCHEME_OBJECT object;
+ SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ object = (ARG_REF (1));
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PAIR_P (object)));
}
SCHEME_OBJECT
-DEFUN (cons, (car, cdr),
- SCHEME_OBJECT car
- AND SCHEME_OBJECT cdr)
+cons (SCHEME_OBJECT car,
+ SCHEME_OBJECT cdr)
{
Primitive_GC_If_Needed (2);
(*Free++) = car;
PRIMITIVE_HEADER (2);
CHECK_ARG (1, PAIR_P);
{
- fast SCHEME_OBJECT pair = (ARG_REF (1));
- fast SCHEME_OBJECT car = (ARG_REF (2));
- SIDE_EFFECT_IMPURIFY (pair, car);
+ SCHEME_OBJECT pair = (ARG_REF (1));
+ SCHEME_OBJECT car = (ARG_REF (2));
SET_PAIR_CAR (pair, car);
}
PRIMITIVE_RETURN (UNSPECIFIC);
PRIMITIVE_HEADER (2);
CHECK_ARG (1, PAIR_P);
{
- fast SCHEME_OBJECT pair = (ARG_REF (1));
- fast SCHEME_OBJECT cdr = (ARG_REF (2));
- SIDE_EFFECT_IMPURIFY (pair, cdr);
+ SCHEME_OBJECT pair = (ARG_REF (1));
+ SCHEME_OBJECT cdr = (ARG_REF (2));
SET_PAIR_CDR (pair, cdr);
}
PRIMITIVE_RETURN (UNSPECIFIC);
{
PRIMITIVE_HEADER (2);
{
- fast SCHEME_OBJECT object = (ARG_REF (1));
- fast long CAR_CDR_Pattern = (arg_nonnegative_integer (2));
+ SCHEME_OBJECT object = (ARG_REF (1));
+ long CAR_CDR_Pattern = (arg_nonnegative_integer (2));
while (CAR_CDR_Pattern > 1)
{
- TOUCH_IN_PRIMITIVE (object, object);
if (! (PAIR_P (object)))
error_wrong_type_arg (1);
object =
Returns the length of LIST.\
")
{
- fast SCHEME_OBJECT list;
- fast long i = 0;
+ SCHEME_OBJECT list;
+ long i = 0;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), list);
+ list = (ARG_REF (1));
while (PAIR_P (list))
{
i += 1;
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
+ list = (PAIR_CDR (list));
}
if (!EMPTY_LIST_P (list))
error_wrong_type_arg (1);
useful values rather than just `#t' or `#f'.\
")
{
- fast SCHEME_OBJECT key;
- fast SCHEME_OBJECT list;
- fast SCHEME_OBJECT list_key;
+ SCHEME_OBJECT key;
+ SCHEME_OBJECT list;
+ SCHEME_OBJECT list_key;
PRIMITIVE_HEADER (2);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), key);
- TOUCH_IN_PRIMITIVE ((ARG_REF (2)), list);
+ key = (ARG_REF (1));
+ list = (ARG_REF (2));
while (PAIR_P (list))
{
- TOUCH_IN_PRIMITIVE ((PAIR_CAR (list)), list_key);
+ list_key = (PAIR_CAR (list));
if (list_key == key)
PRIMITIVE_RETURN (list);
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
+ list = (PAIR_CDR (list));
}
if (!EMPTY_LIST_P (list))
error_wrong_type_arg (2);
useful values rather than just `#t' or `#f'.\
")
{
- fast SCHEME_OBJECT key;
- fast SCHEME_OBJECT alist;
- fast SCHEME_OBJECT association;
- fast SCHEME_OBJECT association_key;
+ SCHEME_OBJECT key;
+ SCHEME_OBJECT alist;
+ SCHEME_OBJECT association;
+ SCHEME_OBJECT association_key;
PRIMITIVE_HEADER (2);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), key);
- TOUCH_IN_PRIMITIVE ((ARG_REF (2)), alist);
+ key = (ARG_REF (1));
+ alist = (ARG_REF (2));
while (PAIR_P (alist))
{
- TOUCH_IN_PRIMITIVE ((PAIR_CAR (alist)), association);
+ association = (PAIR_CAR (alist));
if (! (PAIR_P (association)))
error_wrong_type_arg (2);
- TOUCH_IN_PRIMITIVE ((PAIR_CAR (association)), association_key);
+ association_key = (PAIR_CAR (association));
if (association_key == key)
PRIMITIVE_RETURN (association);
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (alist)), alist);
+ alist = (PAIR_CDR (alist));
}
if (!EMPTY_LIST_P (alist))
error_wrong_type_arg (2);
\f
DEFINE_PRIMITIVE ("SYSTEM-PAIR?", Prim_sys_pair, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
+ SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_PAIR_P (object)));
+ object = (ARG_REF (1));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_TYPE_PAIR (object)));
}
SCHEME_OBJECT
-DEFUN (system_pair_cons, (type, car, cdr),
- long type
- AND SCHEME_OBJECT car
- AND SCHEME_OBJECT cdr)
+system_pair_cons (long type,
+ SCHEME_OBJECT car,
+ SCHEME_OBJECT cdr)
{
Primitive_GC_If_Needed (2);
(*Free++) = car;
{
PRIMITIVE_HEADER (3);
{
- long type = (arg_index_integer (1, (MAX_TYPE_CODE + 1)));
- if ((GC_Type_Code (type)) != GC_Pair)
+ unsigned long type = (arg_ulong_index_integer (1, N_TYPE_CODES));
+ if ((GC_TYPE_CODE (type)) != GC_PAIR)
error_bad_range_arg (1);
PRIMITIVE_RETURN (system_pair_cons (type, (ARG_REF (2)), (ARG_REF (3))));
}
DEFINE_PRIMITIVE ("SYSTEM-PAIR-CAR", Prim_sys_pair_car, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, GC_PAIR_P);
+ CHECK_ARG (1, GC_TYPE_PAIR);
PRIMITIVE_RETURN (PAIR_CAR (ARG_REF (1)));
}
DEFINE_PRIMITIVE ("SYSTEM-PAIR-CDR", Prim_sys_pair_cdr, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, GC_PAIR_P);
+ CHECK_ARG (1, GC_TYPE_PAIR);
PRIMITIVE_RETURN (PAIR_CDR (ARG_REF (1)));
}
DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CAR!", Prim_sys_set_car, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
- CHECK_ARG (1, GC_PAIR_P);
+ CHECK_ARG (1, GC_TYPE_PAIR);
{
- fast SCHEME_OBJECT pair = (ARG_REF (1));
- fast SCHEME_OBJECT car = (ARG_REF (2));
- SIDE_EFFECT_IMPURIFY (pair, car);
+ SCHEME_OBJECT pair = (ARG_REF (1));
+ SCHEME_OBJECT car = (ARG_REF (2));
SET_PAIR_CAR (pair, car);
}
PRIMITIVE_RETURN (UNSPECIFIC);
DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CDR!", Prim_sys_set_cdr, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
- CHECK_ARG (1, GC_PAIR_P);
+ CHECK_ARG (1, GC_TYPE_PAIR);
{
- fast SCHEME_OBJECT pair = (ARG_REF (1));
- fast SCHEME_OBJECT cdr = (ARG_REF (2));
- SIDE_EFFECT_IMPURIFY (pair, cdr);
+ SCHEME_OBJECT pair = (ARG_REF (1));
+ SCHEME_OBJECT cdr = (ARG_REF (2));
SET_PAIR_CDR (pair, cdr);
}
PRIMITIVE_RETURN (UNSPECIFIC);
+++ /dev/null
-/* -*-C-*-
-
-$Id: load.c,v 9.47 2007/04/14 05:39:51 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains common code for reading internal
- format binary files. */
-\f
-#include "outf.h" /* Formatted output for errors */
-
-#include "fasl.h"
-
-#define FASL_FILE_FINE 0
-#define FASL_FILE_TOO_SHORT 1
-#define FASL_FILE_NOT_FASL 2
-#define FASL_FILE_BAD_MACHINE 3
-#define FASL_FILE_BAD_VERSION 4
-#define FASL_FILE_BAD_SUBVERSION 5
-#define FASL_FILE_BAD_PROCESSOR 6
-#define FASL_FILE_BAD_INTERFACE 7
-
-#ifndef BYTE_INVERSION
-
-#define NORMALIZE_HEADER(header, size, base, count)
-#define NORMALIZE_REGION(region, size)
-
-#else /* BYTE_INVERSION */
-
-void
- EXFUN (Byte_Invert_Region, (long *, long)),
- EXFUN (Byte_Invert_Header, (long *, long, long, long));
-
-#define NORMALIZE_HEADER Byte_Invert_Header
-#define NORMALIZE_REGION Byte_Invert_Region
-
-#endif /* BYTE_INVERSION */
-
-/* Static storage for some shared variables */
-
-static Boolean
- band_p;
-
-static long
- Machine_Type, Version, Sub_Version,
- Dumped_Object, Dumped_Stack_Top,
- Heap_Base, Heap_Count,
- Const_Base, Const_Count,
- Dumped_Heap_Top, Dumped_Constant_Top,
- Primitive_Table_Size, Primitive_Table_Length,
- C_Code_Table_Size, C_Code_Table_Length,
- dumped_processor_type, dumped_interface_version,
- dumped_memory_base;
-
-static unsigned long dumped_checksum;
-
-#ifndef INHIBIT_CHECKSUMS
-static unsigned long computed_checksum;
-#endif /* INHIBIT_CHECKSUMS */
-
-
-static SCHEME_OBJECT
- Ext_Prim_Vector,
- dumped_utilities;
-\f
-void
-DEFUN_VOID (print_fasl_information)
-{
- printf ("FASL File Information:\n\n");
- printf ("Machine = %ld; Version = %ld; Subversion = %ld\n",
- Machine_Type, Version, Sub_Version);
- if ((dumped_processor_type != 0) || (dumped_interface_version != 0))
- printf ("Compiled code interface version = %ld; Processor type = %ld\n",
- dumped_interface_version, dumped_processor_type);
- if (band_p)
- printf ("The file contains a dumped image (band).\n");
-
- printf ("\nRelocation Information:\n\n");
- printf ("Heap Count = %ld; Heap Base = 0x%lx; Heap Top = 0x%lx\n",
- Heap_Count, Heap_Base, Dumped_Heap_Top);
- printf ("Const Count = %ld; Const Base = 0x%lx; Const Top = 0x%lx\n",
- Const_Count, Const_Base, Dumped_Constant_Top);
- printf ("Stack Top = 0x%lx\n", Dumped_Stack_Top);
-
- printf ("\nDumped Objects:\n\n");
- printf ("Dumped object at 0x%lx (as read from file)\n", Dumped_Object);
- printf ("Compiled code utilities vector = 0x%lx\n", dumped_utilities);
- if (Ext_Prim_Vector != SHARP_F)
- printf ("External primitives vector = 0x%lx\n", Ext_Prim_Vector);
- else
- printf ("Length of primitive table = %ld\n", Primitive_Table_Length);
- printf ("Length of C table = %ld\n", C_Code_Table_Length);
- printf ("Checksum = 0x%lx\n", dumped_checksum);
- return;
-}
-\f
-long
-DEFUN (initialize_variables_from_fasl_header, (buffer),
- SCHEME_OBJECT * buffer)
-{
- SCHEME_OBJECT Pointer_Heap_Base, Pointer_Const_Base;
-
- if (buffer[FASL_Offset_Marker] != FASL_FILE_MARKER)
- return (FASL_FILE_NOT_FASL);
-
- NORMALIZE_HEADER (buffer,
- (sizeof(buffer) / sizeof(SCHEME_OBJECT)),
- buffer[FASL_Offset_Heap_Base],
- buffer[FASL_Offset_Heap_Count]);
- Heap_Count = OBJECT_DATUM (buffer[FASL_Offset_Heap_Count]);
- Pointer_Heap_Base = buffer[FASL_Offset_Heap_Base];
- Heap_Base = OBJECT_DATUM (Pointer_Heap_Base);
- Dumped_Object = OBJECT_DATUM (buffer[FASL_Offset_Dumped_Obj]);
- Const_Count = OBJECT_DATUM (buffer[FASL_Offset_Const_Count]);
- Pointer_Const_Base = buffer[FASL_Offset_Const_Base];
- Const_Base = OBJECT_DATUM (Pointer_Const_Base);
- Version = The_Version(buffer[FASL_Offset_Version]);
- Sub_Version = The_Sub_Version(buffer[FASL_Offset_Version]);
- Machine_Type = The_Machine_Type(buffer[FASL_Offset_Version]);
- Dumped_Stack_Top = OBJECT_DATUM (buffer[FASL_Offset_Stack_Top]);
- Dumped_Heap_Top =
- ADDRESS_TO_DATUM (MEMORY_LOC (Pointer_Heap_Base, Heap_Count));
- Dumped_Constant_Top =
- ADDRESS_TO_DATUM (MEMORY_LOC (Pointer_Const_Base, Const_Count));
-\f
- if (Version == FASL_FORMAT_ADDED_STACK && Sub_Version < FASL_MERGED_PRIMITIVES)
- {
- Primitive_Table_Length = 0;
- Primitive_Table_Size = 0;
- Ext_Prim_Vector =
- (OBJECT_NEW_TYPE (TC_CELL, (buffer [FASL_Offset_Ext_Loc])));
- }
- else
- {
- Primitive_Table_Length = (OBJECT_DATUM (buffer[FASL_Offset_Prim_Length]));
- Primitive_Table_Size = (OBJECT_DATUM (buffer[FASL_Offset_Prim_Size]));
- Ext_Prim_Vector = SHARP_F;
- }
-
- if (Version == FASL_FORMAT_ADDED_STACK && Sub_Version < FASL_INTERFACE_VERSION)
- {
- /* This may be all wrong, but... */
- band_p = false;
- dumped_processor_type = 0;
- dumped_interface_version = 0;
- dumped_utilities = SHARP_F;
- }
- else
- {
- SCHEME_OBJECT temp = buffer[FASL_Offset_Ci_Version];
-
- band_p = (CI_BAND_P (temp));
- dumped_processor_type = (CI_PROCESSOR (temp));
- dumped_interface_version = (CI_VERSION (temp));
- dumped_utilities = buffer[FASL_Offset_Ut_Base];
- }
-
- if (Version == FASL_FORMAT_ADDED_STACK && Sub_Version < FASL_C_CODE)
- {
- C_Code_Table_Length = 0;
- C_Code_Table_Size = 0;
- }
- else
- {
- C_Code_Table_Length = (OBJECT_DATUM (buffer[FASL_Offset_C_Length]));
- C_Code_Table_Size = (OBJECT_DATUM (buffer[FASL_Offset_C_Size]));
- }
- dumped_memory_base = ((long) buffer[FASL_Offset_Mem_Base]);
-#ifdef HEAP_IN_LOW_MEMORY
- if (dumped_memory_base != 0)
- return (FASL_FILE_BAD_MACHINE);
-#else
- if (dumped_memory_base == 0)
- return (FASL_FILE_BAD_MACHINE);
-#endif
-\f
-#ifndef INHIBIT_FASL_VERSION_CHECK
- /* The error messages here should be handled by the runtime system! */
-
- if ((Version != FASL_READ_VERSION) ||
-#ifndef BYTE_INVERSION
- (Machine_Type != FASL_INTERNAL_FORMAT) ||
-#endif
- (Sub_Version < FASL_READ_SUBVERSION) ||
- (Sub_Version > FASL_SUBVERSION))
- {
- outf_error ("\nread_file:\n");
- outf_error ("FASL File: Version %4d Subversion %4d Machine Type %4d.\n",
- Version, Sub_Version , Machine_Type);
- outf_error ("Expected: Version %4d Subversion %4d Machine Type %4d.\n",
- FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
-
- return ((Machine_Type != FASL_INTERNAL_FORMAT) ?
- FASL_FILE_BAD_MACHINE :
- ((Version != FASL_READ_VERSION) ?
- FASL_FILE_BAD_VERSION :
- FASL_FILE_BAD_SUBVERSION));
- }
-
-#endif /* INHIBIT_FASL_VERSION_CHECK */
-\f
-#ifndef INHIBIT_COMPILED_VERSION_CHECK
-
- /* Is the compiled code "loadable" here? */
-
- {
- extern long compiler_processor_type, compiler_interface_version;
-
- if (((dumped_processor_type != 0) &&
- (dumped_processor_type != compiler_processor_type)) ||
- ((dumped_interface_version != 0) &&
- (dumped_interface_version != compiler_interface_version)))
- {
- outf_error ("\nread_file:\n");
- outf_error ("FASL File: compiled code interface %4d; processor %4d.\n",
- dumped_interface_version, dumped_processor_type);
- outf_error ("Expected: compiled code interface %4d; processor %4d.\n",
- compiler_interface_version, compiler_processor_type);
- return (((dumped_processor_type != 0) &&
- (dumped_processor_type != compiler_processor_type)) ?
- FASL_FILE_BAD_PROCESSOR :
- FASL_FILE_BAD_INTERFACE);
- }
- }
-
-#endif /* INHIBIT_COMPILED_VERSION_CHECK */
-
- dumped_checksum = (buffer [FASL_Offset_Check_Sum]);
-
-#ifndef INHIBIT_CHECKSUMS
-
- {
- extern unsigned long
- EXFUN (checksum_area, (unsigned long *, long, unsigned long));
-
- computed_checksum =
- (checksum_area (((unsigned long *) &buffer[0]),
- ((long) (FASL_HEADER_LENGTH)),
- ((unsigned long) 0)));
- }
-
-#endif /* INHIBIT_CHECKSUMS */
-
- return (FASL_FILE_FINE);
-}
-
-long
-DEFUN_VOID (Read_Header)
-{
- SCHEME_OBJECT header[FASL_HEADER_LENGTH];
-
- if ((Load_Data (FASL_HEADER_LENGTH, header)) !=
- FASL_HEADER_LENGTH)
- return (FASL_FILE_TOO_SHORT);
- return (initialize_variables_from_fasl_header (&header[0]));
-}
-
-#ifdef HEAP_IN_LOW_MEMORY
-
-#define SCHEME_ADDR_TO_OLD_DATUM(addr) \
- (ADDRESS_TO_DATUM (SCHEME_ADDR_TO_ADDR ((SCHEME_OBJECT *) (addr))))
-
-#else /* not HEAP_IN_LOW_MEMORY */
-
-#define SCHEME_ADDR_TO_OLD_DATUM(addr) \
- (((SCHEME_OBJECT *) (addr)) - ((SCHEME_OBJECT *) dumped_memory_base))
-
-#endif /* HEAP_IN_LOW_MEMORY */
-\f
-#ifdef BYTE_INVERSION
-
-static Boolean Byte_Invert_Fasl_Files;
-
-void
-DEFUN (Byte_Invert_Header, (Header, Headsize, Test1, Test2),
- long * Header
- AND long Headsize
- AND long Test1
- AND long Test2)
-{
- Byte_Invert_Fasl_Files = false;
-
- if ((Test1 & 0xff) == TC_BROKEN_HEART &&
- (Test2 & 0xff) == TC_BROKEN_HEART &&
- (OBJECT_TYPE (Test1) != TC_BROKEN_HEART ||
- OBJECT_TYPE (Test2) != TC_BROKEN_HEART))
- {
- Byte_Invert_Fasl_Files = true;
- Byte_Invert_Region(Header, Headsize);
- }
- return;
-}
-
-void
-DEFUN (Byte_Invert_Region, (Region, Size),
- long * Region
- AND long Size)
-{
- register long word, size;
-
- if (Byte_Invert_Fasl_Files)
- {
- for (size = Size; size > 0; size--, Region++)
- {
- word = (*Region);
- *Region = (((word>>24)&0xff) | ((word>>8)&0xff00) |
- ((word<<8)&0xff0000) | ((word<<24)&0xff000000));
- }
- }
- return;
-}
-
-#endif /* BYTE_INVERSION */
/* -*-C-*-
-$Id: lookprm.c,v 1.23 2007/01/05 21:19:25 cph Exp $
+$Id: lookprm.c,v 1.24 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
-#include "locks.h"
#include "trap.h"
#include "lookup.h"
/* -*-C-*-
-$Id: lookup.c,v 9.74 2007/01/05 21:19:25 cph Exp $
+$Id: lookup.c,v 9.75 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "trap.h"
#include "lookup.h"
-
-extern long make_uuo_link
- (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
-extern long make_fake_uuo_link
- (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
-extern SCHEME_OBJECT extract_uuo_link
- (SCHEME_OBJECT, unsigned long);
-
-extern SCHEME_OBJECT extract_variable_cache
- (SCHEME_OBJECT, unsigned long);
-extern void store_variable_cache
- (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
-
-extern SCHEME_OBJECT compiled_block_environment
- (SCHEME_OBJECT);
\f
/* Hopefully a conservative guesstimate. */
#ifndef SPACE_PER_UUO_LINK /* So it can be overriden from config.h */
#define GC_CHECK(n) \
{ \
- if (GC_Check (n)) \
+ if (GC_NEEDED_P (n)) \
{ \
- Request_GC (n); \
+ REQUEST_GC (n); \
return (PRIM_INTERRUPT); \
} \
}
? EXTERNAL_UNASSIGNED_OBJECT \
: (value))
-#define EXTERNAL_UNASSIGNED_OBJECT (Get_Fixed_Obj_Slot (Non_Object))
+#define EXTERNAL_UNASSIGNED_OBJECT \
+ (VECTOR_REF (fixed_objects, NON_OBJECT))
#define WALK_REFERENCES(refs_pointer, ref_var, body) \
{ \
(SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT *, int);
static long assign_variable_cache
(SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, int);
-static long update_uuo_links
- (SCHEME_OBJECT, SCHEME_OBJECT);
static long guarantee_extension_space
(SCHEME_OBJECT);
static long allocate_frame_extension
(unsigned long, SCHEME_OBJECT, SCHEME_OBJECT *);
-static void move_all_references
- (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int);
static long unbind_cached_variable
(SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT);
static void unbind_variable_1
(SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT);
-static long add_cache_reference
- (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int);
-static void add_reference
- (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
-static void install_cache
- (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int);
-static void install_operator_cache
- (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
static unsigned long update_cache_refs_space
(SCHEME_OBJECT, SCHEME_OBJECT);
static long update_cache_references
(SCHEME_OBJECT, SCHEME_OBJECT *, SCHEME_OBJECT);
-static unsigned long ref_pairs_to_move
- (SCHEME_OBJECT *, SCHEME_OBJECT, unsigned long *);
-static void move_ref_pairs
- (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int, SCHEME_OBJECT);
-static int move_ref_pair_p
- (SCHEME_OBJECT, SCHEME_OBJECT);
static SCHEME_OBJECT * find_binding_cell
(SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *);
static SCHEME_OBJECT * scan_frame
(SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, int);
static unsigned long count_references
(SCHEME_OBJECT *);
-static SCHEME_OBJECT * find_references_named
- (SCHEME_OBJECT *, SCHEME_OBJECT);
static void update_assignment_references
(SCHEME_OBJECT);
static long guarantee_cache
(SCHEME_OBJECT);
static long make_cache
(SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *);
+
+#ifdef CC_SUPPORT_P
+
+static long update_uuo_links
+ (SCHEME_OBJECT, SCHEME_OBJECT);
+static void move_all_references
+ (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int);
+static long add_cache_reference
+ (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int);
+static void add_reference
+ (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+static void install_cache
+ (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int);
+static void install_operator_cache
+ (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+static unsigned long ref_pairs_to_move
+ (SCHEME_OBJECT *, SCHEME_OBJECT, unsigned long *);
+static void move_ref_pairs
+ (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int, SCHEME_OBJECT);
+static int move_ref_pair_p
+ (SCHEME_OBJECT, SCHEME_OBJECT);
+static SCHEME_OBJECT * find_references_named
+ (SCHEME_OBJECT *, SCHEME_OBJECT);
static long make_cache_reference
(SCHEME_OBJECT, unsigned long, SCHEME_OBJECT *);
+
+#endif
\f
/***** Basic environment manipulation (lookup, assign, define). *****/
(*value_ret) = (MAP_FROM_UNASSIGNED (old_value));
/* Perform the assignment. If there are any operator references to
this variable, update their links. */
+#ifdef CC_SUPPORT_P
if (PAIR_P (* (GET_CACHE_OPERATOR_REFERENCES (cache))))
return (update_uuo_links (cache, (MAP_TO_UNASSIGNED (value))));
+#endif
SET_CACHE_VALUE (cache, (MAP_TO_UNASSIGNED (value)));
return (PRIM_DONE);
}
+#ifdef CC_SUPPORT_P
static long
update_uuo_links (SCHEME_OBJECT cache, SCHEME_OBJECT new_value)
{
});
return (PRIM_DONE);
}
+#endif
\f
long
define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
SCHEME_OBJECT * source_cell;
trap_kind_t source_kind;
SCHEME_OBJECT * target_cell;
-
+
if (! ((ENVIRONMENT_P (target_environment))
&& (ENVIRONMENT_P (source_environment))))
return (ERR_BAD_FRAME);
* SPACE_PER_UUO_LINK)
+ (2 * SPACE_PER_CACHE));
SET_CACHE_VALUE (target_cache, (GET_CACHE_VALUE (source_cache)));
+#ifdef CC_SUPPORT_P
move_all_references
(source_cache, target_cache, CACHE_REFERENCES_LOOKUP);
move_all_references
(source_cache, target_cache, CACHE_REFERENCES_ASSIGNMENT);
move_all_references
(source_cache, target_cache, CACHE_REFERENCES_OPERATOR);
+#endif
update_clone (source_cache);
update_clone (target_cache);
}
return (define_variable (target_environment, target_symbol, (*source_cell)));
}
+#ifdef CC_SUPPORT_P
static void
move_all_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT to_cache,
unsigned int reference_kind)
reference_kind);
});
}
+#endif
\f
long
unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
case TRAP_UNBOUND:
(*value_ret) = SHARP_F;
return (PRIM_DONE);
-
+
case NON_TRAP_KIND:
case TRAP_UNASSIGNED:
case TRAP_MACRO:
\f
/***** Interface to compiled code. *****/
+#ifdef CC_SUPPORT_P
+
long
compiler_cache_lookup (SCHEME_OBJECT name, SCHEME_OBJECT block,
unsigned long offset)
{
return
- (add_cache_reference ((compiled_block_environment (block)),
+ (add_cache_reference ((cc_block_environment (block)),
name, block, offset,
CACHE_REFERENCES_LOOKUP));
}
unsigned long offset)
{
return
- (add_cache_reference ((compiled_block_environment (block)),
+ (add_cache_reference ((cc_block_environment (block)),
name, block, offset,
CACHE_REFERENCES_ASSIGNMENT));
}
unsigned long offset)
{
return
- (add_cache_reference ((compiled_block_environment (block)),
+ (add_cache_reference ((cc_block_environment (block)),
name, block, offset,
CACHE_REFERENCES_OPERATOR));
}
switch (reference_kind)
{
case CACHE_REFERENCES_LOOKUP:
- store_variable_cache (cache, block, offset);
+ write_variable_cache (cache, block, offset);
break;
case CACHE_REFERENCES_ASSIGNMENT:
- store_variable_cache
+ write_variable_cache
((((GET_CACHE_CLONE (cache)) != SHARP_F)
? (GET_CACHE_CLONE (cache))
: cache),
SCHEME_OBJECT block, unsigned long offset)
{
SCHEME_OBJECT value = (GET_CACHE_VALUE (cache));
- DIE_IF_ERROR
- ((REFERENCE_TRAP_P (value))
- ? (make_fake_uuo_link (cache, block, offset))
- : (make_uuo_link (value, cache, block, offset)));
+ DIE_IF_ERROR (make_uuo_link (value, cache, block, offset));
}
+
+#endif /* CC_SUPPORT_P */
\f
static unsigned long
update_cache_refs_space (SCHEME_OBJECT from_cache, SCHEME_OBJECT environment)
{
+#ifdef CC_SUPPORT_P
unsigned long n_names = 0;
unsigned long n_lookups
= (ref_pairs_to_move ((GET_CACHE_LOOKUP_REFERENCES (from_cache)),
environment, (&n_names)));
/* No references need to be updated. */
- if ((n_lookups == 0) && (n_assignments == 0) && (n_operators == 0))
- return (PRIM_DONE);
+ if (! ((n_lookups == 0) && (n_assignments == 0) && (n_operators == 0)))
+ return
+ ((n_operators * SPACE_PER_UUO_LINK)
+ + (n_names * 4)
+ + (3 * SPACE_PER_CACHE));
+#endif
- return
- ((n_operators * SPACE_PER_UUO_LINK)
- + (n_names * 4)
- + (3 * SPACE_PER_CACHE));
+ return (PRIM_DONE);
}
static long
DIE_IF_ERROR (guarantee_cache (to_cell));
{
SCHEME_OBJECT to_cache = (GET_TRAP_CACHE (*to_cell));
+#ifdef CC_SUPPORT_P
move_ref_pairs
(from_cache, to_cache, CACHE_REFERENCES_LOOKUP, environment);
move_ref_pairs
(from_cache, to_cache, CACHE_REFERENCES_ASSIGNMENT, environment);
move_ref_pairs
(from_cache, to_cache, CACHE_REFERENCES_OPERATOR, environment);
+#endif
update_clone (to_cache);
}
update_clone (from_cache);
return (PRIM_DONE);
}
+#ifdef CC_SUPPORT_P
+
static unsigned long
ref_pairs_to_move (SCHEME_OBJECT * palist, SCHEME_OBJECT environment,
unsigned long * n_names_ret)
move_ref_pair_p (SCHEME_OBJECT ref_pair, SCHEME_OBJECT ancestor)
{
SCHEME_OBJECT descendant
- = (compiled_block_environment
+ = (cc_block_environment
(GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (ref_pair))));
while (PROCEDURE_FRAME_P (descendant))
{
}
return (descendant == ancestor);
}
+
+#endif /* CC_SUPPORT_P */
\f
/***** Utilities *****/
return (n_references);
}
+#ifdef CC_SUPPORT_P
static SCHEME_OBJECT *
find_references_named (SCHEME_OBJECT * palist, SCHEME_OBJECT symbol)
{
}
return (0);
}
+#endif
static void
update_assignment_references (SCHEME_OBJECT cache)
{
+#ifdef CC_SUPPORT_P
SCHEME_OBJECT reference_cache
= (((GET_CACHE_CLONE (cache)) != SHARP_F)
? (GET_CACHE_CLONE (cache))
((GET_CACHE_ASSIGNMENT_REFERENCES (cache)),
reference,
{
- store_variable_cache
+ write_variable_cache
(reference_cache,
(GET_CACHE_REFERENCE_BLOCK (reference)),
(GET_CACHE_REFERENCE_OFFSET (reference)));
});
+#endif
}
\f
static long
return (PRIM_DONE);
}
+#ifdef CC_SUPPORT_P
static long
make_cache_reference (SCHEME_OBJECT block, unsigned long offset,
SCHEME_OBJECT * ref_ret)
(*ref_ret) = (MAKE_POINTER_OBJECT (TC_WEAK_CONS, (Free - 2)));
return (PRIM_DONE);
}
+#endif
# -*- Makefile -*-
#
-# $Id: Makefile.in.in,v 1.46 2007/04/09 16:43:05 cph Exp $
+# $Id: Makefile.in.in,v 1.47 2007/04/22 16:31:24 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
# **** File configuration ****
-SHARED_SOURCES = @(write-sources "files-core")@ \
+STD_SOURCES = @(write-sources "files-core")@ \
@(write-sources "files-os-prim")@ \
@(write-sources "files-unix")@ \
$(OPTIONAL_SOURCES)
-SHARED_OBJECTS = @(write-objects "files-core")@ \
+STD_OBJECTS = @(write-objects "files-core")@ \
@(write-objects "files-os-prim")@ \
@(write-objects "files-unix")@ \
$(OPTIONAL_OBJECTS)
-STD_SOURCES = $(SHARED_SOURCES) @(write-sources "files-gc-std")@
-STD_OBJECTS = $(SHARED_OBJECTS) @(write-objects "files-gc-std")@
-
-BCH_SOURCES = $(SHARED_SOURCES) @(write-sources "files-gc-bch")@
-BCH_OBJECTS = $(SHARED_OBJECTS) @(write-objects "files-gc-bch")@
-
GC_HEAD_FILES = @GC_HEAD_FILES@
OPTIONAL_SOURCES = @OPTIONAL_SOURCES@
OPTIONAL_OBJECTS = @OPTIONAL_OBJECTS@
# **** Program definitions ****
-bin_PROGRAMS = scheme bchscheme
-aux_PROGRAMS = gcdrone ppband
+bin_PROGRAMS = scheme
+aux_PROGRAMS =
aux_LIBS = $(MODULE_TARGETS)
aux_DATA = utabmd.bin
-EXTRA_PROGRAMS = findprim bintopsb psbtobin
+EXTRA_PROGRAMS = findprim
scheme_SOURCES = $(STD_SOURCES) usrdef.c $(LIARC_SOURCES)
scheme_OBJECTS = $(STD_OBJECTS) usrdef.o $(LIARC_OBJECTS)
scheme_LDFLAGS = @SCHEME_LDFLAGS@
scheme_LIBS = $(STATIC_LIBS) $(LIBS)
-bchscheme_SOURCES = $(BCH_SOURCES) bchdef.c $(LIARC_SOURCES)
-bchscheme_OBJECTS = $(BCH_OBJECTS) bchdef.o $(LIARC_OBJECTS)
-bchscheme_DEPENDENCIES =
-bchscheme_LDFLAGS = @SCHEME_LDFLAGS@
-bchscheme_LIBS = $(STATIC_LIBS) $(LIBS)
-
-bchdrn_SOURCES = bchdrn.c bchutl.c
-bchdrn_OBJECTS = bchdrn.o bchutl.o
-bchdrn_DEPENDENCIES =
-bchdrn_LDFLAGS =
-bchdrn_LIBS = $(LIBS)
-
findprim_SOURCES = findprim.c
findprim_OBJECTS = findprim.o
findprim_DEPENDENCIES =
findprim_LDFLAGS =
findprim_LIBS = $(LIBS)
-bintopsb_SOURCES = bintopsb.c missing.c
-bintopsb_OBJECTS = bintopsb.o missing.o
-bintopsb_DEPENDENCIES =
-bintopsb_LDFLAGS =
-bintopsb_LIBS = $(LIBS)
-
-psbtobin_SOURCES = psbtobin.c missing.c
-psbtobin_OBJECTS = psbtobin.o missing.o
-psbtobin_DEPENDENCIES =
-psbtobin_LDFLAGS =
-psbtobin_LIBS = $(LIBS)
-
-ppband_SOURCES = ppband.c outf.c
-ppband_OBJECTS = ppband.o outf.o
-ppband_DEPENDENCIES = load.c storage.c
-ppband_LDFLAGS =
-ppband_LIBS = $(LIBS)
-
ALL_PROGRAMS = $(bin_PROGRAMS) $(aux_PROGRAMS)
ALL_LIBS = $(aux_LIBS)
ALL_DATA = $(aux_DATA)
-MOSTLYCLEAN_FILES = *.o cmpauxmd.s usrdef.c compinit.c compinit.h utabmd.c \
- utabmd.bci bchdef.c $(LIARC_OBJECTS) $(LIARC_BUNDLE_CLEAN_FILES)
+MOSTLYCLEAN_C_FILES = *.o usrdef.c compinit.c compinit.h \
+ $(LIARC_OBJECTS) $(LIARC_BUNDLE_CLEAN_FILES)
+
+MOSTLYCLEAN_FILES = $(MOSTLYCLEAN_C_FILES) cmpauxmd.s utabmd.c utabmd.bci
CLEAN_FILES = $(ALL_PROGRAMS) $(ALL_LIBS) $(ALL_DATA) $(EXTRA_PROGRAMS)
DISTCLEAN_FILES = Makefile config.h config.cache config.log config.status \
- cmpauxmd.m4 cmpauxmd.c cmpintmd.h makegen-cc
+ cmpauxmd.m4 cmpauxmd.c cmpintmd.h makegen-cc \
+ cmpintmd-config.h cmpintmd.c
MAINTAINER_CLEAN_FILES = Makefile.in Makefile.deps liarc-vars liarc-rules \
config.h.in configure TAGS
-C_CLEAN_FILES = *.o usrdef.c compinit.c compinit.h utabmd.bci bchdef.c \
- $(LIARC_OBJECTS) $(LIARC_BUNDLE_CLEAN_FILES) $(ALL_PROGRAMS) \
- $(ALL_LIBS) $(EXTRA_PROGRAMS) $(DISTCLEAN_FILES)
+C_CLEAN_FILES = $(MOSTLYCLEAN_C_FILES) $(CLEAN_FILES) $(DISTCLEAN_FILES)
# **** Implicit rules ****
-rm -f $@
./findprim $(STD_SOURCES) > usrdef.c
-bchscheme: $(bchscheme_OBJECTS) $(bchscheme_DEPENDENCIES)
- -rm -f $@
- $(LINK) $(bchscheme_LDFLAGS) $(bchscheme_OBJECTS) $(bchscheme_LIBS)
-
-bchdef.c: $(BCH_SOURCES) findprim Makefile
- -rm -f $@
- ./findprim $(BCH_SOURCES) > bchdef.c
-
-gcdrone: $(bchdrn_OBJECTS) $(bchdrn_DEPENDENCIES)
- -rm -f $@
- $(LINK) $(bchdrn_LDFLAGS) $(bchdrn_OBJECTS) $(bchdrn_LIBS)
-
findprim: $(findprim_OBJECTS) $(findprim_DEPENDENCIES)
-rm -f $@
$(LINK) $(findprim_LDFLAGS) $(findprim_OBJECTS) $(findprim_LIBS)
-bintopsb: $(bintopsb_OBJECTS) $(bintopsb_DEPENDENCIES)
- -rm -f $@
- $(LINK) $(bintopsb_LDFLAGS) $(bintopsb_OBJECTS) $(bintopsb_LIBS)
-
-psbtobin: $(psbtobin_OBJECTS) $(psbtobin_DEPENDENCIES)
- -rm -f $@
- $(LINK) $(psbtobin_LDFLAGS) $(psbtobin_OBJECTS) $(psbtobin_LIBS)
-
-ppband: $(ppband_OBJECTS) $(ppband_DEPENDENCIES)
- -rm -f $@
- $(LINK) $(ppband_LDFLAGS) $(ppband_OBJECTS) $(ppband_LIBS)
-
utabmd.bin: utabmd.scm
./utabmd.sh
#| -*-Scheme-*-
-$Id: files-core.scm,v 1.6 2007/01/05 21:19:26 cph Exp $
+$Id: files-core.scm,v 1.7 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
"artutl"
"avltree"
+"bkpt"
"bignum"
"bigprm"
"bitstr"
"boot"
"char"
-"comutl"
"daemon"
"debug"
"dfloat"
"error"
"extern"
+"fasdump"
+"fasl"
"fasload"
"fixnum"
"flonum"
+"gcloop"
"generic"
"hooks"
"hunk"
"list"
"lookprm"
"lookup"
+"memmag"
"missing"
"obstack"
"option"
"outf"
"prim"
"primutl"
-"prmcon"
"ptrvec"
+"purify"
"purutl"
"regex"
"rgxprim"
"syntax"
"sysprim"
"term"
-"tterm"
"transact"
+"tterm"
"utils"
"vector"
"wind"
#| -*-Scheme-*-
-$Id: files-optional.scm,v 1.8 2007/01/05 21:19:26 cph Exp $
+$Id: files-optional.scm,v 1.9 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;;;; Optional C files that are conditionally linked in.
"cmpint"
+"comutl"
"prbfish"
"prgdbm"
"prmcrypt"
"prmhash"
"prpgsql"
"pruxdld"
+"svm1-interp"
"termcap"
"terminfo"
"tparam"
#| -*-Scheme-*-
-$Id: files-other.scm,v 1.8 2007/01/05 21:19:26 cph Exp $
+$Id: files-other.scm,v 1.9 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;;;; C files for programs other than Scheme.
-"bchdrn"
-"bintopsb"
"findprim"
-"psbtobin"
-"ppband"
/* -*-C-*-
-$Id: memmag.c,v 9.76 2007/02/10 19:22:13 riastradh Exp $
+$Id: memmag.c,v 9.77 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* Memory management top level.
-
- The memory management code is spread over 4 files:
- - memmag.c: initialization.
- - gcloop.c: main garbage collector loop.
- - purify.c: constant/pure space hacking.
- - wabbit.c: alternate garbage collector loop that collects references.
- There is also a relevant header file, gccode.h.
-
- The object dumper, fasdump, shares properties and code with the
- memory management utilities.
- */
+/* Memory management top level */
#include "scheme.h"
#include "prims.h"
-#include "memmag.h"
+#include "history.h"
#include "gccode.h"
-#include "os.h"
+#include "osscheme.h"
-/* Imports */
+#ifdef __WIN32__
+ extern void win32_allocate_registers (void);
+ extern void win32_deallocate_registers (void);
+# define ALLOCATE_REGISTERS win32_allocate_registers
+# define DEALLOCATE_REGISTERS win32_deallocate_registers
-extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
-extern SCHEME_OBJECT * EXFUN
- (wabbit_hunting_gcloop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
-extern void EXFUN (wabbit_season, (SCHEME_OBJECT));
-extern void EXFUN (duck_season, (SCHEME_OBJECT));
-extern void EXFUN (fix_weak_chain_and_hunt_wabbits, (void));
-extern void EXFUN (error_unimplemented_primitive, (void));
+# include "ntscmlib.h"
+ extern BOOL win32_under_win32s_p (void);
-/* Exports */
+ extern char * NT_allocate_heap (unsigned long, unsigned long *);
+ extern void NT_release_heap (char *, unsigned long);
+# define WIN32_ALLOCATE_HEAP NT_allocate_heap
+# define WIN32_RELEASE_HEAP NT_release_heap
-extern void
- EXFUN (GCFlip, (void)),
- EXFUN (GC, (void));
+ static unsigned long scheme_heap_handle;
+#endif
-extern void
- EXFUN (Clear_Memory, (int, int, int)),
- EXFUN (Setup_Memory, (int, int, int)),
- EXFUN (Reset_Memory, (void));
-\f
-/* Memory Allocation, sequential processor:
+#ifndef HEAP_FREE
+# define HEAP_FREE free
+#endif
+
+#ifndef ALLOCATE_REGISTERS
+# define ALLOCATE_REGISTERS() do { } while (0)
+#endif
+
+#ifndef DEALLOCATE_REGISTERS
+# define DEALLOCATE_REGISTERS() do { } while (0)
+#endif
+
+#ifndef DEFAULT_HEAP_RESERVED
+# define DEFAULT_HEAP_RESERVED 4500
+#endif
+
+static unsigned long saved_heap_size;
+static unsigned long saved_constant_size;
+static unsigned long saved_stack_size;
+
+static gc_tospace_allocator_t allocate_tospace;
+static gc_abort_handler_t abort_gc NORETURN;
+static gc_walk_proc_t save_tospace_copy;
+
+/* Memory Allocation, sequential processor:
oo
------------------------------------------ <- fixed boundary (currently)
in use). In addition, there is a pointer to the top of the
useable area of the heap (the heap is subdivided into two areas for
the purposes of GC, and this pointer indicates the top of the half
- currently in use).
-
-*/
+ currently in use). */
\f
-#define CONSTANT_SPACE_FUDGE 128
-
-/* Initialize free pointers within areas. sp_register is
- special: it always points to a cell that is in use. */
-
-static long saved_heap_size, saved_constant_size, saved_stack_size;
-extern void EXFUN (reset_allocator_parameters, (void));
-extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *));
-
-Boolean
-DEFUN (update_allocator_parameters, (ctop), SCHEME_OBJECT * ctop)
-{
- /* buffer for impurify, etc. */
- SCHEME_OBJECT * nctop = (ctop + CONSTANT_SPACE_FUDGE);
- unsigned long temp;
-
- if (nctop >= (Highest_Allocated_Address + 1))
- return (FALSE);
-
- Constant_Top = nctop;
- temp = ((Highest_Allocated_Address - Constant_Top) / 2);
- Heap_Bottom = Constant_Top;
- Heap_Top = (Heap_Bottom + temp);
- Local_Heap_Base = Heap_Bottom;
- Unused_Heap_Bottom = Heap_Top;
- Unused_Heap_Top = Highest_Allocated_Address;
- Free = Heap_Bottom;
- return (TRUE);
-}
-
void
-DEFUN_VOID (reset_allocator_parameters)
+setup_memory (unsigned long heap_size,
+ unsigned long stack_size,
+ unsigned long constant_size)
{
- GC_Reserve = 4500;
- GC_Space_Needed = 0;
- Stack_Bottom = Lowest_Allocated_Address;
- Stack_Top = (Stack_Bottom + (STACK_ALLOCATION_SIZE (saved_stack_size)));
- Constant_Space = Stack_Top;
- Free_Constant = Constant_Space;
- ALIGN_FLOAT (Free_Constant);
- (void) update_allocator_parameters (Free_Constant);
- SET_CONSTANT_TOP ();
- ALIGN_FLOAT (Free);
- SET_MEMTOP (Heap_Top - GC_Reserve);
- INITIALIZE_STACK ();
- STACK_RESET ();
- return;
-}
-
-void
-DEFUN (Clear_Memory,
- (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size),
- int Our_Heap_Size AND int Our_Stack_Size AND int Our_Constant_Size)
-{
- saved_heap_size = Our_Heap_Size;
- saved_constant_size = Our_Constant_Size;
- saved_stack_size = Our_Stack_Size;
- reset_allocator_parameters ();
-}
-\f
-static void
-DEFUN_VOID (failed_consistency_check)
-{
- outf_flush_fatal ();
- exit (1);
-}
-
-void
-DEFUN_VOID (Reset_Memory)
-{
- HEAP_FREE (Lowest_Allocated_Address);
- DEALLOCATE_REGISTERS ();
- return;
-}
-
-/* This procedure allocates and divides the total memory. */
-
-void
-DEFUN (Setup_Memory,
- (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size),
- int Our_Heap_Size AND int Our_Stack_Size AND int Our_Constant_Size)
-{
- SCHEME_OBJECT test_value;
-
ALLOCATE_REGISTERS ();
/* Consistency check 1 */
- if (Our_Heap_Size == 0)
- {
- outf_fatal ("Configuration won't hold initial data.\n");
- failed_consistency_check ();
- }
+ if ((heap_size == 0) || (stack_size == 0) || (constant_size == 0))
+ {
+ outf_fatal ("Configuration won't hold initial data.\n");
+ outf_flush_fatal ();
+ exit (1);
+ }
/* Allocate */
-
- ALLOCATE_HEAP_SPACE (((STACK_ALLOCATION_SIZE (Our_Stack_Size))
- + (2 * Our_Heap_Size)
- + Our_Constant_Size),
- Lowest_Allocated_Address,
- Highest_Allocated_Address);
+ ALLOCATE_HEAP_SPACE ((stack_size + heap_size + constant_size),
+ memory_block_start,
+ memory_block_end);
/* Consistency check 2 */
- if (Lowest_Allocated_Address == NULL)
- {
- outf_fatal ("Not enough memory for this configuration.\n");
- failed_consistency_check ();
- }
+ if (memory_block_start == 0)
+ {
+ outf_fatal ("Not enough memory for this configuration.\n");
+ outf_flush_fatal ();
+ exit (1);
+ }
/* Consistency check 3 */
+ if ((ADDRESS_TO_DATUM (memory_block_end)) > DATUM_MASK)
+ {
+ outf_fatal ("Requested allocation is too large.\n");
+ outf_fatal ("Try again with a smaller argument to '--heap'.\n");
+ outf_flush_fatal ();
+ reset_memory ();
+ exit (1);
+ }
- test_value = (MAKE_POINTER_OBJECT (LAST_TYPE_CODE,
- Highest_Allocated_Address));
-
- if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
- ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
- {
- outf_fatal (
- "Largest address does not fit in datum field of object.\n");
- outf_fatal (
- "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n");
- Reset_Memory ();
- failed_consistency_check ();
- }
-
- Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
- return;
+ saved_stack_size = stack_size;
+ saved_constant_size = constant_size;
+ saved_heap_size = heap_size;
+ reset_allocator_parameters (0);
+ initialize_gc (heap_size, (&heap_start), (&Free), allocate_tospace, abort_gc);
}
-\f
-/* Utilities for the garbage collector top level.
- The main garbage collector loop is in gcloop.c
-*/
-
-/* Flip into unused heap, extending constant space if we are flipping
- to the low heap, and the fudge area has shrunk.
- */
void
-DEFUN_VOID (GCFlip)
+reset_memory (void)
{
- if (((Constant_Top - Free_Constant) < CONSTANT_SPACE_FUDGE)
- && (Unused_Heap_Bottom < Heap_Bottom)
- && (update_allocator_parameters (Free_Constant)))
- SET_CONSTANT_TOP ();
- else
- {
- SCHEME_OBJECT * temp_bottom, * temp_top;
-
- temp_bottom = Unused_Heap_Bottom;
- temp_top = Unused_Heap_Top;
-
- Unused_Heap_Bottom = Heap_Bottom;
- Unused_Heap_Top = Heap_Top;
-
- Heap_Bottom = temp_bottom;
- Heap_Top = temp_top;
-
- Free = Heap_Bottom;
- }
-
- ALIGN_FLOAT (Free);
- SET_MEMTOP (Heap_Top - GC_Reserve);
-
- Weak_Chain = EMPTY_WEAK_CHAIN;
- return;
+ HEAP_FREE (memory_block_start);
+ DEALLOCATE_REGISTERS ();
}
-\f
-/* Here is the code which "prunes" objects from weak cons cells. See
- the picture in gccode.h for a description of the structure built by
- the GC. This code follows the chain of weak cells (in old space) and
- either updates the new copy's CAR with the relocated version of the
- object, or replaces it with SHARP_F.
-
- Note that this is the only code in the system, besides the inner garbage
- collector, which looks at both old and new space.
-*/
-SCHEME_OBJECT Weak_Chain;
+bool
+allocations_ok_p (unsigned long n_constant, unsigned long n_heap)
+{
+ return
+ ((memory_block_start
+ + saved_stack_size
+ + n_constant + CONSTANT_SPACE_FUDGE
+ + n_heap + DEFAULT_HEAP_RESERVED)
+ < memory_block_end);
+}
void
-DEFUN_VOID (Fix_Weak_Chain)
+reset_allocator_parameters (unsigned long n_constant)
{
- fast SCHEME_OBJECT
- * Old_Weak_Cell, * Scan, Old_Car,
- Temp, * Old, * low_heap;
-
- low_heap = Constant_Top;
- while (Weak_Chain != EMPTY_WEAK_CHAIN)
- {
- Old_Weak_Cell = (OBJECT_ADDRESS (Weak_Chain));
- Scan = (OBJECT_ADDRESS (*Old_Weak_Cell++));
- Weak_Chain = * Old_Weak_Cell;
- Old_Car = * Scan;
- Temp = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, Old_Car));
- Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
-
- switch (GC_Type (Temp))
- { case GC_Non_Pointer:
- *Scan = Temp;
- continue;
-
- case GC_Special:
- if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP)
- {
- /* No other special type makes sense here. */
- goto fail;
- }
- if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
- {
- *Scan = Temp;
- continue;
- }
- /* Otherwise, it is a pointer. Fall through */
-\f
- /* 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 SHARP_F.
- Eliminating this assignment would keep old data (pl. of datum).
- */
- case GC_Cell:
- case GC_Pair:
- case GC_Triple:
- case GC_Quadruple:
- case GC_Vector:
- Old = (OBJECT_ADDRESS (Old_Car));
- if (Old < low_heap)
- {
- *Scan = Temp;
- continue;
- }
- Normal_BH (false, continue);
- *Scan = SHARP_F;
- continue;
+ heap_reserved = DEFAULT_HEAP_RESERVED;
+ gc_space_needed = 0;
+ SET_STACK_LIMITS (memory_block_start, saved_stack_size);
+ constant_start = (memory_block_start + saved_stack_size);
+ constant_alloc_next = constant_start;
+ constant_end = (constant_alloc_next + n_constant + CONSTANT_SPACE_FUDGE);
+ heap_start = constant_end;
+ Free = heap_start;
+ heap_end = memory_block_end;
+
+ RESET_HEAP_ALLOC_LIMIT ();
+ INITIALIZE_STACK ();
+ STACK_RESET ();
+}
- case GC_Compiled:
- Old = (OBJECT_ADDRESS (Old_Car));
- if (Old < low_heap)
+static void
+allocate_tospace (unsigned long n_words,
+ SCHEME_OBJECT ** start_r, SCHEME_OBJECT ** end_r)
+{
+ if (n_words > 0)
+ {
+ SCHEME_OBJECT * p
+ = (((*start_r) == 0)
+ ? (malloc (n_words * SIZEOF_SCHEME_OBJECT))
+ : (realloc ((*start_r), (n_words * SIZEOF_SCHEME_OBJECT))));
+ if (p == 0)
{
- *Scan = Temp;
- continue;
+ outf_fatal ("Unable to allocate temporary heap for GC.\n");
+ outf_flush_fatal ();
+ exit (1);
}
- Compiled_BH (false, { *Scan = Temp; continue; });
- *Scan = SHARP_F;
- continue;
-
- case GC_Undefined:
- outf_error ("\nFix_Weak_Chain: Clearing bad object 0x%08lx.\n",
- Temp);
- *Scan = SHARP_F;
- continue;
-
- default: /* Non Marked Headers and Broken Hearts */
- fail:
- outf_fatal ("\nFix_Weak_Chain: Bad Object: 0x%08lx.\n",
- Temp);
- *Scan = SHARP_F;
+ (*start_r) = p;
+ (*end_r) = (p + n_words);
+ }
+ else if ((*start_r) != 0)
+ {
+ free (*start_r);
+ (*start_r) = 0;
+ (*end_r) = 0;
}
- }
- return;
}
-\f
-#ifdef __WIN32__
static void
-win32_flush_old_halfspace ()
-{
- /* Since we allocated the heap with VirtualAlloc, we can decommit the old
- half-space to tell the VM system that it contains trash.
- Immediately recommitting the region allows the old half-space to be used
- for temporary storage (e.g. by fasdump).
- Note that this is only a win when it prevents paging. When no paging
- would have happened, we incur the cost of zero-filling the recommitted
- pages. This can be significant - up to 50% of the time taken to GC, but
- usually somewhat less.
-
- We are careful to play with pages that are strictly within the old
- half-space, hence the `pagesize' arithmetic.
- */
- long pagesize = 4096;
- void *base =
- ((void*)
- (((DWORD)((char*)Unused_Heap_Bottom + pagesize)) & ~(pagesize-1)));
- DWORD len =
- ((DWORD)(((char*)Unused_Heap_Top) - ((char*)base))) & ~(pagesize-1);
- VirtualFree (base, len, MEM_DECOMMIT);
- VirtualAlloc (base, len, MEM_COMMIT, PAGE_READWRITE);
-}
-
-
-static BOOL win32_flush_old_halfspace_p = FALSE;
-
-void
-win32_advise_end_GC ()
-{
- if (win32_flush_old_halfspace_p)
- win32_flush_old_halfspace ();
-}
-#endif /* __WIN32__ */
-
-DEFINE_PRIMITIVE ("WIN32-FLUSH-OLD-HALFSPACE-AFTER-GC?!", Prim_win32_flush_old_halfspace_after_gc, 1, 1,
- "(boolean)")
+abort_gc (void)
{
- PRIMITIVE_HEADER (1);
-#ifdef __WIN32__
- {
- BOOL old = win32_flush_old_halfspace_p;
- win32_flush_old_halfspace_p = (OBJECT_TO_BOOLEAN (ARG_REF (1)));
- PRIMITIVE_RETURN (old ? SHARP_T : SHARP_F);
- }
-#else
- error_unimplemented_primitive ();
- PRIMITIVE_RETURN (SHARP_F);
-#endif
+ Microcode_Termination (TERM_EXIT);
}
-DEFINE_PRIMITIVE ("WIN32-FLUSH-OLD-HALFSPACE!", Prim_win32_flush_old_halfspace, 0, 0,
- "()")
+bool
+object_in_heap_p (SCHEME_OBJECT object)
{
- PRIMITIVE_HEADER (0);
-#ifdef __WIN32__
- win32_flush_old_halfspace ();
-#else
- error_unimplemented_primitive ();
-#endif
- PRIMITIVE_RETURN (UNSPECIFIC);
+ SCHEME_OBJECT * address = (get_object_address (object));
+ return ((address != 0) && (ADDRESS_IN_HEAP_P (address)));
}
\f
-/* Here is the set up for the full garbage collection:
-
- - First it saves away all the relevant microcode registers into new
- space, making this the root for garbage collection.
-
- - Then it does the actual garbage collection in 4 steps:
- 1) Trace the stack and constant space (contiguous).
- 2) Trace objects pointed out by the root and constant space.
- 3) Trace the precious objects, remembering where consing started.
- 4) Update all weak pointers.
-
- - Finally it restores the microcode registers from the copies in
- new space.
-*/
-\f
-void
-DEFUN_VOID (GC)
+DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1,
+ "(SAFETY-MARGIN)\n\
+Performs a garbage collection and returns the number of words\n\
+available for further allocation. Also sets the "safety margin",\n\
+which is the number of reserved words at the top of the heap, to\n\
+SAFETY-MARGIN, which must be a non-negative integer. Finally, runs\n\
+the primitive GC daemons before returning.")
{
- Boolean hunting_wabbits_p;
- SCHEME_OBJECT
- * Root, * Result, * Check_Value,
- The_Precious_Objects, * Root2;
- SCHEME_OBJECT wabbit_descriptor;
- SCHEME_OBJECT *
- EXFUN ((* transport_loop), (SCHEME_OBJECT *, SCHEME_OBJECT **));
-
- wabbit_descriptor = (Get_Fixed_Obj_Slot (GC_WABBIT_DESCRIPTOR));
- if ((! (VECTOR_P (wabbit_descriptor)))
- || ((VECTOR_LENGTH (wabbit_descriptor)) != 4)
- || ((VECTOR_REF (wabbit_descriptor, 0)) != SHARP_F)
- || (! (VECTOR_P (VECTOR_REF (wabbit_descriptor, 1))))
- || ((OBJECT_ADDRESS (VECTOR_REF (wabbit_descriptor, 1))) < Constant_Top)
- || (! (VECTOR_P (VECTOR_REF (wabbit_descriptor, 2))))
- || ((OBJECT_ADDRESS (VECTOR_REF (wabbit_descriptor, 2))) < Constant_Top)
- || ((VECTOR_LENGTH (VECTOR_REF (wabbit_descriptor, 2)))
- < (2 + (2 * (VECTOR_LENGTH (VECTOR_REF (wabbit_descriptor, 1)))))))
- {
- hunting_wabbits_p = false;
- transport_loop = GCLoop;
- }
- else
- {
- hunting_wabbits_p = true;
- transport_loop = wabbit_hunting_gcloop;
- }
+ PRIMITIVE_HEADER (1);
+ canonicalize_primitive_context ();
- /* Save the microcode registers so that they can be relocated */
-
- Terminate_Old_Stacklet ();
- SEAL_CONSTANT_SPACE ();
- Check_Value = (CONSTANT_AREA_END ());
- The_Precious_Objects = (Get_Fixed_Obj_Slot (Precious_Objects));
- Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F);
- Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F);
-
- if (hunting_wabbits_p)
- wabbit_season (wabbit_descriptor);
-
- Root = Free;
- *Free++ = Fixed_Objects;
- *Free++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
- *Free++ = Get_Current_Stacklet ();
- *Free++ =
- ((Prev_Restore_History_Stacklet == NULL)
- ? SHARP_F
- : (MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
- Prev_Restore_History_Stacklet)));
- *Free++ = Current_State_Point;
- *Free++ = Fluid_Bindings;
-\f
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
- if (gc_objects_referencing != SHARP_F)
+ STACK_CHECK_FATAL ("GC");
+ if (Free > heap_end)
{
- MEMORY_SET
- (gc_objects_referencing, 0,
- (MAKE_OBJECT
- (TC_MANIFEST_NM_VECTOR,
- (OBJECT_DATUM (MEMORY_REF (gc_objects_referencing, 0))))));
- {
- SCHEME_OBJECT * scan = (VECTOR_LOC (gc_objects_referencing, 0));
- SCHEME_OBJECT * end =
- (VECTOR_LOC (gc_objects_referencing,
- (VECTOR_LENGTH (gc_objects_referencing))));
- while (scan < end)
- (*scan++) = SHARP_F;
- }
- *Free++ = gc_objects_referencing;
- gc_objects_referencing_count = 0;
- gc_objects_referencing_scan =
- (VECTOR_LOC (gc_objects_referencing, 1));
- gc_objects_referencing_end =
- (VECTOR_LOC (gc_objects_referencing,
- (VECTOR_LENGTH (gc_objects_referencing))));
+ outf_fatal ("\nGC has been delayed too long!\n");
+ outf_fatal
+ ("Free = %#lx; heap_alloc_limit = %#lx; heap_end = %#lx\n",
+ ((unsigned long) Free),
+ ((unsigned long) heap_alloc_limit),
+ ((unsigned long) heap_end));
+ Microcode_Termination (TERM_NO_SPACE);
}
-#endif
- /* The 4 step GC */
+ heap_reserved = (ARG_HEAP_RESERVED (1));
+ POP_PRIMITIVE_FRAME (1);
- Result = ((* transport_loop) ((CONSTANT_AREA_START ()), &Free));
- if (Result != Check_Value)
- {
- outf_fatal ("\nGC: Constant Scan ended too early.\n");
- Microcode_Termination (TERM_BROKEN_HEART);
- }
+ ENTER_CRITICAL_SECTION ("garbage collector");
- Result = ((* transport_loop) (Root, &Free));
- if (Free != Result)
- {
- outf_fatal ("\nGC-1: Heap Scan ended too early.\n");
- Microcode_Termination (TERM_BROKEN_HEART);
- }
+ open_tospace (heap_start);
+ initialize_weak_chain ();
+
+ std_gc_pt1 ();
+ std_gc_pt2 ();
- Root2 = Free;
- *Free++ = The_Precious_Objects;
- Result = ((* transport_loop) (Root2, &Free));
- if (Free != Result)
+ Will_Push (CONTINUATION_SIZE);
+ SET_RC (RC_NORMAL_GC_DONE);
+ SET_EXP (ULONG_TO_FIXNUM ((HEAP_AVAILABLE > gc_space_needed)
+ ? (HEAP_AVAILABLE - gc_space_needed)
+ : 0));
+ SAVE_CONT ();
+ Pushed ();
+
+ RENAME_CRITICAL_SECTION ("garbage collector daemon");
{
- outf_fatal ("\nGC-2: Heap Scan ended too early.\n");
- Microcode_Termination (TERM_BROKEN_HEART);
+ SCHEME_OBJECT daemon = (VECTOR_REF (fixed_objects, GC_DAEMON));
+ if (daemon == SHARP_F)
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
+
+ Will_Push (2);
+ STACK_PUSH (daemon);
+ PUSH_APPLY_FRAME_HEADER (0);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
}
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
\f
+static SCHEME_OBJECT * saved_to;
+
+void
+std_gc_pt1 (void)
+{
#ifdef ENABLE_GC_DEBUGGING_TOOLS
- if (gc_objects_referencing != SHARP_F)
- {
- UPDATE_GC_OBJECTS_REFERENCING ();
- MEMORY_SET
- (gc_objects_referencing, 0,
- (MAKE_OBJECT
- (TC_MANIFEST_VECTOR,
- (OBJECT_DATUM (MEMORY_REF (gc_objects_referencing, 0))))));
- VECTOR_SET (gc_objects_referencing, 0,
- (LONG_TO_UNSIGNED_FIXNUM (gc_objects_referencing_count)));
- {
- SCHEME_OBJECT * end = gc_objects_referencing_scan;
- Result = (GCLoop ((VECTOR_LOC (gc_objects_referencing, 1)), (&end)));
- if ((end != Result) || (end != gc_objects_referencing_scan))
- {
- outf_fatal ("\nGC-3: Heap Scan ended too early.\n");
- Microcode_Termination (TERM_BROKEN_HEART);
- }
- }
- gc_objects_referencing = SHARP_F;
- gc_object_referenced = SHARP_F;
- }
+ initialize_gc_object_references ();
#endif
- if (hunting_wabbits_p)
- fix_weak_chain_and_hunt_wabbits ();
- else
- Fix_Weak_Chain ();
-
- /* Make the microcode registers point to the copies in new-space. */
+ saved_to = (get_newspace_ptr ());
+ add_to_tospace (fixed_objects);
+ add_to_tospace
+ (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
+ add_to_tospace (current_state_point);
- Fixed_Objects = *Root++;
- Set_Fixed_Obj_Slot (Precious_Objects, *Root2);
- Set_Fixed_Obj_Slot
- (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2))));
+ current_gc_table = (std_gc_table ());
+ gc_scan_oldspace (stack_pointer, stack_end);
+ gc_scan_oldspace (constant_start, constant_alloc_next);
+ gc_scan_tospace (saved_to, 0);
- history_register = (OBJECT_ADDRESS (*Root++));
-
- Set_Current_Stacklet (*Root);
- Root += 1;
- if (*Root == SHARP_F)
- {
- Prev_Restore_History_Stacklet = NULL;
- Root += 1;
- }
- else
- Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*Root++));
- Current_State_Point = *Root++;
- Fluid_Bindings = *Root++;
- Free_Stacklets = NULL;
-
- if (hunting_wabbits_p)
- {
- wabbit_descriptor = (Get_Fixed_Obj_Slot (GC_WABBIT_DESCRIPTOR));
- duck_season (wabbit_descriptor);
- }
-
- COMPILER_TRANSPORT_END ();
-
-#ifdef __WIN32__
- {
- extern void win32_advise_end_GC ();
- win32_advise_end_GC ();
- }
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ finalize_gc_object_references ();
#endif
-
- CLEAR_INTERRUPT (INT_GC);
- return;
+ update_weak_pointers ();
}
-\f
-/* (GARBAGE-COLLECT SLACK)
- Requests a garbage collection leaving the specified amount of slack
- for the top of heap check on the next GC. The primitive ends by invoking
- the GC daemon if there is one.
- This primitive never returns normally. It always escapes into
- the interpreter because some of its cached registers (e.g.
- history_register) have changed. */
-
-DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
+void
+std_gc_pt2 (void)
{
- extern unsigned long gc_counter;
- SCHEME_OBJECT daemon;
- PRIMITIVE_HEADER (1);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
-
- STACK_SANITY_CHECK ("GC");
- if (Free > Heap_Top)
- {
- outf_fatal ("\nGARBAGE-COLLECT: GC has been delayed too long!\n");
- outf_fatal ("Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n",
- Free, MemTop, Heap_Top);
- Microcode_Termination (TERM_NO_SPACE);
- }
+ SCHEME_OBJECT * p = (get_newspace_ptr ());
+ (void) save_tospace (save_tospace_copy, 0);
+ Free = p;
- GC_Reserve = (arg_nonnegative_integer (1));
- POP_PRIMITIVE_FRAME (1);
+ fixed_objects = (*saved_to++);
+ history_register = (OBJECT_ADDRESS (*saved_to++));
+ current_state_point = (*saved_to++);
+ saved_to = 0;
- ENTER_CRITICAL_SECTION ("garbage collector");
- run_pre_gc_hooks ();
- gc_counter += 1;
- GCFlip ();
- GC ();
- run_post_gc_hooks ();
- daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
-
- Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_NORMAL_GC_DONE);
- exp_register = (LONG_TO_FIXNUM (MemTop - Free - GC_Space_Needed));
- Save_Cont ();
- Pushed ();
+ CC_TRANSPORT_END ();
+ CLEAR_INTERRUPT (INT_GC);
+}
- RENAME_CRITICAL_SECTION ("garbage collector daemon");
- if (daemon == SHARP_F)
- PRIMITIVE_ABORT (PRIM_POP_RETURN);
- /*NOTREACHED*/
+static bool
+save_tospace_copy (SCHEME_OBJECT * start, SCHEME_OBJECT * end, void * p)
+{
+ (void) memmove ((tospace_to_newspace (start)),
+ start,
+ ((end - start) * SIZEOF_SCHEME_OBJECT));
+ return (true);
+}
- Will_Push (2);
- STACK_PUSH (daemon);
- STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
+void
+stack_death (const char * name)
+{
+ outf_fatal
+ ("\n%s: The stack has overflowed and overwritten adjacent memory.\n",
+ name);
+ outf_fatal ("This was probably caused by a runaway recursion.\n");
+ Microcode_Termination (TERM_STACK_OVERFLOW);
/*NOTREACHED*/
- PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
DEFINE_PRIMITIVE ("GC-TRACE-REFERENCES", Prim_gc_trace_references, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
{
- SCHEME_OBJECT objects_referencing = (ARG_REF (2));
- if (! ((objects_referencing == SHARP_F)
- || ((VECTOR_P (objects_referencing))
- && ((VECTOR_LENGTH (objects_referencing)) >= 1))))
+ SCHEME_OBJECT collector = (ARG_REF (2));
+ if (! ((collector == SHARP_F)
+ || ((VECTOR_P (collector))
+ && ((VECTOR_LENGTH (collector)) >= 1))))
error_wrong_type_arg (2);
#ifdef ENABLE_GC_DEBUGGING_TOOLS
- gc_object_referenced = (ARG_REF (1));
- gc_objects_referencing = objects_referencing;
-#else /* not ENABLE_GC_DEBUGGING_TOOLS */
+ collect_gc_object_references ((ARG_REF (1)), collector);
+#else
error_external_return ();
-#endif /* not ENABLE_GC_DEBUGGING_TOOLS */
+#endif
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-void
-DEFUN (check_transport_vector_lossage, (Scan, Saved_Scan, To),
- SCHEME_OBJECT * Scan
- AND SCHEME_OBJECT * Saved_Scan
- AND SCHEME_OBJECT * To)
-{
- outf_fatal ("\nBad transport_vector limit:\n");
- outf_fatal (" limit = 0x%lx\n", ((long) Scan));
- outf_fatal (" Scan = 0x%lx\n", ((long) Saved_Scan));
- outf_fatal (" To = 0x%lx\n", ((long) To));
- outf_flush_fatal ();
- abort ();
-}
/* -*-C-*-
-$Id: memmag.h,v 1.12 2007/01/05 21:19:25 cph Exp $
+$Id: memmag.h,v 1.13 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* OS-dependent conditionalization of memory management stuff. */
+/* Memory management */
\f
#ifndef SCM_MEMMAG_H
-#define SCM_MEMMAG_H
+#define SCM_MEMMAG_H 1
-#ifdef __WIN32__
- extern void win32_allocate_registers (void);
- extern void win32_deallocate_registers (void);
-# define ALLOCATE_REGISTERS win32_allocate_registers
-# define DEALLOCATE_REGISTERS win32_deallocate_registers
+/* Overflow detection, various cases */
-# include "ntscmlib.h"
+#define GC_ENABLED_P() (INTERRUPT_ENABLED_P (INT_GC))
- extern BOOL win32_under_win32s_p (void);
+#define HEAP_AVAILABLE \
+ ((unsigned long) ((FREE_OK_P (Free)) ? (heap_alloc_limit - Free) : 0))
- extern char * NT_allocate_heap (unsigned long, unsigned long *);
- extern void NT_release_heap (char *, unsigned long);
-# define WIN32_ALLOCATE_HEAP NT_allocate_heap
-# define WIN32_RELEASE_HEAP NT_release_heap
+#define FREE_OK_P(free) \
+ (((free) >= heap_start) && ((free) < heap_alloc_limit))
- static unsigned long scheme_heap_handle;
-#endif
+#define HEAP_AVAILABLE_P(n_words) \
+ ((FREE_OK_P (Free)) && ((Free + (n_words)) <= heap_alloc_limit))
-#ifndef HEAP_FREE
-# define HEAP_FREE free
-#endif
+#define GC_NEEDED_P(n_words) \
+ ((!HEAP_AVAILABLE_P (n_words)) && (GC_ENABLED_P ()))
-#ifndef ALLOCATE_REGISTERS
-# define ALLOCATE_REGISTERS() do { } while (0)
-#endif
+#define SPACE_BEFORE_GC() \
+ ((GC_ENABLED_P ()) \
+ ? HEAP_AVAILABLE \
+ : (ADDRESS_IN_HEAP_P (Free)) \
+ ? ((unsigned long) (heap_end - Free)) \
+ : 0)
+
+#define REQUEST_GC(n_words) do \
+{ \
+ REQUEST_INTERRUPT (INT_GC); \
+ gc_space_needed = (n_words); \
+} while (0)
+
+#define RESET_HEAP_ALLOC_LIMIT() do \
+{ \
+ heap_alloc_limit = (heap_end - heap_reserved); \
+ COMPILER_SETUP_INTERRUPT (); \
+} while (0)
+
+#define ARG_HEAP_RESERVED(n) \
+ (arg_ulong_index_integer ((n), ((heap_end - heap_start) / 2)))
-#ifndef DEALLOCATE_REGISTERS
-# define DEALLOCATE_REGISTERS() do { } while (0)
+#define ADDRESS_IN_MEMORY_BLOCK_P(address) \
+ (((address) >= memory_block_start) && ((address) < memory_block_end))
+
+#define ADDRESS_IN_HEAP_P(address) \
+ (((address) >= heap_start) && ((address) < heap_end))
+
+#define ADDRESS_IN_STACK_P(address) \
+ (((address) >= stack_start) && ((address) < stack_end))
+
+#define ADDRESS_IN_CONSTANT_P(address) \
+ (((address) >= constant_start) && ((address) < constant_end))
+
+/* buffer for impurify, etc. */
+#ifndef CONSTANT_SPACE_FUDGE
+# define CONSTANT_SPACE_FUDGE 128
#endif
+extern bool allocations_ok_p (unsigned long, unsigned long);
+extern void reset_allocator_parameters (unsigned long);
+extern bool object_in_heap_p (SCHEME_OBJECT);
+extern void std_gc_pt1 (void);
+extern void std_gc_pt2 (void);
+extern void stack_death (const char *) NORETURN;
+
#endif /* SCM_MEMMAG_H */
/* -*-C-*-
-$Id: missing.c,v 9.37 2007/01/05 21:19:25 cph Exp $
+$Id: missing.c,v 9.38 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#ifndef HAVE_FREXP
double
-DEFUN (frexp, (value, eptr),
- double value
- AND int * eptr)
+frexp (double value, int * eptr)
{
- register double x = ((value < 0) ? (-value) : value);
+ double x = ((value < 0) ? (-value) : value);
int e = 0;
if (x >= 1)
{
{
if (x > 2)
{
- register double xr = (x / 2);
- register double r = 2;
- register int n = 1;
+ double xr = (x / 2);
+ double r = 2;
+ int n = 1;
while (xr >= r)
{
/* ((xr == (x / r)) && (xr >= r) && (x >= (r * r))) */
{
if (x < 0.25)
{
- register double xr = (x * 2);
- register double r = 0.5;
- register int n = 1;
+ double xr = (x * 2);
+ double r = 0.5;
+ int n = 1;
/* ((xr == (x / r)) && (xr < 0.5) && (x < (r / 2))) */
while (xr < (r / 2))
{
}
\f
double
-DEFUN (ldexp, (value, exponent),
- double value
- AND int exponent)
+ldexp (double value, int exponent)
{
- register double x = value;
- register int e = exponent;
- register double r = 2;
+ double x = value;
+ int e = exponent;
+ double r = 2;
if (e > 0)
{
if (e == 1)
#ifndef HAVE_MODF
double
-DEFUN (modf, (value, iptr),
- double value
- AND double * iptr)
+modf (double value, double * iptr)
{
int exponent;
double significand = (frexp (value, (&exponent)));
return (value);
}
{
- register double s =
+ double s =
((((significand < 0) ? (-significand) : significand) * 2) - 1);
- register int e = (exponent - 1);
- register double n = 1;
+ int e = (exponent - 1);
+ double n = 1;
while (1)
{
if (e == 0)
if (s <= 0)
{
/* Multiply n by 2^e */
- register double b = 2;
+ double b = 2;
if (e == 0)
break;
while (1)
#ifndef HAVE_FLOOR
double
-DEFUN (floor, (x), double x)
+floor (double x)
{
double iptr;
double fraction = (modf (x, (&iptr)));
}
double
-DEFUN (ceil, (x), double x)
+ceil (double x)
{
double iptr;
double fraction = (modf (x, (&iptr)));
#ifdef DEBUG_MISSING
-#include <stdio.h>
-
main ()
{
double input;
/* -*-C-*-
-$Id: mul.c,v 9.39 2007/01/05 21:19:25 cph Exp $
+$Id: mul.c,v 9.40 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
version has only been tried on machines with long = 32 bits. This
file is included in the appropriate os file. */
\f
-extern SCHEME_OBJECT
- EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT));
-
#if (TYPE_CODE_LENGTH == 8)
#if defined(vax) && defined(__unix__)
*/
SCHEME_OBJECT
-DEFUN (Mul, (Arg1, Arg2),
- SCHEME_OBJECT Arg1
- AND SCHEME_OBJECT Arg2)
+Mul (SCHEME_OBJECT Arg1,
+ SCHEME_OBJECT Arg2)
{
- register long A = (FIXNUM_TO_LONG (Arg1));
- register long B = (FIXNUM_TO_LONG (Arg2));
+ long A = (FIXNUM_TO_LONG (Arg1));
+ long B = (FIXNUM_TO_LONG (Arg2));
#if __GNUC__
#if FALSE
/* GCC isn't yet efficient enough with `long long' -- KR. */
{
- register long long X;
+ long long X;
asm ("emul %1,%2,$0,%0" : "=g" (X) : "g" (A), "g" (B));
return
((((X & (-1 << 23)) == 0) ||
#else
/* non-long-long version: */
{
- register struct
+ struct
{
long low;
long high;
#define ABS(x) (((x) < 0) ? -(x) : (x))
SCHEME_OBJECT
-DEFUN (Mul, (Arg1, Arg2),
- SCHEME_OBJECT Arg1
- AND SCHEME_OBJECT Arg2)
+Mul (SCHEME_OBJECT Arg1,
+ SCHEME_OBJECT Arg2)
{
long A, B, C;
- fast unsigned long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
- Boolean Sign;
+ unsigned long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
+ bool Sign;
A = (FIXNUM_TO_LONG (Arg1));
B = (FIXNUM_TO_LONG (Arg2));
/* -*-C-*-
-$Id: nt.h,v 1.13 2007/01/05 21:19:25 cph Exp $
+$Id: nt.h,v 1.14 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include <io.h>
#include <conio.h>
#include <sys/stat.h>
-#include <stdio.h>
-#include <stdlib.h>
#include <direct.h>
#include <signal.h>
#include <errno.h>
extern enum windows_type NT_windows_type;
#ifndef ERRNO_NONBLOCK
-#define ERRNO_NONBLOCK 1998
+# define ERRNO_NONBLOCK 1998
#endif
#ifndef EINTR
-#define EINTR 1999
+# define EINTR 1999
#endif
#include "config.h"
-
#include "intext.h"
#include "dstack.h"
#include "osscheme.h"
#include "ntsys.h"
#include "syscall.h"
#include "ntapi.h"
-#include <limits.h>
#include <time.h>
/* Crufty, but it will work here. */
#endif
\f
#ifndef DECL_GETLOGIN
-extern char * EXFUN (getlogin, (void));
+extern char * getlogin (void);
#endif
#ifdef _NFILE
/* -*-C-*-
-$Id: ntenv.c,v 1.23 2007/01/05 21:19:25 cph Exp $
+$Id: ntenv.c,v 1.24 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "nt.h"
#include "osenv.h"
#include "ntscreen.h"
-#include <stdlib.h>
-#include <string.h>
\f
extern unsigned long file_time_to_unix_time (FILETIME *);
extern void unix_time_to_file_time (unsigned long, FILETIME *);
#endif
time_t
-DEFUN_VOID (OS_encoded_time)
+OS_encoded_time (void)
{
SYSTEMTIME t;
GetSystemTime (&t);
(((4294967296.0 * (double) ft.dwHighDateTime) + ft.dwLowDateTime)*100e-6)
double
-DEFUN_VOID (OS_process_clock)
+OS_process_clock (void)
{
/* This must not signal an error in normal use. */
/* Return answer in milliseconds, was in 1/100th seconds */
}
double
-DEFUN_VOID (OS_real_time_clock)
+OS_real_time_clock (void)
{
return ((((double) (clock ())) * 1000.0) / ((double) CLOCKS_PER_SEC));
}
extern HANDLE master_tty_window;
static void
-DEFUN (clear_timer, (timer_id), int timer_id)
+clear_timer (int timer_id)
{
struct timer_state_s * timer = &scheme_timers[timer_id - TIMER_ID_BASE];
if (timer->global_id != 0)
return;
}
\f
-extern VOID /* CALLBACK */ EXFUN (TimerProc, (HWND, UINT, UINT, DWORD));
+extern VOID /* CALLBACK */ TimerProc (HWND, UINT, UINT, DWORD);
#define THE_TIMER_PROC ((TIMERPROC) NULL) /* TimerProc */
VOID /* CALLBACK */
-DEFUN (TimerProc, (hwnd, umsg, timer_id, dwtime),
- HWND hwnd AND UINT umsg AND UINT timer_id AND DWORD dwtime)
+TimerProc (HWND hwnd, UINT umsg, UINT timer_id, DWORD dwtime)
{
if (hwnd == master_tty_window)
{
THE_TIMER_PROC));
timer->next = timer_next_normal;
break;
-
+
case timer_next_normal:
break;
case timer_next_none:
case timer_next_disable:
- default:
+ default:
clear_timer (timer_id);
break;
}
}
\f
static void
-DEFUN (set_timer, (timer_id, first, interval),
- int timer_id AND clock_t first AND clock_t interval)
+set_timer (int timer_id, clock_t first, clock_t interval)
{
struct timer_state_s * timer = &scheme_timers[timer_id - TIMER_ID_BASE];
if (timer->global_id != 0)
KillTimer (master_tty_window, timer->global_id);
timer->global_id = 0;
}
-
+
timer->period = interval;
if ((first == 0) || (interval == first))
timer->next = timer_next_normal;
struct timer_state_s scheme_timers[3] = { { 0, 0, }, { 0, 0, }, { 0, 0, } };
-extern void EXFUN (low_level_timer_tick, (void));
+extern void low_level_timer_tick (void);
void
-DEFUN_VOID (low_level_timer_tick)
+low_level_timer_tick (void)
{
int i;
int number_signalled = 0;
}
static void
-DEFUN (set_timer, (timer_id, first, interval),
- int timer_id AND clock_t first AND clock_t interval)
+set_timer (int timer_id, clock_t first, clock_t interval)
{
struct timer_state_s * timer = &scheme_timers[timer_id];
- /* Round up. */
+ /* Round up. */
timer->counter = ((first + 49) / 50);
timer->reload = ((interval + 49) / 50);
return;
}
static void
-DEFUN (clear_timer, (timer_id), int timer_id)
+clear_timer (int timer_id)
{
struct timer_state_s * timer = &scheme_timers[timer_id];
#endif /* USE_WM_TIMER */
\f
void
-DEFUN (OS_process_timer_set, (first, interval),
- clock_t first AND clock_t interval)
+OS_process_timer_set (clock_t first, clock_t interval)
{
set_timer (TIMER_ID_PROCESS, first, interval);
return;
}
void
-DEFUN_VOID (OS_process_timer_clear)
+OS_process_timer_clear (void)
{
clear_timer (TIMER_ID_PROCESS);
return;
}
void
-DEFUN (OS_profile_timer_set, (first, interval),
- clock_t first AND clock_t interval)
+OS_profile_timer_set (clock_t first, clock_t interval)
{
set_timer (TIMER_ID_PROFILE, first, interval);
return;
}
void
-DEFUN_VOID (OS_profile_timer_clear)
+OS_profile_timer_clear (void)
{
clear_timer (TIMER_ID_PROFILE);
return;
}
void
-DEFUN (OS_real_timer_set, (first, interval),
- clock_t first AND clock_t interval)
+OS_real_timer_set (clock_t first, clock_t interval)
{
set_timer (TIMER_ID_REAL, first, interval);
return;
}
void
-DEFUN_VOID (OS_real_timer_clear)
+OS_real_timer_clear (void)
{
clear_timer (TIMER_ID_REAL);
return;
static size_t current_dir_path_size = 0;
static char * current_dir_path = 0;
-CONST char *
-DEFUN_VOID (OS_working_dir_pathname)
+const char *
+OS_working_dir_pathname (void)
{
if (current_dir_path) {
return (current_dir_path);
}
void
-DEFUN (OS_set_working_dir_pathname, (name), CONST char * name)
+OS_set_working_dir_pathname (const char * name)
{
size_t name_size = (strlen (name));
- CONST char * filename = name;
+ const char * filename = name;
STD_BOOL_API_CALL (SetCurrentDirectory, (filename));
/* -*-C-*-
-$Id: ntfs.c,v 1.33 2007/01/05 21:19:25 cph Exp $
+$Id: ntfs.c,v 1.34 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define X_OK 1
int
-DEFUN (OS_file_access, (name, mode), CONST char * name AND unsigned int mode)
+OS_file_access (const char * name, unsigned int mode)
{
BY_HANDLE_FILE_INFORMATION info;
if ((NT_get_file_info (name, (&info), 1)) != gfi_ok)
}
int
-DEFUN (OS_file_directory_p, (name), CONST char * name)
+OS_file_directory_p (const char * name)
{
BY_HANDLE_FILE_INFORMATION info;
return
&& (((info . dwFileAttributes) & FILE_ATTRIBUTE_DIRECTORY) != 0));
}
-CONST char *
-DEFUN (OS_file_soft_link_p, (name), CONST char * name)
+const char *
+OS_file_soft_link_p (const char * name)
{
return (0);
}
static void
-DEFUN (guarantee_writable, (name, errorp),
- CONST char * name AND
+guarantee_writable (const char * name,
int errorp)
{
DWORD attributes = (GetFileAttributes (name));
}
void
-DEFUN (OS_file_remove, (name), CONST char * name)
+OS_file_remove (const char * name)
{
guarantee_writable (name, 1);
STD_BOOL_API_CALL (DeleteFile, (name));
}
void
-DEFUN (OS_file_remove_link, (name), CONST char * name)
+OS_file_remove_link (const char * name)
{
struct stat s;
if ((stat (name, (&s)) == 0)
}
void
-DEFUN (OS_file_rename, (from, to),
- CONST char * from AND
- CONST char * to)
+OS_file_rename (const char * from, const char * to)
{
guarantee_writable (to, 1);
STD_BOOL_API_CALL (MoveFile, (from, to));
}
void
-DEFUN (OS_file_copy, (from, to),
- CONST char * from AND
- CONST char * to)
+OS_file_copy (const char * from, const char * to)
{
guarantee_writable (to, 1);
STD_BOOL_API_CALL (CopyFile, (from, to, FALSE));
}
void
-DEFUN (OS_file_link_hard, (from_name, to_name),
- CONST char * from_name AND
- CONST char * to_name)
+OS_file_link_hard (const char * from_name, const char * to_name)
{
error_unimplemented_primitive ();
}
void
-DEFUN (OS_file_link_soft, (from_name, to_name),
- CONST char * from_name AND
- CONST char * to_name)
+OS_file_link_soft (const char * from_name, const char * to_name)
{
error_unimplemented_primitive ();
}
void
-DEFUN (OS_directory_make, (name), CONST char * name)
+OS_directory_make (const char * name)
{
STD_BOOL_API_CALL (CreateDirectory, (name, 0));
}
void
-DEFUN (OS_directory_delete, (name), CONST char * name)
+OS_directory_delete (const char * name)
{
STD_BOOL_API_CALL (RemoveDirectory, (name));
}
\f
-static void EXFUN (protect_fd, (int fd));
+static void protect_fd (int fd);
int
OS_file_touch (const char * filename)
}
static void
-DEFUN (protect_fd_close, (ap), PTR ap)
+protect_fd_close (void * ap)
{
close (* ((int *) ap));
}
static void
-DEFUN (protect_fd, (fd), int fd)
+protect_fd (int fd)
{
int * p = (dstack_alloc (sizeof (int)));
(*p) = fd;
static unsigned int n_directory_pointers;
void
-DEFUN_VOID (NT_initialize_directory_reader)
+NT_initialize_directory_reader (void)
{
directory_pointers = 0;
n_directory_pointers = 0;
}
static unsigned int
-DEFUN (allocate_directory_pointer, (pointer), nt_dir * pointer)
+allocate_directory_pointer (nt_dir * pointer)
{
if (n_directory_pointers == 0)
{
unsigned int result = n_directory_pointers;
unsigned int n_pointers = (2 * n_directory_pointers);
nt_dir ** pointers
- = (OS_realloc (((PTR) directory_pointers),
+ = (OS_realloc (((void *) directory_pointers),
((sizeof (nt_dir *)) * n_pointers)));
{
nt_dir ** scan = (pointers + result);
#define DEALLOCATE_DIRECTORY(index) ((directory_pointers[(index)]) = 0)
int
-DEFUN (OS_directory_valid_p, (index), long index)
+OS_directory_valid_p (unsigned int index)
{
return
- ((0 <= index)
- && (index < (long) n_directory_pointers)
+ ((index < n_directory_pointers)
&& ((REFERENCE_DIRECTORY (index)) != 0));
}
\f
unsigned int
-DEFUN (OS_directory_open, (name), CONST char * search_pattern)
+OS_directory_open (const char * search_pattern)
{
char pattern [MAX_PATH];
nt_dir * dir = (OS_malloc (sizeof (nt_dir)));
return (1);
}
-CONST char *
-DEFUN (OS_directory_read, (index), unsigned int index)
+const char *
+OS_directory_read (unsigned int index)
{
static WIN32_FIND_DATA info;
return
: 0);
}
-CONST char *
-DEFUN (OS_directory_read_matching, (index, prefix),
- unsigned int index AND
- CONST char * prefix)
+const char *
+OS_directory_read_matching (unsigned int index, const char * prefix)
{
unsigned int n = (strlen (prefix));
while (1)
{
- CONST char * pathname = (OS_directory_read (index));
+ const char * pathname = (OS_directory_read (index));
if (pathname == 0)
return (0);
if ((strnicmp (pathname, prefix, n)) == 0)
}
void
-DEFUN (OS_directory_close, (index), unsigned int index)
+OS_directory_close (unsigned int index)
{
nt_dir * dir = (REFERENCE_DIRECTORY (index));
if (dir)
/* -*-C-*-
-$Id: ntgui.c,v 1.33 2007/01/05 21:19:25 cph Exp $
+$Id: ntgui.c,v 1.34 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <string.h>
-#include <stdarg.h>
#include "scheme.h"
#include "prims.h"
#include "os.h"
}
BOOL
-DEFUN (InitApplication, (hInstance), HANDLE hInstance)
+InitApplication (HANDLE hInstance)
{
static BOOL done = FALSE;
if (done) return (TRUE);
static BOOL instance_initialized = FALSE;
BOOL
-DEFUN (InitInstance, (hInstance, nCmdShow), HANDLE hInstance AND int nCmdShow)
+InitInstance (HANDLE hInstance, int nCmdShow)
{
instance_initialized = TRUE;
return (Screen_InitInstance (hInstance, nCmdShow));
}
void
-DEFUN_VOID (nt_gui_default_poll)
+nt_gui_default_poll (void)
{
MSG msg;
int events_processed = 0;
}
}
-extern void EXFUN (NT_gui_init, (void));
+extern void NT_gui_init (void);
void
-DEFUN_VOID (NT_gui_init)
+NT_gui_init (void)
{
if (!instance_initialized)
{
return integer_to_long (thing);
if (STRING_P (thing))
- return (long) STRING_LOC (thing, 0);
+ return (long) (STRING_POINTER (thing));
if (thing==SHARP_F)
return 0;
PRIMITIVE_HEADER(1);
{
SCHEME_OBJECT wndproc = ARG_REF(1);
- if (! (ADDRESS_CONSTANT_P (OBJECT_ADDRESS (wndproc))))
+ if (!ADDRESS_IN_CONSTANT_P (OBJECT_ADDRESS (wndproc)))
signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE);
general_scheme_wndproc = wndproc;
PRIMITIVE_RETURN (UNSPECIFIC);
}
static unsigned long
-DEFUN (arg_ulong_default, (arg_number, def),
- int arg_number AND unsigned long def)
+arg_ulong_default (int arg_number, unsigned long def)
{
- fast SCHEME_OBJECT object = (ARG_REF (arg_number));
+ SCHEME_OBJECT object = (ARG_REF (arg_number));
if (object == SHARP_F)
return def;
if (! (INTEGER_P (object)))
CHECK_ARG (1, STRING_P);
CHECK_ARG (2, STRING_P);
- class_name = STRING_LOC (ARG_REF (1), 0);
- window_name = STRING_LOC (ARG_REF (2), 0);
+ class_name = (STRING_POINTER (ARG_REF (1)));
+ window_name = (STRING_POINTER (ARG_REF (2)));
style = integer_to_ulong (ARG_REF (3));
x = (int) arg_ulong_default (4, ((unsigned long) CW_USEDEFAULT));
y = (int) arg_ulong_default (5, ((unsigned long) CW_USEDEFAULT));
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- it = GetModuleHandle (STRING_LOC (ARG_REF (1), 0));
+ it = GetModuleHandle (STRING_POINTER (ARG_REF (1)));
PRIMITIVE_RETURN (long_to_integer ((long) it));
}
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- it = LoadLibrary ((LPSTR)STRING_LOC (ARG_REF (1), 0));
+ it = LoadLibrary ((LPSTR) (STRING_POINTER (ARG_REF (1))));
PRIMITIVE_RETURN (long_to_integer ((long) it));
}
module = (HMODULE) arg_integer (1);
function = ARG_REF (2);
if (STRING_P (function))
- function_name = STRING_LOC (function, 0);
+ function_name = (STRING_POINTER (function));
else
function_name = (LPSTR) arg_integer (2);
wParam = arg_integer (3);
thing = ARG_REF (4);
if (STRING_P (thing))
- lParam = (LPARAM) STRING_LOC (thing, 0);
+ lParam = (LPARAM) (STRING_POINTER (thing));
else
lParam = arg_integer (4);
- PRIMITIVE_RETURN (
- long_to_integer (SendMessage (hwnd, message, wParam, lParam)));
+ PRIMITIVE_RETURN (long_to_integer (SendMessage (hwnd, message, wParam, lParam)));
}
\f
static SCHEME_OBJECT call_ff_really (void);
static SCHEME_OBJECT
call_ff_really (void)
{
- long function_address;
+ unsigned long function_address;
SCHEME_OBJECT * argument_scan;
SCHEME_OBJECT * argument_limit;
long result = UNSPECIFIC;
- long nargs = (LEXPR_N_ARGUMENTS ());
+ unsigned long nargs = GET_LEXPR_ACTUALS;
if (nargs < 1)
signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
if (nargs > 30)
signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- function_address = (arg_integer (1));
+ function_address = (arg_ulong_integer (1));
argument_scan = (ARG_LOC (nargs + 1));
argument_limit = (ARG_LOC (2));
while (argument_scan > argument_limit)
long *base;
int offset;
CHECK_ARG (1, STRING_P);
- base = (long*) STRING_LOC (ARG_REF(1), 0);
+ base = (long*) (STRING_POINTER (ARG_REF (1)));
offset = arg_integer (2);
PRIMITIVE_RETURN ( long_to_integer(* (long*) (((char*)base)+offset) ) );
}
int offset;
long value;
CHECK_ARG (1, STRING_P);
- base = (long*) STRING_LOC (ARG_REF(1), 0);
+ base = (long*) (STRING_POINTER (ARG_REF (1)));
offset = arg_integer (2);
value = scheme_object_to_windows_object (ARG_REF (3));
* (long*) (((char*)base)+offset) = value;
unsigned long *base;
int offset;
CHECK_ARG (1, STRING_P);
- base = (unsigned long*) STRING_LOC (ARG_REF(1), 0);
+ base = (unsigned long*) (STRING_POINTER (ARG_REF (1)));
offset = arg_integer (2);
PRIMITIVE_RETURN
(ulong_to_integer(* (unsigned long*) (((char*)base)+offset)));
int offset;
unsigned long value;
CHECK_ARG (1, STRING_P);
- base = (unsigned long*) STRING_LOC (ARG_REF(1), 0);
+ base = (unsigned long*) (STRING_POINTER (ARG_REF (1)));
offset = arg_integer (2);
value = scheme_object_to_windows_object (ARG_REF (3));
* (unsigned long*) (((char*)base)+offset) = value;
static int askuserbufferlength = 0;
static BOOL APIENTRY
-DEFUN (askuserdlgproc, (hwnddlg, message, wparam, lparam),
- HWND hwnddlg AND UINT message
- AND WPARAM wparam AND LPARAM lparam)
+askuserdlgproc (HWND hwnddlg, UINT message,
+ WPARAM wparam, LPARAM lparam)
{
switch (message)
{
}
char *
-DEFUN (AskUser, (buf, len), char * buf AND int len)
+AskUser (char * buf, int len)
{
char * result;
/* -*-C-*-
-$Id: ntio.c,v 1.34 2007/01/05 21:19:25 cph Exp $
+$Id: ntio.c,v 1.35 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
\f
static long
cooked_channel_write (Tchannel channel, const void * buffer,
- unsigned long n_bytes)
+ unsigned long n_bytes)
{
/* Map LF to CR/LF */
static const unsigned char crlf [] = {CARRIAGE_RETURN, LINEFEED};
int OS_have_select_p = 0;
extern HANDLE master_tty_window;
-extern void EXFUN (NT_initialize_channels, (void));
-extern void EXFUN (NT_reset_channels, (void));
-extern void EXFUN (NT_restore_channels, (void));
+extern void NT_initialize_channels (void);
+extern void NT_reset_channels (void);
+extern void NT_restore_channels (void);
void
NT_reset_channels (void)
? SELECT_PROCESS_STATUS_CHANGE
: 0);
}
-
+
static unsigned int
test_single_object_1 (Tchannel channel, unsigned int qmode)
/* -*-C-*-
-$Id: ntio.h,v 1.16 2007/01/05 21:19:25 cph Exp $
+$Id: ntio.h,v 1.17 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define CNTRL_Z '\032'
#define ASCII_DELETE '\177'
-extern BOOL EXFUN (Screen_IsScreenHandle, (HANDLE));
+extern BOOL Screen_IsScreenHandle (HANDLE);
#ifndef GUI
# define CONSOLE_HANDLE (STDIN_HANDLE)
/* -*-C-*-
-$Id: ntscmlib.h,v 1.14 2007/01/05 21:19:25 cph Exp $
+$Id: ntscmlib.h,v 1.15 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
unsigned short *, /* cs */
unsigned short *, /* ds */
unsigned short *); /* ss */
-
+
void
(__cdecl *release_scheme_selectors) (unsigned short, /* cs */
unsigned short, /* ds */
/* -*-C-*-
-$Id: ntscreen.c,v 1.54 2007/01/05 21:19:25 cph Exp $
+$Id: ntscreen.c,v 1.55 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <stdlib.h>
#include "nt.h"
#include "ntscreen.h"
#include "ntgui.h"
}
/* We can lose focus while a modifier key has been pressed. When
- we regain focus, be conservative and clear all modifiers since
+ we regain focus, be conservative and clear all modifiers since
we cannot reconstruct the left and right modifier state. */
static void
case VK_NUMLOCK:
case VK_SCROLL:
case VK_CAPITAL:
- case VK_CONTROL:
+ case VK_CONTROL:
case VK_SHIFT:
/* Let Windows handle the modifier keys. */
use_translate_message (handle, message, wparam, lparam);
cfTTYFont.hDC = NULL;
cfTTYFont.rgbColors = screen->rgbFGColour;
cfTTYFont.lpLogFont = &screen->lfFont;
- cfTTYFont.Flags = (
- CF_FIXEDPITCHONLY
+ cfTTYFont.Flags = (CF_FIXEDPITCHONLY
| CF_SCREENFONTS
| CF_EFFECTS
| CF_INITTOLOGFONTSTRUCT
/* -*-C-*-
-$Id: ntscreen.h,v 1.25 2007/01/05 21:19:25 cph Exp $
+$Id: ntscreen.h,v 1.26 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define SCREEN_SETATTRIBUTE (SCREEN_COMMAND_FIRST+3)
/* attribute = wParam */
-
+
#define SCREEN_GETATTRIBUTE (SCREEN_COMMAND_FIRST+4)
/* return attribute = retval */
-
+
#define SCREEN_PEEKEVENT (SCREEN_COMMAND_FIRST+5)
/* count = wParam */
/* buffer = (SCREEN_EVENT*) lParam */
/* kind = wParam */
/* kind=0 : whole screen */
/* kind=1 : to eol */
-
+
/* Predefined commands for SCREEN_SETBINDING etc */
#define SCREEN_COMMAND_CHOOSEFONT 0x400
/* -*-C-*-
-$Id: ntsig.c,v 1.26 2007/01/05 21:19:25 cph Exp $
+$Id: ntsig.c,v 1.27 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
void
-DEFUN_VOID (preserve_signal_mask)
+preserve_signal_mask (void)
{
return;
}
void
-DEFUN_VOID (block_signals)
+block_signals (void)
{
return;
}
void
-DEFUN_VOID (unblock_signals)
+unblock_signals (void)
{
return;
}
static unsigned char keyboard_interrupt_enables;
void
-DEFUN (OS_ctty_get_interrupt_enables, (mask), Tinterrupt_enables * mask)
+OS_ctty_get_interrupt_enables (Tinterrupt_enables * mask)
{
*mask = ((Tinterrupt_enables) keyboard_interrupt_enables);
return;
}
void
-DEFUN (OS_ctty_set_interrupt_enables, (mask), Tinterrupt_enables * mask)
+OS_ctty_set_interrupt_enables (Tinterrupt_enables * mask)
{
/* Kludge: ctl-break always enabled. */
keyboard_interrupt_enables = (((unsigned char) (* mask))
#define SCREEN_COMMAND_INTERRUPT_FIRST (SCREEN_COMMAND_CLOSE+10)
-int EXFUN (signal_keyboard_character_interrupt, (int));
+int signal_keyboard_character_interrupt (int);
LRESULT
master_tty_interrupt (HWND tty, WORD command)
}
static void
-DEFUN_VOID (update_interrupt_characters)
+update_interrupt_characters (void)
{
int i;
}
\f
unsigned int
-DEFUN_VOID (OS_ctty_num_int_chars)
+OS_ctty_num_int_chars (void)
{
return (NUM_INT_CHANNELS);
}
cc_t *
-DEFUN_VOID (OS_ctty_get_int_chars)
+OS_ctty_get_int_chars (void)
{
return (&int_chars[0]);
}
void
-DEFUN (OS_ctty_set_int_chars, (new_int_chars), cc_t * new_int_chars)
+OS_ctty_set_int_chars (cc_t * new_int_chars)
{
int i;
}
cc_t *
-DEFUN_VOID (OS_ctty_get_int_char_handlers)
+OS_ctty_get_int_char_handlers (void)
{
return (&int_handlers[0]);
}
void
-DEFUN (OS_ctty_set_int_char_handlers, (new_int_handlers),
- cc_t * new_int_handlers)
+OS_ctty_set_int_char_handlers (cc_t * new_int_handlers)
{
int i;
}
static void
-DEFUN (console_write_string, (string), unsigned char * string)
+console_write_string (unsigned char * string)
{
outf_console ("%s", string);
outf_flush_console ();
}
\f
static void
-DEFUN_VOID (initialize_keyboard_interrupt_table)
+initialize_keyboard_interrupt_table (void)
{
/* Set up default interrupt characters */
int_chars[0] = CONTROL_B;
static int hard_attn_counter = 0;
cc_t
-DEFUN (OS_tty_map_interrupt_char, (int_char), cc_t int_char)
+OS_tty_map_interrupt_char (cc_t int_char)
{
/* Scheme got a keyboard interrupt, reset the hard attention counter. */
hard_attn_counter = 0;
}
static void
-DEFUN_VOID (print_interrupt_help)
+print_interrupt_help (void)
{
- console_write_string (
- "\r\nInterrupt choices are:\r\n"
+ console_write_string ("\r\nInterrupt choices are:\r\n"
"C-G interrupt: ^G (abort to top level)\r\n"
"C-X interrupt: ^x (abort)\r\n"
"C-B interrupt: ^B (break)\r\n"
return;
}
-extern void EXFUN (tty_set_next_interrupt_char, (cc_t));
+extern void tty_set_next_interrupt_char (cc_t);
#define REQUEST_INTERRUPT_IF_ENABLED(mask) do \
{ \
} while (0)
\f
int
-DEFUN (signal_keyboard_character_interrupt, (c), int c)
+signal_keyboard_character_interrupt (int c)
{
if (c == -1)
{
}
void
-DEFUN_VOID (OS_restartable_exit)
+OS_restartable_exit (void)
{
return;
}
extern unsigned long * win32_catatonia_block;
static char *
-DEFUN_VOID (install_timer)
+install_timer (void)
{
/* This presumes that the catatonia block is allocated near
the register block and locked in physical memory with it.
}
static void
-DEFUN_VOID (flush_timer)
+flush_timer (void)
{
win32_system_utilities.flush_async_timer (timer_state);
return;
*/
void
-DEFUN (NT_initialize_fov, (fov), SCHEME_OBJECT fov)
+NT_initialize_fov (SCHEME_OBJECT fov)
{
int ctr, in;
SCHEME_OBJECT iv, imv, prim;
- extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
+ extern SCHEME_OBJECT make_primitive (char *, int);
static int interrupt_numbers[2] =
{
Global_GC_Level,
(INT_Stack_Overflow | INT_Global_GC | INT_GC),
};
- iv = (FAST_VECTOR_REF (fov, System_Interrupt_Vector));
- imv = (FAST_VECTOR_REF (fov, FIXOBJ_INTERRUPT_MASK_VECTOR));
+ iv = (VECTOR_REF (fov, SYSTEM_INTERRUPT_VECTOR));
+ imv = (VECTOR_REF (fov, FIXOBJ_INTERRUPT_MASK_VECTOR));
prim = (make_primitive ("MICROCODE-POLL-INTERRUPT-HANDLER", 2));
for (ctr = 0; ctr < ((sizeof (interrupt_numbers)) / (sizeof (int))); ctr++)
}
void
-DEFUN_VOID (NT_initialize_signals)
+NT_initialize_signals (void)
{
char * timer_error;
outf_fatal ("install_timer: %s", timer_error);
outf_flush_fatal ();
abort ();
- }
+ }
return;
}
-extern void EXFUN (NT_restore_signals, (void));
+extern void NT_restore_signals (void);
void
-DEFUN_VOID (NT_restore_signals)
+NT_restore_signals (void)
{
flush_timer ();
return;
/* -*-C-*-
-$Id: ntsys.c,v 1.13 2007/01/05 21:19:25 cph Exp $
+$Id: ntsys.c,v 1.14 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <stdio.h>
#include "nt.h"
#include "ntsys.h"
-\f
+
int
nt_console_write (void * vbuffer, size_t nsize)
{
/* -*-C-*-
-$Id: nttop.c,v 1.39 2007/01/05 21:19:25 cph Exp $
+$Id: nttop.c,v 1.40 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* reset_interruptable_extent */
-extern CONST char * OS_Name;
-extern CONST char * OS_Variant;
+extern const char * OS_Name;
+extern const char * OS_Variant;
static const char * w32_error_message (DWORD);
static int syserr_to_unix_error_code (enum syserr_names);
void
OS_reset (void)
{
- /*
- There should really be a reset for each initialize above,
- but the rest seem innocuous.
- */
-
+ /* There should really be a reset for each initialize above, but the
+ rest seem innocuous. */
NT_reset_channels ();
execute_reload_cleanups ();
- return;
}
void
{
outf_console ("\nScheme has terminated abnormally!\n");
OS_restore_external_state ();
- return;
}
\f
/* Memory Allocation */
((LPTSTR) (&buffer)),
0,
0));
-
+
if (length == 0)
return (0);
/* Assumes that we're using ANSI rather than Unicode characters. */
if (errno != EINTR)
NT_error_unix_call (errno, name);
deliver_pending_interrupts ();
- return;
}
\f
void
NT_restore_traps ();
NT_restore_signals ();
NT_restore_channels ();
- return;
}
#ifndef __OPEN_WATCOM_14__
-void
+void
bcopy (const char * s1, char * s2, int n)
{
while (n-- > 0)
}
#endif
-/* This is called during initialization, when the error system is not
- set up.
-*/
-
void *
-OS_malloc_init (unsigned int size)
+OS_malloc_init (size_t size)
{
- void * result = (malloc (size));
- return (result);
+ return (malloc (size));
}
void *
-OS_malloc (unsigned int size)
+OS_malloc (size_t size)
{
void * result = (malloc (size));
if (result == 0)
}
void *
-OS_realloc (void * ptr, unsigned int size)
+OS_realloc (void * ptr, size_t size)
{
void * result = (realloc (ptr, size));
if (result == 0)
}
void
-OS_syscall_names (unsigned int * length, unsigned char *** names)
+OS_syscall_names (unsigned long * length, const char *** names)
{
(*length) = ((sizeof (syscall_names_table)) / (sizeof (char *)));
- (*names) = ((unsigned char **) syscall_names_table);
+ (*names) = syscall_names_table;
}
void
-OS_syserr_names (unsigned int * length, unsigned char *** names)
+OS_syserr_names (unsigned long * length, const char *** names)
{
(*length) = ((sizeof (syserr_names_table)) / (sizeof (char *)));
- (*names) = ((unsigned char **) syserr_names_table);
+ (*names) = syserr_names_table;
}
\f
static CRITICAL_SECTION interrupt_registers_lock;
/* -*-C-*-
-$Id: nttrap.c,v 1.29 2007/01/05 21:19:25 cph Exp $
+$Id: nttrap.c,v 1.30 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <stdarg.h>
#include "scheme.h"
#include "os.h"
#include "nt.h"
#ifdef W32_TRAP_DEBUG
extern char * AskUser (char *, int);
-extern int EXFUN (TellUser, (char *, ...));
-extern int EXFUN (TellUserEx, (int, char *, ...));
+extern int TellUser (char *, ...);
+extern int TellUserEx (int, char *, ...);
#endif /* W32_TRAP_DEBUG */
-extern void EXFUN (callWinntExceptionTransferHook, (void));
-extern void EXFUN (NT_initialize_traps, (void));
-extern void EXFUN (NT_restore_traps, (void));
+extern void callWinntExceptionTransferHook (void);
+extern void NT_initialize_traps (void);
+extern void NT_restore_traps (void);
extern DWORD
C_Stack_Pointer,
{ \
if (trap_verbose_p) \
{ \
- int result = command; \
+ int result = (command); \
if (result == IDCANCEL) \
trap_verbose_p = FALSE; \
} \
} while (0)
-#else /* not W32_TRAP_DEBUG */
-
-#define IFVERBOSE(command) do { } while (0)
-
-#endif /* W32_TRAP_DEBUG */
+#else
+# define IFVERBOSE(command) do { } while (0)
+#endif
static char * trap_output = ((char *) NULL);
static char * trap_output_pointer = ((char *) NULL);
static void
-DEFUN_VOID (trap_noise_start)
+trap_noise_start (void)
{
trap_output = ((char *) NULL);
trap_output_pointer = ((char *) NULL);
}
static void
-DEFUN (trap_noise, (format), char * format DOTS)
+trap_noise (const char * format, ...)
{
va_list arg_ptr;
unsigned long size;
char * temp;
-
+
size = (trap_output_pointer - trap_output);
temp = ((trap_output == ((char *) NULL))
? ((char *) (malloc (256)))
}
static int
-DEFUN (trap_noise_end, (style), UINT style)
+trap_noise_end (UINT style)
{
int value;
}
static BOOL
-DEFUN (isvowel, (c), char c)
+isvowel (char c)
{
switch (c)
{
}
static void
-DEFUN (describe_trap, (noise, code),
- char * noise AND DWORD code)
+describe_trap (char * noise, DWORD code)
{
char * name;
static DWORD saved_trap_code;
enum trap_state
-DEFUN (OS_set_trap_state, (state), enum trap_state state)
+OS_set_trap_state (enum trap_state state)
{
enum trap_state old_trap_state = user_trap_state;
}
static void
-DEFUN_VOID (trap_normal_termination)
+trap_normal_termination (void)
{
trap_state = trap_state_exitting_soft;
termination_trap ();
}
static void
-DEFUN_VOID (trap_immediate_termination)
+trap_immediate_termination (void)
{
- extern void EXFUN (OS_restore_external_state, (void));
+ extern void OS_restore_external_state (void);
trap_state = trap_state_exitting_hard;
OS_restore_external_state ();
}
void
-DEFUN_VOID (NT_initialize_traps)
+NT_initialize_traps (void)
{
trap_state = trap_state_recover;
user_trap_state = trap_state_recover;
}
void
-DEFUN_VOID (NT_restore_traps)
+NT_restore_traps (void)
{
return;
}
\f
static int
-DEFUN (display_exception_information, (info, context, flags),
- PEXCEPTION_RECORD info AND PCONTEXT context AND int flags)
+display_exception_information (PEXCEPTION_RECORD info, PCONTEXT context, int flags)
{
int value;
char msgbuf[4096];
name = (find_exception_name (info->ExceptionCode));
flag = ((info->ExceptionFlags == 0) ? "Continuable" : "Non-continuable");
if (name == ((char *) NULL))
- bufptr += (sprintf (bufptr, "%s Unknown Exception %d Raised at address 0x%lx",
- flag, info->ExceptionCode, info->ExceptionAddress));
+ bufptr
+ += (sprintf (bufptr, "%s Unknown Exception %d Raised at address %#lx",
+ flag, info->ExceptionCode, info->ExceptionAddress));
else
- bufptr += (sprintf (bufptr, "%s %s Exception Raised at address 0x%lx",
+ bufptr += (sprintf (bufptr, "%s %s Exception Raised at address %#lx",
flag, name, info->ExceptionAddress));
#ifdef W32_TRAP_DEBUG
if ((context->ContextFlags & CONTEXT_FLOATING_POINT) != 0)
bufptr += (sprintf (bufptr,
"\nContext contains floating-point registers."));
- bufptr += (sprintf (bufptr, "\ncontext->Eip = 0x%lx.", context->Eip));
- bufptr += (sprintf (bufptr, "\ncontext->Esp = 0x%lx.", context->Esp));
- bufptr += (sprintf (bufptr, "\nsp_register = 0x%lx.", sp_register));
- bufptr += (sprintf (bufptr, "\nadj (sp_register) = 0x%lx.",
- (ADDR_TO_SCHEME_ADDR (sp_register))));
+ bufptr
+ += (sprintf (bufptr, "\ncontext->Eip = %#lx.", context->Eip));
+ bufptr
+ += (sprintf (bufptr, "\ncontext->Esp = %#lx.", context->Esp));
+ bufptr += (sprintf (bufptr, "\nstack_pointer = %#lx.",
+ stack_pointer));
+ bufptr += (sprintf (bufptr, "\nadj (stack_pointer) = %#lx.",
+ ((unsigned long) stack_pointer)));
}
#endif /* W32_TRAP_DEBUG */
static int size;
static SCHEME_OBJECT * temp_stack_ptr, * new_sp;
- temp_stack_ptr = sp_register;
+ temp_stack_ptr = stack_pointer;
size = (temp_stack_limit - temp_stack_ptr);
IFVERBOSE (TellUserEx (MB_OKCANCEL, "WinntExceptionTransferHook."));
INITIALIZE_STACK ();
else
{
- sp_register = real_stack_pointer;
- Stack_Guard = real_stack_guard;
+ stack_pointer = real_stack_pointer;
+ stack_guard = real_stack_guard;
}
-
+
new_sp = (real_stack_pointer - size);
if (new_sp != temp_stack_ptr)
memcpy (new_sp, temp_stack_ptr, (size * (sizeof (SCHEME_OBJECT))));
- sp_register = new_sp;
- SET_INTERRUPT_MASK ((FETCH_INTERRUPT_MASK ()));
+ stack_pointer = new_sp;
+ SET_INTERRUPT_MASK (GET_INT_MASK);
if (return_by_aborting)
abort_to_interpreter (PRIM_APPLY);
return (PRIM_APPLY);
}
-extern unsigned short __cdecl EXFUN (getCS, (void));
-extern unsigned short __cdecl EXFUN (getDS, (void));
+extern unsigned short __cdecl getCS (void);
+extern unsigned short __cdecl getDS (void);
\f
-/* Needed because Stack_Check checks for <= instead of < when pushing */
-
-#define MAGIC_BUFFER_SIZE 1
-
static void
-DEFUN (setup_trap_frame, (code, context, trinfo, new_stack_pointer),
- DWORD code
- AND PCONTEXT context
- AND struct trap_recovery_info * trinfo
- AND SCHEME_OBJECT * new_stack_pointer)
+setup_trap_frame (DWORD code,
+ PCONTEXT context,
+ struct trap_recovery_info * trinfo,
+ SCHEME_OBJECT * new_stack_pointer)
{
SCHEME_OBJECT trap_name, trap_code;
SCHEME_OBJECT handler;
int stack_recovered_p = (new_stack_pointer != 0);
- long saved_mask = (FETCH_INTERRUPT_MASK ());
+ unsigned long saved_mask = GET_INT_MASK;
SET_INTERRUPT_MASK (0); /* To prevent GC for now. */
IFVERBOSE (TellUserEx (MB_OKCANCEL,
- "setup_trap_frame (%s, 0x%lx, %s, 0x%lx, 0x%lx).",
+ "setup_trap_frame (%s, %#lx, %s, %#lx, %#lx).",
(find_exception_name (code)),
context,
trinfo,
new_stack_pointer));
-
- if ((! (Valid_Fixed_Obj_Vector ()))
- || ((handler = (Get_Fixed_Obj_Slot (Trap_Handler))) == SHARP_F))
+ handler
+ = ((VECTOR_P (fixed_objects))
+ ? (VECTOR_REF (fixed_objects, TRAP_HANDLER))
+ : SHARP_F);
+ if (!INTERPRETER_APPLICABLE_P (handler))
{
trap_noise_start ();
trap_noise ("There is no trap handler for recovery!\n");
(void) trap_noise_end (MB_OK | MB_ICONSTOP);
termination_trap ();
}
- if (Free > MemTop)
- Request_GC (0);
+ if (!FREE_OK_P (Free))
+ REQUEST_GC (0);
- trap_name = ((context == ((PCONTEXT) NULL))
+ trap_name = ((context == 0)
? SHARP_F
: (char_pointer_to_string (find_exception_name (code))));
trap_code = (long_to_integer (0));
if (! stack_recovered_p)
INITIALIZE_STACK ();
clear_real_stack = FALSE;
- real_stack_pointer = sp_register;
- real_stack_guard = Stack_Guard;
- temp_stack_limit = sp_register;
+ real_stack_pointer = stack_pointer;
+ real_stack_guard = stack_guard;
+ temp_stack_limit = stack_pointer;
}
else
{
clear_real_stack = (!stack_recovered_p);
real_stack_pointer = new_stack_pointer;
- real_stack_guard = Stack_Guard;
+ real_stack_guard = stack_guard;
temp_stack_limit = temp_stack_end;
- sp_register = temp_stack_end;
- Stack_Guard = temp_stack;
+ stack_pointer = temp_stack_end;
+ stack_guard = temp_stack;
}
\f
Will_Push (7 + CONTINUATION_SIZE);
STACK_PUSH (BOOLEAN_TO_OBJECT (stack_recovered_p));
STACK_PUSH (trap_code);
STACK_PUSH (trap_name);
- Store_Return (RC_HARDWARE_TRAP);
- exp_register = (long_to_integer (code));
- Save_Cont ();
+ SET_RC (RC_HARDWARE_TRAP);
+ SET_EXP (long_to_integer (code));
+ SAVE_CONT ();
Pushed ();
if (stack_recovered_p
/* This may want to be done in other cases, but this may be enough. */
&& (trinfo->state == STATE_COMPILED_CODE))
- Stop_History ();
+ stop_history ();
- history_register = (Make_Dummy_History ());
+ history_register = (make_dummy_history ());
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (trap_name);
STACK_PUSH (handler);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
+ PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
SET_INTERRUPT_MASK (saved_mask);
or execution was in the interpreter;
3) guess what C global state is still valid; and
4) set up a recovery frame for the interpreter so that debuggers can
- display more information.
+ display more information.
*/
-#define SCHEME_ALIGNMENT_MASK ((sizeof (long)) - 1)
+#define SCHEME_ALIGNMENT_MASK ((sizeof (SCHEME_OBJECT)) - 1)
#define STACK_ALIGNMENT_MASK SCHEME_ALIGNMENT_MASK
#define FREE_PARANOIA_MARGIN 0x100
-/* PCs must be aligned according to this. */
-
-#define PC_ALIGNMENT_MASK ((1 << PC_ZERO_BITS) - 1)
+#define ALIGNED_P(addr) \
+ ((((unsigned long) (addr)) & SCHEME_ALIGNMENT_MASK) == 0)
/* But they may have bits that can be masked by this. */
#ifndef PC_VALUE_MASK
-# define PC_VALUE_MASK (~0)
+# define PC_VALUE_MASK (~0)
#endif
#define C_STACK_SIZE 0x01000000
-#ifdef HAS_COMPILER_SUPPORT
-# define ALLOW_ONLY_C 0
-#else
-# define ALLOW_ONLY_C 1
-# define PLAUSIBLE_CC_BLOCK_P(block) 0
-#endif
-
-static SCHEME_OBJECT * EXFUN
- (find_block_address, (char * pc_value, SCHEME_OBJECT * area_start));
+static SCHEME_OBJECT * find_block_address
+ (char * pc_value, SCHEME_OBJECT * area_start);
#define IA32_NREGS 12
/* For now */
-#define GET_ETEXT() (Heap_Bottom)
+#define GET_ETEXT() (heap_start)
static void
-DEFUN (continue_from_trap, (code, context),
- DWORD code AND PCONTEXT context)
+continue_from_trap (DWORD code, PCONTEXT context)
{
int pc_in_builtin;
int builtin_index;
SCHEME_OBJECT * new_stack_pointer;
SCHEME_OBJECT * xtra_info;
struct trap_recovery_info trinfo;
- extern int EXFUN (pc_to_utility_index, (unsigned long));
- extern int EXFUN (pc_to_builtin_index, (unsigned long));
IFVERBOSE (TellUserEx (MB_OKCANCEL,
- "continue_from_trap (%s, 0x%lx).",
+ "continue_from_trap (%s, %#lx).",
(find_exception_name (code)), context));
-\f
+
if (context == ((PCONTEXT) NULL))
{
- if (Free < MemTop)
- Free = MemTop;
+ if (Free < heap_alloc_limit)
+ Free = heap_alloc_limit;
setup_trap_frame (code, context, (&dummy_recovery_info), 0);
/*NOTREACHED*/
}
IFVERBOSE
(TellUserEx
(MB_OKCANCEL,
- "continue_from_trap: SS = C DS; sp_register = 0x%lx; Esp = 0x%lx.",
- sp_register, context->Esp));
+ "continue_from_trap: SS = C DS; stack_pointer = %#lx; Esp = %#lx.",
+ stack_pointer, context->Esp));
scheme_sp = (context->Esp);
}
else
goto pc_in_hyperspace;
}
- if ((the_pc & PC_ALIGNMENT_MASK) != 0)
+ if (!PC_ALIGNED_P (the_pc))
{
pc_in_hyperspace:
pc_in_builtin = 0;
builtin_index = (pc_to_builtin_index (the_pc));
pc_in_builtin = (builtin_index != -1);
utility_index = (pc_to_utility_index (the_pc));
- pc_in_utility = (utility_index != -1);
+ pc_in_utility = (utility_index != -1);
pc_in_C = ((the_pc <= ((long) (GET_ETEXT ()))) && (! pc_in_builtin));
pc_in_heap =
- ((the_pc < ((long) Heap_Top)) && (the_pc >= ((long) Heap_Bottom)));
+ ((the_pc < ((long) heap_end)) && (the_pc >= ((long) heap_start)));
pc_in_constant_space =
- ((the_pc < ((long) Constant_Top)) &&
- (the_pc >= ((long) Constant_Space)));
+ ((the_pc < ((long) constant_end)) &&
+ (the_pc >= ((long) constant_start)));
pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_builtin);
pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
}
IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 1"));
- scheme_sp_valid =
- (pc_in_scheme
- && ((scheme_sp < ((long) Stack_Top)) &&
- (scheme_sp >= ((long) Stack_Bottom)) &&
- ((scheme_sp & STACK_ALIGNMENT_MASK) == 0)));
+ scheme_sp_valid
+ = (pc_in_scheme
+ && (ADDRESS_IN_STACK_P (scheme_sp))
+ && (ALIGNED_P (scheme_sp)));
IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 2"));
- new_stack_pointer =
- (scheme_sp_valid
- ? ((SCHEME_OBJECT *) scheme_sp)
- : ((pc_in_C
- && (sp_register < Stack_Top)
- && (sp_register > Stack_Bottom))
- ? sp_register
- : ((SCHEME_OBJECT *) 0)));
-\f
+ new_stack_pointer
+ = (scheme_sp_valid
+ ? ((SCHEME_OBJECT *) scheme_sp)
+ : ((pc_in_C
+ && (ADDRESS_IN_STACK_P (stack_pointer)))
+ ? stack_pointer
+ : 0));
+
IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 3"));
- if (pc_in_hyper_space || (pc_in_scheme && ALLOW_ONLY_C))
+ if (pc_in_hyper_space || pc_in_scheme)
{
/* In hyper space. */
(trinfo . state) = STATE_UNKNOWN;
(trinfo . pc_info_1) = SHARP_F;
(trinfo . pc_info_2) = SHARP_F;
new_stack_pointer = 0;
- if ((Free < MemTop) ||
- (Free >= Heap_Top) ||
- ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
- Free = MemTop;
+ if (! ((ADDRESS_IN_HEAP_P (Free)) && (ALIGNED_P (Free))))
+ Free = heap_alloc_limit;
}
else if (pc_in_scheme)
{
block_addr =
(pc_in_builtin
? ((SCHEME_OBJECT *) NULL)
- : (find_block_address (((PTR) the_pc),
- (pc_in_heap ? Heap_Bottom : Constant_Space))));
+ : (find_block_address (((void *) the_pc),
+ (pc_in_heap
+ ? heap_start
+ : constant_start))));
if (block_addr != ((SCHEME_OBJECT *) NULL))
{
(trinfo . state) = STATE_COMPILED_CODE;
- (trinfo . pc_info_1) =
- (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
+ (trinfo . pc_info_1) = (MAKE_CC_BLOCK (block_addr));
(trinfo . pc_info_2) =
(LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
}
(trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (builtin_index));
(trinfo . pc_info_2) = SHARP_T;
}
- else
+ else
{
(trinfo . state) = STATE_PROBABLY_COMPILED;
(trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (the_pc));
(trinfo . pc_info_2) = SHARP_F;
}
- if ((block_addr == ((SCHEME_OBJECT *) NULL)) && (! pc_in_builtin))
+ if ((block_addr == 0) && (!pc_in_builtin))
{
- if ((Free < MemTop) ||
- (Free >= Heap_Top) ||
- ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
- Free = MemTop;
+ if (! ((ADDRESS_IN_HEAP_P (Free))
+ && (ALIGNED_P (Free))
+ && (!FREE_OK_P (Free))))
+ Free = heap_alloc_limit;
}
else
{
maybe_free = ((SCHEME_OBJECT *) context->Edi);
- if (((((unsigned long) maybe_free) & SCHEME_ALIGNMENT_MASK) == 0)
- && (maybe_free >= Heap_Bottom) && (maybe_free < Heap_Top))
+ if ((ADDRESS_IN_HEAP_P (maybe_free)) && (ALIGNED_P (maybe_free)))
Free = (maybe_free + FREE_PARANOIA_MARGIN);
else
- if ((Free < MemTop) || (Free >= Heap_Top)
- || ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
- Free = MemTop;
+ if (! ((ADDRESS_IN_HEAP_P (Free))
+ && (ALIGNED_P (Free))
+ && (!FREE_OK_P (Free))))
+ Free = heap_alloc_limit;
}
}
-\f
+
else /* pc_in_C */
{
/* In the interpreter, a primitive, or a compiled code utility. */
- SCHEME_OBJECT primitive = (Registers[REGBLOCK_PRIMITIVE]);
+ SCHEME_OBJECT primitive = GET_PRIMITIVE;
if (pc_in_utility)
{
{
(trinfo . state) = STATE_PRIMITIVE;
(trinfo . pc_info_1) = primitive;
- (trinfo . pc_info_2) =
- (LONG_TO_UNSIGNED_FIXNUM (Registers[REGBLOCK_LEXPR_ACTUALS]));
+ (trinfo . pc_info_2) = (ULONG_TO_FIXNUM (GET_LEXPR_ACTUALS));
}
- if ((new_stack_pointer == 0)
- || ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0)
- || ((Free < Heap_Bottom) || (Free >= Heap_Top))
- || ((Free < MemTop) && ((Free + FREE_PARANOIA_MARGIN) >= MemTop)))
- Free = MemTop;
- else if ((Free + FREE_PARANOIA_MARGIN) < MemTop)
- Free += FREE_PARANOIA_MARGIN;
+ if ((new_stack_pointer != 0)
+ && (ADDRESS_IN_HEAP_P (Free))
+ && (ALIGNED_P (Free)))
+ {
+ if (FREE_OK_P (Free))
+ {
+ Free += FREE_PARANOIA_MARGIN;
+ if (!FREE_OK_P (Free))
+ Free = heap_alloc_limit;
+ }
+ }
+ else
+ Free = heap_alloc_limit;
}
IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 4"));
If the pointer is in the heap, it can actually do twice as
much work, but it is expected to pay off on the average. */
-static SCHEME_OBJECT * EXFUN
- (find_block_address_in_area, (char * pc_value, SCHEME_OBJECT * area_start));
+static SCHEME_OBJECT * find_block_address_in_area
+ (char * pc_value, SCHEME_OBJECT * area_start);
#define MINIMUM_SCAN_RANGE 2048
static SCHEME_OBJECT *
-DEFUN (find_block_address, (pc_value, area_start),
- char * pc_value AND
- SCHEME_OBJECT * area_start)
+find_block_address (char * pc_value, SCHEME_OBJECT * area_start)
{
- if (area_start == Constant_Space)
+ SCHEME_OBJECT * nearest_word
+ = ((SCHEME_OBJECT *)
+ (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
+ long maximum_distance = (nearest_word - area_start);
+ long distance = maximum_distance;
+ while ((distance / 2) > MINIMUM_SCAN_RANGE)
+ distance = (distance / 2);
+ while ((distance * 2) < maximum_distance)
{
- extern SCHEME_OBJECT * EXFUN
- (find_constant_space_block, (SCHEME_OBJECT *));
- SCHEME_OBJECT * constant_block =
- (find_constant_space_block
- ((SCHEME_OBJECT *)
- (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK)));
- return
- ((constant_block == 0)
- ? 0
- : (find_block_address_in_area (pc_value, constant_block)));
+ SCHEME_OBJECT * block
+ = (find_block_address_in_area (pc_value, (nearest_word - distance)));
+ if (block != 0)
+ return (block);
+ distance *= 2;
}
- {
- SCHEME_OBJECT * nearest_word =
- ((SCHEME_OBJECT *)
- (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
- long maximum_distance = (nearest_word - area_start);
- long distance = maximum_distance;
- while ((distance / 2) > MINIMUM_SCAN_RANGE)
- distance = (distance / 2);
- while ((distance * 2) < maximum_distance)
- {
- SCHEME_OBJECT * block =
- (find_block_address_in_area (pc_value, (nearest_word - distance)));
- if (block != 0)
- return (block);
- distance *= 2;
- }
- }
return (find_block_address_in_area (pc_value, area_start));
}
\f
For the time being, skip over manifest closures and linkage sections. */
static SCHEME_OBJECT *
-DEFUN (find_block_address_in_area, (pc_value, area_start),
- char * pc_value AND
+find_block_address_in_area (char * pc_value,
SCHEME_OBJECT * area_start)
{
SCHEME_OBJECT * first_valid = area_start;
{
case TC_LINKAGE_SECTION:
{
- switch (READ_LINKAGE_KIND (object))
- {
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- case OPERATOR_LINKAGE_KIND:
+ unsigned long count = (linkage_section_count (object));
+ area += 1;
+ switch (linkage_section_type (object))
{
- long count = (READ_OPERATOR_LINKAGE_COUNT (object));
- area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
+ case LINKAGE_SECTION_TYPE_OPERATOR:
+ case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
+ area += (count * UUO_LINK_SIZE);
break;
- }
+ case LINKAGE_SECTION_TYPE_REFERENCE:
+ case LINKAGE_SECTION_TYPE_ASSIGNMENT:
default:
-#if FALSE
- {
- gc_death (TERM_EXIT,
- "find_block_address: Unknown compiler linkage kind.",
- area, NULL);
- /*NOTREACHED*/
- }
-#else
- /* Fall through, no reason to crash here. */
-#endif
- case ASSIGNMENT_LINKAGE_KIND:
- case CLOSURE_PATTERN_LINKAGE_KIND:
- case REFERENCE_LINKAGE_KIND:
- area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
+ area += count;
break;
-
- }
- break;
+ }
}
+ break;
+
case TC_MANIFEST_CLOSURE:
- {
- area += 1;
- {
- long count = (MANIFEST_CLOSURE_COUNT (area));
- area = (MANIFEST_CLOSURE_END (area, count));
- }
- break;
- }
+ area = (compiled_closure_objects (area + 1));
+ break;
+
case TC_MANIFEST_NM_VECTOR:
{
- long count = (OBJECT_DATUM (object));
+ unsigned long count = (OBJECT_DATUM (object));
if (((char *) (area + (count + 1))) < pc_value)
{
area += (count + 1);
{
SCHEME_OBJECT * block = (area - 1);
return
- (((area == first_valid)
- || ((OBJECT_TYPE (* block)) != TC_MANIFEST_VECTOR)
- || ((OBJECT_DATUM (* block)) < ((unsigned long) (count + 1)))
- || (! (PLAUSIBLE_CC_BLOCK_P (block))))
- ? 0
- : block);
+ (((area > first_valid)
+ && ((OBJECT_TYPE (*block)) == TC_MANIFEST_VECTOR)
+ && ((OBJECT_DATUM (*block)) >= (count + 1))
+ && (plausible_cc_block_p (block)))
+ ? block
+ : 0);
}
}
+
default:
- {
- area += 1;
- break;
- }
+ area += 1;
+ break;
}
}
return (0);
}
\f
static void
-DEFUN (trap_recover, (code, context),
- DWORD code AND PCONTEXT context)
+trap_recover (DWORD code, PCONTEXT context)
{
IFVERBOSE (TellUserEx (MB_OKCANCEL,
- "trap_recover (%s, 0x%lx).",
+ "trap_recover (%s, %#lx).",
(find_exception_name (code)), context));
if (WITHIN_CRITICAL_SECTION_P ())
}
static void
-DEFUN (nt_trap_handler, (code, context),
- DWORD code AND PCONTEXT context)
+nt_trap_handler (DWORD code, PCONTEXT context)
{
- Boolean stack_overflowed_p = (STACK_OVERFLOWED_P ());
+ bool stack_overflowed_p = (STACK_OVERFLOWED_P ());
enum trap_state old_trap_state = trap_state;
int flags;
IFVERBOSE (TellUserEx (MB_OKCANCEL,
- "nt_trap_handler (%s, 0x%lx).",
+ "nt_trap_handler (%s, %#lx).",
(find_exception_name (code)), context));
if (old_trap_state == trap_state_exitting_hard)
break;
}
else
- {
+ {
(void) trap_noise_end (MB_OK | MB_ICONSTOP);
trap_immediate_termination ();
}
#ifdef W32_TRAP_DEBUG
static void
-DEFUN (parse_response, (buf, addr, len),
- char * buf AND unsigned long * addr AND int * len)
+parse_response (char * buf, unsigned long * addr, int * len)
{
const char * separators = " ,\t;";
char * token;
}
static void
-DEFUN (tinyexcpdebug, (code, info),
- DWORD code AND LPEXCEPTION_POINTERS info)
+tinyexcpdebug (DWORD code, LPEXCEPTION_POINTERS info)
{
int count, len;
char * message;
unsigned long * addr;
char responsebuf[256], * response;
-
+
if ((MessageBox
(NULL, "Debug?", "MIT/GNU Scheme Exception Debugger", MB_YESNO))
!= IDYES)
while (1)
{
trap_noise_start ();
- trap_noise ("%s 0x%lx.\n", message, ((unsigned long) addr));
+ trap_noise ("%s %#lx.\n", message, ((unsigned long) addr));
for (count = 0; count < len; count++)
- trap_noise ("\n*0x%08x\t= 0x%08x\t= %d.",
+ trap_noise ("\n*%#08x\t= %#08x\t= %d.",
(addr + count),
addr[count],
addr[count]);
#endif /* W32_TRAP_DEBUG */
\f
#ifndef PAGE_SIZE
-# define PAGE_SIZE 0x1000
+# define PAGE_SIZE 0x1000
#endif
-static Boolean stack_protected = FALSE;
+static bool stack_protected = false;
unsigned long protected_stack_base;
unsigned long protected_stack_end;
void
-DEFUN_VOID (win32_unprotect_stack)
+win32_unprotect_stack (void)
{
DWORD old_protection;
&& (VirtualProtect (((LPVOID) protected_stack_base),
PAGE_SIZE,
PAGE_READWRITE,
- &old_protection)))
- stack_protected = FALSE;
- return;
+ (&old_protection))))
+ stack_protected = false;
}
void
-DEFUN_VOID (win32_protect_stack)
+win32_protect_stack (void)
{
DWORD old_protection;
- if ((! stack_protected)
+ if ((!stack_protected)
&& (VirtualProtect (((LPVOID) protected_stack_base),
PAGE_SIZE,
(PAGE_GUARD | PAGE_READWRITE),
- &old_protection)))
- stack_protected = TRUE;
- return;
+ (&old_protection))))
+ stack_protected = true;
}
void
-DEFUN_VOID (win32_stack_reset)
+win32_stack_reset (void)
{
- unsigned long boundary;
-
- /* This presumes that the distance between Stack_Bottom and
- Stack_Guard is at least a page.
- */
-
- boundary = ((((unsigned long) Stack_Guard)
- & (~ ((unsigned long) (PAGE_SIZE - 1))))
- - (2 * PAGE_SIZE));
+ /* This presumes that the distance between stack_end and
+ stack_guard is at least a page. */
+ unsigned long boundary
+ = ((((unsigned long) stack_guard)
+ & (~ ((unsigned long) (PAGE_SIZE - 1))))
+ - (2 * PAGE_SIZE));
if (stack_protected && (protected_stack_base == boundary))
return;
win32_unprotect_stack ();
protected_stack_base = boundary;
protected_stack_end = (boundary + PAGE_SIZE);
win32_protect_stack ();
- return;
}
\f
-#define EXCEPTION_CODE_GUARDED_PAGE_ACCESS 0x80000001L
+#define EXCEPTION_CODE_GUARDED_PAGE_ACCESS 0x80000001L
static LONG
-DEFUN (WinntException, (code, info),
- DWORD code AND LPEXCEPTION_POINTERS info)
+WinntException (DWORD code, LPEXCEPTION_POINTERS info)
{
PCONTEXT context;
/* -*-C-*-
-$Id: nttrap.h,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: nttrap.h,v 1.10 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#ifndef SCM_NTTRAP_H
#define SCM_NTTRAP_H
-\f
+
enum trap_state
{
trap_state_trapped,
trap_state_exitting_hard
};
-extern enum trap_state EXFUN (OS_set_trap_state, (enum trap_state state));
+extern enum trap_state OS_set_trap_state (enum trap_state state);
#endif /* SCM_NTTRAP_H */
/* -*-C-*-
-$Id: nttterm.c,v 1.9 2007/01/12 03:45:55 cph Exp $
+$Id: nttterm.c,v 1.10 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
#include "osterm.h"
-extern char * EXFUN (tparam, (char *, char*, int, int, ...));
-extern char * EXFUN (tgoto, (char *, int, int));
-extern int EXFUN (tputs, (char *, int, void (*) (int)));
+extern char * tparam (char *, char*, int, int, ...);
+extern char * tgoto (char *, int, int);
+extern int tputs (char *, int, void (*) (int));
extern char * BC;
extern char * UP;
extern char PC;
static char * tputs_output_scan;
static void
-DEFUN (tputs_write_char, (c), int c)
+tputs_write_char (int c)
{
(*tputs_output_scan++) = c;
return;
BC = (((ARG_REF (4)) == SHARP_F) ? 0 : (STRING_ARG (4)));
UP = (((ARG_REF (5)) == SHARP_F) ? 0 : (STRING_ARG (5)));
PRIMITIVE_RETURN
- (char_pointer_to_string
- (tgoto ((STRING_ARG (1)),
- (arg_nonnegative_integer (2)),
- (arg_nonnegative_integer (3)))));
+ (char_pointer_to_string (tgoto ((STRING_ARG (1)),
+ (arg_nonnegative_integer (2)),
+ (arg_nonnegative_integer (3)))));
}
}
/* -*-C-*-
-$Id: nttty.c,v 1.12 2007/01/05 21:19:25 cph Exp $
+$Id: nttty.c,v 1.13 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
return (tty_y_size);
}
-CONST char *
+const char *
OS_tty_command_beep (void)
{
return (tty_command_beep);
}
-CONST char *
+const char *
OS_tty_command_clear (void)
{
return (tty_command_clear);
int
tputs (string, nlines, outfun)
- register char * string;
+ char * string;
int nlines;
- register int (*outfun) ();
+ int (*outfun) ();
{
- register int padcount = 0;
+ int padcount = 0;
if (string == (char *) 0)
return (0);
/* -*-C-*-
-$Id: config.h,v 1.13 2007/01/05 21:19:26 cph Exp $
+$Id: config.h,v 1.14 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Define if you have the <fcntl.h> header file. */
#define HAVE_FCNTL_H 1
-/* Define if architecture has native-code compiler support. */
-#define HAS_COMPILER_SUPPORT 1
-
/* Define if you have the <blowfish.h> header file. */
#define HAVE_BLOWFISH_H 1
#define PACKAGE_BUGREPORT "bug-mit-scheme@gnu.org"
/* Define to the full name of this package. */
-#define PACKAGE_NAME "MIT/GNU Scheme"
+#define PACKAGE_NAME "MIT/GNU Scheme microcode"
/* Define to the full name and version of this package. */
-#define PACKAGE_STRING "MIT/GNU Scheme 14.18"
+#define PACKAGE_STRING "MIT/GNU Scheme microcode 15.0"
/* Define to the one symbol short name of this package. */
#define PACKAGE_TARNAME "mit-scheme"
/* Define to the version of this package. */
-#define PACKAGE_VERSION "14.18"
+#define PACKAGE_VERSION "15.0"
/* Include the shared configuration header. */
#include "confshared.h"
VALUE "FileDescription", "MIT/GNU Scheme Microcode"
VALUE "FileVersion", "14.11"
VALUE "InternalName", "SCHEME"
- VALUE "LegalCopyright", "Copyright Massachusetts Institute of Technology 1993-2003"
+ VALUE "LegalCopyright", "Copyright 1993,1994,1995,2000,2003 Massachusetts Institute of Technology"
VALUE "OriginalFilename", "SCHEME.EXE"
VALUE "ProductName", "MIT/GNU Scheme"
VALUE "ProductVersion", "7.8.0"
/* -*-C-*-
-$Id: object.h,v 9.64 2007/01/12 03:45:55 cph Exp $
+$Id: object.h,v 9.65 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
/* This file defines the macros which define and manipulate Scheme
- objects. This is the lowest level of abstraction in this program.
+ objects. This is the lowest level of abstraction in this program.
*/
#ifndef SCM_OBJECT_H
#define SCM_OBJECT_H
-\f
-/* The value in "Wsize.c" for `TYPE_CODE_LENGTH' must match this!! */
-#ifndef TYPE_CODE_LENGTH
-# define TYPE_CODE_LENGTH 8
-#endif
+
+#include "config.h"
+#include "types.h"
+
+#define TYPE_CODE_LENGTH (6U)
#if defined(MIN_TYPE_CODE_LENGTH) && (TYPE_CODE_LENGTH < MIN_TYPE_CODE_LENGTH)
-# include "Inconsistency between object.h and types.h: MIN_TYPE_CODE_LENGTH"
+# include ";; inconsistency: TYPE_CODE_LENGTH < MIN_TYPE_CODE_LENGTH"
#endif
+#if (TYPE_CODE_LENGTH == 8)
+# define N_TYPE_CODES (0x100)
+#endif
+#if (TYPE_CODE_LENGTH == 6)
+# define N_TYPE_CODES (0x40)
+#endif
+#ifndef N_TYPE_CODES
+# define N_TYPE_CODES (1U << TYPE_CODE_LENGTH)
+#endif
+#define __LOW_TYPE_MASK ((unsigned long) (N_TYPE_CODES - 1U))
+
+typedef unsigned long SCHEME_OBJECT;
+#define SIZEOF_SCHEME_OBJECT SIZEOF_UNSIGNED_LONG
+#define OBJECT_LENGTH ((unsigned int) (CHAR_BIT * SIZEOF_UNSIGNED_LONG))
+\f
+/* A convenience definition since "unsigned char" is so verbose. */
+typedef unsigned char byte_t;
+
#if (SIZEOF_UNSIGNED_LONG == 4) /* 32 bit word versions */
+# if (TYPE_CODE_LENGTH == 6)
+# define DATUM_LENGTH (26U)
+# define FIXNUM_LENGTH (25U)
+# define FIXNUM_SIGN_BIT (0x02000000L)
+# define SIGN_MASK (0xFE000000L)
+# define SMALLEST_FIXNUM (-33554432L)
+# define BIGGEST_FIXNUM (33554431L)
+# define HALF_DATUM_LENGTH (13U)
+# define HALF_DATUM_MASK (0x00001FFFL)
+# define DATUM_MASK (0x03FFFFFFL)
+# define TYPE_CODE_MASK (0XFC000000L)
+# endif
# if (TYPE_CODE_LENGTH == 8)
-# define MAX_TYPE_CODE 0xFF
-# define DATUM_LENGTH 24
-# define FIXNUM_LENGTH 23
-# define FIXNUM_SIGN_BIT 0x00800000
-# define SIGN_MASK 0xFF800000
-# define SMALLEST_FIXNUM ((long) 0xFF800000)
-# define BIGGEST_FIXNUM ((long) 0x007FFFFF)
-# define HALF_DATUM_LENGTH 12
-# define HALF_DATUM_MASK 0x00000FFF
-# define DATUM_MASK 0x00FFFFFF
-# define TYPE_CODE_MASK 0xFF000000
+# define DATUM_LENGTH (24U)
+# define FIXNUM_LENGTH (23U)
+# define FIXNUM_SIGN_BIT (0x00800000L)
+# define SIGN_MASK (0xFF800000L)
+# define SMALLEST_FIXNUM (-8388608)
+# define BIGGEST_FIXNUM (8388607)
+# define HALF_DATUM_LENGTH (12U)
+# define HALF_DATUM_MASK (0x00000FFFL)
+# define DATUM_MASK (0x00FFFFFFL)
+# define TYPE_CODE_MASK (0xFF000000L)
# endif
+#endif
+
+#if (SIZEOF_UNSIGNED_LONG == 8) /* 64 bit word versions */
# if (TYPE_CODE_LENGTH == 6)
-# define MAX_TYPE_CODE 0x3F
-# define DATUM_LENGTH 26
-# define FIXNUM_LENGTH 25
-# define FIXNUM_SIGN_BIT 0x02000000
-# define SIGN_MASK 0xFE000000
-# define SMALLEST_FIXNUM ((long) 0xFE000000)
-# define BIGGEST_FIXNUM ((long) 0x01FFFFFF)
-# define HALF_DATUM_LENGTH 13
-# define HALF_DATUM_MASK 0x00001FFF
-# define DATUM_MASK 0x03FFFFFF
-# define TYPE_CODE_MASK 0XFC000000
+# define DATUM_LENGTH (58U)
+# define FIXNUM_LENGTH (57U)
+# define FIXNUM_SIGN_BIT (0x0200000000000000L)
+# define SIGN_MASK (0xFE00000000000000L)
+# define SMALLEST_FIXNUM (-144115188075855872L)
+# define BIGGEST_FIXNUM (144115188075855871L)
+# define HALF_DATUM_LENGTH (29U)
+# define HALF_DATUM_MASK (0x000000001FFFFFFFL)
+# define DATUM_MASK (0x03FFFFFFFFFFFFFFL)
+# define TYPE_CODE_MASK (0XFC00000000000000L)
# endif
#endif
#ifndef DATUM_LENGTH /* Safe versions */
-# define MAX_TYPE_CODE ((1 << TYPE_CODE_LENGTH) - 1)
# define DATUM_LENGTH (OBJECT_LENGTH - TYPE_CODE_LENGTH)
/* FIXNUM_LENGTH does NOT include the sign bit! */
-# define FIXNUM_LENGTH (DATUM_LENGTH - 1)
-# define FIXNUM_SIGN_BIT (1L << FIXNUM_LENGTH)
-# define SIGN_MASK ((long) (-1L << FIXNUM_LENGTH))
-# define SMALLEST_FIXNUM ((long) (-1L << FIXNUM_LENGTH))
-# define BIGGEST_FIXNUM ((1L << FIXNUM_LENGTH) - 1)
-# define HALF_DATUM_LENGTH (DATUM_LENGTH / 2)
-# define HALF_DATUM_MASK ((1L << HALF_DATUM_LENGTH) - 1)
-# define DATUM_MASK ((1L << DATUM_LENGTH) - 1)
-# define TYPE_CODE_MASK (~ DATUM_MASK)
+# define FIXNUM_LENGTH (DATUM_LENGTH - 1U)
+# define FIXNUM_SIGN_BIT (1UL << FIXNUM_LENGTH)
+# define __SIGN_MASK ((unsigned long) ((N_TYPE_CODES * 2U) - 1U))
+# define SIGN_MASK (__SIGN_MASK << FIXNUM_LENGTH)
+# define SMALLEST_FIXNUM SIGN_MASK
+# define BIGGEST_FIXNUM ((1UL << FIXNUM_LENGTH) - 1U)
+# define HALF_DATUM_LENGTH (DATUM_LENGTH / 2U)
+# define HALF_DATUM_MASK ((1UL << HALF_DATUM_LENGTH) - 1UL)
+# define DATUM_MASK ((1UL << DATUM_LENGTH) - 1UL)
+# define TYPE_CODE_MASK (__LOW_TYPE_MASK << DATUM_LENGTH)
#endif
\f
/* Basic object structure */
#ifndef OBJECT_TYPE
-#ifdef UNSIGNED_SHIFT_BUG
-/* This fixes bug in some compilers. */
-#define OBJECT_TYPE(object) (((object) >> DATUM_LENGTH) & MAX_TYPE_CODE)
-#else
-/* Faster for logical shifts */
-#define OBJECT_TYPE(object) ((object) >> DATUM_LENGTH)
-#endif
+# ifdef UNSIGNED_SHIFT_BUG
+# define OBJECT_TYPE(object) (((object) >> DATUM_LENGTH) & __LOW_TYPE_MASK)
+# else
+# define OBJECT_TYPE(object) ((object) >> DATUM_LENGTH)
+# endif
#endif
#define OBJECT_DATUM(object) ((object) & DATUM_MASK)
-#define OBJECT_ADDRESS(object) (DATUM_TO_ADDRESS ((object) & DATUM_MASK))
+#define OBJECT_ADDRESS(object) (DATUM_TO_ADDRESS (OBJECT_DATUM (object)))
#define MAKE_OBJECT(type, datum) \
((((unsigned long) (type)) << DATUM_LENGTH) | (datum))
-#define OBJECT_NEW_DATUM(type_object, datum) \
- (((type_object) & TYPE_CODE_MASK) | (datum))
-
#define OBJECT_NEW_TYPE(type, datum_object) \
(MAKE_OBJECT ((type), (OBJECT_DATUM (datum_object))))
+#define OBJECT_NEW_DATUM(type_object, datum) \
+ (MAKE_OBJECT ((OBJECT_TYPE (type_object)), (datum)))
+
#define MAKE_OBJECT_FROM_OBJECTS(type_object, datum_object) \
- (((type_object) & TYPE_CODE_MASK) | ((datum_object) & DATUM_MASK))
+ (MAKE_OBJECT ((OBJECT_TYPE (type_object)), (OBJECT_DATUM (datum_object))))
#define MAKE_POINTER_OBJECT(type, address) \
(MAKE_OBJECT ((type), (ADDRESS_TO_DATUM (address))))
#ifdef HEAP_IN_LOW_MEMORY /* Storing absolute addresses */
-typedef long relocation_type; /* Used to relocate pointers on fasload */
-
-#define ALLOCATE_HEAP_SPACE(space,low,high) do \
+#define ALLOCATE_HEAP_SPACE(space, low, high) do \
{ \
unsigned long _space = (space); \
SCHEME_OBJECT * _low \
# define ADDRESS_TO_DATUM(address) ((SCHEME_OBJECT) (address))
#endif
-#else /* not HEAP_IN_LOW_MEMORY (portable version) */
-
-/* Used to relocate pointers on fasload */
-
-typedef SCHEME_OBJECT * relocation_type;
+#else /* not HEAP_IN_LOW_MEMORY */
extern SCHEME_OBJECT * memory_base;
-#define ALLOCATE_HEAP_SPACE(space,low,high) do \
+#define ALLOCATE_HEAP_SPACE(space, low, high) do \
{ \
unsigned long _space = (space); \
memory_base = ((SCHEME_OBJECT *) \
#define MEMBASE memory_base
/* These use the MEMBASE macro so that C-compiled code can cache
- memory_base locally and use the local version.
-*/
+ memory_base locally and use the local version. */
#ifndef DATUM_TO_ADDRESS
# define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) ((datum) + MEMBASE))
# define ADDRESS_TO_DATUM(address) ((SCHEME_OBJECT) ((address) - MEMBASE))
#endif
-#endif /* HEAP_IN_LOW_MEMORY */
-
-#ifndef SCHEME_ADDR_TO_ADDR
- typedef SCHEME_OBJECT * SCHEME_ADDR;
-# define SCHEME_ADDR_TO_ADDR(saddr) ((SCHEME_OBJECT *) (saddr))
-# define ADDR_TO_SCHEME_ADDR(caddr) ((SCHEME_OBJECT) (caddr))
-#endif /* SCHEME_ADDR_TO_ADDR */
+#endif /* not HEAP_IN_LOW_MEMORY */
\f
/* Lots of type predicates */
#define BOOLEAN_P(object) (((object) == SHARP_T) || ((object) == SHARP_F))
#define REFERENCE_TRAP_P(object) ((OBJECT_TYPE (object)) == TC_REFERENCE_TRAP)
#define PRIMITIVE_P(object) ((OBJECT_TYPE (object)) == TC_PRIMITIVE)
-#define FUTURE_P(object) ((OBJECT_TYPE (object)) == TC_FUTURE)
#define PROMISE_P(object) ((OBJECT_TYPE (object)) == TC_DELAYED)
#define APPARENT_LIST_P(object) ((EMPTY_LIST_P (object)) || (PAIR_P (object)))
#define CONTROL_POINT_P(object) ((OBJECT_TYPE (object)) == TC_CONTROL_POINT)
#define BROKEN_HEART_P(object) ((OBJECT_TYPE (object)) == TC_BROKEN_HEART)
-#define GC_NON_POINTER_P(object) ((GC_Type (object)) == GC_Non_Pointer)
-#define GC_CELL_P(object) ((GC_Type (object)) == GC_Cell)
-#define GC_PAIR_P(object) ((GC_Type (object)) == GC_Pair)
-#define GC_TRIPLE_P(object) ((GC_Type (object)) == GC_Triple)
-#define GC_QUADRUPLE_P(object) ((GC_Type (object)) == GC_Quadruple)
-#define GC_VECTOR_P(object) ((GC_Type (object)) == GC_Vector)
-
-#define COMPILED_CODE_ADDRESS_P(object) \
- ((OBJECT_TYPE (object)) == TC_COMPILED_ENTRY)
-
-#define STACK_ADDRESS_P(object) \
- ((OBJECT_TYPE (object)) == TC_STACK_ENVIRONMENT)
+#define RETURN_CODE_P(object) ((OBJECT_TYPE (object)) == TC_RETURN_CODE)
#define NON_MARKED_VECTOR_P(object) \
((OBJECT_TYPE (object)) == TC_NON_MARKED_VECTOR)
#define SYMBOL_P(object) \
- (((OBJECT_TYPE (object)) == TC_INTERNED_SYMBOL) || \
- ((OBJECT_TYPE (object)) == TC_UNINTERNED_SYMBOL))
+ ((INTERNED_SYMBOL_P (object)) || (UNINTERNED_SYMBOL_P (object)))
+
+#define INTERNED_SYMBOL_P(object) \
+ ((OBJECT_TYPE (object)) == TC_INTERNED_SYMBOL)
+
+#define UNINTERNED_SYMBOL_P(object) \
+ ((OBJECT_TYPE (object)) == TC_UNINTERNED_SYMBOL)
#define INTEGER_P(object) \
- (((OBJECT_TYPE (object)) == TC_FIXNUM) || \
- ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM))
+ (((OBJECT_TYPE (object)) == TC_FIXNUM) \
+ || ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM))
#define REAL_P(object) \
- (((OBJECT_TYPE (object)) == TC_FIXNUM) || \
- ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) || \
- ((OBJECT_TYPE (object)) == TC_BIG_FLONUM))
-
-#define NUMBER_P(object) \
- (((OBJECT_TYPE (object)) == TC_FIXNUM) || \
- ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) || \
- ((OBJECT_TYPE (object)) == TC_BIG_FLONUM) \
- ((OBJECT_TYPE (object)) == TC_COMPLEX))
+ (((OBJECT_TYPE (object)) == TC_FIXNUM) \
+ || ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) \
+ || ((OBJECT_TYPE (object)) == TC_BIG_FLONUM))
#define HUNK3_P(object) \
- (((OBJECT_TYPE (object)) == TC_HUNK3_A) || \
- ((OBJECT_TYPE (object)) == TC_HUNK3_B))
+ (((OBJECT_TYPE (object)) == TC_HUNK3_A) \
+ || ((OBJECT_TYPE (object)) == TC_HUNK3_B))
#define INTERPRETER_APPLICABLE_P interpreter_applicable_p
#define ENVIRONMENT_P(env) \
(((OBJECT_TYPE (env)) == TC_ENVIRONMENT) || (GLOBAL_FRAME_P (env)))
+
+#define EMPTY_LIST_P(object) ((object) == EMPTY_LIST)
\f
/* Memory Operations */
-/* The FAST_ operations are used only where the object is known to be
- immutable. On a parallel processor they don't require atomic
- references. */
-
-#define FAST_MEMORY_REF(object, offset) \
- ((OBJECT_ADDRESS (object)) [(offset)])
-
-#define FAST_MEMORY_SET(object, offset, value) \
- ((OBJECT_ADDRESS (object)) [(offset)]) = (value)
-
-#define MEMORY_LOC(object, offset) \
- (& ((OBJECT_ADDRESS (object)) [(offset)]))
-
-/* General case memory access requires atomicity for parallel processors. */
-
-#define MEMORY_REF(object, offset) \
- (MEMORY_FETCH ((OBJECT_ADDRESS (object)) [(offset)]))
-
-#define MEMORY_SET(object, offset, value) \
- MEMORY_STORE (((OBJECT_ADDRESS (object)) [(offset)]), (value))
+#define MEMORY_REF(obj, i) ((OBJECT_ADDRESS (obj)) [(i)])
+#define MEMORY_SET(obj, i, value) ((MEMORY_REF (obj, i)) = (value))
+#define MEMORY_LOC(obj, i) (& (MEMORY_REF (obj, i)))
/* Pair Operations */
-#define FAST_PAIR_CAR(pair) (FAST_MEMORY_REF ((pair), CONS_CAR))
-#define FAST_PAIR_CDR(pair) (FAST_MEMORY_REF ((pair), CONS_CDR))
-#define FAST_SET_PAIR_CAR(pair, car) FAST_MEMORY_SET ((pair), CONS_CAR, (car))
-#define FAST_SET_PAIR_CDR(pair, cdr) FAST_MEMORY_SET ((pair), CONS_CDR, (cdr))
#define PAIR_CAR_LOC(pair) (MEMORY_LOC ((pair), CONS_CAR))
#define PAIR_CDR_LOC(pair) (MEMORY_LOC ((pair), CONS_CDR))
-
#define PAIR_CAR(pair) (MEMORY_REF ((pair), CONS_CAR))
#define PAIR_CDR(pair) (MEMORY_REF ((pair), CONS_CDR))
#define SET_PAIR_CAR(pair, car) MEMORY_SET ((pair), CONS_CAR, (car))
/* Vector Operations */
-#define VECTOR_LENGTH(vector) (OBJECT_DATUM (FAST_MEMORY_REF ((vector), 0)))
+#define VECTOR_LENGTH(v) (OBJECT_DATUM (MEMORY_REF ((v), 0)))
-#define SET_VECTOR_LENGTH(vector, length) \
- FAST_MEMORY_SET \
- ((vector), \
- 0, \
- (OBJECT_NEW_DATUM ((FAST_MEMORY_REF ((vector), 0)), (length))));
+#define SET_VECTOR_LENGTH(v, length) \
+ (MEMORY_SET ((v), 0, (OBJECT_NEW_DATUM ((MEMORY_REF ((v), 0)), (length)))))
-#define FAST_VECTOR_REF(vector, index) \
- (FAST_MEMORY_REF ((vector), ((index) + 1)))
-
-#define FAST_VECTOR_SET(vector, index, value) \
- FAST_MEMORY_SET ((vector), ((index) + 1), (value))
-
-#define VECTOR_LOC(vector, index) (MEMORY_LOC ((vector), ((index) + 1)))
-#define VECTOR_REF(vector, index) (MEMORY_REF ((vector), ((index) + 1)))
-
-#define VECTOR_SET(vector, index, value) \
- MEMORY_SET ((vector), ((index) + 1), (value))
+#define VECTOR_LOC(v, i) (MEMORY_LOC ((v), ((i) + 1)))
+#define VECTOR_REF(v, i) (MEMORY_REF ((v), ((i) + 1)))
+#define VECTOR_SET(v, i, object) MEMORY_SET ((v), ((i) + 1), (object))
\f
/* String Operations */
/* Add 1 byte to length to account for '\0' at end of string.
Add 1 word to length to account for string header word. */
-#define STRING_LENGTH_TO_GC_LENGTH(length) \
- ((BYTES_TO_WORDS ((length) + 1)) + 1)
+#define STRING_LENGTH_TO_GC_LENGTH(n_chars) \
+ ((BYTES_TO_WORDS ((n_chars) + 1)) + 1)
-#define STRING_LENGTH(string) \
- ((long) (MEMORY_REF ((string), STRING_LENGTH_INDEX)))
+#define STRING_LENGTH(s) \
+ (OBJECT_DATUM (MEMORY_REF ((s), STRING_LENGTH_INDEX)))
-#define SET_STRING_LENGTH(string, length) do \
+#define SET_STRING_LENGTH(s, n_chars) do \
{ \
- MEMORY_SET ((string), STRING_LENGTH_INDEX, (length)); \
- STRING_SET ((string), (length), '\0'); \
+ MEMORY_SET ((s), \
+ STRING_LENGTH_INDEX, \
+ (MAKE_OBJECT (0, (n_chars)))); \
+ STRING_SET ((s), (n_chars), '\0'); \
} while (0)
/* Subtract 1 to account for the fact that we maintain a '\0'
at the end of the string. */
-#define MAXIMUM_STRING_LENGTH(string) \
- ((long) ((((VECTOR_LENGTH (string)) - 1) * (sizeof (SCHEME_OBJECT))) - 1))
+#define MAXIMUM_STRING_LENGTH(s) \
+ ((((VECTOR_LENGTH (s)) - 1) * (sizeof (SCHEME_OBJECT))) - 1)
-#define SET_MAXIMUM_STRING_LENGTH(string, length) \
- SET_VECTOR_LENGTH ((string), (STRING_LENGTH_TO_GC_LENGTH (length)))
+#define SET_MAXIMUM_STRING_LENGTH(s, n_chars) \
+ (SET_VECTOR_LENGTH ((s), (STRING_LENGTH_TO_GC_LENGTH (n_chars))))
-#define STRING_LOC(string, index) \
- (((unsigned char *) (MEMORY_LOC (string, STRING_CHARS))) + (index))
+#define STRING_LOC(s, i) \
+ (((unsigned char *) (MEMORY_LOC (s, STRING_CHARS))) + (i))
#define STRING_POINTER(s) ((char *) (MEMORY_LOC (s, STRING_CHARS)))
+#define STRING_BYTE_PTR(s) ((byte_t *) (MEMORY_LOC (s, STRING_CHARS)))
-#define STRING_REF(string, index) \
- ((int) (* (STRING_LOC ((string), (index)))))
-
-#define STRING_SET(string, index, c_char) \
- (* (STRING_LOC ((string), (index)))) = (c_char)
+#define STRING_REF(s, i) (* (STRING_LOC ((s), (i))))
+#define STRING_SET(s, i, c) ((* (STRING_LOC ((s), (i)))) = (c))
/* Character Operations */
#define CHAR_BITS_SUPER 0x4
#define CHAR_BITS_HYPER 0x8
-#define MAX_ASCII (1L << ASCII_LENGTH)
-#define MAX_CODE (1L << CODE_LENGTH)
-#define MAX_BITS (1L << BITS_LENGTH)
-#define MAX_MIT_ASCII (1L << MIT_ASCII_LENGTH)
+#define MAX_ASCII (1UL << ASCII_LENGTH)
+#define MAX_CODE (1UL << CODE_LENGTH)
+#define MAX_BITS (1UL << BITS_LENGTH)
+#define MAX_MIT_ASCII (1UL << MIT_ASCII_LENGTH)
#define MASK_ASCII (MAX_ASCII - 1)
#define CHAR_MASK_CODE (MAX_CODE - 1)
#define CHAR_TO_ASCII_P(object) ((OBJECT_DATUM (object)) < MAX_ASCII)
#define CHAR_TO_ASCII(object) ((object) & MASK_ASCII)
-#define MAKE_CHAR(bucky_bits, code) \
- (MAKE_OBJECT \
- (TC_CHARACTER, \
- (((unsigned long) (bucky_bits)) << (CODE_LENGTH)) \
- | ((unsigned long) (code))))
+#define MAKE_CHAR(bits, code) \
+ (MAKE_OBJECT (TC_CHARACTER, \
+ ((((unsigned long) (bits)) << (CODE_LENGTH)) \
+ | ((unsigned long) (code)))))
-#define CHAR_BITS(chr) \
- ((((unsigned long) (OBJECT_DATUM (chr))) >> CODE_LENGTH) & CHAR_MASK_BITS)
-
-#define CHAR_CODE(chr) ((OBJECT_DATUM (chr)) & CHAR_MASK_CODE)
+#define CHAR_BITS(c) (((OBJECT_DATUM (c)) >> CODE_LENGTH) & CHAR_MASK_BITS)
+#define CHAR_CODE(c) ((OBJECT_DATUM (c)) & CHAR_MASK_CODE)
\f
/* Fixnum Operations */
#define FIXNUM_ZERO_P(fixnum) ((OBJECT_DATUM (fixnum)) == 0)
#define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0)
-#define UNSIGNED_FIXNUM_P(x) ((FIXNUM_P (x)) && (! (FIXNUM_NEGATIVE_P (x))))
+#define UNSIGNED_FIXNUM_P(x) ((FIXNUM_P (x)) && (!FIXNUM_NEGATIVE_P (x)))
#define FIXNUM_EQUAL_P(x, y) ((OBJECT_DATUM (x)) == (OBJECT_DATUM (y)))
#define FIXNUM_LESS_P(x, y) ((FIXNUM_TO_LONG (x)) < (FIXNUM_TO_LONG (y)))
(! ((FIXNUM_ZERO_P (fixnum)) || (FIXNUM_NEGATIVE_P (fixnum))))
#define UNSIGNED_FIXNUM_TO_LONG(fixnum) ((long) (OBJECT_DATUM (fixnum)))
-#define LONG_TO_UNSIGNED_FIXNUM_P(value) (((value) & SIGN_MASK) == 0)
-#define LONG_TO_UNSIGNED_FIXNUM(value) (FIXNUM_ZERO + (value))
-#define LONG_TO_FIXNUM(value) (OBJECT_NEW_TYPE (TC_FIXNUM, (value)))
+#define LONG_TO_UNSIGNED_FIXNUM_P(n) ((((unsigned long) (n)) & SIGN_MASK) == 0)
+
+#define LONG_TO_UNSIGNED_FIXNUM(n) \
+ (MAKE_OBJECT (TC_FIXNUM, ((unsigned long) (n))))
+
+#define LONG_TO_FIXNUM_P(n) \
+ (((((unsigned long) (n)) & SIGN_MASK) == 0) \
+ || ((((unsigned long) (n)) & SIGN_MASK) == SIGN_MASK))
-#define LONG_TO_FIXNUM_P(value) \
- ((((value) & SIGN_MASK) == 0) || (((value) & SIGN_MASK) == SIGN_MASK))
+#define LONG_TO_FIXNUM(n) \
+ (MAKE_OBJECT (TC_FIXNUM, (((unsigned long) (n)) & DATUM_MASK)))
#define FIXNUM_TO_LONG(fixnum) \
- ((((long) (fixnum)) ^ ((long) FIXNUM_SIGN_BIT)) \
- - ((long) ((((unsigned long) TC_FIXNUM) << DATUM_LENGTH) \
- | FIXNUM_SIGN_BIT)))
+ ((long) \
+ (((fixnum) ^ FIXNUM_SIGN_BIT) \
+ - ((((unsigned long) TC_FIXNUM) << DATUM_LENGTH) | FIXNUM_SIGN_BIT)))
-#define ULONG_TO_FIXNUM_P(value) (((value) & SIGN_MASK) == 0)
-#define ULONG_TO_FIXNUM(value) (FIXNUM_ZERO + (value))
+#define ULONG_TO_FIXNUM_P(n) (((n) & SIGN_MASK) == 0)
+#define ULONG_TO_FIXNUM(n) (MAKE_OBJECT (TC_FIXNUM, (n)))
#define FIXNUM_TO_ULONG_P(fixnum) (((OBJECT_DATUM (fixnum)) & SIGN_MASK) == 0)
#define FIXNUM_TO_ULONG(fixnum) (OBJECT_DATUM (fixnum))
&& ((number) < ((double) (BIGGEST_FIXNUM + 1))))
#ifdef HAVE_DOUBLE_TO_LONG_BUG
-#define DOUBLE_TO_FIXNUM double_to_fixnum
+# define DOUBLE_TO_FIXNUM double_to_fixnum
#else
-#define DOUBLE_TO_FIXNUM(number) (LONG_TO_FIXNUM ((long) (number)))
+# define DOUBLE_TO_FIXNUM(number) (LONG_TO_FIXNUM ((long) (number)))
#endif
\f
/* Bignum Operations */
#define BIGNUM_TO_ULONG_P(bignum) \
(bignum_fits_in_word_p ((bignum), ((sizeof (unsigned long)) * CHAR_BIT), 0))
-/* If precision should not be lost,
- compare to DBL_MANT_DIG instead. */
#define BIGNUM_TO_DOUBLE_P(bignum) \
(bignum_fits_in_word_p ((bignum), DBL_MAX_EXP, 0))
+#define LOSSLESS_BIGNUM_TO_DOUBLE_P(bignum) \
+ (bignum_fits_in_word_p ((bignum), DBL_MANT_DIG, 0))
+
/* Flonum Operations */
#define FLONUM_SIZE (BYTES_TO_WORDS (sizeof (double)))
#define OBJECT_TO_BOOLEAN(object) ((object) != SHARP_F)
#define MAKE_BROKEN_HEART(address) \
- (BROKEN_HEART_ZERO + (ADDRESS_TO_DATUM (address)))
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, (address)))
+
+#define MAKE_RETURN_CODE(n) (MAKE_OBJECT (TC_RETURN_CODE, (n)))
#define BYTES_TO_WORDS(nbytes) \
(((nbytes) + ((sizeof (SCHEME_OBJECT)) - 1)) / (sizeof (SCHEME_OBJECT)))
-#define ADDRESS_CONSTANT_P(address) \
- (((address) >= Constant_Space) && ((address) < Free_Constant))
-
-#define ADDRESS_PURE_P(address) \
- ((ADDRESS_CONSTANT_P (address)) && (Pure_Test (address)))
-
-#define ADDRESS_HEAP_P(address) \
- (((address) >= Heap_Bottom) && ((address) < Heap_Top))
-
-#define SIDE_EFFECT_IMPURIFY(Old_Pointer, Will_Contain) \
-if ((ADDRESS_CONSTANT_P (OBJECT_ADDRESS (Old_Pointer))) && \
- (GC_Type (Will_Contain) != GC_Non_Pointer) && \
- (! (ADDRESS_CONSTANT_P (OBJECT_ADDRESS (Will_Contain)))) && \
- (Pure_Test (OBJECT_ADDRESS (Old_Pointer)))) \
- signal_error_from_primitive (ERR_WRITE_INTO_PURE_SPACE); \
+#define HEAP_ADDRESS_P(address) \
+ (((address) >= heap_start) && ((address) < Free))
#ifndef FLOATING_ALIGNMENT
# define FLOATING_ALIGNMENT 0
#define FLOATING_ALIGNED_P(ptr) \
((((unsigned long) ((ptr) + 1)) & FLOATING_ALIGNMENT) == 0)
-#define ALIGN_FLOAT(Where) do \
+#define ALIGN_FLOAT(loc) do \
{ \
- while (!FLOATING_ALIGNED_P (Where)) \
- (*(Where)++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); \
+ while (!FLOATING_ALIGNED_P (loc)) \
+ (*(loc)++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); \
} while (0)
+/* Assigned TC_CONSTANT datum values:
+ 0 #t
+ 1 unspecific
+ 2 [non-object]
+ 3 #!optional
+ 4 #!rest
+ 5 #!key
+ 6 #!eof
+ 7 #!default
+ 8 #!aux
+ 9 '()
+ */
+
+#define SHARP_F MAKE_OBJECT (TC_NULL, 0)
+#define SHARP_T MAKE_OBJECT (TC_CONSTANT, 0)
+#define UNSPECIFIC MAKE_OBJECT (TC_CONSTANT, 1)
+#define DEFAULT_OBJECT MAKE_OBJECT (TC_CONSTANT, 7)
+#define EMPTY_LIST MAKE_OBJECT (TC_CONSTANT, 9)
+#define FIXNUM_ZERO MAKE_OBJECT (TC_FIXNUM, 0)
+#define BROKEN_HEART_ZERO MAKE_OBJECT (TC_BROKEN_HEART, 0)
+
+/* Last immediate reference trap. */
+#define TRAP_MAX_IMMEDIATE 9
+
#endif /* SCM_OBJECT_H */
/* obstack.c - subroutines used implicitly by object stack macros
Copyright (C) 1988 Free Software Foundation, Inc.
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 1, or (at your option) any
#include "obstack.h"
-#ifdef HAVE_STDC
-#define POINTER void *
-#else
-#define POINTER char *
-#endif
/* Determine default alignment. */
struct fooalign {char x; double d;};
in such a case, redefine COPYING_UNIT to `long' (if that works)
or `char' as a last resort. */
#ifndef COPYING_UNIT
-#define COPYING_UNIT int
+# define COPYING_UNIT int
#endif
/* The non-GNU-C macros copy the obstack into this global variable
and FREEFUN the function to free them. */
void
-_obstack_begin (h, size, alignment, chunkfun, freefun)
- struct obstack *h;
- int size;
- long alignment;
- POINTER EXFUN ((*chunkfun), (size_t));
- void EXFUN ((*freefun), (PTR));
+_obstack_begin (struct obstack * h,
+ int size,
+ long alignment,
+ void * (*chunkfun) (size_t),
+ void (*freefun) (void *))
{
- register struct _obstack_chunk* chunk; /* points to new chunk */
+ struct _obstack_chunk* chunk; /* points to new chunk */
if (alignment == 0)
alignment = DEFAULT_ALIGNMENT;
size = 4096 - extra;
}
- h->chunkfun = (struct _obstack_chunk * EXFUN((*),(long))) chunkfun;
+ h->chunkfun = (struct _obstack_chunk * (*)(long)) chunkfun;
h->freefun = freefun;
h->chunk_size = size;
h->alignment_mask = alignment - 1;
to the beginning of the new one. */
void
-_obstack_newchunk (h, length)
- struct obstack *h;
- int length;
+_obstack_newchunk (struct obstack * h, int length)
{
- register struct _obstack_chunk* old_chunk = h->chunk;
- register struct _obstack_chunk* new_chunk;
- register long new_size;
- register int obj_size = h->next_free - h->object_base;
- register int i;
+ struct _obstack_chunk* old_chunk = h->chunk;
+ struct _obstack_chunk* new_chunk;
+ long new_size;
+ int obj_size = h->next_free - h->object_base;
+ int i;
int already;
/* Compute size for new chunk. */
This is here for debugging.
If you use it in a program, you are probably losing. */
-extern int EXFUN (_obstack_allocated_p, (struct obstack *, POINTER));
-
int
-_obstack_allocated_p (h, obj)
- struct obstack *h;
- POINTER obj;
+_obstack_allocated_p (struct obstack * h, void * obj)
{
- register struct _obstack_chunk* lp; /* below addr of any objects in this chunk */
- register struct _obstack_chunk* plp; /* point to previous chunk if any */
+ struct _obstack_chunk* lp; /* below addr of any objects in this chunk */
+ struct _obstack_chunk* plp; /* point to previous chunk if any */
lp = (h)->chunk;
- while (lp != 0 && ((POINTER)lp > obj || (POINTER)(lp)->limit < obj))
+ while (lp != 0 && ((void *)lp > obj || (void *)(lp)->limit < obj))
{
plp = lp -> prev;
lp = plp;
/* Free objects in obstack H, including OBJ and everything allocate
more recently than OBJ. If OBJ is zero, free everything in H. */
-void
-#ifdef HAVE_STDC
#undef obstack_free
-obstack_free (struct obstack *h, POINTER obj)
-#else
-_obstack_free (h, obj)
- struct obstack *h;
- POINTER obj;
-#endif
+
+void
+obstack_free (struct obstack *h, void * obj)
{
- register struct _obstack_chunk* lp; /* below addr of any objects in this chunk */
- register struct _obstack_chunk* plp; /* point to previous chunk if any */
+ struct _obstack_chunk* lp; /* below addr of any objects in this chunk */
+ struct _obstack_chunk* plp; /* point to previous chunk if any */
lp = (h)->chunk;
/* We use >= because there cannot be an object at the beginning of a chunk.
But there can be an empty object at that address
at the end of another chunk. */
- while (lp != 0 && ((POINTER)lp >= obj || (POINTER)(lp)->limit < obj))
+ while (lp != 0 && ((void *)lp >= obj || (void *)(lp)->limit < obj))
{
plp = lp -> prev;
(*h->freefun) (lp);
/* Let same .o link with output of gcc and other compilers. */
-#ifdef HAVE_STDC
void
-_obstack_free (h, obj)
- struct obstack *h;
- POINTER obj;
+_obstack_free (struct obstack * h, void * obj)
{
obstack_free (h, obj);
}
-#endif
-\f
-#if 0
-/* These are now turned off because the applications do not use it
- and it uses bcopy via obstack_grow, which causes trouble on sysV. */
-
-/* Now define the functional versions of the obstack macros.
- Define them to simply use the corresponding macros to do the job. */
-
-#ifdef HAVE_STDC
-/* These function definitions do not work with non-ANSI preprocessors;
- they won't pass through the macro names in parentheses. */
-
-/* The function names appear in parentheses in order to prevent
- the macro-definitions of the names from being expanded there. */
-
-POINTER (obstack_base) (obstack)
- struct obstack *obstack;
-{
- return obstack_base (obstack);
-}
-
-POINTER (obstack_next_free) (obstack)
- struct obstack *obstack;
-{
- return obstack_next_free (obstack);
-}
-
-int (obstack_object_size) (obstack)
- struct obstack *obstack;
-{
- return obstack_object_size (obstack);
-}
-
-int (obstack_room) (obstack)
- struct obstack *obstack;
-{
- return obstack_room (obstack);
-}
-
-void (obstack_grow) (obstack, pointer, length)
- struct obstack *obstack;
- POINTER pointer;
- int length;
-{
- obstack_grow (obstack, pointer, length);
-}
-
-void (obstack_grow0) (obstack, pointer, length)
- struct obstack *obstack;
- POINTER pointer;
- int length;
-{
- obstack_grow0 (obstack, pointer, length);
-}
-
-void (obstack_1grow) (obstack, character)
- struct obstack *obstack;
- int character;
-{
- obstack_1grow (obstack, character);
-}
-
-void (obstack_blank) (obstack, length)
- struct obstack *obstack;
- int length;
-{
- obstack_blank (obstack, length);
-}
-
-void (obstack_1grow_fast) (obstack, character)
- struct obstack *obstack;
- int character;
-{
- obstack_1grow_fast (obstack, character);
-}
-
-void (obstack_blank_fast) (obstack, length)
- struct obstack *obstack;
- int length;
-{
- obstack_blank_fast (obstack, length);
-}
-
-POINTER (obstack_finish) (obstack)
- struct obstack *obstack;
-{
- return obstack_finish (obstack);
-}
-
-POINTER (obstack_alloc) (obstack, length)
- struct obstack *obstack;
- int length;
-{
- return obstack_alloc (obstack, length);
-}
-
-POINTER (obstack_copy) (obstack, pointer, length)
- struct obstack *obstack;
- POINTER pointer;
- int length;
-{
- return obstack_copy (obstack, pointer, length);
-}
-
-POINTER (obstack_copy0) (obstack, pointer, length)
- struct obstack *obstack;
- POINTER pointer;
- int length;
-{
- return obstack_copy0 (obstack, pointer, length);
-}
-
-#endif /* HAVE_STDC */
-
-#endif /* 0 */
/* obstack.h - object stack macros
Copyright (C) 1988 Free Software Foundation, Inc.
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 1, or (at your option) any
/* Don't do the contents of this file more than once. */
-#ifndef __OBSTACKS__
-#define __OBSTACKS__
+#ifndef SCM_OBSTACK_H
+#define SCM_OBSTACK_H 1
\f
#include "config.h"
-#include "ansidecl.h"
-
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# include <string.h>
-#endif
/* We use subtraction of (char *)0 instead of casting to int
because on word-addressable machines a simple cast to int
may ignore the byte-within-word field of the pointer. */
#ifndef __PTR_TO_INT
-#define __PTR_TO_INT(P) ((P) - (char *)0)
+# define __PTR_TO_INT(P) (((char *) (P)) - ((char *) 0))
#endif
#ifndef __INT_TO_PTR
-#define __INT_TO_PTR(P) ((PTR) ((P) + (char *)0))
+# define __INT_TO_PTR(P) ((void *) (((char *) 0) + (P)))
#endif
struct _obstack_chunk /* Lives at front of each chunk. */
long temp; /* Temporary for some macros. */
long alignment_mask; /* Mask of alignment for each object. */
/* User's fcn to allocate a chunk. */
- struct _obstack_chunk * EXFUN ((*chunkfun), (long));
+ struct _obstack_chunk * (*chunkfun) (long);
/* User's function to free a chunk. */
- void EXFUN ((*freefun), (PTR));
+ void (*freefun) (void *);
};
/* Declare the external functions we use; they are in obstack.c. */
-#ifdef HAVE_STDC
- extern void _obstack_newchunk (struct obstack *, int);
- extern void _obstack_free (struct obstack *, void *);
- extern void _obstack_begin (struct obstack *, int, long,
- void * (*) (size_t), void (*) (void *));
-#else
- extern void _obstack_newchunk ();
- extern void _obstack_free ();
- extern void _obstack_begin ();
-#endif
+extern void _obstack_newchunk (struct obstack *, int);
+extern void _obstack_free (struct obstack *, void *);
+extern void _obstack_begin
+ (struct obstack *, int, long, void * (*) (size_t), void (*) (void *));
\f
-#ifdef HAVE_STDC
-
/* Do the function-declarations after the structs
but before defining the macros. */
void * obstack_next_free (struct obstack *obstack);
int obstack_alignment_mask (struct obstack *obstack);
int obstack_chunk_size (struct obstack *obstack);
-
-#endif /* HAVE_STDC */
-
-/* Non-ANSI C cannot really support alternative functions for these macros,
- so we do not declare them. */
\f
/* Pointer to beginning of object being allocated or to be allocated next.
Note that this might not be the final address of the object
#define obstack_blank_fast(h,n) ((h)->next_free += (n))
\f
-#if defined (__GNUC__) && defined (__STDC__)
+#ifdef __GNUC__
/* For GNU C, if not -traditional,
we can define these macros to compute all args only once
/* These assume that the obstack alignment is good enough for pointers or ints,
and that the data added so far to the current object
shares that much alignment. */
-
+
#define obstack_ptr_grow(OBSTACK,datum) \
({ struct obstack *__o = (OBSTACK); \
((__o->next_free + sizeof (void *) > __o->chunk_limit) \
__o->next_free = __o->object_base = __obj; \
else (obstack_free) (__o, __obj); })
\f
-#else /* not __GNUC__ or not __STDC__ */
+#else /* not __GNUC__ */
#define obstack_object_size(h) \
(unsigned) ((h)->next_free - (h)->object_base)
(h)->object_base = (h)->next_free, \
__INT_TO_PTR ((h)->temp))
-#ifdef HAVE_STDC
#define obstack_free(h,obj) \
( (h)->temp = (char *)(obj) - (char *) (h)->chunk, \
(((h)->temp >= 0 && (h)->temp < (h)->chunk_limit - (char *) (h)->chunk)\
? (int) ((h)->next_free = (h)->object_base \
= (h)->temp + (char *) (h)->chunk) \
: (((obstack_free) ((h), (h)->temp + (char *) (h)->chunk), 0), 0)))
-#else
-#define obstack_free(h,obj) \
-( (h)->temp = (char *)(obj) - (char *) (h)->chunk, \
- (((h)->temp >= 0 && (h)->temp < (h)->chunk_limit - (char *) (h)->chunk)\
- ? (int) ((h)->next_free = (h)->object_base \
- = (h)->temp + (char *) (h)->chunk) \
- : (_obstack_free ((h), (h)->temp + (char *) (h)->chunk), 0)))
-#endif
-#endif /* not __GNUC__ or not __STDC__ */
+#endif /* not __GNUC__ */
-#endif /* not __OBSTACKS__ */
+#endif /* not SCM_OBSTACK_H */
/* -*-C-*-
-$Id: option.c,v 1.64 2007/01/05 21:19:25 cph Exp $
+$Id: option.c,v 1.65 2007/04/22 16:31:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "osfs.h"
#include <sys/stat.h>
-extern char * getenv ();
-extern void free ();
-#define xfree(p) free ((PTR) (p))
-extern int atoi ();
+#define xfree(p) OS_free ((void *) (p))
#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# include <string.h>
-#endif
-
-#ifdef HAVE_MALLOC_H
-# include <malloc.h>
-#endif
-
#ifdef __WIN32__
# include <io.h>
# include "nt.h"
# define DOS_LIKE_FILENAMES
#endif
-extern struct obstack scratch_obstack;
-extern CONST char * scheme_program_name;
-extern void EXFUN (termination_init_error, (void));
-
#ifndef SUB_DIRECTORY_DELIMITER
# ifdef DOS_LIKE_FILENAMES
# define SUB_DIRECTORY_DELIMITER '\\'
#define FILE_READABLE(filename) (OS_file_access ((filename), 4))
\f
-static int option_summary;
-static int option_large_sizes;
-
-#ifdef HAS_COMPILER_SUPPORT
-static int option_compiler_defaults;
-static int option_edwin_defaults;
-#endif
-
-static CONST char * option_raw_library = 0;
-static CONST char * option_raw_utabmd = 0;
-static CONST char * option_raw_utab = 0;
-static CONST char * option_raw_band = 0;
-static CONST char * option_raw_heap = 0;
-static CONST char * option_raw_constant = 0;
-static CONST char * option_raw_stack = 0;
+static bool option_summary;
+static bool option_large_sizes;
+static bool option_compiler_defaults;
+static bool option_edwin_defaults;
+
+static const char * option_raw_library;
+static const char * option_raw_utabmd;
+static const char * option_raw_utab;
+static const char * option_raw_band;
+static const char * option_raw_heap;
+static const char * option_raw_constant;
+static const char * option_raw_stack;
/* Command-line arguments */
int option_saved_argc;
-CONST char ** option_saved_argv;
+const char ** option_saved_argv;
int option_unused_argc;
-CONST char ** option_unused_argv;
+const char ** option_unused_argv;
/* Boolean options */
-int option_emacs_subprocess;
-int option_force_interactive;
-int option_disable_core_dump;
-int option_band_specified;
-int option_empty_list_eq_false;
-int option_batch_mode;
+bool option_emacs_subprocess;
+bool option_force_interactive;
+bool option_disable_core_dump;
+bool option_band_specified;
+bool option_batch_mode;
/* String options */
-CONST char ** option_library_path = 0;
-CONST char * option_band_file = 0;
-CONST char * option_fasl_file = 0;
-CONST char * option_utabmd_file = 0;
+const char ** option_library_path = 0;
+const char * option_band_file = 0;
+const char * option_fasl_file = 0;
+const char * option_utabmd_file = 0;
/* Numeric options */
-unsigned int option_heap_size;
-unsigned int option_constant_size;
-unsigned int option_stack_size;
-
-/* These only matter for bchscheme */
-static CONST char * option_raw_gc_end_position = 0;
-static CONST char * option_raw_gc_file = 0;
-static CONST char * option_raw_gc_read_overlap = 0;
-static CONST char * option_raw_gc_start_position = 0;
-static CONST char * option_raw_gc_window_size = 0;
-static CONST char * option_raw_gc_write_overlap = 0;
-CONST char * option_gc_directory = 0;
-CONST char * option_gc_drone = 0;
-CONST char * option_gc_file = 0;
-int option_gc_keep;
-int option_gc_read_overlap;
-int option_gc_window_size;
-int option_gc_write_overlap;
-long option_gc_start_position;
-long option_gc_end_position;
-\f/*
+unsigned long option_heap_size;
+unsigned long option_constant_size;
+unsigned long option_stack_size;
+\f
+/*
+
Scheme accepts the following command-line options. The options may
appear in any order, but they must all appear before any other
arguments on the command line.
--option-summary
Causes Scheme to write option information to standard error.
-\f
+
--emacs
Specifies that Scheme is running as a subprocess of GNU Emacs.
This option is automatically supplied by GNU Emacs, and should not
MITSCHEME_EDWIN_BAND is used, otherwise "edwin.com" is used. It
also specifies the use of large sizes, exactly like "--large".
-The following options are only meaningful to bchscheme:
-
---gc-directory DIRECTORY
- Specifies what directory to use to allocate the garbage collection file.
-
---gc-drone FILENAME
- Specifies the program to use as the gc drones for overlapped I/O.
-
---gc-end-position N
- Specifies a position into the gc file past which bchscheme should not use.
-
---gc-file FILENAME
- Specifies that FILENAME should be used garbage collection. Overrides
- -gc-directory if it is an absolute pathname. -gcfile means the same thing,
- but is deprecated.
-
---gc-keep
- Specifles that newly allocated gc files should be kept rather than deleted.
-
---gc-read-overlap N
- Specifies the number of additional GC windows to use when reading
- for overlapped I/O. Each implies a drone process to manage it,
- if supported.
-
---gc-start-position N
- Specifies a position into the gc file before which bchscheme should not use.
-
---gc-window-size BLOCKS
- Specifies the size in 1024-word blocks of each GC window.
-
---gc-write-overlap N
- Specifies the number of additional GC windows to use when writing for
- overlapped I/O. Each implies a drone process to manage it, if supported.
*/
\f
#ifndef LIBRARY_PATH_VARIABLE
#ifndef DEFAULT_UTABMD_FILE
# define DEFAULT_UTABMD_FILE "utabmd.bin"
#endif
-\f
-#ifdef HAS_COMPILER_SUPPORT
-
-# if defined(hp9000s800) || defined(__hp9000s800)
-/* HPPA compiled binaries are large! */
-
-# ifndef DEFAULT_SMALL_CONSTANT
-# define DEFAULT_SMALL_CONSTANT 600
-# endif
-
-# ifndef DEFAULT_LARGE_CONSTANT
-# define DEFAULT_LARGE_CONSTANT 1400
-# endif
-
-# endif /* hp9000s800 */
-
-# ifdef mips
-/* MIPS compiled binaries are large! */
-
-# ifndef DEFAULT_SMALL_CONSTANT
-# define DEFAULT_SMALL_CONSTANT 700
-# endif
-
-# ifndef DEFAULT_LARGE_CONSTANT
-# define DEFAULT_LARGE_CONSTANT 1500
-# endif
-
-# endif /* mips */
-
-# ifdef __IA32__
-/* 386 code is large too! */
-
-# ifndef DEFAULT_SMALL_CONSTANT
-# define DEFAULT_SMALL_CONSTANT 600
-# endif
-
-# ifndef DEFAULT_LARGE_CONSTANT
-# define DEFAULT_LARGE_CONSTANT 1200
-# endif
-
-# endif /* __IA32__ */
-
-#endif /* HAS_COMPILER_SUPPORT */
#ifndef DEFAULT_SMALL_HEAP
# define DEFAULT_SMALL_HEAP 250
#endif
#ifndef DEFAULT_SMALL_STACK
-# define DEFAULT_SMALL_STACK 100
+# define DEFAULT_SMALL_STACK 100
#endif
#ifndef SMALL_STACK_VARIABLE
# define LARGE_STACK_VARIABLE "MITSCHEME_LARGE_STACK"
#endif
\f
-/* These are only meaningful for bchscheme */
-
-#ifndef DEFAULT_GC_DIRECTORY
-# ifdef DOS_LIKE_FILENAMES
-# define DEFAULT_GC_DIRECTORY "\\tmp"
-# else
-# define DEFAULT_GC_DIRECTORY "/tmp"
-# endif
-#endif
-
-#ifndef GC_DIRECTORY_VARIABLE
-# define GC_DIRECTORY_VARIABLE "MITSCHEME_GC_DIRECTORY"
-#endif
-
-#ifndef DEFAULT_GC_DRONE
-# define DEFAULT_GC_DRONE "gcdrone"
-#endif
-
-#ifndef GC_DRONE_VARIABLE
-# define GC_DRONE_VARIABLE "MITSCHEME_GC_DRONE"
-#endif
-
-#ifndef DEFAULT_GC_END_POSITION
-# define DEFAULT_GC_END_POSITION (-1)
-#endif
-
-#ifndef GC_END_POSITION_VARIABLE
-# define GC_END_POSITION_VARIABLE "MITSCHEME_GC_END_POSITION"
-#endif
-
-#ifndef DEFAULT_GC_FILE
-# define DEFAULT_GC_FILE "GCXXXXXX"
-#endif
-
-#ifndef GC_FILE_VARIABLE
-# define GC_FILE_VARIABLE "MITSCHEME_GC_FILE"
-#endif
-
-#ifndef DEFAULT_GC_READ_OVERLAP
-# define DEFAULT_GC_READ_OVERLAP 0
-#endif
-
-#ifndef GC_READ_OVERLAP_VARIABLE
-# define GC_READ_OVERLAP_VARIABLE "MITSCHEME_GC_READ_OVERLAP"
-#endif
-
-#ifndef DEFAULT_GC_START_POSITION
-# define DEFAULT_GC_START_POSITION 0
-#endif
-
-#ifndef GC_START_POSITION_VARIABLE
-# define GC_START_POSITION_VARIABLE "MITSCHEME_GC_START_POSITION"
-#endif
-
-#ifndef DEFAULT_GC_WINDOW_SIZE
-# define DEFAULT_GC_WINDOW_SIZE 16
-#endif
-
-#ifndef GC_WINDOW_SIZE_VARIABLE
-# define GC_WINDOW_SIZE_VARIABLE "MITSCHEME_GC_WINDOW_SIZE"
-#endif
-
-#ifndef DEFAULT_GC_WRITE_OVERLAP
-# define DEFAULT_GC_WRITE_OVERLAP 0
-#endif
-
-#ifndef GC_WRITE_OVERLAP_VARIABLE
-# define GC_WRITE_OVERLAP_VARIABLE "MITSCHEME_GC_WRITE_OVERLAP"
-#endif
-\f
static int
-DEFUN (string_compare_ci, (string1, string2),
- CONST char * string1 AND
- CONST char * string2)
+string_compare_ci (const char * string1, const char * string2)
{
- CONST char * scan1 = string1;
+ const char * scan1 = string1;
unsigned int length1 = (strlen (string1));
- CONST char * scan2 = string2;
+ const char * scan2 = string2;
unsigned int length2 = (strlen (string2));
unsigned int length = ((length1 < length2) ? length1 : length2);
- CONST char * end1 = (scan1 + length);
- CONST char * end2 = (scan2 + length);
+ const char * end1 = (scan1 + length);
+ const char * end2 = (scan2 + length);
while ((scan1 < end1) && (scan2 < end2))
{
int c1 = (*scan1++);
: ((length1 < length2) ? (-1) : 1));
}
-static PTR
-DEFUN (xmalloc, (n), unsigned long n)
-{
- PTR result = (malloc (n));
- if (result == 0)
- {
- outf_fatal ("%s: unable to allocate space while parsing options.\n",
- scheme_program_name);
- termination_init_error ();
- }
- return (result);
-}
-
static char *
-DEFUN (string_copy, (s), CONST char * s)
+string_copy (const char * s)
{
- char * result = (xmalloc ((strlen (s)) + 1));
+ char * result = (OS_malloc ((strlen (s)) + 1));
{
- CONST char * s1 = s;
+ const char * s1 = s;
char * s2 = result;
while (((*s2++) = (*s1++)) != '\0') ;
}
\f
struct option_descriptor
{
- CONST char * option;
- int argument_p;
- PTR value_cell;
+ const char * option;
+ bool argument_p;
+ void * value_cell;
};
static void
-DEFUN (option_argument, (option, argument_p, value_cell),
- CONST char * option AND
- int argument_p AND
- CONST PTR value_cell)
+option_argument (const char * option, bool argument_p, void * value_cell)
{
struct option_descriptor descriptor;
(descriptor . option) = option;
(descriptor . argument_p) = argument_p;
- (descriptor . value_cell) = ((PTR) value_cell);
+ (descriptor . value_cell) = value_cell;
obstack_grow ((&scratch_obstack), (&descriptor), (sizeof (descriptor)));
}
static void
-DEFUN (parse_options, (argc, argv), int argc AND CONST char ** argv)
+parse_options (int argc, const char ** argv)
{
- CONST char ** scan_argv = (argv + 1);
- CONST char ** end_argv = (scan_argv + (argc - 1));
+ const char ** scan_argv = (argv + 1);
+ const char ** end_argv = (scan_argv + (argc - 1));
unsigned int n_descriptors =
((obstack_object_size (&scratch_obstack))
/ (sizeof (struct option_descriptor)));
struct option_descriptor * end_desc = (descriptors + n_descriptors);
struct option_descriptor * scan_desc;
for (scan_desc = descriptors; (scan_desc < end_desc); scan_desc += 1)
- if (scan_desc -> argument_p)
+ if (scan_desc->argument_p)
{
- CONST char ** value_cell = (scan_desc -> value_cell);
+ const char ** value_cell = (scan_desc->value_cell);
(*value_cell) = 0;
}
else
{
- int * value_cell = (scan_desc -> value_cell);
- (*value_cell) = 0;
+ bool * value_cell = (scan_desc->value_cell);
+ (*value_cell) = false;
}
while (scan_argv < end_argv)
{
- CONST char * option = (*scan_argv++);
+ const char * option = (*scan_argv++);
if ((strncmp ("--", option, 2)) == 0)
option += 2;
else if ((strncmp ("-", option, 1)) == 0)
break;
}
for (scan_desc = descriptors; (scan_desc < end_desc); scan_desc += 1)
- if ((string_compare_ci (option, (scan_desc -> option))) == 0)
+ if ((string_compare_ci (option, (scan_desc->option))) == 0)
{
- if (scan_desc -> argument_p)
+ if (scan_desc->argument_p)
{
- CONST char ** value_cell = (scan_desc -> value_cell);
+ const char ** value_cell = (scan_desc->value_cell);
if (scan_argv < end_argv)
(*value_cell) = (*scan_argv++);
else
{
outf_fatal ("%s: option --%s requires an argument.\n",
- scheme_program_name, option);
+ scheme_program_name, option);
termination_init_error ();
}
}
else
{
- int * value_cell = (scan_desc -> value_cell);
- (*value_cell) = 1;
+ bool * value_cell = (scan_desc->value_cell);
+ (*value_cell) = true;
}
break;
}
}
\f
static void
-DEFUN (parse_standard_options, (argc, argv), int argc AND CONST char ** argv)
+parse_standard_options (int argc, const char ** argv)
{
- option_argument ("band", 1, (&option_raw_band));
- option_argument ("constant", 1, (&option_raw_constant));
- option_argument ("emacs", 0, (&option_emacs_subprocess));
- option_argument ("fasl", 1, (&option_fasl_file));
- option_argument ("heap", 1, (&option_raw_heap));
- option_argument ("interactive", 0, (&option_force_interactive));
- option_argument ("large", 0, (&option_large_sizes));
- option_argument ("library", 1, (&option_raw_library));
- option_argument ("nocore", 0, (&option_disable_core_dump));
- option_argument ("option-summary", 0, (&option_summary));
- option_argument ("stack", 1, (&option_raw_stack));
- option_argument ("utab", 1, (&option_raw_utab));
- option_argument ("utabmd", 1, (&option_raw_utabmd));
- option_argument ("empty-list-eq-false", 0, (&option_empty_list_eq_false));
- option_argument ("batch-mode", 0, (&option_batch_mode));
-#ifdef HAS_COMPILER_SUPPORT
- option_argument ("compiler", 0, (&option_compiler_defaults));
- option_argument ("edwin", 0, (&option_edwin_defaults));
-#endif
- /* The following options are only meaningful to bchscheme. */
- option_argument ("gc-directory", 1, (&option_gc_directory));
- option_argument ("gc-drone", 1, (&option_gc_drone));
- option_argument ("gc-end-position", 1, (&option_raw_gc_end_position));
- option_argument ("gc-file", 1, (&option_gc_file));
- option_argument ("gc-keep", 0, (&option_gc_keep));
- option_argument ("gc-start-position", 1, (&option_raw_gc_start_position));
- option_argument ("gc-read-overlap", 1, (&option_raw_gc_read_overlap));
- option_argument ("gc-window-size", 1, (&option_raw_gc_window_size));
- option_argument ("gc-write-overlap", 1, (&option_raw_gc_write_overlap));
- option_argument ("gcfile", 1, (&option_raw_gc_file)); /* Obsolete */
+ option_argument ("band", true, (&option_raw_band));
+ option_argument ("constant", true, (&option_raw_constant));
+ option_argument ("emacs", false, (&option_emacs_subprocess));
+ option_argument ("fasl", true, (&option_fasl_file));
+ option_argument ("heap", true, (&option_raw_heap));
+ option_argument ("interactive", false, (&option_force_interactive));
+ option_argument ("large", false, (&option_large_sizes));
+ option_argument ("library", true, (&option_raw_library));
+ option_argument ("nocore", false, (&option_disable_core_dump));
+ option_argument ("option-summary", false, (&option_summary));
+ option_argument ("stack", true, (&option_raw_stack));
+ option_argument ("utab", true, (&option_raw_utab));
+ option_argument ("utabmd", true, (&option_raw_utabmd));
+ option_argument ("batch-mode", false, (&option_batch_mode));
+ option_argument ("compiler", false, (&option_compiler_defaults));
+ option_argument ("edwin", false, (&option_edwin_defaults));
parse_options (argc, argv);
}
-\f
-static CONST char *
-DEFUN (string_option, (option, defval),
- CONST char * option AND
- CONST char * defval)
-{
- return ((option == 0) ? defval : option);
-}
-
-static CONST char *
-DEFUN (environment_default, (variable, defval),
- CONST char * variable AND
- CONST char * defval)
-{
- CONST char * temp = (getenv (variable));
- return ((temp == 0) ? defval : temp);
-}
-static CONST char *
-DEFUN (standard_string_option, (option, variable, defval),
- CONST char * option AND
- CONST char * variable AND
- CONST char * defval)
+static const char *
+standard_string_option (const char * option,
+ const char * variable,
+ const char * defval)
{
if (option != 0)
return (option);
{
- CONST char * t = (getenv (variable));
+ const char * t = (getenv (variable));
return ((t != 0) ? t : defval);
}
}
-static long
-DEFUN (non_negative_numeric_option, (option, optval, variable, defval),
- CONST char * option AND
- CONST char * optval AND
- CONST char * variable AND
- long defval)
-{
- if (optval != 0)
- {
- long n = (strtol (optval, 0, 0));
- if (n < 0)
- {
- outf_fatal ("%s: illegal argument %s for option --%s.\n",
- scheme_program_name, optval, option);
- termination_init_error ();
- }
- return (n);
- }
- {
- CONST char * t = (getenv (variable));
- if (t != 0)
- {
- long n = (strtol (t, 0, 0));
- if (n < 0)
- {
- outf_fatal ("%s: illegal value %s for variable %s.\n",
- scheme_program_name, t, variable);
- termination_init_error ();
- }
- return (n);
- }
- }
- return (defval);
-}
-
-static unsigned int
-DEFUN (standard_numeric_option, (option, optval, variable, defval),
- CONST char * option AND
- CONST char * optval AND
- CONST char * variable AND
- unsigned int defval)
+static unsigned long
+standard_numeric_option (const char * option,
+ const char * optval,
+ const char * variable,
+ unsigned long defval)
{
if (optval != 0)
{
- int n = (atoi (optval));
- if (n <= 0)
+ char * end;
+ unsigned long n = (strtoul (optval, (&end), 0));;
+ if ((end == optval) || ((*end) != '\0'))
{
- outf_fatal ("%s: illegal argument %s for option --%s.\n",
- scheme_program_name, optval, option);
+ outf_fatal ("%s: illegal argument for option --%s: %s\n",
+ scheme_program_name, option, optval);
termination_init_error ();
}
return (n);
}
{
- CONST char * t = (getenv (variable));
+ const char * t = (getenv (variable));
if (t != 0)
{
- int n = (atoi (t));
- if (n <= 0)
+ char * end;
+ unsigned long n = (strtoul (t, (&end), 0));;
+ if ((end == t) || ((*end) != '\0'))
{
- outf_fatal ("%s: illegal value %s for variable %s.\n",
- scheme_program_name, t, variable);
+ outf_fatal ("%s: illegal value for environment variable %s: %s\n",
+ scheme_program_name, variable, t);
termination_init_error ();
}
return (n);
return (defval);
}
\f
-static CONST char *
-DEFUN_VOID (get_wd)
+static const char *
+get_wd (void)
{
- CONST char * wd = (OS_working_dir_pathname ());
+ const char * wd = (OS_working_dir_pathname ());
unsigned int len = (strlen (wd));
if ((wd [len - 1]) == SUB_DIRECTORY_DELIMITER)
len -= 1;
{
- char * result = (xmalloc (len + 1));
+ char * result = (OS_malloc (len + 1));
char * scan_result = result;
- CONST char * scan_wd = wd;
- CONST char * end_wd = (scan_wd + len);
+ const char * scan_wd = wd;
+ const char * end_wd = (scan_wd + len);
while (scan_wd < end_wd)
(*scan_result++) = (*scan_wd++);
(*scan_result) = '\0';
}
}
-static CONST char **
-DEFUN (parse_path_string, (path), CONST char * path)
+static const char **
+parse_path_string (const char * path)
{
- CONST char * start = path;
+ const char * start = path;
/* It is important that this get_wd be called here to make sure that
the the unix getcwd is called now, before it allocates heap space
This is because getcwd forks off a new process and we want to do
that before the scheme process gets too big
*/
- CONST char * wd = (get_wd ());
+ const char * wd = (get_wd ());
unsigned int lwd = (strlen (wd));
while (1)
{
- CONST char * scan = start;
- CONST char * end;
+ const char * scan = start;
+ const char * end;
while (1)
{
int c = (*scan++);
int absolute = (FILE_ABSOLUTE (start));
{
char * element =
- (xmalloc ((absolute ? 0 : (lwd + 1)) + (end - start) + 1));
+ (OS_malloc ((absolute ? 0 : (lwd + 1)) + (end - start) + 1));
char * scan_element = element;
if (!absolute)
{
- CONST char * s = wd;
- CONST char * e = (wd + lwd);
+ const char * s = wd;
+ const char * e = (wd + lwd);
while (s < e)
(*scan_element++) = (*s++);
(*scan_element++) = SUB_DIRECTORY_DELIMITER;
}
{
- CONST char * s = start;
+ const char * s = start;
while (s < end)
(*scan_element++) = (*s++);
}
xfree (wd);
{
unsigned int n_bytes = (obstack_object_size (&scratch_obstack));
- CONST char ** elements = (obstack_finish (&scratch_obstack));
- CONST char ** scan = elements;
- CONST char ** end = (scan + (n_bytes / (sizeof (char *))));
- CONST char ** result = (xmalloc (n_bytes));
- CONST char ** scan_result = result;
+ const char ** elements = (obstack_finish (&scratch_obstack));
+ const char ** scan = elements;
+ const char ** end = (scan + (n_bytes / (sizeof (char *))));
+ const char ** result = (OS_malloc (n_bytes));
+ const char ** scan_result = result;
while (scan < end)
(*scan_result++) = (*scan++);
obstack_free ((&scratch_obstack), elements);
}
static void
-DEFUN (free_parsed_path, (path), CONST char ** path)
+free_parsed_path (const char ** path)
{
- CONST char ** scan = path;
+ const char ** scan = path;
while (1)
{
- CONST char * element = (*scan++);
+ const char * element = (*scan++);
if (element == 0)
break;
xfree (element);
xfree (path);
}
\f
-CONST char *
-DEFUN (search_for_library_file, (filename), CONST char * filename)
+const char *
+search_for_library_file (const char * filename)
{
unsigned int flen = (strlen (filename));
- CONST char ** scan_path = option_library_path;
+ const char ** scan_path = option_library_path;
while (1)
{
- CONST char * directory = (*scan_path++);
+ const char * directory = (*scan_path++);
unsigned int dlen;
- CONST char * fullname;
+ const char * fullname;
if (directory == 0)
return (0);
dlen = (strlen (directory));
fullname = (obstack_finish (&scratch_obstack));
if (FILE_READABLE (fullname))
{
- CONST char * result = (string_copy (fullname));
+ const char * result = (string_copy (fullname));
obstack_free ((&scratch_obstack), ((char *) fullname));
return (result);
}
}
}
-CONST char *
-DEFUN (search_path_for_file, (option, filename, default_p, fail_p),
- CONST char * option AND
- CONST char * filename AND
- int default_p AND
- int fail_p)
+const char *
+search_path_for_file (const char * option,
+ const char * filename,
+ bool default_p,
+ bool fail_p)
{
- CONST char * result = (search_for_library_file (filename));
+ const char * result = (search_for_library_file (filename));
if (result != 0)
return (result);
if (!fail_p)
return (filename);
else
{
- CONST char ** scan_path = option_library_path;
+ const char ** scan_path = option_library_path;
outf_fatal ("%s: can't find a readable %s",
scheme_program_name,
(default_p ? "default" : "file"));
outf_fatal ("\t.\n");
while (1)
{
- CONST char * element = (*scan_path++);
+ const char * element = (*scan_path++);
if (element == 0)
break;
outf_fatal ("\t%s\n", element);
}
}
\f
-static CONST char *
-DEFUN (standard_filename_option, (option, optval, variable, defval, fail_p),
- CONST char * option AND
- CONST char * optval AND
- CONST char * variable AND
- CONST char * defval AND
- int fail_p)
+static const char *
+standard_filename_option (const char * option,
+ const char * optval,
+ const char * variable,
+ const char * defval,
+ bool fail_p)
{
if (optval != 0)
{
}
return (string_copy (optval));
}
- return (search_path_for_file (option, optval, 0, fail_p));
+ return (search_path_for_file (option, optval, false, fail_p));
}
{
- CONST char * filename = (getenv (variable));
+ const char * filename = (getenv (variable));
if (filename == 0)
filename = defval;
if (FILE_ABSOLUTE (filename))
return (string_copy (filename));
}
else
- return (search_path_for_file (option, filename, 1, fail_p));
+ return (search_path_for_file (option, filename, true, fail_p));
}
}
static void
-DEFUN (conflicting_options, (option1, option2),
- CONST char * option1 AND
- CONST char * option2)
+conflicting_options (const char * option1, const char * option2)
{
outf_fatal ("%s: can't specify both options --%s and --%s.\n",
scheme_program_name, option1, option2);
#define SCHEME_WORDS_TO_BLOCKS(n) (((n) + 1023) / 1024)
static int
-DEFUN (read_band_header, (filename, header),
- CONST char * filename AND
- SCHEME_OBJECT * header)
+read_band_sizes (const char * filename,
+ unsigned long * constant_size,
+ unsigned long * heap_size)
{
- int result = 1;
-
-#ifdef __WIN32__
+ fasl_file_handle_t handle;
+ fasl_header_t h;
+ bool ok;
- HANDLE handle
- = (CreateFile (filename,
- GENERIC_READ,
- (FILE_SHARE_READ | FILE_SHARE_WRITE),
- 0,
- OPEN_EXISTING,
- (FILE_ATTRIBUTE_NORMAL | FILE_FLAG_SEQUENTIAL_SCAN),
- 0));
- DWORD bytes_to_read = ((sizeof (SCHEME_OBJECT)) * FASL_HEADER_LENGTH);
- DWORD bytes_read;
- if (handle == INVALID_HANDLE_VALUE)
+ if (!open_fasl_input_file (filename, (&handle)))
return (0);
-
- if (! ((ReadFile (handle, header, bytes_to_read, (&bytes_read), 0))
- && (bytes_read == bytes_to_read)))
- result = 0;
-
- CloseHandle (handle);
-
-#else /* not __WIN32__ */
-
- FILE * stream = (fopen (filename, "r"));
- if (stream == 0)
+ ok = (read_fasl_header ((&h), handle));
+ if (! ((close_fasl_input_file (handle)) && ok))
return (0);
- if ((fread (header, (sizeof (SCHEME_OBJECT)), FASL_HEADER_LENGTH, stream))
- != FASL_HEADER_LENGTH)
- result = 0;
-
- fclose (stream);
-
-#endif /* not __WIN32__ */
-
- /* Note: This is an approximation to whether the file can be loaded
- as a band.
- Mostly it catches wrong-format files (e.g. bands for another arch.)
- */
-
- if (((header[FASL_Offset_Marker]) != FASL_FILE_MARKER)
- || ((The_Version (header[FASL_Offset_Version])) != FASL_READ_VERSION)
- || ((The_Machine_Type (header[FASL_Offset_Version]))
- != FASL_INTERNAL_FORMAT))
- result = 0;
-
- return (result);
-}
-
-static int
-DEFUN (read_band_sizes, (filename, constant_size, heap_size),
- CONST char * filename AND
- unsigned long * constant_size AND
- unsigned long * heap_size)
-{
- SCHEME_OBJECT header [FASL_HEADER_LENGTH];
- if (!read_band_header (filename, header))
+ if ((check_fasl_version (&h)) != FASL_FILE_FINE)
+ return (0);
+ if ((check_fasl_cc_version ((&h),
+ COMPILER_INTERFACE_VERSION,
+ COMPILER_PROCESSOR_TYPE))
+ != FASL_FILE_FINE)
return (0);
- (*constant_size)
- = (SCHEME_WORDS_TO_BLOCKS
- (OBJECT_DATUM (header [FASL_Offset_Const_Count])));
- (*heap_size)
- = (SCHEME_WORDS_TO_BLOCKS
- (OBJECT_DATUM (header [FASL_Offset_Heap_Count])));
+ (*constant_size) = (SCHEME_WORDS_TO_BLOCKS (FASLHDR_CONSTANT_SIZE (&h)));
+ (*heap_size) = (SCHEME_WORDS_TO_BLOCKS (FASLHDR_HEAP_SIZE (&h)));
return (1);
}
\f
static void
-DEFUN (describe_boolean_option, (name, value),
- CONST char * name AND
- int value)
+describe_boolean_option (const char * name, int value)
{
outf_fatal (" %s: %s\n", name, (value ? "yes" : "no"));
}
static void
-DEFUN (describe_string_option, (name, value),
- CONST char * name AND
- CONST char * value)
+describe_string_option (const char * name, const char * value)
{
outf_fatal (" %s: %s\n", name, value);
}
static void
-DEFUN (describe_numeric_option, (name, value),
- CONST char * name AND
- int value)
-{
- outf_fatal (" %s: %d\n", name, value);
-}
-
-static void
-DEFUN (describe_size_option, (name, value),
- CONST char * name AND
- unsigned int value)
+describe_size_option (const char * name, unsigned int value)
{
outf_fatal (" %s size: %d\n", name, value);
}
static void
-DEFUN (describe_path_option, (name, value),
- CONST char * name AND
- CONST char ** value)
+describe_path_option (const char * name, const char ** value)
{
outf_fatal (" %s: ", name);
{
- CONST char ** scan = value;
+ const char ** scan = value;
outf_fatal ("%s", (*scan++));
while (1)
{
- CONST char * element = (*scan++);
+ const char * element = (*scan++);
if (element == 0) break;
outf_fatal (":%s", element);
}
}
static void
-DEFUN_VOID (describe_options)
+describe_options (void)
{
outf_fatal ("Summary of configuration options:\n");
describe_size_option ("heap", option_heap_size);
else
describe_string_option ("band", option_band_file);
describe_string_option ("microcode tables", option_utabmd_file);
- {
- /* These are only relevant to bchscheme. */
- if (option_gc_directory != DEFAULT_GC_DIRECTORY)
- describe_string_option ("GC directory", option_gc_directory);
- if (option_gc_drone != DEFAULT_GC_DRONE)
- describe_string_option ("GC drone program", option_gc_drone);
- if (option_raw_gc_end_position)
- describe_numeric_option ("GC end position", option_gc_end_position);
- if (option_gc_file != DEFAULT_GC_FILE)
- describe_string_option ("GC file", option_gc_file);
- if (option_raw_gc_read_overlap)
- describe_numeric_option ("GC read overlap", option_gc_read_overlap);
- if (option_raw_gc_start_position)
- describe_numeric_option ("GC start position", option_gc_start_position);
- if (option_raw_gc_window_size)
- describe_size_option ("GC window size", option_gc_window_size);
- if (option_raw_gc_write_overlap)
- describe_numeric_option ("GC write overlap", option_gc_write_overlap);
- if (option_gc_keep)
- describe_boolean_option ("keep GC file", option_gc_keep);
- }
describe_boolean_option ("emacs subprocess", option_emacs_subprocess);
describe_boolean_option ("force interactive", option_force_interactive);
describe_boolean_option ("disable core dump", option_disable_core_dump);
outf_fatal (" no unused arguments\n");
else
{
- CONST char ** scan = option_unused_argv;
- CONST char ** end = (scan + option_unused_argc);
+ const char ** scan = option_unused_argv;
+ const char ** end = (scan + option_unused_argc);
outf_fatal (" unused arguments:");
while (scan < end)
outf_fatal (" %s", (*scan++));
}
\f
void
-DEFUN (read_command_line_options, (argc, argv),
- int argc AND
- CONST char ** argv)
+read_command_line_options (int argc, const char ** argv)
{
- int band_sizes_valid = 0;
- int fail_fasl_if_no_utab = 0;
- unsigned long band_constant_size;
- unsigned long band_heap_size;
+ bool band_sizes_valid = false;
+ unsigned long band_constant_size = 0;
+ unsigned long band_heap_size = 0;
parse_standard_options (argc, argv);
if (option_library_path != 0)
LIBRARY_PATH_VARIABLE,
DEFAULT_LIBRARY_PATH)));
{
- CONST char * band_variable = BAND_VARIABLE;
- CONST char * default_band = DEFAULT_BAND;
+ const char * band_variable = BAND_VARIABLE;
+ const char * default_band = DEFAULT_BAND;
-#ifdef HAS_COMPILER_SUPPORT
struct band_descriptor
{
- CONST char * band;
- CONST char * envvar;
+ const char * band;
+ const char * envvar;
int large_p;
int compiler_support_p;
int edwin_support_p;
{ 0, 0, 0, 0, 0 }
};
struct band_descriptor * scan = available_bands;
-#endif
- option_band_specified = 0;
+ option_band_specified = false;
if (option_band_file != 0)
xfree (option_band_file);
-#ifdef HAS_COMPILER_SUPPORT
while ((scan -> band) != 0)
{
if ((option_compiler_defaults ? (scan -> compiler_support_p) : 1)
&& (option_edwin_defaults ? (scan -> edwin_support_p) : 1)
&& (search_for_library_file (scan -> band)))
{
- option_band_specified = 1;
+ option_band_specified = true;
band_variable = (scan -> envvar);
default_band = (scan -> band);
if (scan -> large_p)
- option_large_sizes = 1;
+ option_large_sizes = true;
break;
}
scan += 1;
}
-#endif
if (option_fasl_file != 0)
{
if (option_raw_band != 0)
conflicting_options ("fasl", "band");
-#ifndef NATIVE_CODE_IS_C
- if (! (FILE_READABLE (option_fasl_file)))
+#ifndef CC_IS_C
+ if (!FILE_READABLE (option_fasl_file))
{
+ /* Kludge; FILE_READABLE doesn't work right for this case. */
outf_fatal ("%s: can't read option file: --fasl %s\n",
scheme_program_name, option_fasl_file);
termination_init_error ();
}
-#endif /* NATIVE_CODE_IS_C */
- option_large_sizes = 1;
- option_band_specified = 1;
+#endif
+ option_large_sizes = true;
+ option_band_specified = true;
option_band_file = 0;
}
else
{
if (option_raw_band != 0)
- option_band_specified = 1;
+ option_band_specified = true;
option_band_file =
(standard_filename_option ("band",
option_raw_band,
band_variable,
default_band,
- 1));
+ true));
}
}
if (option_band_file != 0)
(option_large_sizes
? DEFAULT_LARGE_HEAP
: DEFAULT_SMALL_HEAP)))
- + (band_sizes_valid ? band_heap_size : 0));
+ + (band_sizes_valid
+ ? band_heap_size
+ : (option_fasl_file != 0)
+ ? DEFAULT_LARGE_CONSTANT
+ : 0));
option_constant_size
= (standard_numeric_option ("constant",
option_raw_constant,
(option_large_sizes
? DEFAULT_LARGE_STACK
: DEFAULT_SMALL_STACK)));
-
- fail_fasl_if_no_utab = (option_fasl_file != 0);
-
if (option_utabmd_file != 0)
xfree (option_utabmd_file);
if (option_raw_utabmd != 0)
option_raw_utabmd,
UTABMD_FILE_VARIABLE,
DEFAULT_UTABMD_FILE,
- fail_fasl_if_no_utab));
+ (option_fasl_file != 0)));
}
else
- {
-#ifdef NATIVE_CODE_IS_C
- /* FIXME: This should check if we have "microcode_utabmd" compiled */
- fail_fasl_if_no_utab = 0;
-#endif
-
option_utabmd_file =
(standard_filename_option ("utab",
option_raw_utab,
UTABMD_FILE_VARIABLE,
DEFAULT_UTABMD_FILE,
- fail_fasl_if_no_utab));
- }
-
- /* These are only meaningful for bchscheme. */
-
- if (option_raw_gc_file != ((char *) 0))
- {
- if (option_gc_file != ((char *) 0))
- conflicting_options ("gcfile", "gc-file");
- else
- option_gc_file = option_raw_gc_file;
- }
-
- {
- CONST char * dir = (environment_default (GC_DIRECTORY_VARIABLE, 0));
- if ((dir == 0) || (!OS_file_directory_p (dir)))
- dir = (environment_default ("TMPDIR", 0));
- if ((dir == 0) || (!OS_file_directory_p (dir)))
- dir = (environment_default ("TEMP", 0));
- if ((dir == 0) || (!OS_file_directory_p (dir)))
- dir = (environment_default ("TMP", 0));
- if ((dir == 0) || (!OS_file_directory_p (dir)))
- dir = (environment_default ("TMP", 0));
-#ifdef __unix__
- if ((dir == 0) || (!OS_file_directory_p (dir)))
- {
- if (OS_file_directory_p ("/var/tmp"))
- dir = "/var/tmp";
- if (OS_file_directory_p ("/usr/tmp"))
- dir = "/usr/tmp";
- if (OS_file_directory_p ("/tmp"))
- dir = "/tmp";
- }
-#endif /* __unix__ */
- if ((dir == 0) || (!OS_file_directory_p (dir)))
- dir = DEFAULT_GC_DIRECTORY;
- option_gc_directory = (string_option (option_gc_directory, dir));
- }
- option_gc_drone =
- (standard_filename_option ("gc-drone",
- option_gc_drone,
- GC_DRONE_VARIABLE,
- DEFAULT_GC_DRONE,
- 0));
-
- option_gc_end_position =
- (non_negative_numeric_option ("gc-end-position",
- option_raw_gc_end_position,
- GC_END_POSITION_VARIABLE,
- DEFAULT_GC_END_POSITION));
-
- option_gc_file =
- (standard_string_option (option_gc_file,
- GC_FILE_VARIABLE,
- DEFAULT_GC_FILE));
-
- option_gc_read_overlap =
- ((int)
- (non_negative_numeric_option ("gc-read-overlap",
- option_raw_gc_read_overlap,
- GC_READ_OVERLAP_VARIABLE,
- DEFAULT_GC_READ_OVERLAP)));
-
- option_gc_start_position =
- (non_negative_numeric_option ("gc-start-position",
- option_raw_gc_start_position,
- GC_START_POSITION_VARIABLE,
- DEFAULT_GC_START_POSITION));
-
- option_gc_window_size =
- (standard_numeric_option ("gc-window-size",
- option_raw_gc_window_size,
- GC_WINDOW_SIZE_VARIABLE,
- DEFAULT_GC_WINDOW_SIZE));
-
- option_gc_write_overlap =
- ((int)
- (non_negative_numeric_option ("gc-write-overlap",
- option_raw_gc_write_overlap,
- GC_WRITE_OVERLAP_VARIABLE,
- DEFAULT_GC_WRITE_OVERLAP)));
+#ifdef CC_IS_C
+ /* FIXME: This should check if we
+ have "microcode_utabmd"
+ compiled */
+ false
+#else
+ (option_fasl_file != 0)
+#endif
+ ));
if (option_summary)
describe_options ();
-
}
/* -*-C-*-
-$Id: option.h,v 1.18 2007/01/05 21:19:25 cph Exp $
+$Id: option.h,v 1.19 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#ifndef SCM_OPTION_H
#define SCM_OPTION_H
-#include "ansidecl.h"
+#include "config.h"
extern int option_saved_argc;
-extern CONST char ** option_saved_argv;
+extern const char ** option_saved_argv;
extern int option_unused_argc;
-extern CONST char ** option_unused_argv;
+extern const char ** option_unused_argv;
/* Boolean options */
-extern int option_emacs_subprocess;
-extern int option_force_interactive;
-extern int option_disable_core_dump;
-extern int option_empty_list_eq_false;
-extern int option_batch_mode;
+extern bool option_emacs_subprocess;
+extern bool option_force_interactive;
+extern bool option_disable_core_dump;
+extern bool option_batch_mode;
+extern bool option_band_specified;
/* String options */
-extern CONST char ** option_library_path;
-extern CONST char * option_band_file;
-extern CONST char * option_fasl_file;
-extern int option_band_specified;
-extern CONST char * option_utabmd_file;
+extern const char ** option_library_path;
+extern const char * option_band_file;
+extern const char * option_fasl_file;
+extern const char * option_utabmd_file;
/* Numeric options */
-extern unsigned int option_heap_size;
-extern unsigned int option_constant_size;
-extern unsigned int option_stack_size;
+extern unsigned long option_heap_size;
+extern unsigned long option_constant_size;
+extern unsigned long option_stack_size;
-/* Meaningful only to bchscheme */
+extern void read_command_line_options (int argc, const char ** argv);
-extern CONST char * option_gc_directory;
-extern CONST char * option_gc_drone;
-extern CONST char * option_gc_file;
-extern int option_gc_keep;
-extern int option_gc_read_overlap;
-extern int option_gc_window_size;
-extern int option_gc_write_overlap;
-extern long option_gc_start_position;
-extern long option_gc_end_position;
+extern const char * search_for_library_file (const char *);
-extern void EXFUN (read_command_line_options, (int argc, CONST char ** argv));
-
-extern CONST char * EXFUN (search_for_library_file, (CONST char *));
-
-extern CONST char * EXFUN
- (search_path_for_file,
- (CONST char * option, CONST char * filename, int default_p, int fail_p));
+extern const char * search_path_for_file
+ (const char * option, const char * filename, bool default_p, bool fail_p);
#endif /* SCM_OPTION_H */
/* -*-C-*-
-$Id: os.h,v 1.12 2007/01/05 21:19:25 cph Exp $
+$Id: os.h,v 1.13 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
typedef unsigned int Tchannel;
-extern PTR EXFUN (OS_malloc_init, (unsigned int));
-extern PTR EXFUN (OS_malloc, (unsigned int));
-extern PTR EXFUN (OS_realloc, (PTR, unsigned int));
-extern void EXFUN (OS_free, (PTR));
-
-#define FASTCOPY(from, to, n) \
-{ \
- const char * FASTCOPY_scan_src = (from); \
- const char * FASTCOPY_end_src = (FASTCOPY_scan_src + (n)); \
- char * FASTCOPY_scan_dst = (to); \
- while (FASTCOPY_scan_src < FASTCOPY_end_src) \
- (*FASTCOPY_scan_dst++) = (*FASTCOPY_scan_src++); \
-}
+extern void * OS_malloc_init (size_t);
+extern void * OS_malloc (size_t);
+extern void * OS_realloc (void *, size_t);
+extern void OS_free (void *);
+
+#define FASTCOPY(from, to, n) (memcpy ((to), (from), (n)))
#endif /* SCM_OS_H */
/* -*-C-*-
-$Id: os2.c,v 1.13 2007/01/05 21:19:25 cph Exp $
+$Id: os2.c,v 1.14 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
}
void *
-OS2_malloc_noerror (unsigned int size)
+OS2_malloc_noerror (unsigned long size)
{
PVOID result;
APIRET rc
}
void *
-OS2_realloc_noerror (void * ptr, unsigned int size)
+OS2_realloc_noerror (void * ptr, unsigned long size)
{
- unsigned int osize = ((guarantee_valid_malloc_pointer (ptr)) -> size);
+ unsigned long osize = ((guarantee_valid_malloc_pointer (ptr)) -> size);
if (osize == size)
return (ptr);
{
}
void *
-OS2_malloc_noerror (unsigned int size)
+OS2_malloc_noerror (unsigned long size)
{
return (malloc (size));
}
void *
-OS2_realloc_noerror (void * ptr, unsigned int size)
+OS2_realloc_noerror (void * ptr, unsigned long size)
{
return (realloc (ptr, size));
}
#endif /* not OS2_USE_SUBHEAP_MALLOC */
-/* This is called during initialization, when the error system is not
- set up.
-*/
-
void *
-OS_malloc_init (unsigned int size)
+OS_malloc_init (size_t size)
{
- void * result = (OS2_malloc_noerror (size));
- return (result);
+ return (OS2_malloc_noerror (size));
}
void *
-OS_malloc (unsigned int size)
+OS_malloc (size_t size)
{
void * result = (OS2_malloc_noerror (size));
if (result == 0)
}
void *
-OS_realloc (void * ptr, unsigned int size)
+OS_realloc (void * ptr, size_t size)
{
void * result = (OS2_realloc_noerror (ptr, size));
if (result == 0)
/* -*-C-*-
-$Id: os2.h,v 1.12 2007/01/05 21:19:25 cph Exp $
+$Id: os2.h,v 1.13 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define INCL_BASE
#define INCL_PM
#include <os2.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stddef.h>
-#include <string.h>
-#include <ctype.h>
#include <setjmp.h>
-#include <limits.h>
#include "os2api.h"
#include "os2msg.h"
/* -*-C-*-
-$Id: os2env.c,v 1.18 2007/01/05 21:19:25 cph Exp $
+$Id: os2env.c,v 1.19 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
int wday = (ts -> tm_wday);
(buffer -> day_of_week) = ((wday == 0) ? 6 : (wday - 1));
}
-}
+}
void
OS_decode_utc (time_t t, struct time_structure * buffer)
int wday = (ts -> tm_wday);
(buffer -> day_of_week) = ((wday == 0) ? 6 : (wday - 1));
}
-}
+}
time_t
OS_encode_time (struct time_structure * buffer)
/* -*-C-*-
-$Id: os2fs.c,v 1.18 2007/01/05 21:19:25 cph Exp $
+$Id: os2fs.c,v 1.19 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define DEALLOCATE_DIR_SEARCH_STATE(state) ((state) -> allocatedp) = 0
\f
int
-OS_directory_valid_p (long index)
+OS_directory_valid_p (unsigned int index)
{
return
- ((0 <= index)
- && (index < n_dir_search_states)
+ ((index < n_dir_search_states)
&& ((REFERENCE_DIR_SEARCH_STATE (index)) -> allocatedp));
}
/* -*-C-*-
-$Id: os2msg.c,v 1.19 2007/01/05 21:19:25 cph Exp $
+$Id: os2msg.c,v 1.20 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "os2.h"
-extern void EXFUN (tty_set_next_interrupt_char, (cc_t c));
-extern void * OS2_malloc_noerror (unsigned int);
+extern void tty_set_next_interrupt_char (cc_t c);
+extern void * OS2_malloc_noerror (unsigned long);
static qid_t allocate_qid (void);
static void OS2_initialize_message_lengths (void);
last read and the second clear -- and since we cleared the bit no
one else is going to look at the queue until another event comes
along.
-
+
This code serves two purposes. First, this is the only way to
reliably clear the interrupt bit to avoid having an event stuck
in the queue and the Scheme thread not bothering to look.
/* -*-C-*-
-$Id: os2msg.h,v 1.20 2007/01/05 21:19:25 cph Exp $
+$Id: os2msg.h,v 1.21 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* This is a timer interrupt event. It is generated automatically
by the timer thread when the timer is active. */
mt_timer_event,
-
+
/* This event signals the termination of a child process. It is
generated automatically by the thread that monitors child
processes. */
/* -*-C-*-
-$Id: os2pmcon.c,v 1.33 2007/01/05 21:19:25 cph Exp $
+$Id: os2pmcon.c,v 1.34 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
static short console_point_y;
static const char * console_font_specs [] =
- { "8.Courier", "10.Courier", "12.Courier",
+ { "8.Courier", "10.Courier", "12.Courier",
"4.System VIO", "10.System Monospaced" };
#define CHAR_WIDTH (FONT_METRICS_WIDTH (console_metrics))
/* -*-C-*-
-$Id: os2term.c,v 1.8 2007/01/05 21:19:25 cph Exp $
+$Id: os2term.c,v 1.9 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
}
void
-OS_terminal_get_state (Tchannel channel, PTR statep)
+OS_terminal_get_state (Tchannel channel, void * statep)
{
}
void
-OS_terminal_set_state (Tchannel channel, PTR statep)
+OS_terminal_set_state (Tchannel channel, void * statep)
{
}
\f
/* -*-C-*-
-$Id: os2top.c,v 1.25 2007/01/05 21:19:25 cph Exp $
+$Id: os2top.c,v 1.26 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
extern void OS2_initialize_window_primitives (void);
extern void OS2_check_message_length_initializations (void);
-extern void * OS2_malloc_noerror (unsigned int);
-extern void * OS2_realloc_noerror (void *, unsigned int);
+extern void * OS2_malloc_noerror (unsigned long);
+extern void * OS2_realloc_noerror (void *, unsigned long);
extern void OS2_create_msg_queue (void); /* forward reference */
};
void
-OS_syserr_names (unsigned int * length, unsigned char *** names)
+OS_syserr_names (unsigned long * length, const char *** names)
{
(*length) = ((sizeof (syserr_names_table)) / (sizeof (char *)));
- (*names) = ((unsigned char **) syserr_names_table);
+ (*names) = syserr_names_table;
}
void
-OS_syscall_names (unsigned int * length, unsigned char *** names)
+OS_syscall_names (unsigned long * length, const char *** names)
{
(*length) = ((sizeof (syscall_names_table)) / (sizeof (char *)));
- (*names) = ((unsigned char **) syscall_names_table);
+ (*names) = syscall_names_table;
}
/* -*-C-*-
-$Id: os2tty.c,v 1.6 2007/01/05 21:19:25 cph Exp $
+$Id: os2tty.c,v 1.7 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
void
OS2_initialize_tty (void)
{
- extern Tchannel EXFUN (OS_open_fd, (int fd));
+ extern Tchannel OS_open_fd (int fd);
input_channel = (OS2_make_channel (0, CHANNEL_READ));
(CHANNEL_INTERNAL (input_channel)) = 1;
output_channel = (OS2_make_channel (1, CHANNEL_WRITE));
/* -*-C-*-
-$Id: config.h,v 1.11 2007/01/05 21:19:26 cph Exp $
+$Id: config.h,v 1.12 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Define if you have the <fcntl.h> header file. */
#define HAVE_FCNTL_H 1
-/* Define if architecture has native-code compiler support. */
-#define HAS_COMPILER_SUPPORT 1
-
/* Define if you have the <blowfish.h> header file. */
#define HAVE_BLOWFISH_H 1
#define PACKAGE_BUGREPORT "bug-mit-scheme@gnu.org"
/* Define to the full name of this package. */
-#define PACKAGE_NAME "MIT/GNU Scheme"
+#define PACKAGE_NAME "MIT/GNU Scheme microcode"
/* Define to the full name and version of this package. */
-#define PACKAGE_STRING "MIT/GNU Scheme 14.18"
+#define PACKAGE_STRING "MIT/GNU Scheme microcode 15.0"
/* Define to the one symbol short name of this package. */
#define PACKAGE_TARNAME "mit-scheme"
/* Define to the version of this package. */
-#define PACKAGE_VERSION "14.18"
+#define PACKAGE_VERSION "15.0"
/* Include the shared configuration header. */
#include "confshared.h"
/* -*-C-*-
-$Id: os2xcpt.c,v 1.18 2007/01/12 03:45:55 cph Exp $
+$Id: os2xcpt.c,v 1.19 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <stdarg.h>
#include "scheme.h"
#include "gccode.h"
#include "os2.h"
-extern int pc_to_utility_index (unsigned long);
-extern int pc_to_builtin_index (unsigned long);
-extern SCHEME_OBJECT * find_constant_space_block (SCHEME_OBJECT *);
extern int OS2_disable_stack_guard (void *);
extern int OS2_essential_thread_p (TID);
extern void OS2_message_box (const char *, const char *, int);
const char * description;
} exception_entry_t;
-#define PC_ALIGNMENT_MASK ((1 << PC_ZERO_BITS) - 1)
#define SCHEME_ALIGNMENT_MASK ((sizeof (long)) - 1)
#define FREE_PARANOIA_MARGIN 0x100
-#ifdef HAS_COMPILER_SUPPORT
-#define ALLOW_ONLY_C 0
-#else
-#define ALLOW_ONLY_C 1
-#define PLAUSIBLE_CC_BLOCK_P(block) 0
-#endif
-
static ULONG find_program_end_address (void);
extern ULONG APIENTRY OS2_exception_handler
(PEXCEPTIONREPORTRECORD, PEXCEPTIONREGISTRATIONRECORD, PCONTEXTRECORD,
static void
trap_immediate_termination (void)
{
- extern void EXFUN (OS_restore_external_state, (void));
+ extern void OS_restore_external_state (void);
trap_state = trap_state_exitting_hard;
OS_restore_external_state ();
exit (1);
/* Classify the PC location. */
pc = (context -> ctx_RegEip);
- if ((pc & PC_ALIGNMENT_MASK) != 0)
+ if (!PC_ALIGNED_P (pc))
pc_location = pc_in_hyperspace;
else if (pc <= program_end_address)
{
pc_location = pc_in_builtin;
else if ((pc_to_utility_index (pc)) != (-1))
pc_location = pc_in_utility;
- else if (PRIMITIVE_P (Registers[REGBLOCK_PRIMITIVE]))
+ else if (PRIMITIVE_P (GET_PRIMITIVE))
pc_location = pc_in_primitive;
else
pc_location = pc_in_c;
}
- else if (ALLOW_ONLY_C)
- pc_location = pc_in_hyperspace;
- else if ((((ULONG) Heap_Bottom) <= pc) && (pc < ((ULONG) Heap_Top)))
+ else if ((((ULONG) heap_start) <= pc) && (pc < ((ULONG) heap_end)))
{
pc_location = pc_in_heap;
- block_address = (find_block_address (((void *) pc), Heap_Bottom));
+ block_address = (find_block_address (((void *) pc), heap_start));
}
- else if ((((ULONG) Constant_Space) <= pc) && (pc < ((ULONG) Constant_Top)))
+ else if ((((ULONG) constant_start) <= pc) && (pc < ((ULONG) constant_end)))
{
pc_location = pc_in_heap;
- block_address = (find_block_address (((void *) pc), Constant_Space));
+ block_address = (find_block_address (((void *) pc), constant_start));
}
else
pc_location = pc_in_hyperspace;
case pc_in_utility:
case pc_in_primitive:
case pc_in_c:
- new_sp = sp_register;
+ new_sp = stack_pointer;
break;
default:
new_sp = 0;
break;
}
- if (! ((Stack_Bottom <= new_sp)
- && (new_sp < Stack_Top)
+ if (! ((ADDRESS_IN_STACK_P (new_sp))
&& ((((ULONG) new_sp) & SCHEME_ALIGNMENT_MASK) == 0)))
new_sp = 0;
if (block_address != 0)
{
(trinfo . state) = STATE_COMPILED_CODE;
- (trinfo . pc_info_1)
- = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_address));
+ (trinfo . pc_info_1) = (MAKE_CC_BLOCK (block_address));
(trinfo . pc_info_2)
= (LONG_TO_UNSIGNED_FIXNUM (pc - ((ULONG) block_address)));
}
(trinfo . pc_info_1)
= (LONG_TO_UNSIGNED_FIXNUM (pc_to_utility_index (pc)));
(trinfo . pc_info_2) = UNSPECIFIC;
- Free = ((new_sp == 0) ? MemTop : (interpreter_free (0)));
+ Free = ((new_sp == 0) ? heap_alloc_limit : (interpreter_free (0)));
break;
case pc_in_primitive:
(trinfo . state) = STATE_PRIMITIVE;
- (trinfo . pc_info_1) = (Registers[REGBLOCK_PRIMITIVE]);
- (trinfo . pc_info_2)
- = (LONG_TO_UNSIGNED_FIXNUM (Registers[REGBLOCK_LEXPR_ACTUALS]));
- Free = ((new_sp == 0) ? MemTop : (interpreter_free (0)));
+ (trinfo . pc_info_1) = GET_PRIMITIVE;
+ (trinfo . pc_info_2) = (ULONG_TO_FIXNUM (GET_LEXPR_ACTUALS));
+ Free = ((new_sp == 0) ? heap_alloc_limit : (interpreter_free (0)));
break;
default:
(trinfo . state) = STATE_UNKNOWN;
{
ULONG edi = (context -> ctx_RegEdi);
if (((edi & SCHEME_ALIGNMENT_MASK) == 0)
- && (((ULONG) Heap_Bottom) <= edi)
- && (edi < ((ULONG) Heap_Top)))
+ && (((ULONG) heap_start) <= edi)
+ && (edi < ((ULONG) heap_end)))
return (((SCHEME_OBJECT *) edi) + FREE_PARANOIA_MARGIN);
}
return (interpreter_free (1));
interpreter_free (int force_gc)
{
return
- ((((force_gc ? MemTop : Heap_Bottom) <= Free)
- && (Free < Heap_Top)
+ ((((force_gc ? heap_alloc_limit : heap_start) <= Free)
+ && (Free < heap_end)
&& ((((ULONG) Free) & SCHEME_ALIGNMENT_MASK) == 0))
- ? (((Free + FREE_PARANOIA_MARGIN) < MemTop)
+ ? (((Free + FREE_PARANOIA_MARGIN) < heap_alloc_limit)
? (Free + FREE_PARANOIA_MARGIN)
- : (Free < MemTop)
- ? MemTop
+ : (Free < heap_alloc_limit)
+ ? heap_alloc_limit
: Free)
- : MemTop);
+ : heap_alloc_limit);
}
\f
/* Find the compiled code block in area which contains `pc_value'.
static SCHEME_OBJECT *
find_block_address (char * pc_value, SCHEME_OBJECT * area_start)
{
- if (area_start == Constant_Space)
+ SCHEME_OBJECT * nearest_word
+ = ((SCHEME_OBJECT *)
+ (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
+ long maximum_distance = (nearest_word - area_start);
+ long distance = maximum_distance;
+ while ((distance / 2) > MINIMUM_SCAN_RANGE)
+ distance = (distance / 2);
+ while ((distance * 2) < maximum_distance)
{
- SCHEME_OBJECT * constant_block =
- (find_constant_space_block
- ((SCHEME_OBJECT *)
- (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK)));
- return
- ((constant_block == 0)
- ? 0
- : (find_block_address_in_area (pc_value, constant_block)));
+ SCHEME_OBJECT * block
+ = (find_block_address_in_area (pc_value, (nearest_word - distance)));
+ if (block != 0)
+ return (block);
+ distance *= 2;
}
- {
- SCHEME_OBJECT * nearest_word =
- ((SCHEME_OBJECT *)
- (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
- long maximum_distance = (nearest_word - area_start);
- long distance = maximum_distance;
- while ((distance / 2) > MINIMUM_SCAN_RANGE)
- distance = (distance / 2);
- while ((distance * 2) < maximum_distance)
- {
- SCHEME_OBJECT * block =
- (find_block_address_in_area (pc_value, (nearest_word - distance)));
- if (block != 0)
- return (block);
- distance *= 2;
- }
- }
return (find_block_address_in_area (pc_value, area_start));
}
\f
switch (OBJECT_TYPE (object))
{
case TC_LINKAGE_SECTION:
- switch (READ_LINKAGE_KIND (object))
- {
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- case OPERATOR_LINKAGE_KIND:
+ {
+ unsigned long count = (linkage_section_count (object));
+ area += 1;
+ switch (linkage_section_type (object))
{
- long count = (READ_OPERATOR_LINKAGE_COUNT (object));
- area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
+ case LINKAGE_SECTION_TYPE_OPERATOR:
+ case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
+ area += (count * UUO_LINK_SIZE);
+ break;
+
+ case LINKAGE_SECTION_TYPE_REFERENCE:
+ case LINKAGE_SECTION_TYPE_ASSIGNMENT:
+ default:
+ area += count;
+ break;
}
- break;
- case ASSIGNMENT_LINKAGE_KIND:
- case CLOSURE_PATTERN_LINKAGE_KIND:
- case REFERENCE_LINKAGE_KIND:
- default:
- area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
- break;
- }
+ }
break;
+
case TC_MANIFEST_CLOSURE:
- area += 1;
- {
- long count = (MANIFEST_CLOSURE_COUNT (area));
- area = (MANIFEST_CLOSURE_END (area, count));
- }
+ area = (compiled_closure_objects (area + 1));
break;
+
case TC_MANIFEST_NM_VECTOR:
{
- long count = (OBJECT_DATUM (object));
+ unsigned long count = (OBJECT_DATUM (object));
if (((char *) (area + (count + 1))) < pc_value)
{
area += (count + 1);
{
SCHEME_OBJECT * block = (area - 1);
return
- (((area == first_valid)
- || ((OBJECT_TYPE (* block)) != TC_MANIFEST_VECTOR)
- || ((OBJECT_DATUM (* block)) < ((unsigned long) (count + 1)))
- || (! (PLAUSIBLE_CC_BLOCK_P (block))))
- ? 0
- : block);
+ (((area > first_valid)
+ && ((OBJECT_TYPE (*block)) == TC_MANIFEST_VECTOR)
+ && ((OBJECT_DATUM (*block)) >= (count + 1))
+ && (plausible_cc_block_p (block)))
+ ? block
+ : 0);
}
}
+
default:
area += 1;
break;
SCHEME_OBJECT trap_name;
/* Disable interrupts while building stack frame. */
- saved_mask = (FETCH_INTERRUPT_MASK ());
+ saved_mask = GET_INT_MASK;
SET_INTERRUPT_MASK (0);
/* Get the trap handler -- lose if there isn't one. */
handler
- = ((Valid_Fixed_Obj_Vector ())
- ? (Get_Fixed_Obj_Slot (Trap_Handler))
+ = ((VECTOR_P (fixed_objects))
+ ? (VECTOR_REF (fixed_objects, TRAP_HANDLER))
: SHARP_F);
- if (handler == SHARP_F)
+ if (!INTERPRETER_APPLICABLE_P (handler))
{
noise_start ();
noise ("There is no trap handler for recovery!\n");
noise ("This occurred during ");
describe_exception ((report -> ExceptionNum), 0);
noise (".\n");
- noise ("pc = 0x%08x; sp = 0x%08x.\n",
+ noise ("pc = %#08x; sp = %#08x.\n",
(context -> ctx_RegEip), (context -> ctx_RegEsp));
(void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
termination_trap ();
}
/* Set the GC interrupt bit if necessary. */
- if (Free >= MemTop)
- Request_GC (0);
+ if (!FREE_OK_P (Free))
+ REQUEST_GC (0);
/* Make sure the stack is correctly initialized. */
if (new_sp != 0)
- sp_register = new_sp;
+ stack_pointer = new_sp;
else
{
INITIALIZE_STACK ();
Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_END_OF_COMPUTATION);
- exp_register = SHARP_F;
- Save_Cont ();
+ SET_RC (RC_END_OF_COMPUTATION);
+ SET_EXP (SHARP_F);
+ SAVE_CONT ();
Pushed ();
}
{
STACK_PUSH (BOOLEAN_TO_OBJECT (new_sp != 0));
STACK_PUSH (long_to_integer (report -> ExceptionNum));
STACK_PUSH (trap_name);
- Store_Return (RC_HARDWARE_TRAP);
- exp_register = UNSPECIFIC;
- Save_Cont ();
+ SET_RC (RC_HARDWARE_TRAP);
+ SET_EXP (UNSPECIFIC);
+ SAVE_CONT ();
Pushed ();
/* Make sure the history register is properly initialized. */
if ((new_sp != 0) && ((trinfo -> state) == STATE_COMPILED_CODE))
- Stop_History ();
- history_register = (Make_Dummy_History ());
+ stop_history ();
+ history_register = (make_dummy_history ());
/* Push the call frame for the trap handler. */
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (trap_name);
STACK_PUSH (handler);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
+ PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
/* Restore the interrupt mask and call the handler. */
PPIB ppib;
TID tid;
char * format
- = "Scheme has detected exception number 0x%08x within thread %d.%s%s\
+ = "Scheme has detected exception number %#08x within thread %d.%s%s\
This indicates a bug in the Scheme implementation.\
Please report this information to a Scheme wizard.\n\n";
char backtrace [1024];
ULONG * ebp = ((ULONG *) (context -> ctx_RegEbp));
unsigned int count = 0;
sprintf (backtrace, " (Backtrace:");
- sprintf ((backtrace + (strlen (backtrace))), " 0x%08x",
+ sprintf ((backtrace + (strlen (backtrace))), " %#08x",
(context -> ctx_RegEip));
while ((((char *) ebp) > ((char *) (ptib -> tib_pstack)))
&& (((char *) ebp) < ((char *) (ptib -> tib_pstacklimit)))
&& (count < 10))
{
- sprintf ((backtrace + (strlen (backtrace))), " 0x%08x", (ebp[1]));
+ sprintf ((backtrace + (strlen (backtrace))), " %#08x", (ebp[1]));
ebp = ((ULONG *) (ebp[0]));
}
sprintf ((backtrace + (strlen (backtrace))), ")");
/* -*-C-*-
-$Id: osctty.h,v 1.8 2007/01/05 21:19:25 cph Exp $
+$Id: osctty.h,v 1.9 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* If this procedure returns 0, the interrupt control procedures will
not work correctly. */
-extern int EXFUN (OS_ctty_interrupt_control, (void));
+extern int OS_ctty_interrupt_control (void);
typedef unsigned int Tinterrupt_enables;
-extern void EXFUN (OS_ctty_get_interrupt_enables, (Tinterrupt_enables * mask));
-extern void EXFUN (OS_ctty_set_interrupt_enables, (Tinterrupt_enables * mask));
-
-extern unsigned int EXFUN (OS_ctty_num_int_chars, (void));
-extern cc_t * EXFUN (OS_ctty_get_int_chars, (void));
-extern cc_t * EXFUN (OS_ctty_get_int_char_handlers, (void));
-extern void EXFUN (OS_ctty_set_int_chars, (cc_t *));
-extern void EXFUN (OS_ctty_set_int_char_handlers, (cc_t *));
+extern void OS_ctty_get_interrupt_enables (Tinterrupt_enables * mask);
+extern void OS_ctty_set_interrupt_enables (Tinterrupt_enables * mask);
+
+extern unsigned int OS_ctty_num_int_chars (void);
+extern cc_t * OS_ctty_get_int_chars (void);
+extern cc_t * OS_ctty_get_int_char_handlers (void);
+extern void OS_ctty_set_int_chars (cc_t *);
+extern void OS_ctty_set_int_char_handlers (cc_t *);
#endif /* SCM_OSCTTY_H */
/* -*-C-*-
-$Id: osenv.h,v 1.14 2007/01/05 21:19:25 cph Exp $
+$Id: osenv.h,v 1.15 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
int time_zone;
};
-extern time_t EXFUN (OS_encoded_time, (void));
-extern void EXFUN (OS_decode_time, (time_t, struct time_structure *));
-extern void EXFUN (OS_decode_utc, (time_t, struct time_structure *));
-extern time_t EXFUN (OS_encode_time, (struct time_structure *));
-extern double EXFUN (OS_process_clock, (void));
-extern double EXFUN (OS_real_time_clock, (void));
-extern void EXFUN (OS_process_timer_set, (clock_t, clock_t));
-extern void EXFUN (OS_process_timer_clear, (void));
-extern void EXFUN (OS_profile_timer_set, (clock_t, clock_t));
-extern void EXFUN (OS_profile_timer_clear, (void));
-extern void EXFUN (OS_real_timer_set, (clock_t, clock_t));
-extern void EXFUN (OS_real_timer_clear, (void));
-extern CONST char * EXFUN (OS_working_dir_pathname, (void));
-extern void EXFUN (OS_set_working_dir_pathname, (CONST char *));
+extern time_t OS_encoded_time (void);
+extern void OS_decode_time (time_t, struct time_structure *);
+extern void OS_decode_utc (time_t, struct time_structure *);
+extern time_t OS_encode_time (struct time_structure *);
+extern double OS_process_clock (void);
+extern double OS_real_time_clock (void);
+extern void OS_process_timer_set (clock_t, clock_t);
+extern void OS_process_timer_clear (void);
+extern void OS_profile_timer_set (clock_t, clock_t);
+extern void OS_profile_timer_clear (void);
+extern void OS_real_timer_set (clock_t, clock_t);
+extern void OS_real_timer_clear (void);
+extern const char * OS_working_dir_pathname (void);
+extern void OS_set_working_dir_pathname (const char *);
#endif /* SCM_OSENV_H */
/* -*-C-*-
-$Id: osfile.h,v 1.8 2007/01/05 21:19:25 cph Exp $
+$Id: osfile.h,v 1.9 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "os.h"
-extern Tchannel EXFUN (OS_open_input_file, (CONST char * filename));
-extern Tchannel EXFUN (OS_open_output_file, (CONST char * filename));
-extern Tchannel EXFUN (OS_open_io_file, (CONST char * filename));
-extern Tchannel EXFUN (OS_open_append_file, (CONST char * filename));
-extern Tchannel EXFUN (OS_open_load_file, (CONST char * filename));
-extern Tchannel EXFUN (OS_open_dump_file, (CONST char * filename));
-extern off_t EXFUN (OS_file_length, (Tchannel channel));
-extern off_t EXFUN (OS_file_position, (Tchannel channel));
-extern void EXFUN (OS_file_set_position, (Tchannel channel, off_t position));
-extern void EXFUN (OS_file_truncate, (Tchannel channel, off_t length));
+extern Tchannel OS_open_input_file (const char * filename);
+extern Tchannel OS_open_output_file (const char * filename);
+extern Tchannel OS_open_io_file (const char * filename);
+extern Tchannel OS_open_append_file (const char * filename);
+extern Tchannel OS_open_load_file (const char * filename);
+extern Tchannel OS_open_dump_file (const char * filename);
+extern off_t OS_file_length (Tchannel channel);
+extern off_t OS_file_position (Tchannel channel);
+extern void OS_file_set_position (Tchannel channel, off_t position);
+extern void OS_file_truncate (Tchannel channel, off_t length);
#endif /* SCM_OSFILE_H */
/* -*-C-*-
-$Id: osfs.h,v 1.14 2007/01/05 21:19:25 cph Exp $
+$Id: osfs.h,v 1.15 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
file_type_unknown = 0xFFFF
};
-extern enum file_existence EXFUN (OS_file_existence_test, (CONST char * name));
-extern enum file_existence EXFUN
- (OS_file_existence_test_direct, (CONST char * name));
-extern enum file_type EXFUN (OS_file_type_direct, (CONST char *));
-extern enum file_type EXFUN (OS_file_type_indirect, (CONST char *));
-extern int EXFUN (OS_file_access, (CONST char * name, unsigned int mode));
-extern int EXFUN (OS_file_directory_p, (CONST char * name));
-extern CONST char * EXFUN (OS_file_soft_link_p, (CONST char * name));
-extern void EXFUN (OS_file_remove, (CONST char * name));
-extern void EXFUN (OS_file_remove_link, (CONST char * name));
-extern void EXFUN
- (OS_file_rename, (CONST char * from_name, CONST char * to_name));
-extern void EXFUN
- (OS_file_link_hard, (CONST char * from_name, CONST char * to_name));
-extern void EXFUN
- (OS_file_link_soft, (CONST char * from_name, CONST char * to_name));
-extern void EXFUN (OS_directory_make, (CONST char * name));
-extern void EXFUN (OS_directory_delete, (CONST char * name));
-extern int EXFUN (OS_file_touch, (CONST char *));
-extern unsigned int EXFUN (OS_directory_open, (CONST char * name));
-extern int EXFUN (OS_directory_valid_p, (long index));
-extern void EXFUN (OS_directory_close, (unsigned int index));
-extern CONST char * EXFUN (OS_directory_read, (unsigned int index));
-extern CONST char * EXFUN
- (OS_directory_read_matching, (unsigned int index, CONST char * prefix));
+extern enum file_existence OS_file_existence_test (const char *);
+extern enum file_existence OS_file_existence_test_direct (const char *);
+extern enum file_type OS_file_type_direct (const char *);
+extern enum file_type OS_file_type_indirect (const char *);
+extern int OS_file_access (const char *, unsigned int);
+extern int OS_file_directory_p (const char *);
+extern const char * OS_file_soft_link_p (const char *);
+extern void OS_file_remove (const char *);
+extern void OS_file_remove_link (const char *);
+extern void OS_file_rename (const char *, const char *);
+extern void OS_file_link_hard (const char *, const char *);
+extern void OS_file_link_soft (const char *, const char *);
+extern void OS_directory_make (const char *);
+extern void OS_directory_delete (const char *);
+extern int OS_file_touch (const char *);
+extern unsigned int OS_directory_open (const char *);
+extern int OS_directory_valid_p (unsigned int);
+extern void OS_directory_close (unsigned int);
+extern const char * OS_directory_read (unsigned int);
+extern const char * OS_directory_read_matching (unsigned int, const char *);
+extern int OS_channel_copy (off_t, Tchannel, Tchannel);
+extern void OS_file_copy (const char *, const char *);
#endif /* SCM_OSFS_H */
/* -*-C-*-
-$Id: osio.h,v 1.21 2007/01/05 21:19:25 cph Exp $
+$Id: osio.h,v 1.22 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
extern size_t OS_channel_table_size;
#define NO_CHANNEL OS_channel_table_size
-extern int EXFUN (OS_channel_open_p, (Tchannel channel));
-extern void EXFUN (OS_channel_close, (Tchannel channel));
-extern void EXFUN (OS_channel_close_noerror, (Tchannel channel));
-extern void EXFUN (OS_channel_close_on_abort, (Tchannel channel));
-extern enum channel_type EXFUN (OS_channel_type, (Tchannel channel));
-extern size_t EXFUN
- (OS_channel_read_load_file, (Tchannel channel, PTR buffer, size_t nbytes));
-extern size_t EXFUN
- (OS_channel_write_dump_file,
- (Tchannel channel, CONST PTR buffer, size_t nbytes));
-extern long EXFUN
- (OS_channel_read, (Tchannel channel, PTR buffer, size_t nbytes));
-extern long EXFUN
- (OS_channel_write, (Tchannel channel, CONST PTR buffer, size_t nbytes));
-extern void EXFUN
- (OS_channel_write_string, (Tchannel channel, CONST char * string));
-extern void EXFUN
- (OS_make_pipe, (Tchannel * readerp, Tchannel * writerp));
-extern int EXFUN (OS_channel_nonblocking_p, (Tchannel channel));
-extern void EXFUN (OS_channel_nonblocking, (Tchannel channel));
-extern void EXFUN (OS_channel_blocking, (Tchannel channel));
+extern int OS_channel_open_p (Tchannel channel);
+extern void OS_channel_close (Tchannel channel);
+extern void OS_channel_close_noerror (Tchannel channel);
+extern void OS_channel_close_on_abort (Tchannel channel);
+extern enum channel_type OS_channel_type (Tchannel channel);
+extern size_t OS_channel_read_load_file
+ (Tchannel channel, void * buffer, size_t nbytes);
+extern size_t OS_channel_write_dump_file
+ (Tchannel channel, const void * buffer, size_t nbytes);
+extern long OS_channel_read
+ (Tchannel channel, void * buffer, size_t nbytes);
+extern long OS_channel_write
+ (Tchannel channel, const void * buffer, size_t nbytes);
+extern void OS_channel_write_string
+ (Tchannel channel, const char * string);
+extern void OS_make_pipe
+ (Tchannel * readerp, Tchannel * writerp);
+extern int OS_channel_nonblocking_p (Tchannel channel);
+extern void OS_channel_nonblocking (Tchannel channel);
+extern void OS_channel_blocking (Tchannel channel);
\f
/* Interface to poll(2) or select(2) */
#ifdef __WIN32__
extern int OS_have_select_p;
#else
-extern CONST int OS_have_select_p;
+extern const int OS_have_select_p;
#endif
-typedef PTR select_registry_t;
+typedef void * select_registry_t;
#define SELECT_MODE_READ 1
#define SELECT_MODE_WRITE 2
#define SELECT_MODE_ERROR 4
#define SELECT_INTERRUPT (-1)
#define SELECT_PROCESS_STATUS_CHANGE (-2)
-extern select_registry_t EXFUN
- (OS_allocate_select_registry, (void));
-extern void EXFUN
- (OS_deallocate_select_registry, (select_registry_t registry));
-extern void EXFUN
- (OS_add_to_select_registry,
- (select_registry_t registry, int fd, unsigned int mode));
-extern void EXFUN
- (OS_remove_from_select_registry,
- (select_registry_t registry, int fd, unsigned int mode));
-extern unsigned int EXFUN
- (OS_select_registry_length, (select_registry_t registry));
-extern void EXFUN
- (OS_select_registry_result,
- (select_registry_t registry, unsigned int index,
- int * fd_r, unsigned int * mode_r));
-extern int EXFUN
- (OS_test_select_registry, (select_registry_t registry, int blockp));
-extern int EXFUN
- (OS_test_select_descriptor, (int fd, int blockp, unsigned int mode));
+extern select_registry_t OS_allocate_select_registry
+ (void);
+extern void OS_deallocate_select_registry
+ (select_registry_t registry);
+extern void OS_add_to_select_registry
+ (select_registry_t registry, int fd, unsigned int mode);
+extern void OS_remove_from_select_registry
+ (select_registry_t registry, int fd, unsigned int mode);
+extern unsigned int OS_select_registry_length
+ (select_registry_t registry);
+extern void OS_select_registry_result
+ (select_registry_t registry, unsigned int index,
+ int * fd_r, unsigned int * mode_r);
+extern int OS_test_select_registry
+ (select_registry_t registry, int blockp);
+extern int OS_test_select_descriptor
+ (int fd, int blockp, unsigned int mode);
#endif /* SCM_OSIO_H */
/* -*-C-*-
-$Id: osproc.h,v 1.14 2007/01/05 21:19:25 cph Exp $
+$Id: osproc.h,v 1.15 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
extern enum process_jc_status scheme_jc_status;
/* OS_make_subprocess is obsolete; use OS-specific procedure. */
-extern Tprocess EXFUN
- (OS_make_subprocess,
- (CONST char * filename,
- CONST char ** argv,
- CONST char ** env,
- CONST char * working_directory,
- enum process_ctty_type ctty_type,
- char * ctty_name,
- enum process_channel_type channel_in_type,
- Tchannel channel_in,
- enum process_channel_type channel_out_type,
- Tchannel channel_out,
- enum process_channel_type channel_err_type,
- Tchannel channel_err));
-extern void EXFUN (OS_process_deallocate, (Tprocess process));
-
-extern int EXFUN (OS_process_valid_p, (Tprocess process));
-extern int EXFUN (OS_process_continuable_p, (Tprocess process));
-extern int EXFUN (OS_process_foregroundable_p, (Tprocess process));
-
-extern pid_t EXFUN (OS_process_id, (Tprocess process));
-extern enum process_jc_status EXFUN (OS_process_jc_status, (Tprocess process));
-extern int EXFUN (OS_process_status_sync, (Tprocess process));
-extern int EXFUN (OS_process_status_sync_all, (void));
-extern int EXFUN (OS_process_any_status_change, (void));
-extern enum process_status EXFUN (OS_process_status, (Tprocess process));
-extern unsigned short EXFUN (OS_process_reason, (Tprocess process));
-
-extern void EXFUN (OS_process_send_signal, (Tprocess process, int sig));
-extern void EXFUN (OS_process_kill, (Tprocess process));
-extern void EXFUN (OS_process_stop, (Tprocess process));
-extern void EXFUN (OS_process_interrupt, (Tprocess process));
-extern void EXFUN (OS_process_quit, (Tprocess process));
-extern void EXFUN (OS_process_hangup, (Tprocess process));
-
-extern void EXFUN (OS_process_continue_background, (Tprocess process));
-extern void EXFUN (OS_process_continue_foreground, (Tprocess process));
-extern void EXFUN (OS_process_wait, (Tprocess process));
+extern Tprocess OS_make_subprocess
+ (const char * filename,
+ const char ** argv,
+ const char ** env,
+ const char * working_directory,
+ enum process_ctty_type ctty_type,
+ char * ctty_name,
+ enum process_channel_type channel_in_type,
+ Tchannel channel_in,
+ enum process_channel_type channel_out_type,
+ Tchannel channel_out,
+ enum process_channel_type channel_err_type,
+ Tchannel channel_err);
+extern void OS_process_deallocate (Tprocess process);
+
+extern int OS_process_valid_p (Tprocess process);
+extern int OS_process_continuable_p (Tprocess process);
+extern int OS_process_foregroundable_p (Tprocess process);
+
+extern pid_t OS_process_id (Tprocess process);
+extern enum process_jc_status OS_process_jc_status (Tprocess process);
+extern int OS_process_status_sync (Tprocess process);
+extern int OS_process_status_sync_all (void);
+extern int OS_process_any_status_change (void);
+extern enum process_status OS_process_status (Tprocess process);
+extern unsigned short OS_process_reason (Tprocess process);
+
+extern void OS_process_send_signal (Tprocess process, int sig);
+extern void OS_process_kill (Tprocess process);
+extern void OS_process_stop (Tprocess process);
+extern void OS_process_interrupt (Tprocess process);
+extern void OS_process_quit (Tprocess process);
+extern void OS_process_hangup (Tprocess process);
+
+extern void OS_process_continue_background (Tprocess process);
+extern void OS_process_continue_foreground (Tprocess process);
+extern void OS_process_wait (Tprocess process);
#endif /* SCM_OSPROC_H */
/* -*-C-*-
-$Id: ospty.h,v 1.8 2007/01/05 21:19:25 cph Exp $
+$Id: ospty.h,v 1.9 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "os.h"
-extern CONST char * EXFUN
- (OS_open_pty_master, (Tchannel * master_fd, CONST char ** master_fname));
-extern void EXFUN (OS_pty_master_send_signal, (Tchannel channel, int sig));
-extern void EXFUN (OS_pty_master_kill, (Tchannel channel));
-extern void EXFUN (OS_pty_master_stop, (Tchannel channel));
-extern void EXFUN (OS_pty_master_continue, (Tchannel channel));
-extern void EXFUN (OS_pty_master_interrupt, (Tchannel channel));
-extern void EXFUN (OS_pty_master_quit, (Tchannel channel));
-extern void EXFUN (OS_pty_master_hangup, (Tchannel channel));
+extern const char * OS_open_pty_master
+ (Tchannel * master_fd, const char ** master_fname);
+extern void OS_pty_master_send_signal (Tchannel channel, int sig);
+extern void OS_pty_master_kill (Tchannel channel);
+extern void OS_pty_master_stop (Tchannel channel);
+extern void OS_pty_master_continue (Tchannel channel);
+extern void OS_pty_master_interrupt (Tchannel channel);
+extern void OS_pty_master_quit (Tchannel channel);
+extern void OS_pty_master_hangup (Tchannel channel);
#endif /* SCM_OSPTY_H */
/* -*-C-*-
-$Id: osscheme.c,v 1.17 2007/01/05 21:19:25 cph Exp $
+$Id: osscheme.c,v 1.18 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
#include "osscheme.h"
\f
-extern void
- EXFUN (signal_error_from_primitive, (long error_code));
-
void
-DEFUN_VOID (error_out_of_channels)
+error_out_of_channels (void)
{
signal_error_from_primitive (ERR_OUT_OF_FILE_HANDLES);
}
void
-DEFUN_VOID (error_out_of_processes)
+error_out_of_processes (void)
{
signal_error_from_primitive (ERR_OUT_OF_FILE_HANDLES);
}
void
-DEFUN_VOID (error_unimplemented_primitive)
+error_unimplemented_primitive (void)
{
signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
}
void
-DEFUN_VOID (error_floating_point_exception)
+error_floating_point_exception (void)
{
signal_error_from_primitive (ERR_FLOATING_OVERFLOW);
}
int
-DEFUN_VOID (executing_scheme_primitive_p)
+executing_scheme_primitive_p (void)
{
- return (PRIMITIVE_P (Registers[REGBLOCK_PRIMITIVE]));
+ return (PRIMITIVE_P (GET_PRIMITIVE));
}
#ifdef __OS2__
void
-DEFUN_VOID (request_attention_interrupt)
+request_attention_interrupt (void)
{
REQUEST_INTERRUPT (INT_Global_1);
}
int
-DEFUN_VOID (test_and_clear_attention_interrupt)
+test_and_clear_attention_interrupt (void)
{
- long code;
+ unsigned long code;
GRAB_INTERRUPT_REGISTERS ();
- code = (FETCH_INTERRUPT_CODE ());
+ code = GET_INT_CODE;
CLEAR_INTERRUPT_NOLOCK (INT_Global_1);
RELEASE_INTERRUPT_REGISTERS ();
return ((code & INT_Global_1) != 0);
#endif /* __OS2__ */
void
-DEFUN_VOID (request_console_resize_interrupt)
+request_console_resize_interrupt (void)
{
REQUEST_INTERRUPT (INT_Global_3);
}
void
-DEFUN_VOID (request_character_interrupt)
+request_character_interrupt (void)
{
REQUEST_INTERRUPT (INT_Character);
}
void
-DEFUN_VOID (request_timer_interrupt)
+request_timer_interrupt (void)
{
REQUEST_INTERRUPT (INT_Timer);
}
void
-DEFUN_VOID (request_suspend_interrupt)
+request_suspend_interrupt (void)
{
REQUEST_INTERRUPT (INT_Suspend);
- return;
}
int
-DEFUN_VOID (pending_interrupts_p)
+pending_interrupts_p (void)
{
return (INTERRUPT_PENDING_P (INT_Mask));
}
void
-DEFUN_VOID (deliver_pending_interrupts)
+deliver_pending_interrupts (void)
{
if (INTERRUPT_PENDING_P (INT_Mask))
signal_interrupt_from_primitive ();
- return;
}
-long
-DEFUN_VOID (get_interrupt_mask)
+unsigned long
+get_interrupt_mask (void)
{
- return (FETCH_INTERRUPT_MASK ());
+ return (GET_INT_MASK);
}
void
-DEFUN (set_interrupt_mask, (mask), long mask)
+set_interrupt_mask (unsigned long mask)
{
SET_INTERRUPT_MASK (mask & INT_Mask);
- return;
}
void
-DEFUN (debug_back_trace, (stream), outf_channel stream)
+debug_back_trace (outf_channel stream)
{
outf (stream, "*** Scheme Microcode Back Trace: ***\n");
Back_Trace (stream);
outf (stream, "*** End of Back Trace ***\n");
outf_flush (stream);
- return;
}
void
-DEFUN (debug_examine_memory, (address, label),
- long address AND
- CONST char * label)
+debug_examine_memory (long address, const char * label)
{
Print_Expression ((* ((SCHEME_OBJECT *) address)), ((char *) label));
- return;
}
/* -*-C-*-
-$Id: osscheme.h,v 1.16 2007/01/05 21:19:25 cph Exp $
+$Id: osscheme.h,v 1.17 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
#ifndef SCM_OSSCHEME_H
-#define SCM_OSSCHEME_H
+#define SCM_OSSCHEME_H 1
#include "outf.h"
#include "os.h"
-extern Tchannel EXFUN (arg_channel, (int arg_number));
+extern Tchannel arg_channel (int);
-extern int option_emacs_subprocess;
+extern int executing_scheme_primitive_p (void);
-extern int EXFUN (executing_scheme_primitive_p, (void));
+extern void debug_edit_flags (void);
+extern void debug_back_trace (outf_channel);
+extern void debug_examine_memory (long, const char *);
-extern void EXFUN (debug_edit_flags, (void));
-extern void EXFUN (debug_back_trace, (outf_channel));
-extern void EXFUN (debug_examine_memory, (long address, CONST char * label));
-
-extern void EXFUN (error_out_of_channels, (void));
-extern void EXFUN (error_unimplemented_primitive, (void));
-extern void EXFUN (error_external_return, (void));
-extern void EXFUN (error_out_of_processes, (void));
-extern void EXFUN (error_floating_point_exception, (void));
-
-extern void EXFUN (termination_eof, (void));
-extern void EXFUN (termination_normal, (CONST int));
-extern void EXFUN (termination_init_error, (void));
-extern void EXFUN (termination_signal, (CONST char * signal_name));
-extern void EXFUN (termination_trap, (void));
+extern void error_out_of_channels (void) NORETURN;
+extern void error_unimplemented_primitive (void) NORETURN;
+extern void error_out_of_processes (void) NORETURN;
+extern void error_floating_point_exception (void) NORETURN;
#ifdef __OS2__
-extern void EXFUN (request_attention_interrupt, (void));
-extern int EXFUN (test_and_clear_attention_interrupt, (void));
-#endif /* __OS2__ */
-
-extern void EXFUN (request_console_resize_interrupt, (void));
-extern void EXFUN (request_character_interrupt, (void));
-extern void EXFUN (request_timer_interrupt, (void));
-extern void EXFUN (request_suspend_interrupt, (void));
-extern void EXFUN (deliver_pending_interrupts, (void));
-extern int EXFUN (pending_interrupts_p, (void));
-extern long EXFUN (get_interrupt_mask, (void));
-extern void EXFUN (set_interrupt_mask, (long mask));
-extern void EXFUN (signal_interrupt_for_primitive, (void));
-extern void EXFUN (preserve_interrupt_mask, (void));
-extern void EXFUN (back_out_of_primitive, (void));
+ extern void request_attention_interrupt (void);
+ extern int test_and_clear_attention_interrupt (void);
+#endif
+
+extern void request_console_resize_interrupt (void);
+extern void request_character_interrupt (void);
+extern void request_timer_interrupt (void);
+extern void request_suspend_interrupt (void);
+extern void deliver_pending_interrupts (void);
+extern int pending_interrupts_p (void);
+extern unsigned long get_interrupt_mask (void);
+extern void set_interrupt_mask (unsigned long mask);
+extern void signal_interrupt_for_primitive (void) NORETURN;
#endif /* SCM_OSSCHEME_H */
/* -*-C-*-
-$Id: osterm.h,v 1.15 2007/01/05 21:19:25 cph Exp $
+$Id: osterm.h,v 1.16 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "os.h"
-extern Tchannel EXFUN (arg_channel, (int));
-extern Tchannel EXFUN (arg_terminal, (int));
-
-extern unsigned int EXFUN (OS_terminal_get_ispeed, (Tchannel channel));
-extern unsigned int EXFUN (OS_terminal_get_ospeed, (Tchannel channel));
-extern void EXFUN
- (OS_terminal_set_ispeed, (Tchannel channel, unsigned int baud));
-extern void EXFUN
- (OS_terminal_set_ospeed, (Tchannel channel, unsigned int baud));
-extern unsigned int EXFUN (arg_baud_index, (unsigned int argument));
-extern unsigned int EXFUN (OS_baud_index_to_rate, (unsigned int index));
-extern int EXFUN (OS_baud_rate_to_index, (unsigned int rate));
-extern unsigned int EXFUN (OS_terminal_state_size, (void));
-extern void EXFUN (OS_terminal_get_state, (Tchannel channel, PTR statep));
-extern void EXFUN (OS_terminal_set_state, (Tchannel channel, PTR statep));
-extern int EXFUN (OS_terminal_cooked_output_p, (Tchannel channel));
-extern void EXFUN (OS_terminal_raw_output, (Tchannel channel));
-extern void EXFUN (OS_terminal_cooked_output, (Tchannel channel));
-extern int EXFUN (OS_terminal_buffered_p, (Tchannel channel));
-extern void EXFUN (OS_terminal_buffered, (Tchannel channel));
-extern void EXFUN (OS_terminal_nonbuffered, (Tchannel channel));
-extern void EXFUN (OS_terminal_flush_input, (Tchannel channel));
-extern void EXFUN (OS_terminal_flush_output, (Tchannel channel));
-extern void EXFUN (OS_terminal_drain_output, (Tchannel channel));
-extern int EXFUN (OS_job_control_p, (void));
-extern int EXFUN (OS_have_ptys_p, (void));
+extern Tchannel arg_terminal (int);
+
+extern unsigned int OS_terminal_get_ispeed (Tchannel channel);
+extern unsigned int OS_terminal_get_ospeed (Tchannel channel);
+extern void OS_terminal_set_ispeed
+ (Tchannel channel, unsigned int baud);
+extern void OS_terminal_set_ospeed
+ (Tchannel channel, unsigned int baud);
+extern unsigned int arg_baud_index (unsigned int argument);
+extern unsigned int OS_baud_index_to_rate (unsigned int index);
+extern int OS_baud_rate_to_index (unsigned int rate);
+extern unsigned int OS_terminal_state_size (void);
+extern void OS_terminal_get_state (Tchannel channel, void * statep);
+extern void OS_terminal_set_state (Tchannel channel, void * statep);
+extern int OS_terminal_cooked_output_p (Tchannel channel);
+extern void OS_terminal_raw_output (Tchannel channel);
+extern void OS_terminal_cooked_output (Tchannel channel);
+extern int OS_terminal_buffered_p (Tchannel channel);
+extern void OS_terminal_buffered (Tchannel channel);
+extern void OS_terminal_nonbuffered (Tchannel channel);
+extern void OS_terminal_flush_input (Tchannel channel);
+extern void OS_terminal_flush_output (Tchannel channel);
+extern void OS_terminal_drain_output (Tchannel channel);
+extern int OS_job_control_p (void);
+extern int OS_have_ptys_p (void);
#endif /* SCM_OSTERM_H */
/* -*-C-*-
-$Id: ostop.h,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: ostop.h,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "os.h"
-extern int EXFUN (OS_under_emacs_p, (void));
-extern void EXFUN (OS_initialize, (void));
-extern void EXFUN (OS_reset, (void));
-extern void EXFUN (OS_quit, (int code, int abnormal_p));
-extern void EXFUN (OS_restartable_exit, (void));
-extern void EXFUN (OS_save_external_state, (void));
-extern void EXFUN (OS_save_internal_state, (void));
-extern void EXFUN (OS_restore_internal_state, (void));
-extern void EXFUN (OS_restore_external_state, (void));
-extern CONST char * EXFUN (OS_error_code_to_message, (unsigned int code));
+extern int OS_under_emacs_p (void);
+extern void OS_initialize (void);
+extern void OS_reset (void);
+extern void OS_quit (int code, int abnormal_p);
+extern void OS_restartable_exit (void);
+extern void OS_save_external_state (void);
+extern void OS_save_internal_state (void);
+extern void OS_restore_internal_state (void);
+extern void OS_restore_external_state (void);
+extern const char * OS_error_code_to_message (unsigned int code);
#endif /* SCM_OSTOP_H */
/* -*-C-*-
-$Id: ostty.c,v 1.8 2007/01/05 21:19:25 cph Exp $
+$Id: ostty.c,v 1.9 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "ostty.h"
#include "osscheme.h"
+#include "prims.h"
static cc_t next_interrupt_char;
void
-DEFUN (tty_set_next_interrupt_char, (c), cc_t c)
+tty_set_next_interrupt_char (cc_t c)
{
if (next_interrupt_char == '\0')
{
}
cc_t
-DEFUN_VOID (OS_tty_next_interrupt_char)
+OS_tty_next_interrupt_char (void)
{
if (next_interrupt_char == '\0')
error_external_return ();
/* -*-C-*-
-$Id: ostty.h,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: ostty.h,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "os.h"
-extern Tchannel EXFUN (OS_tty_input_channel, (void));
-extern Tchannel EXFUN (OS_tty_output_channel, (void));
-extern unsigned int EXFUN (OS_tty_x_size, (void));
-extern unsigned int EXFUN (OS_tty_y_size, (void));
-extern CONST char * EXFUN (OS_tty_command_beep, (void));
-extern CONST char * EXFUN (OS_tty_command_clear, (void));
-extern cc_t EXFUN (OS_tty_next_interrupt_char, (void));
-extern cc_t EXFUN (OS_tty_map_interrupt_char, (cc_t));
+extern Tchannel OS_tty_input_channel (void);
+extern Tchannel OS_tty_output_channel (void);
+extern unsigned int OS_tty_x_size (void);
+extern unsigned int OS_tty_y_size (void);
+extern const char * OS_tty_command_beep (void);
+extern const char * OS_tty_command_clear (void);
+extern cc_t OS_tty_next_interrupt_char (void);
+extern cc_t OS_tty_map_interrupt_char (cc_t);
#endif /* SCM_OSTTY_H */
/* -*-C-*-
-$Id: outf.c,v 1.16 2007/01/05 21:19:25 cph Exp $
+$Id: outf.c,v 1.17 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
USA.
*/
-\f
-/*
- OUTF system
-
- outf_channel i/o is a substitute for <stdio.h>. On text based unix-like
- systems it is implmented in terms of stdio. On windowing systems, however,
- we have to be able to report problems withou having an obvious text output.
-
- There are three channels for output:
-
- console_output - for normal output to the user
- error_output - for output of exceptional things
- fatal_output - for details of an impending crash
-
- Use outf where you would normally think of using fprintf and outf_flush
- where you would normally use fflush.
-
- outf_flush(fatal_output) is special. It causes the buffered fatal_output
- data to be displayed. On windowing systems this may cause a window to be
- created to display the information, or allow the window containging the
- information to stay visible `after' the termination of Scheme.
-*/
-#include <stdio.h>
-#include "scheme.h"
+/* OUTF system
-#ifdef STDC_HEADERS
-# include <string.h>
-# include <stdarg.h>
-# define VA_START(args, lastarg) va_start(args, lastarg)
-# define VA_DCL
-#else
-# include <varargs.h>
-# define VA_START(args, lastarg) va_start(args)
-# define VA_DCL va_dcl
-#endif
+ outf_channel I/O is a substitute for <stdio.h>. On text-based
+ systems it is implemented in terms of stdio. On windowing systems,
+ however, we have to be able to report problems without having an
+ obvious text output.
+
+ There are three channels for output:
+
+ CONSOLE_OUTPUT - for normal output to the user
+ ERROR_OUTPUT - for output of exceptional things
+ FATAL_OUTPUT - for details of an impending crash
+
+ Use outf where you would normally think of using fprintf and
+ outf_flush where you would normally use fflush. */
+
+#include "config.h"
+#include "outf.h"
#ifdef __WIN32__
# include <windows.h>
# include "ntscreen.h"
+ extern HANDLE master_tty_window;
#endif
-/* forward reference */
-extern void EXFUN
- (voutf, (CONST outf_channel chan, CONST char * format, va_list ap));
+#ifdef __OS2__
+ extern char * OS2_thread_fatal_error_buffer (void);
+ extern void OS2_message_box (const char *, const char *, int);
+ extern void OS2_console_write (const char *, size_t);
+#endif
\f
-#define make_outf_variants(outputter,flusher,chan) \
-void \
-DEFUN (outputter, (format, va_alist), CONST char *format DOTS) \
- VA_DCL \
-{ \
- va_list args; \
- VA_START(args, format); \
- voutf((chan), format, args); \
-} \
-void \
-DEFUN_VOID (flusher) \
-{ \
- outf_flush (chan); \
-}
-
-make_outf_variants(outf_console, outf_flush_console, console_output)
-make_outf_variants(outf_error, outf_flush_error, error_output)
-make_outf_variants(outf_fatal, outf_flush_fatal, fatal_output)
-
-void
-DEFUN (outf, (chan, format, va_alist),
- outf_channel chan AND
- CONST char *format DOTS)
- VA_DCL
+void
+outf (outf_channel chan, const char * format, ...)
{
va_list ap;
- VA_START(ap, format);
- voutf(chan, format, ap);
+ va_start (ap, format);
+ voutf (chan, format, ap);
+ va_end (ap);
+}
+
+void
+voutf (outf_channel chan, const char * format, va_list ap)
+{
+ switch (chan)
+ {
+ case CONSOLE_OUTPUT: voutf_console (format, ap); break;
+ case ERROR_OUTPUT: voutf_error (format, ap); break;
+ case FATAL_OUTPUT: voutf_fatal (format, ap); break;
+ }
+}
+
+void
+outf_flush (outf_channel chan)
+{
+ switch (chan)
+ {
+ case CONSOLE_OUTPUT: outf_flush_console (); break;
+ case ERROR_OUTPUT: outf_flush_error (); break;
+ case FATAL_OUTPUT: outf_flush_fatal (); break;
+ }
+}
+
+void
+outf_console (const char * format, ...)
+{
+ va_list args;
+ va_start (args, format);
+ voutf_console (format, args);
+ va_end (args);
}
-static FILE *
-DEFUN (outf_channel_to_FILE, (chan), outf_channel chan)
+void
+outf_error (const char * format, ...)
{
- if (chan==fatal_output) return stderr;
- if (chan==error_output) return stderr;
- if (chan==console_output) return stdout;
- return (FILE*)chan;
+ va_list args;
+ va_start (args, format);
+ voutf_error (format, args);
+ va_end (args);
+}
+
+void
+outf_fatal (const char * format, ...)
+{
+ va_list args;
+ va_start (args, format);
+ voutf_fatal (format, args);
+ va_end (args);
}
\f
#ifdef __WIN32__
-#define USE_WINDOWED_OUTPUT
+#define OUTF_VARIANTS_DEFINED 1
#define MAX_FATAL_BUF 1000
-static char fatal_buf[MAX_FATAL_BUF + 1] = {0};
+static char fatal_buf [MAX_FATAL_BUF + 1] = { '\0' };
#ifdef CL386
-# define VSNPRINTF(buffer,length,format,args) \
+# define VSNPRINTF(buffer, length, format, args) \
_vsnprintf ((buffer), (length), (format), (args))
#else
# ifdef __WATCOMC__
-# define VSNPRINTF(buffer,length,format,args) \
+# define VSNPRINTF(buffer, length, format, args) \
vsprintf ((buffer), (format), (args))
# endif
#endif
+static void
+voutf_master_tty (const char * format, va_list args)
+{
+ char buf [1000];
+ VSNPRINTF (buf, 1000, format, args);
+ Screen_WriteText (master_tty_window, buf);
+ return (true);
+}
+
void
-DEFUN (voutf_fatal, (format, args), CONST char *format AND va_list args)
+voutf_console (const char * format, va_list args)
{
- int end = strlen(fatal_buf);
- VSNPRINTF (&fatal_buf[end], MAX_FATAL_BUF - end, format, args);
+ if (master_tty_window != 0)
+ voutf_master_tty (format, args);
+ else
+ vfprintf (stdout, format, args);
}
void
-DEFUN_VOID (popup_outf_flush_fatal)
+outf_flush_console (void)
{
- fprintf(stderr,"%s", fatal_buf); fflush(stderr);
- MessageBox(0,fatal_buf,"MIT-Scheme terminating", MB_OK|MB_TASKMODAL);
- fatal_buf[0] = 0;
+ if (master_tty_window == 0)
+ fflush (stdout);
}
void
-DEFUN (voutf_master_tty, (chan, format, args),
- outf_channel chan AND CONST char *format AND va_list args)
+voutf_error (const char * format, va_list args)
{
- extern HANDLE master_tty_window;
- char buf[1000];
+ if (master_tty_window != 0)
+ voutf_master_tty (format, args);
+ else
+ vfprintf (stderr, format, args);
+}
- if (master_tty_window) {
- VSNPRINTF (buf, 1000, format, args);
- Screen_WriteText (master_tty_window, buf);
- } else {
- vfprintf (outf_channel_to_FILE(chan), format, args);
- }
+void
+outf_flush_error (void)
+{
+ if (master_tty_window == 0)
+ fflush (stderr);
+}
+
+void
+voutf_fatal (const char * format, va_list args)
+{
+ unsigned int end = (strlen (fatal_buf));
+ VSNPRINTF ((& (fatal_buf[end])), (MAX_FATAL_BUF - end), format, args);
+}
+
+void
+outf_flush_fatal (void)
+{
+ fprintf (stderr, "%s", fatal_buf);
+ fflush (stderr);
+ MessageBox
+ (0, fatal_buf, "MIT/GNU Scheme terminating", (MB_OK | MB_TASKMODAL));
+ (fatal_buf[0]) = '\0';
}
-#else /* not __WIN32__ */
+#endif /* __WIN32__ */
+\f
#ifdef __OS2__
-extern char * OS2_thread_fatal_error_buffer (void);
-extern void OS2_message_box (const char *, const char *, int);
+#define OUTF_VARIANTS_DEFINED 1
-#define USE_WINDOWED_OUTPUT
+void
+voutf_console (const char * format, va_list args)
+{
+ char buffer [4096];
+ vsprintf (buffer, format, args);
+ OS2_console_write (buffer, (strlen (buffer)));
+}
-static void
+void
+outf_flush_console (void)
+{
+}
+
+void
+voutf_error (const char * format, va_list args)
+{
+ voutf_console (format, args);
+}
+
+void
+outf_flush_error (void)
+{
+}
+
+void
voutf_fatal (const char * format, va_list args)
{
char * buffer = (OS2_thread_fatal_error_buffer ());
vsprintf ((& (buffer [end])), format, args);
}
-static void
-popup_outf_flush_fatal (void)
+void
+outf_flush_fatal (void)
{
char * buffer = (OS2_thread_fatal_error_buffer ());
- OS2_message_box ("Scheme Terminating", buffer, 1);
+ OS2_message_box ("MIT/GNU Scheme terminating", buffer, 1);
(buffer[0]) = '\0';
}
-static void
-voutf_master_tty (const outf_channel chan, const char * format, va_list args)
+#endif /* __OS2__ */
+\f
+#ifndef OUTF_VARIANTS_DEFINED
+
+void
+voutf_console (const char * format, va_list args)
{
- extern void OS2_console_write (const char *, size_t);
- char buffer [4096];
- vsprintf (buffer, format, args);
- OS2_console_write (buffer, (strlen (buffer)));
+ vfprintf (stdout, format, args);
}
-#endif /* __OS2__ */
-#endif /* not __WIN32__ */
-\f
void
-DEFUN (voutf, (chan, format, ap),
- CONST outf_channel chan AND
- CONST char * format AND
- va_list ap)
+outf_flush_console (void)
{
-#ifdef USE_WINDOWED_OUTPUT
+ fflush (stdout);
+}
- if (chan == fatal_output)
- voutf_fatal (format, ap);
- else if ((chan == console_output) || (chan == error_output))
- voutf_master_tty (chan, format, ap);
- else
-#endif
- vfprintf ((outf_channel_to_FILE (chan)), format, ap);
+void
+voutf_error (const char * format, va_list args)
+{
+ vfprintf (stderr, format, args);
}
void
-DEFUN (outf_flush, (chan), outf_channel chan)
+outf_flush_error (void)
{
-#ifdef USE_WINDOWED_OUTPUT
- if (chan == fatal_output)
- popup_outf_flush_fatal ();
- else
-#endif
- fflush (outf_channel_to_FILE (chan));
+ fflush (stderr);
+}
+
+void
+voutf_fatal (const char * format, va_list args)
+{
+ vfprintf (stderr, format, args);
+}
+
+void
+outf_flush_fatal (void)
+{
+ fflush (stderr);
}
+
+#endif /* not OUTF_VARIANTS_DEFINED */
/* -*-C-*-
-$Id: outf.h,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: outf.h,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
#ifndef SCM_OUTF_H
-#define SCM_OUTF_H
+#define SCM_OUTF_H 1
-#include <stdio.h>
#include "config.h"
-typedef struct __outf_channel_type_placeholder *outf_channel;
+typedef enum { CONSOLE_OUTPUT, ERROR_OUTPUT, FATAL_OUTPUT } outf_channel;
-extern void EXFUN (outf, (outf_channel chan, CONST char *format DOTS));
-extern void EXFUN (outf_console, (CONST char *format DOTS));
-extern void EXFUN (outf_error, (CONST char *format DOTS));
-extern void EXFUN (outf_fatal, (CONST char *format DOTS));
+extern void outf (outf_channel, const char *, ...)
+ ATTRIBUTE ((__format__ (__printf__, 2, 3)));
-extern void EXFUN (outf_flush, (outf_channel chan));
-extern void EXFUN (outf_flush_console, (void));
-extern void EXFUN (outf_flush_error, (void));
-extern void EXFUN (outf_flush_fatal, (void));
+extern void outf_console (const char *, ...)
+ ATTRIBUTE ((__format__ (__printf__, 1, 2)));
-#define console_output ((outf_channel)-1)
-#define error_output ((outf_channel)-2)
-#define fatal_output ((outf_channel)-3)
+extern void outf_error (const char *, ...)
+ ATTRIBUTE ((__format__ (__printf__, 1, 2)));
-#endif /* SCM_OUTF_H */
+extern void outf_fatal (const char *, ...)
+ ATTRIBUTE ((__format__ (__printf__, 1, 2)));
+
+extern void voutf (outf_channel, const char *, va_list);
+extern void voutf_console (const char *, va_list);
+extern void voutf_error (const char *, va_list);
+extern void voutf_fatal (const char *, va_list);
+
+extern void outf_flush (outf_channel chan);
+extern void outf_flush_console (void);
+extern void outf_flush_error (void);
+extern void outf_flush_fatal (void);
+
+#endif /* not SCM_OUTF_H */
+++ /dev/null
-#ifdef BSD
-#ifndef BSD4_1
-#define HAVE_GETPAGESIZE
-#endif
-#endif
-
-#ifndef HAVE_GETPAGESIZE
-
-#include <sys/param.h>
-
-#ifdef EXEC_PAGESIZE
-#define getpagesize() EXEC_PAGESIZE
-#else
-#ifdef NBPG
-#define getpagesize() NBPG * CLSIZE
-#ifndef CLSIZE
-#define CLSIZE 1
-#endif /* no CLSIZE */
-#else /* no NBPG */
-#define getpagesize() NBPC
-#endif /* no NBPG */
-#endif /* no EXEC_PAGESIZE */
-
-#endif /* not HAVE_GETPAGESIZE */
-
+++ /dev/null
-/* -*-C-*-
-
-$Id: ppband.c,v 9.68 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Dumps Scheme FASL in user-readable form. */
-\f
-#include <stdio.h>
-#include <ctype.h>
-#include "config.h"
-#include "errors.h"
-#include "types.h"
-#include "const.h"
-#include "object.h"
-#include "gccode.h"
-#include "sdata.h"
-#include "scheme.h" /* For `fast' and several other niceties */
-
-#ifdef STDC_HEADERS
-# include <stdlib.h> /* For `malloc', `free' and `exit' (Linux) */
-# include <string.h> /* For `strlen' and `strcpy' */
-#else
- extern PTR EXFUN (malloc, (int));
- extern void EXFUN (free, (PTR));
-
- extern void EXFUN (exit, (int));
-
- extern int EXFUN (strcmp, (CONST char *, CONST char *));
- extern int EXFUN (strlen, (CONST char *));
-#endif
-
-
-#include "storage.c" /* For `Type_Names' and "gctype.c" goodies */
-
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-# ifndef ENABLE_PPBAND_DEBUGGING_TOOLS
-# define ENABLE_PPBAND_DEBUGGING_TOOLS
-# endif
-#endif
-#if ENABLE_PPBAND_DEBUGGING_TOOLS
-# ifndef ENABLE_PPBAND_DEBUGGING_TOOLS_STORAGE_LAYOUT_DISPLAY
-# define ENABLE_PPBAND_DEBUGGING_TOOLS_STORAGE_LAYOUT_DISPLAY
-# endif
-#endif
-#if 0 /* Maybe make this a switch arg some day */
-#define ENABLE_PPBAND_DEBUGGING_TOOLS_IMPLIES_EARLY_EXIT /* Header checks */
-#endif
-# define ENABLE_PPBAND_DEBUGGING_TOOLS_STORAGE_LAYOUT_DISPLAY // MRB likes
-
-
-#if (CHAR_BIT == 8)
-# if (SIZEOF_UNSIGNED_LONG == 4) /* 32-bit word versions */
-# define UNSIGNED_LONG_HIGH_HALF(unsigned_long) ((unsigned_long) >> 16)
-# define UNSIGNED_LONG_LOW_HALF(unsigned_long) ((unsigned_long) & 0xFFFF)
-# elif (SIZEOF_UNSIGNED_LONG == 8) /* 32-bit word versions */
-# define UNSIGNED_LONG_HIGH_HALF(unsigned_long) ((unsigned_long) >> 32)
-# define UNSIGNED_LONG_LOW_HALF(unsigned_long) ((unsigned_long) & 0xFFFFFFFF)
-# else
-# error "Unexpected SIZEOF_UNSIGNED_LONG for ppband."
-# endif
-#else
-# error "`ppband' assumes that (CHAR_BIT == 8) is true."
-#endif
-
-
-#undef HEAP_MALLOC
-#define HEAP_MALLOC malloc
-\f
-/* This is needed when there is no compiler support. Cf. "boot.c". */
-
-void
-DEFUN (gc_death, (code, message, scan, free),
- signed long code /* So says "gccode.h", anyway. */
- AND char * message
- AND SCHEME_OBJECT * scan
- AND SCHEME_OBJECT * free)
-{
- outf_fatal ("\n");
- outf_fatal ("gc_death [%s = 0x%lx]: %s.\n", Term_Names[code], code, message);
- outf_fatal ("scan = 0x%lx; free = 0x%lx\n", scan, free);
-
- exit (1);
-}
-
-
-/* These are needed by load.c */
-
-#ifdef OS2
-
-#include <fcntl.h>
-#include <io.h>
-#include <sys\types.h>
-
-#define fread OS2_fread
-extern off_t EXFUN (OS2_fread, (char *, unsigned int, off_t, FILE *));
-
-#define fwrite OS2_fwrite
-extern off_t EXFUN (OS2_fwrite, (char *, unsigned int, off_t, FILE *));
-
-#endif /* OS2 */
-
-unsigned long
-DEFUN (Load_Data, (Count, To_Where), unsigned long Count AND SCHEME_OBJECT *To_Where)
-{
-#ifdef OS2
- setmode ((fileno (stdin)), O_BINARY);
-#endif /* OS2 */
-
- return (fread (((char *) To_Where),
- (sizeof (SCHEME_OBJECT)),
- Count,
- stdin));
-}
-
-#define INHIBIT_COMPILED_VERSION_CHECK
-#define INHIBIT_CHECKSUMS
-#include "load.c"
-\f
-#ifdef HEAP_IN_LOW_MEMORY
-# if defined(hp9000s800) || defined(__hp9000s800)
-# define File_To_Pointer(P) \
- ((((unsigned long) (P)) & DATUM_MASK) / (sizeof (SCHEME_OBJECT)))
-# else
-# define File_To_Pointer(P) \
- (((unsigned long) (P)) / (sizeof (SCHEME_OBJECT)))
-# endif /* [__]hp9000s800 */
-#else
-# define File_To_Pointer(P) \
- ((unsigned long) (P))
-#endif /* HEAP_IN_LOW_MEMORY */
-
-
-#ifndef Conditional_Bug
-
-# define Relocate(P) \
-(((unsigned long) (P) < Const_Base) ? \
- (File_To_Pointer (((unsigned long) (P)) - Heap_Base)) : \
- (Heap_Count + (File_To_Pointer (((unsigned long) (P)) - Const_Base))))
-
-#else
-
- static unsigned long Relocate_Temp;
-
-# define Relocate(P) \
- (Relocate_Into (Relocate_Temp, P), Relocate_Temp)
-
-# define Relocate_Into(What, P) \
- if (((unsigned long) (P)) < Const_Base) \
- (What) = (File_To_Pointer (((unsigned long) (P)) - Heap_Base))\
- else \
- (What) = (Heap_Count + \
- (File_To_Pointer (((unsigned long) P) - Const_Base)))
-
-#endif /* Conditional_Bug */
-
-
-static SCHEME_OBJECT *Data, *end_of_memory;
-\f
-void
-DEFUN (print_scheme_object_as_string, (string), char *string)
-{
- int i;
- char *temp;
- unsigned char c;
-
- temp = string;
- putchar ('"');
- for (i = 0; i < (sizeof (SCHEME_OBJECT)); i++)
- {
- c = *temp++;
- if (isgraph ((int) c))
- putchar (c);
- else
- putchar (' ');
- }
- printf ("\" = ");
-
- temp = string;
- for (i = 0; i < (sizeof (SCHEME_OBJECT)); i++)
- {
- c = *temp++;
- if (isgraph ((int) c))
- {
- printf (" ");
- putchar (c);
- }
- else
- {
- switch (c)
- {
- case '\0':
- printf (" \\0");
- break;
-
- case ' ':
- printf (" ");
- break;
-
-#ifdef __STDC__
- case '\a':
-#else
- case '\007':
-#endif
- printf (" \\a");
- break;
-
- case '\b':
- printf (" \\b");
- break;
-
- case '\f':
- printf (" \\f");
- break;
-
- case '\n':
- printf (" \\n");
- break;
-
- case '\r':
- printf (" \\r");
- break;
-
- case '\t':
- printf (" \\t");
- break;
-
- case '\v':
- printf (" \\v");
- break;
-
- default:
- printf (" \\%03o", c);
- break;
- }
- }
- }
- return;
-}
-\f
-Boolean
-DEFUN (scheme_string, (From, Quoted), unsigned long From AND Boolean Quoted)
-{
- fast unsigned long i, Count;
- fast char *Chars;
-
- Chars = ((char *) &Data[From + STRING_CHARS]);
- if ((Chars < ((char *) end_of_memory))
- && (Chars >= ((char *) Data)))
- {
- Count = ((unsigned long) (Data[From + STRING_LENGTH_INDEX]));
- if (&Chars[Count] < ((char *) end_of_memory))
- {
- if (Quoted)
- putchar ('\"');
- for (i = 0; i < Count; i++)
- printf ("%c", *Chars++);
- if (Quoted)
- putchar ('\"');
- putchar ('\n');
- return (true);
- }
- }
- if (Quoted)
- printf ("String not in memory; datum = 0x%lx\n", From);
- return (false); /* <0x><> */
-}
-
-#define via(File_Address) Relocate (OBJECT_DATUM (Data[File_Address]))
-
-void
-DEFUN (scheme_symbol, (From), unsigned long From)
-{
- SCHEME_OBJECT *symbol;
-
- symbol = &Data[From+SYMBOL_NAME];
- if ((symbol >= end_of_memory) ||
- (!(scheme_string (via (From + SYMBOL_NAME), false))))
- printf ("Symbol not in memory; datum = 0x%lx\n", From);
- return; /*<S><>*/ /* <0x><> */
-}
-\f
-#if (CHAR_BIT == 8)
-# if (SIZEOF_UNSIGNED_LONG == 4) /* 32-bit word versions */
-# if (TYPE_CODE_LENGTH == 8) /* So DATUM_LENGTH == 24, so ----v */
-# define Display_LOC_TYPE_DAT_FORMAT_STRING "%6lx: %2lx|%6lx "
-# define Display_LOC_HILO_RAW_FORMAT_STRING "%6lx: "\
- "[%04lx|%04lx] = "
-# endif
-# if (TYPE_CODE_LENGTH == 6) /* So DATUM_LENGTH == 26, so ---v */
-# define Display_LOC_TYPE_DAT_FORMAT_STRING "%7lx: %2lx|%7lx "
-# define Display_LOC_HILO_RAW_FORMAT_STRING "%7lx: "\
- "[%04lx|%04lx] = "
-# endif
-# elif (SIZEOF_UNSIGNED_LONG == 8)
-# define Display_LOC_TYPE_DAT_FORMAT_STRING "%7lx: %2lx|%15lx "
-# define Display_LOC_HILO_RAW_FORMAT_STRING "%7lx: "\
- "[%08lx|%08lx] = "
-# else
-# error "Unexpected SIZEOF_UNSIGNED_LONG for ppband."
-# endif
-#else
-# error "`ppband' assumes that (CHAR_BIT == 8) is true."
-#endif
-
-forward void EXFUN (Display, (unsigned long Location,
- unsigned long Type,
- unsigned long The_Datum));
-void
-DEFUN (Display_raw_type_dat_Scheme_object, (Location, Count, Area),
- fast unsigned long Location AND
- fast unsigned long Count AND
- fast SCHEME_OBJECT *Area)
-{
- fast unsigned long i;
-
- for (i = 0; ((i < Count) && (Area+i < end_of_memory)); i += 1)
- {
- /* Show as deconstructed raw Scheme datum. */
- Display (Location+i, (OBJECT_TYPE ((* (Area+i)))),
- /**/ (OBJECT_DATUM ((* (Area+i)))));
- }
-}
-
-void
-DEFUN (Display_raw_hilo_hex_Scheme_object, (Location, Count, Area),
- fast unsigned long Location AND /* unused - For tracing */
- fast unsigned long Count AND
- fast SCHEME_OBJECT *Area)
-{
- fast unsigned long i;
-
- for (i = 0; ((i < Count) && (Area+i < end_of_memory)); i += 1)
- {
- /* Show as raw hex anything that cannot be scanned as Scheme data. */
- printf (Display_LOC_HILO_RAW_FORMAT_STRING,
- Location+i,
- UNSIGNED_LONG_HIGH_HALF((unsigned long) (* (Area+i))),
- UNSIGNED_LONG_LOW_HALF( (unsigned long) (* (Area+i))));
- print_scheme_object_as_string ((char *) (Area+i));
- putchar ('\n');
- }
-}
-\f
-#define PRINT_OBJECT(type, datum) do \
-{ \
- printf ("[%s 0x%lx]", type, datum); \
-} while (0) /*<0x><>*/
-
-#define NON_POINTER(string) do \
-{ \
- the_string = string; \
- Points_To = The_Datum; \
-} while (0)
-
-#define POINTER(string) do \
-{ \
- the_string = string; \
-} while (0)
-
-// char *Type_Names[] = TYPE_NAME_TABLE; /* We get this now from "storage.c" */
-
-forward Boolean EXFUN (Display_constant, (unsigned long Location,
- unsigned long Type,
- unsigned long The_Datum));
-void
-DEFUN (Display, (Location, Type, The_Datum),
- unsigned long Location AND
- unsigned long Type AND
- unsigned long The_Datum)
-{
- char string_buf[100];
- char *the_string;
- unsigned long Points_To;
-
- printf (Display_LOC_TYPE_DAT_FORMAT_STRING, Location, Type, The_Datum);
- Points_To = Relocate ((SCHEME_OBJECT *) The_Datum);
-
- switch (Type) /* I.e., `Switch_by_GC_Type(object)' */
- {
- /* "Strange" cases */
-
- case TC_NULL:
- if (The_Datum == 0)
- {
- printf ("#F\n");
- return;
- }
- NON_POINTER ("MANIFEST-VECTOR"); /* "types.h" defines this alias. */
- break;
-
- case TC_CONSTANT:
- {
- Boolean recognized_scheme_constant_p =
- (Display_constant (Location, Type, The_Datum));
-
- if (recognized_scheme_constant_p)
- return; /* Deed done. */
- else
- NON_POINTER ("CONSTANT"); /* "const.h" implies this alias. */
- }
- break;
-\f
- /* Non-"Strange" Non_Pointer cases */
-
- case_TC_FIXNUMs: /* Courtesy of "types.h" (q.v.) */
- PRINT_OBJECT ("FIXNUM", The_Datum);
- Points_To = (FIXNUM_TO_LONG ((MAKE_OBJECT (Type, The_Datum))));
- printf (" = %ld\n", ((signed long) Points_To));
- return;
-
- /* ------
- * Caveat: The above special cases _must_ precede `case_Non_Pointer'.
- * ------
- *
- * As much as we'd dearly like to use `case_Non_Pointer' here
- * (defined from "gccode.h", q.v.), that results in duplicate
- * case values. Instead, we enumerate the remaining Non_Pointer
- * cases in the order in which they would have expanded by using
- * `case_Non_Pointer' (with duplicates commented out).
- */
-// ----
-// From `case_simple_Non_Pointer' of "gccode.h":
-// ----
-// case TC_NULL:
-// case TC_CONSTANT:
- case TC_RETURN_CODE:
- case TC_THE_ENVIRONMENT:
-// ----
-// From `case_Fasload_Non_Pointer' of "gccode.h" (also includes preceding):
-// ----
-// case_TC_FIXNUMs:
- case TC_CHARACTER:
-// ----
-// From `case_Non_Pointer' of "gccode.h" (which alss includes the preceding):
-// ----
- case TC_PRIMITIVE:
- case TC_PCOMB0:
- case TC_STACK_ENVIRONMENT:
-// ----
-// From ``Missing Non Pointer types'' of "gccode.h".
-// ----
-// case TC_BROKEN_HEART: Treated specially below...
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
-// case TC_RETURN_CODE: Treated specially below...
- case TC_MANIFEST_CLOSURE:
- case TC_LINKAGE_SECTION:
-
- NON_POINTER (Type_Names[Type]);
- break;
-\f
- /* Special GC Fasdump_Pair of "gccode.h" */
-
- case TC_LIST:
- POINTER ("PAIR"); /* See comment for LIST in "sdata.h". */
- break;
-
- /* Non-Fasdump GC Pairs of "gccode.h" */
-
- case TC_INTERNED_SYMBOL:
- PRINT_OBJECT ("INTERNED-SYMBOL", Points_To);
- printf (" = ");
- scheme_symbol (Points_To);
- return;
-
- case TC_UNINTERNED_SYMBOL:
- PRINT_OBJECT ("UNINTERNED-SYMBOL", Points_To);
- printf (" = ");
- scheme_symbol (Points_To);
- return;
-
- /* Special case: CHARACTER-STRING */
-
- case TC_CHARACTER_STRING:
- PRINT_OBJECT ("CHARACTER-STRING", Points_To);
- printf (" = ");
- scheme_string (Points_To, true);
- return;
-
- /* "Special" non-Non Pointer types of "gccode.h" */
-
- case TC_REFERENCE_TRAP:
- if (The_Datum <= TRAP_MAX_IMMEDIATE)
- NON_POINTER ("REFERENCE-TRAP");
- else
- POINTER ("REFERENCE-TRAP");
- break;
-
- case TC_BROKEN_HEART:
- if (The_Datum == 0)
- Points_To = 0;
- /* Fall through... */
-
- /* The rest are non-special Pointer types. See "gccode.h" for details. */
-
- default:
- if (Type <= LAST_TYPE_CODE)
- POINTER (Type_Names[Type]);
- else
- {
- sprintf (&string_buf[0], "0x%02lx ", Type);
- POINTER (&string_buf[0]);
- }
- break;
- }
-
- /* The preceding will have established `the_string' and `Points_To'. */
-
- PRINT_OBJECT (the_string, Points_To);
- printf ("\tDatum = %ld (%lu)\n", ((signed long) Points_To), The_Datum);
- return;
-}
-\f
-#define RECOGNIZED_SCHEME_CONSTANT TRUE
-
-Boolean
-DEFUN (Display_constant, (Location, Type, The_Datum),
- unsigned long Location AND /* unused - For tracing */
- unsigned long Type AND /* unused - For tracing */
- unsigned long The_Datum)
-{
- switch (The_Datum) /* See "const.h". */
- {
- case 0: /* #t *//* a.k.a. SHARP_T */
- printf ("#T");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 1: /* unspecific *//* a.k.a. UNSPECIFIC */
- printf ("UNSPECIFIC");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 2: /* [non-object] */
- printf ("[Non-Object]");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 3: /* #!optional */
- printf ("#!OPTIONAL");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 4: /* #!rest */
- printf ("#!REST");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 5: /* #!key */
- printf ("#!KEY");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 6: /* #!eof */
- printf ("#!EOF");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 7: /* #!default *//* a.k.a. DEFAULT_OBJECT */
- printf ("DEFAULT_OBJECT");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 8: /* #!aux */
- printf ("#!AUX");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- case 9: /* '() *//* a.k.a. EMPTY_LIST */
- printf ("EMPTY_LIST");
- printf ("\n");
- return (RECOGNIZED_SCHEME_CONSTANT);
-
- default:
- return (! RECOGNIZED_SCHEME_CONSTANT);
- }
-}
-\f
-forward \
-unsigned long EXFUN (show_area_raw_hex_count_for_special_non_pointer_types,
- (fast SCHEME_OBJECT *));
-
-SCHEME_OBJECT *
-DEFUN (show_area, (area, start, end, name),
- fast SCHEME_OBJECT *area AND
- unsigned long start AND
- fast unsigned long end AND
- char *name)
-{
- /*
- * Begin update of old ver.9.50 of 2000/12/05 (this file) to match the more
- * current "uxtrap.c" ver.1.31 of 2001/12/16. This file had bit rotted.
- *
- * Old code was botching counts so could get out of step w/ data in memory:
- *
- * count =
- * ((OBJECT_TYPE (*area) == TC_LINKAGE_SECTION)
- * ? (READ_CACHE_LINKAGE_COUNT (*area))
- * : (OBJECT_DATUM (*area)));
- *
- * New code avoids direct counts in favor of direct `area' computations since
- * the "cmpgc.h" COUNT/END macros automagically scale by entry sizes while
- * also skipping intervening headers & format words and accommodating both
- * short and long object formats for TC_MANIFEST_CLOSUREs (all of which the
- * old bit-rotted code was now botching here in the future).
- *
- */
-
- fast unsigned long i;
-
- printf ("\n");
- printf ("\n===========================================================");
- printf ("\n%s contents:\n\n", name);
-
- for (i = start; i < end; area++, i++)
- {
- /* Show object header */
- Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
-
- /* Show object contents as raw hex bits if it's a non-scannable region */
- if (GC_Type_Special(*area)) /* Courtesy "gc.h"<-"gctype.c"<-"storage.c" */
- {
- fast unsigned long count;
-
- count = show_area_raw_hex_count_for_special_non_pointer_types(area);
-
- Display_raw_hilo_hex_Scheme_object ((i + 1), count, (area + 1));
-
- i += count; /* Loopy `i++' will count the header we also Display'd. */
- area += count; /* Ditto `area++'. */
- }
- }
- return (area);
-}
-\f
-unsigned long
-DEFUN (show_area_raw_hex_count_for_special_non_pointer_types, (area),
- fast SCHEME_OBJECT *area)
-{
- fast unsigned long raw_hex_count; /* computed indirectly via `area_end' */
-
- /*
- * Begin update of old ver.9.50 of 2000/12/05 (this file) to match the more
- * current "uxtrap.c" ver.1.31 of 2001/12/16. This file had bit rotted.
- *
- * Old code was botching counts so could get out of step w/ data in memory.
- *
- * New code avoids direct counts in favor of direct `area' computations since
- * the "cmpgc.h" COUNT/END macros automagically scale by entry sizes while
- * also skipping intervening headers & format words and accommodating both
- * short and long object formats for TC_MANIFEST_CLOSUREs (all of which the
- * old bit-rotted code was now botching here in the future).
- *
- * For details, see fasdump.c, fasload.c, gcloop.c, purify.c, bintopsb.c, &c.
- *
- * For comparison, see skippy `uxtrap.c:find_block_address_in_area()' code.
- *
- * Note that we compute END-style ``one-object-shy-of-the-first-byte-after''
- * area pointers (called `area_end') since: a) the END-macro based cases
- * already compute this directly, while: b) the COUNT-macro based cases can
- * ``cheat'' by just adding the computed count to AREA, ignoring the header,
- * to (in effect) also compute an END-like area pointer one shy of the first
- * byte after the end of the object data. This allows all cases to share
- * a common ``show-the-raw-hex'' code block at the end of the loop.
- *
- */
-
- fast SCHEME_OBJECT * area_end; /* value for AREA when pointing at last obj */
- {
- fast SCHEME_OBJECT object = (*area); /* current candidate */
-
- Switch_by_GC_Type(object) /* Courtesy of "gccode.h" (q.v.) */
- {
- case TC_LINKAGE_SECTION:
- {
- switch (READ_LINKAGE_KIND (object))
- {
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- case OPERATOR_LINKAGE_KIND:
- {
- unsigned long \
- count = (READ_OPERATOR_LINKAGE_COUNT (object));
- area_end = (END_OPERATOR_LINKAGE_AREA (area, count));
- }
- break;
-
- default: /* This should never arise in true linkage sections. */
-#if BAD_TYPES_LETHAL /* This is handy for gdbugging: please don't delete.*/
- {
- char gc_death_message_buffer[100];
-
- sprintf(gc_death_message_buffer,
- "show_area: Unknown compiler linkage kind (0x%lx).",
- ((unsigned long) (OBJECT_TYPE (object))));
-
- gc_death (TERM_EXIT, gc_death_message_buffer, area, NULL);
- /*NOTREACHED*/
- }
-#else
- /* Fall through, no reason to crash here. */
-#endif
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- case CLOSURE_PATTERN_LINKAGE_KIND:
- {
- unsigned long \
- count = (READ_CACHE_LINKAGE_COUNT (object));
- area_end = (area + count); /* Cheat: ignores header */
- }
- break;
- } /* End `switch' on READ_LINKAGE_KIND */
- }
- break;
-\f
- case TC_MANIFEST_CLOSURE:
- {
- SCHEME_OBJECT * word_after_header = (area + 1); /* Cf. "cmpgc.h" */
- {
- unsigned long \
- count = (MANIFEST_CLOSURE_COUNT (word_after_header));
- area_end = (MANIFEST_CLOSURE_END (area, count)); /* Cheat!! */
- }
- }
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- {
- {
- unsigned long \
- count = (OBJECT_DATUM (object));
- area_end = (area + count); /* Cheat: ignores header */
- }
- }
- break;
-
- default:
- /* Missing Non Pointer types (must always be treated specially):
-
- TC_BROKEN_HEART
- TC_MANIFEST_SPECIAL_NM_VECTOR
- TC_REFERENCE_TRAP
-
- ...are handled by the `Display' procedure w/o resorting to a block
- of raw hex spewage, thank you very much. MANIFEST_SPECIAL_NM_VECT
- is just a noise header, for example, with no non-scannable data
- following it. The other two cases are handled similarly.
- */
- {
- area_end = area; /* i.e., nothing to show as raw bits, thanks */
- }
- break;
-
- } /* End `switch' GC_Type() case analysis */
-
- } /* End of `area_end' replacement for rotted old `count' computation */
-
-
- /* Compulsively name return values to make the code more self-documenting. */
-
- raw_hex_count = (area_end - area);
-
- return(raw_hex_count);
-}
-\f
-int
-DEFUN (main, (argc, argv),
- int argc AND
- char **argv)
-{
- int counter = 0;
-
- while (1)
- {
- fast SCHEME_OBJECT *Next = ((SCHEME_OBJECT *) NULL);
- unsigned long total_length, load_length;
-
-#ifdef ENABLE_PPBAND_DEBUGGING_TOOLS_STORAGE_LAYOUT_DISPLAY
- /* debug hooks */
- unsigned long Heap_first, Heap_last, Heap_size, Heap_length, Heap_top;
- unsigned long Const_first, Const_last, Const_size, Const_length, Const_top;
- unsigned long Prims_first, Prims_last, Prims_size, Prims_length;
- unsigned long CCode_first, CCode_last, CCode_size, CCode_length;
-
- /* debug hooks for symmetry w.r.t. Heap and Constant spaces */
- unsigned long Prims_count;
- unsigned long CCode_count;
-#endif
-
- if (argc == 1)
- {
- switch (Read_Header ())
- {
- case FASL_FILE_FINE :
- if (counter != 0)
- printf ("\f\n\t*** New object ***\n\n");
- break;
-
- /* There should really be a difference between no header
- and a short header.
- */
-
- case FASL_FILE_TOO_SHORT:
- exit (0);
-
- default:
- {
- fprintf (stderr,
- "%s: Input does not appear to be in correct FASL format.\n",
- argv[0]);
- exit (1);
- /* NOTREACHED */
- }
- }
- print_fasl_information ();
- printf ("Dumped object (relocated) at 0x%lx\n",
- (Relocate (Dumped_Object)));
- }
- else if (argc == 4) /* Forge FASL header bases for RELOCATE/Data_Load() */
- {
- const char * mbase_format_string = "%lx"; /* sscanf warns if literals */
- const char * count_format_string = "%lu";
-
- /* Show only heap for FASL headerless data files */
- Const_Count = 0;
- Primitive_Table_Size = 0;
- C_Code_Table_Size = 0;
-
- /* Fake minimal bases to keep RELOCATE/Data_Load() happy */
- sscanf (argv[1], mbase_format_string, ((unsigned long) &Heap_Base));
- sscanf (argv[2], mbase_format_string, ((unsigned long) &Const_Base));
- sscanf (argv[3], count_format_string, ((unsigned long) &Heap_Count));
- printf ("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %lu\n",
- Heap_Base, Const_Base, Heap_Count);
- }
-\f
- else
- {
- printf("\nUsage: %s < FILE"
- "\n %s Heap_Base Const_Base Heap_Count < FILE"
- "\n"
- "\n where FILE is a fasdumped MIT Scheme file to inspect."
- "\n",
- argv[0], argv[0]);
- fprintf (stderr, "\nerror: %s: 0 or 3 arguments required (saw %u).\n",
- argv[0], argc);
- exit (1);
- /* NOTREACHED */
- }
-\f
-#ifdef ENABLE_PPBAND_DEBUGGING_TOOLS_STORAGE_LAYOUT_DISPLAY
- /*
- ** Fill in some handy debug hooks
- */
-
- /* Given: tops */
-
- Heap_top = Dumped_Heap_Top;
- Const_top = Dumped_Constant_Top;
-
- /* Given: sizes and lengths */
-
- Prims_size = Primitive_Table_Size;
- Prims_length = Primitive_Table_Length;
-
- CCode_size = C_Code_Table_Size;
- CCode_length = C_Code_Table_Length;
-
- /* Derived: sizes and lengths */
-
- Heap_size = ( Heap_top - Heap_Base);
- Heap_length = ( Heap_size >> 2);
-
- if (Const_Count == 0)
- {
- Const_size = 0;
- Const_length = 0;
- }
- else
- {
- Const_size = (Const_top - Const_Base);
- Const_length = (Const_size >> 2);
- }
-
- /* Derived: firsts and lasts */
-
- Heap_first = 0;
- Heap_last = ( Heap_first + Heap_length - 1);
-
- Const_first = ( Heap_last + 1);
- Const_last = (Const_first + Const_length - 1);
-
- Prims_first = (Const_last + 1);
- Prims_last = (Prims_first + Prims_length - 1);
-
- CCode_first = (Prims_last + 1);
- CCode_last = (CCode_first + CCode_length - 1);
-
- /* Derived: counts */
-
- Prims_count = (Prims_last - Prims_first + 1);
- CCode_count = (CCode_last - CCode_first + 1);
-\f
- /* Show and tell */
-
- printf ("\n");
- printf ("\n-----------------------");
- printf ("\nPartition Configuration:");
- printf ("\n");
- printf ("\nHeap_first = 0x%08lx (%10lu)", Heap_first, Heap_first);
- printf ("\nHeap_top = 0x%08lx (%10lu)", Heap_top, Heap_top);
- printf ("\nHeap_Base = 0x%08lx (%10lu)", Heap_Base, Heap_Base);
- printf ("\nHeap_size = 0x%08lx (%10lu)", Heap_size, Heap_size);
- printf ("\nHeap_length = 0x%08lx (%10lu)", Heap_length, Heap_length);
- printf ("\nHeap_Count = 0x%08lx (%10lu)", Heap_Count, Heap_Count);
- printf ("\nHeap_last = 0x%08lx (%10lu)", Heap_last, Heap_last);
- printf ("\n");
- printf ("\nConst_first = 0x%08lx (%10lu)", Const_first, Const_first);
- printf ("\nConst_top = 0x%08lx (%10lu)", Const_top, Const_top);
- printf ("\nConst_Base = 0x%08lx (%10lu)", Const_Base, Const_Base);
- printf ("\nConst_size = 0x%08lx (%10lu)", Const_size, Const_size);
- printf ("\nConst_length = 0x%08lx (%10lu)", Const_length, Const_length);
- printf ("\nConst_Count = 0x%08lx (%10lu)", Const_Count, Const_Count);
- printf ("\nConst_last = 0x%08lx (%10lu)", Const_last, Const_last);
- printf ("\n");
- printf ("\nPrims_first = 0x%08lx (%10lu)", Prims_first, Prims_first);
- printf ("\nPrims_size = 0x%08lx (%10lu)", Prims_size, Prims_size);
- printf ("\nPrims_length = 0x%08lx (%10lu)", Prims_length, Prims_length);
- printf ("\nPrims_count = 0x%08lx (%10lu)", Prims_count, Prims_count);
- printf ("\nPrims_last = 0x%08lx (%10lu)", Prims_last, Prims_last);
- printf ("\n");
- printf ("\nCCode_first = 0x%08lx (%10lu)", CCode_first, CCode_first);
- printf ("\nCCode_size = 0x%08lx (%10lu)", CCode_size, CCode_size);
- printf ("\nCCode_length = 0x%08lx (%10lu)", CCode_length, CCode_length);
- printf ("\nCCode_count = 0x%08lx (%10lu)", CCode_count, CCode_count);
- printf ("\nCCode_last = 0x%08lx (%10lu)", CCode_last, CCode_last);
- printf ("\n");
- printf ("\n");
-
-#ifdef ENABLE_PPBAND_DEBUGGING_TOOLS_IMPLIES_EARLY_EXIT
- exit(0); /* Just wanted quick check of dump file header/partition info. */
-#endif
-
-#endif /* ENABLE_PPBAND_DEBUGGING_TOOLS_STORAGE_LAYOUT_DISPLAY */
-\f
- /*
- ** We allocate one Scheme object to serve as an end-of-memory sentinel, so
- ** the total allocation in units of Scheme objects is `load_length' plus 1.
- */
-#define PPBAND_NUM_SCHEME_OBJECTS_TO_ALLOCATE (load_length + 1) /* <EOM> */
-#define PPBAND_NUM_DATA_WORDS_TO_ALLOCATE \
- (PPBAND_NUM_SCHEME_OBJECTS_TO_ALLOCATE * (sizeof (SCHEME_OBJECT)))
- /*
- ** Caveat: The Heap_Count and Const_Count measure how many Scheme objs are
- ** in each area whereas Primitive_Table_Size and C_Code_Table_Size
- ** measure how many Scheme object sized parcels were dumped there.
- ** By contrast, the xx_Table_Length's measure how many table items
- ** were witnessed by the dump but _multiple_bytes_of_data_were_
- ** _dumped_for_each_item_witnessed_. Don't get confused by this.
- */
- load_length = (Heap_Count + Const_Count + Primitive_Table_Size
- /**/ + C_Code_Table_Size);
- Data = ((SCHEME_OBJECT *)
- (malloc (PPBAND_NUM_DATA_WORDS_TO_ALLOCATE)));
- if (Data == NULL)
- {
- fprintf (stderr,
- "Allocation of %lu words failed.\n",
- PPBAND_NUM_DATA_WORDS_TO_ALLOCATE);
- exit (1);
- }
-#ifdef ENABLE_PPBAND_DEBUGGING_TOOLS
- bzero(Data, PPBAND_DATA_WORDS_TO_ALLOCATE);
-#endif
- total_length = (Load_Data (load_length, Data));
- end_of_memory = &Data[total_length];
- if (total_length != load_length)
- {
- printf ("The FASL file does not have the right length.\n");
- printf ("Expected %lu objects. Obtained %lu objects.\n\n",
- ((unsigned long) load_length), ((unsigned long) total_length));
- /*
- * The following truncates area counts/sizes upon running out of Data
- * space. The first area that is too big to fit and all those checked
- * afterward will be ignored (dropped on the floor) as if not present.
- *
- * I'm not taking credit for this cleverness, just documenting the non-
- * obvious. The code is straightforward once you know the intent. -mrb
- */
- if (total_length < Heap_Count)
- Heap_Count = total_length;
- total_length -= Heap_Count;
- if (total_length < Const_Count)
- Const_Count = total_length;
- total_length -= Const_Count;
- if (total_length < Primitive_Table_Size)
- Primitive_Table_Size = total_length;
- total_length -= Primitive_Table_Size;
- if (total_length < C_Code_Table_Size)
- C_Code_Table_Size = total_length;
- }
-\f
- if (Heap_Count > 0)
- Next = show_area (Data, 0, Heap_Count, "Heap");
- if (Const_Count > 0)
- Next = show_area (Next, Heap_Count, (Heap_Count + Const_Count), "Constant Space");
- if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
- {
- signed long arity; /* Note: LEXPR and UNKNOWN prim arity < 0. */
- unsigned long size;
- fast unsigned long entries, count;
-
- /* This is done in case the file is short. See `<EOM>' marker above. */
- end_of_memory[0] = ((SCHEME_OBJECT) 0);
- end_of_memory[1] = ((SCHEME_OBJECT) 0);
- end_of_memory[2] = ((SCHEME_OBJECT) 0);
- end_of_memory[3] = ((SCHEME_OBJECT) 0);
-
- entries = Primitive_Table_Length;
-
- printf ("\n");
-
-#ifdef ENABLE_PPBAND_DEBUGGING_TOOLS
- /*
- * For each primitive existent in the world, fasdump dumps its arity
- * and name string at the end of the fasdump file. Spew them now.
- *
- * See <microcode/primutl.c>:copy_primitive_information() for details.
- *
- * For comparison, see <microcode/primutl.c>:install_primitive_table().
- *
- */
- printf ("\n===========================================================");
- printf ("\nRaw Scheme format of Primitive Table contents:\n");
-
- printf ("\n---------------");
- printf ("\nPrimitive table: Number of entries = %lu (0x%03lx)\n\n",
- entries, entries);
-
- Display_raw_type_dat_Scheme_object (0, entries, Next);
-
-
- printf ("\n===========================================================");
- printf ("\nRaw hex format of Primitive Table contents:\n");
-
- printf ("\n---------------");
- printf ("\nPrimitive table: Number of entries = %lu (0x%03lx)\n\n",
- entries, entries);
-
- Display_raw_hilo_hex_Scheme_object (0, entries, Next);
-
-#endif /* ENABLE_PPBAND_DEBUGGING_TOOLS */
-\f
- /*
- * For each primitive existent in the world, fasdump dumps its arity
- * and name string at the end of the fasdump file. Show them now.
- *
- * See <microcode/primutl.c>:copy_primitive_information() for details.
- *
- * For comparison, see <microcode/primutl.c>:install_primitive_table().
- *
- */
- printf ("\n===========================================================");
- printf ("\nPrimitive Table contents:\n");
-
- printf ("\n---------------");
- printf ("\nPrimitive table: Number of entries = %lu (0x%03lx)\n\n",
- entries, entries);
-
- for (count = 0;
- ((count < entries) && (Next < end_of_memory));
- count += 1)
- {
- arity = (FIXNUM_TO_LONG (*Next));
- Next += 1;
- size = (OBJECT_DATUM (*Next)); /* word count of Scheme char string */
-#ifdef ENABLE_PPBAND_DEBUGGING_TOOLS
- printf ("size = %2lu; ", size);
-#endif /**/ /* <0x><><%0> */
- printf ("Number = 0x%03lx; Arity = %2ld; Name = ", count, arity);
- scheme_string ((Next - Data), true);
- Next += (1 + size);
- }
- printf ("\n");
- }
-\f
- if ((C_Code_Table_Size > 0) && (Next < end_of_memory))
- {
- unsigned long dumped_initial_entry_number, nentries;
- fast unsigned long entries, count;
-
- /* This is done in case the file is short. See `<EOM>' marker above. */
- end_of_memory[0] = ((SCHEME_OBJECT) 0);
- end_of_memory[1] = ((SCHEME_OBJECT) 0);
- end_of_memory[2] = ((SCHEME_OBJECT) 0);
- end_of_memory[3] = ((SCHEME_OBJECT) 0);
-
- entries = C_Code_Table_Length;
-
- printf ("\n");
-
-#ifdef ENABLE_PPBAND_DEBUGGING_TOOLS
- /*
- * For each C code block existent in the world, fasdump dumps its entry
- * count and name string at the end of the fasdump file. Spew them now.
- *
- * Details: see <microcode/cmpauxmd/c.c>:copy_c_code_block_information().
- *
- * For comparison, see <microcode/cmpauxmd/c.c>:install_c_code_table().
- *
- */
- printf ("\n===========================================================");
- printf ("\nRaw Scheme format of C Code Table contents:\n");
-
- printf ("\n------------");
- printf ("\nC Code table: Number of entries = %lu\n\n", entries);
-
- /* See: <microcode/cmpauxmd/c.c>:cons_c_code_table(). */
- dumped_initial_entry_number = (FIXNUM_TO_ULONG (* Next));
- printf ("Initial Entry Number = %lu (0x%02lx)\n\n",
- dumped_initial_entry_number,
- dumped_initial_entry_number);
-
- Display_raw_type_dat_Scheme_object (0, entries, Next);
-
-
- printf ("\n===========================================================");
- printf ("\nRaw hex format of C Code Table contents:\n");
-
- printf ("\n------------");
- printf ("\nC Code table: Number of entries = %lu\n\n", entries);
-
- /* See: <microcode/cmpauxmd/c.c>:cons_c_code_table(). */
- dumped_initial_entry_number = (FIXNUM_TO_ULONG (* Next));
- printf ("Initial Entry Number = %lu (0x%02lx)\n\n",
- dumped_initial_entry_number,
- dumped_initial_entry_number);
-
- Display_raw_hilo_hex_Scheme_object (0, entries, Next);
-
-#endif /* ENABLE_PPBAND_DEBUGGING_TOOLS */
-\f
- /*
- * For each C code block existent in the world, fasdump dumps its entry
- * count and name string at the end of the fasdump file. Show them now.
- *
- * Details: see <microcode/cmpauxmd/c.c>:copy_c_code_block_information().
- *
- * For comparison, see <microcode/cmpauxmd/c.c>:install_c_code_table().
- *
- */
- printf ("\n===========================================================");
- printf ("\nC Code Table contents:\n");
-
- printf ("\n------------");
- printf ("\nC Code table: Number of entries = %lu (0x%03lx)\n\n",
- entries, entries);
-
- /* See: <microcode/cmpauxmd/c.c>:cons_c_code_table(). */
- dumped_initial_entry_number = (FIXNUM_TO_ULONG (* Next));
- Next += 1;
- printf ("Initial Entry Number = %lu (0x%02lx)\n\n",
- dumped_initial_entry_number,
- dumped_initial_entry_number);
-
- for (count = 0;
- ((count < entries) && (Next < end_of_memory));
- count += 1)
- {
- int nlen, size;
- char * ncopy;
-
- nentries = (FIXNUM_TO_ULONG (*Next));
- Next += 1;
- nlen = (strlen ((char *) Next)); /* `fasdump'd a native C string */
- size = (nlen + 1);
-
- ncopy = ((char *) (malloc (size)));
- if (ncopy == ((char *) NULL))
- {
- fprintf (stderr,
- "Allocation of C code block no.%lu name string failed.\n",
- count);
- exit (1);
- /*NOTREACHED*/
- }
- (void) strcpy (ncopy, ((char *) Next));
-
- printf ("Index = 0x%02lx; NEntries = %2lu; Name = \"%s\"\n",
- count, nentries, ncopy);
- printf ("size = %u\n", size);
- Next += (1 + nlen);
- }
- printf ("\n");
- }
-\f
- if (argc != 1)
- exit (0);
- free ((char *) Data);
- counter = 1;
- }
- return (0);
-}
/* -*-C-*-
-$Id: prbfish.c,v 1.16 2007/01/05 21:19:25 cph Exp $
+$Id: prbfish.c,v 1.17 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
if ((STRING_LENGTH (string)) > 72)
error_bad_range_arg (1);
result = (allocate_string (sizeof (BF_KEY)));
- BF_set_key (((BF_KEY *) (STRING_LOC (result, 0))),
+ BF_set_key (((BF_KEY *) (STRING_POINTER (result))),
(STRING_LENGTH (string)),
- (STRING_LOC (string, 0)));
+ (STRING_BYTE_PTR (string)));
PRIMITIVE_RETURN (result);
}
static BF_KEY *
-DEFUN (key_arg, (arg), unsigned int arg)
+key_arg (unsigned int arg)
{
CHECK_ARG (arg, STRING_P);
if ((STRING_LENGTH (ARG_REF (arg))) != (sizeof (BF_KEY)))
error_bad_range_arg (arg);
- return ((BF_KEY *) (STRING_LOC ((ARG_REF (arg)), 0)));
+ return ((BF_KEY *) (STRING_BYTE_PTR (ARG_REF (arg))));
}
static unsigned char *
-DEFUN (init_vector_arg, (arg), unsigned int arg)
+init_vector_arg (unsigned int arg)
{
CHECK_ARG (arg, STRING_P);
if ((STRING_LENGTH (ARG_REF (arg))) != 8)
error_bad_range_arg (arg);
- return (STRING_LOC ((ARG_REF (arg)), 0));
+ return (STRING_BYTE_PTR (ARG_REF (arg)));
}
DEFINE_PRIMITIVE ("BLOWFISH-ECB", Prim_blowfish_ecb, 4, 4,
output_text = (ARG_REF (2));
if ((STRING_LENGTH (output_text)) != 8)
error_bad_range_arg (2);
- BF_ecb_encrypt ((STRING_LOC (input_text, 0)),
- (STRING_LOC (output_text, 0)),
+ BF_ecb_encrypt ((STRING_BYTE_PTR (input_text)),
+ (STRING_BYTE_PTR (output_text)),
(key_arg (3)),
((BOOLEAN_ARG (4)) ? BF_ENCRYPT : BF_DECRYPT));
PRIMITIVE_RETURN (UNSPECIFIC);
if ((output_text == input_text)
|| ((STRING_LENGTH (output_text)) != (STRING_LENGTH (input_text))))
error_bad_range_arg (2);
- BF_cbc_encrypt ((STRING_LOC (input_text, 0)),
- (STRING_LOC (output_text, 0)),
+ BF_cbc_encrypt ((STRING_BYTE_PTR (input_text)),
+ (STRING_BYTE_PTR (output_text)),
(STRING_LENGTH (input_text)),
(key_arg (3)),
(init_vector_arg (4)),
&& (istart < (ostart + ilen)))
error_bad_range_arg (4);
num = (arg_index_integer (8, 8));
- BF_cfb64_encrypt ((STRING_LOC (input_text, istart)),
- (STRING_LOC (output_text, ostart)),
+ BF_cfb64_encrypt ((STRING_BYTE_PTR (input_text)),
+ (STRING_BYTE_PTR (output_text)),
ilen,
(key_arg (6)),
(init_vector_arg (7)),
#ifdef COMPILE_AS_MODULE
char *
-DEFUN_VOID (dload_initialize_file)
+dload_initialize_file (void)
{
declare_primitive
("BLOWFISH-SET-KEY", Prim_blowfish_set_key, 1, 1,
/* -*-C-*-
-$Id: prdb4.c,v 1.7 2007/02/11 05:55:00 riastradh Exp $
+$Id: prdb4.c,v 1.8 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
}
\f
static SCHEME_OBJECT
-DEFUN (convert_dbtype, (type), DBTYPE type)
+convert_dbtype (DBTYPE type)
{
switch (type)
{
}
static DBTYPE
-DEFUN (arg_dbtype, (n), int n)
+arg_dbtype (int n)
{
const char * s = (arg_interned_symbol (n));
if ((strcmp (s, "btree")) == 0)
}
static DBT *
-DEFUN (arg_dbt, (n), int n)
+arg_dbt (int n)
{
SCHEME_OBJECT s = (ARG_REF (n));
if (!STRING_P (s))
error_wrong_type_arg (n);
if ((STRING_LENGTH (s)) != (sizeof (DBT)))
error_bad_range_arg (n);
- return ((DBT *) (STRING_LOC (s, 0)));
+ return ((DBT *) (STRING_POINTER (s)));
}
DEFINE_PRIMITIVE ("DB4:DB-GET-PAGESIZE", Prim_db4_db_get_pagesize, 2, 2, 0)
SCHEME_OBJECT s = (ARG_REF (2));
u_int32_t ulen = (STRING_LENGTH (s));
memset (dbt, 0, (sizeof (*dbt)));
- (dbt -> data) = (STRING_LOC (s, 0));
+ (dbt -> data) = (STRING_POINTER (s));
(dbt -> size) = ulen;
(dbt -> ulen) = ulen;
(dbt -> flags) = DB_DBT_USERMEM;
}
static DB_LOCK *
-DEFUN (arg_db_lock, (n), int n)
+arg_db_lock (int n)
{
SCHEME_OBJECT s = (ARG_REF (n));
if (!STRING_P (s))
error_wrong_type_arg (n);
if ((STRING_LENGTH (s)) != (sizeof (DB_LOCK)))
error_bad_range_arg (n);
- return ((DB_LOCK *) (STRING_LOC (s, 0)));
+ return ((DB_LOCK *) (STRING_POINTER (s)));
}
DEFINE_PRIMITIVE ("DB4:DB-ENV-LOCK-ID", Prim_db4_db_env_lock_id, 2, 2, 0)
/* -*-C-*-
-$Id: prgdbm.c,v 1.10 2007/02/11 05:55:00 riastradh Exp $
+$Id: prgdbm.c,v 1.11 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
struct allocation_table
{
- PTR * items;
+ void ** items;
int length;
};
static void
-DEFUN (allocation_table_initialize, (table), struct allocation_table * table)
+allocation_table_initialize (struct allocation_table * table)
{
(table -> length) = 0;
}
static unsigned int
-DEFUN (allocate_table_index, (table, item),
- struct allocation_table * table AND
- PTR item)
+allocate_table_index (struct allocation_table * table, void * item)
{
unsigned int length = (table -> length);
unsigned int new_length;
- PTR * items = (table -> items);
- PTR * new_items;
- PTR * scan;
- PTR * end;
+ void ** items = (table -> items);
+ void ** new_items;
+ void ** scan;
+ void ** end;
if (length == 0)
{
new_length = 4;
- new_items = (OS_malloc ((sizeof (PTR)) * new_length));
+ new_items = (OS_malloc ((sizeof (void *)) * new_length));
}
else
{
return (scan - items);
}
new_length = (length * 2);
- new_items = (OS_realloc (items, ((sizeof (PTR)) * new_length)));
+ new_items = (OS_realloc (items, ((sizeof (void *)) * new_length)));
}
scan = (new_items + length);
end = (new_items + new_length);
return (length);
}
-static PTR
-DEFUN (allocation_item_arg, (arg, table),
- unsigned int arg AND
- struct allocation_table * table)
+static void *
+allocation_item_arg (unsigned int arg, struct allocation_table * table)
{
unsigned int index = (arg_ulong_index_integer (arg, (table -> length)));
- PTR item = ((table -> items) [index]);
+ void * item = ((table -> items) [index]);
if (item == 0)
error_bad_range_arg (arg);
return (item);
static struct allocation_table dbf_table;
#define DBF_VAL(dbf) \
- (ulong_to_integer (allocate_table_index ((&dbf_table), ((PTR) (dbf)))))
+ (ulong_to_integer (allocate_table_index ((&dbf_table), ((void *) (dbf)))))
#define DBF_ARG(arg) \
((GDBM_FILE) (allocation_item_arg ((arg), (&dbf_table))))
(((expression) == 0) ? SHARP_F : (GDBM_ERROR_VAL ()))
static datum
-DEFUN (arg_datum, (arg), int arg)
+arg_datum (int arg)
{
datum d;
CHECK_ARG (arg, STRING_P);
- (d . dptr) = ((char *) (STRING_LOC ((ARG_REF (arg)), 0)));
+ (d . dptr) = (STRING_POINTER (ARG_REF (arg)));
(d . dsize) = (STRING_LENGTH (ARG_REF (arg)));
return (d);
}
static SCHEME_OBJECT
-DEFUN (datum_to_object, (d), datum d)
+datum_to_object (datum d)
{
if (d . dptr)
{
SCHEME_OBJECT result = (allocate_string (d . dsize));
- CONST char * scan_d = (d . dptr);
- CONST char * end_d = (scan_d + (d . dsize));
- unsigned char * scan_result = (STRING_LOC (result, 0));
+ const char * scan_d = (d . dptr);
+ const char * end_d = (scan_d + (d . dsize));
+ char * scan_result = (STRING_POINTER (result));
while (scan_d < end_d)
- (*scan_result++) = ((unsigned char) (*scan_d++));
+ (*scan_result++) = (*scan_d++);
free (d . dptr);
return (result);
}
}
static void
-DEFUN (gdbm_fatal_error, (msg), char * msg)
+gdbm_fatal_error (char * msg)
{
outf_error ("\ngdbm: %s\n", msg);
outf_flush_error ();
#ifdef COMPILE_AS_MODULE
char *
-DEFUN_VOID (dload_initialize_file)
+dload_initialize_file (void)
{
declare_primitive ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0);
declare_primitive ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0);
/* -*-C-*-
-$Id: prim.c,v 9.48 2007/01/05 21:19:25 cph Exp $
+$Id: prim.c,v 9.49 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
static unsigned long
-DEFUN (arg_type, (arg), int arg)
+arg_type (int arg)
{
return (arg_ulong_index_integer (arg, (1L << TYPE_CODE_LENGTH)));
}
static unsigned long
-DEFUN (arg_datum, (arg), int arg)
+arg_datum (int arg)
{
return (arg_ulong_index_integer (arg, (1L << DATUM_LENGTH)));
}
"Return the type code of OBJECT as an unsigned integer.")
{
PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (OBJECT_TYPE (ARG_REF (1))));
-}
-
-DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-GC-TYPE", Prim_prim_obj_gc_type, 1, 1,
- "Return an unsigned integer indicating the GC type of the object.")
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (LONG_TO_FIXNUM (GC_Type_Map [OBJECT_TYPE (ARG_REF (1))]));
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (OBJECT_TYPE (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE?", Prim_prim_obj_type_p, 2, 2,
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT
- (((long) (OBJECT_TYPE (ARG_REF (2))))
- == (arg_index_integer (1, (MAX_TYPE_CODE + 1)))));
+ (BOOLEAN_TO_OBJECT ((OBJECT_TYPE (ARG_REF (2))) == (arg_type (1))));
}
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-DATUM", Prim_prim_obj_datum, 1, 1,
Assert: (= (OBJECT-DATUM (MAKE-NON-POINTER-OBJECT X)) X).")
{
PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (arg_datum (1)));
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (arg_datum (1)));
}
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-SET-TYPE", Prim_prim_obj_set_type, 2, 2,
PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* Safe versions of the object manipulators.
- These touch their arguments, and provide GC safety tests. */
+/* Safe versions of the object manipulators. */
DEFINE_PRIMITIVE ("OBJECT-TYPE", Prim_object_type, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (OBJECT_TYPE (object)));
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (OBJECT_TYPE (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("OBJECT-GC-TYPE", Prim_object_gc_type, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (LONG_TO_FIXNUM (GC_Type (object)));
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (GC_TYPE_TO_INT (GC_TYPE (ARG_REF (1)))));
}
DEFINE_PRIMITIVE ("TYPE->GC-TYPE", Prim_type_to_gc_type, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
- (LONG_TO_FIXNUM
- (GC_Type_Map [arg_ulong_index_integer (1, (MAX_TYPE_CODE + 1))]));
+ (LONG_TO_FIXNUM (GC_TYPE_TO_INT (GC_TYPE_CODE (arg_type (1)))));
}
DEFINE_PRIMITIVE ("OBJECT-TYPE?", Prim_object_type_p, 2, 2, 0)
{
- fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
- TOUCH_IN_PRIMITIVE ((ARG_REF (2)), object);
PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT
- (((long) (OBJECT_TYPE (object)))
- == (arg_index_integer (1, (MAX_TYPE_CODE + 1)))));
+ (BOOLEAN_TO_OBJECT ((OBJECT_TYPE (ARG_REF (2))) == (arg_type (1))));
}
DEFINE_PRIMITIVE ("OBJECT-DATUM", Prim_object_datum, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (long_to_integer (OBJECT_DATUM (object)));
+ PRIMITIVE_RETURN (long_to_integer (OBJECT_DATUM (ARG_REF (1))));
}
-\f
+
DEFINE_PRIMITIVE ("OBJECT-SET-TYPE", Prim_object_set_type, 2, 2, 0)
{
- fast long type_code;
- fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
- type_code = (arg_index_integer (1, (MAX_TYPE_CODE + 1)));
- TOUCH_IN_PRIMITIVE ((ARG_REF (2)), object);
{
- fast long gc_type_code;
-
- gc_type_code = (GC_Type_Map [type_code]);
- if ((gc_type_code == GC_Undefined) ||
- (! ((gc_type_code == GC_Non_Pointer) ||
- (gc_type_code == (GC_Type (object))))))
+ unsigned long type_code = (arg_type (1));
+ SCHEME_OBJECT object = (ARG_REF (2));
+ gc_type_t gc_type = (GC_TYPE_CODE (type_code));
+ if ((gc_type == GC_UNDEFINED)
+ || ((gc_type != GC_NON_POINTER)
+ && (gc_type != (GC_TYPE (object)))))
error_bad_range_arg (1);
+ PRIMITIVE_RETURN (OBJECT_NEW_TYPE (type_code, object));
}
- PRIMITIVE_RETURN (OBJECT_NEW_TYPE (type_code, object));
}
/* (EQ? OBJECT-1 OBJECT-2)
DEFINE_PRIMITIVE ("EQ?", Prim_eq, 2, 2, 0)
{
- fast SCHEME_OBJECT object_1;
- fast SCHEME_OBJECT object_2;
PRIMITIVE_HEADER (2);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object_1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (2)), object_2);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (object_1 == object_2));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((ARG_REF (1)) == (ARG_REF (2))));
}
/* (NOT OBJECT)
DEFINE_PRIMITIVE ("NOT", Prim_not, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (object == SHARP_F));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((ARG_REF (1)) == SHARP_F));
}
/* (NULL? OBJECT)
DEFINE_PRIMITIVE ("NULL?", Prim_null_p, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (EMPTY_LIST_P (object)));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (EMPTY_LIST_P (ARG_REF (1))));
}
\f
/* Cells */
DEFINE_PRIMITIVE ("SET-CELL-CONTENTS!", Prim_set_cell_contents, 2, 2, 0)
{
- fast SCHEME_OBJECT cell;
- fast SCHEME_OBJECT object;
+ SCHEME_OBJECT cell;
+ SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
cell = (CELL_ARG (1));
object = (ARG_REF (2));
- SIDE_EFFECT_IMPURIFY (cell, object);
MEMORY_SET (cell, CELL_CONTENTS, object);
PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-$Id: prim.h,v 9.52 2007/01/05 21:19:25 cph Exp $
+$Id: prim.h,v 9.53 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#ifndef SCM_PRIM_H
#define SCM_PRIM_H
-typedef SCHEME_OBJECT EXFUN ((*primitive_procedure_t), (void));
+typedef SCHEME_OBJECT (*primitive_procedure_t) (void);
extern primitive_procedure_t * Primitive_Procedure_Table;
extern int * Primitive_Arity_Table;
extern int * Primitive_Count_Table;
-extern CONST char ** Primitive_Name_Table;
-extern CONST char ** Primitive_Documentation_Table;
+extern const char ** Primitive_Name_Table;
+extern const char ** Primitive_Documentation_Table;
extern unsigned long MAX_PRIMITIVE;
-extern SCHEME_OBJECT EXFUN
- (declare_primitive,
- (CONST char *, primitive_procedure_t, int, int, CONST char *));
+extern SCHEME_OBJECT declare_primitive
+ (const char *, primitive_procedure_t, int, int, const char *);
-extern SCHEME_OBJECT EXFUN
- (install_primitive,
- (CONST char *, primitive_procedure_t, int, int, CONST char *));
+extern SCHEME_OBJECT install_primitive
+ (const char *, primitive_procedure_t, int, int, const char *);
-extern SCHEME_OBJECT EXFUN (Prim_unimplemented, (void));
+extern SCHEME_OBJECT Prim_unimplemented (void);
#define PRIMITIVE_NUMBER(primitive) (OBJECT_DATUM (primitive))
#define PRIMITIVE_N_ARGUMENTS(prim) \
(((PRIMITIVE_ARITY (prim)) == LEXPR_PRIMITIVE_ARITY) \
- ? ((long) (Registers[REGBLOCK_LEXPR_ACTUALS])) \
+ ? GET_LEXPR_ACTUALS \
: (PRIMITIVE_ARITY (prim)))
#endif /* SCM_PRIM_H */
/* -*-C-*-
-$Id: prims.h,v 9.56 2007/04/01 17:33:07 riastradh Exp $
+$Id: prims.h,v 9.57 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#ifndef SCM_PRIMS_H
#define SCM_PRIMS_H
-#include "ansidecl.h"
+#include "scheme.h"
\f
/* Definition of primitives. */
#define DEFINE_PRIMITIVE(scheme_name, fn_name, min_args, max_args, doc) \
-extern SCHEME_OBJECT EXFUN (fn_name, (void)); \
-SCHEME_OBJECT DEFUN_VOID (fn_name)
+SCHEME_OBJECT fn_name (void)
/* Can be used for `max_args' in `DEFINE_PRIMITIVE' to indicate that
the primitive has no upper limit on its arity. */
/* Primitives should have this as their first statement. */
#ifdef ENABLE_PRIMITIVE_PROFILING
-#define PRIMITIVE_HEADER(n_args) record_primitive_entry (exp_register)
+ extern void record_primitive_entry (SCHEME_OBJECT);
+# define PRIMITIVE_HEADER(n_args) record_primitive_entry (GET_EXP)
#else
-#define PRIMITIVE_HEADER(n_args) {}
+# define PRIMITIVE_HEADER(n_args) do {} while (0)
#endif
/* Primitives return by performing one of the following operations. */
#define PRIMITIVE_RETURN(value) return (value)
#define PRIMITIVE_ABORT abort_to_interpreter
-extern void EXFUN (canonicalize_primitive_context, (void));
-#define PRIMITIVE_CANONICALIZE_CONTEXT canonicalize_primitive_context
-
/* Various utilities */
-#define Primitive_GC(Amount) \
+#define Primitive_GC(Amount) do \
{ \
- Request_GC (Amount); \
+ REQUEST_GC (Amount); \
signal_interrupt_from_primitive (); \
-}
+} while (0)
-#define Primitive_GC_If_Needed(Amount) \
+#define Primitive_GC_If_Needed(Amount) do \
{ \
- if (GC_Check (Amount)) Primitive_GC (Amount); \
-}
+ if (GC_NEEDED_P (Amount)) Primitive_GC (Amount); \
+} while (0)
#define CHECK_ARG(argument, type_p) do \
{ \
#define ARG_LOC(argument) (STACK_LOC (argument - 1))
#define ARG_REF(argument) (STACK_REF (argument - 1))
-#define LEXPR_N_ARGUMENTS() (Registers[REGBLOCK_LEXPR_ACTUALS])
\f
-extern void EXFUN (signal_error_from_primitive, (long error_code));
-extern void EXFUN (signal_interrupt_from_primitive, (void));
-extern void EXFUN (error_wrong_type_arg, (int));
-extern void EXFUN (error_bad_range_arg, (int));
-extern void EXFUN (error_external_return, (void));
-extern void EXFUN (error_with_argument, (SCHEME_OBJECT));
-extern long EXFUN (arg_integer, (int));
-extern long EXFUN (arg_nonnegative_integer, (int));
-extern long EXFUN (arg_index_integer, (int, long));
-extern long EXFUN (arg_integer_in_range, (int, long, long));
-extern unsigned long EXFUN (arg_ulong_integer, (int));
-extern unsigned long EXFUN (arg_ulong_index_integer, (int, unsigned long));
-extern double EXFUN (arg_real_number, (int));
-extern double EXFUN (arg_real_in_range, (int, double, double));
-extern long EXFUN (arg_ascii_char, (int));
-extern long EXFUN (arg_ascii_integer, (int));
+extern void signal_error_from_primitive (long) NORETURN;
+extern void signal_interrupt_from_primitive (void) NORETURN;
+extern void error_wrong_type_arg (int) NORETURN;
+extern void error_bad_range_arg (int) NORETURN;
+extern void error_external_return (void) NORETURN;
+extern void error_with_argument (SCHEME_OBJECT) NORETURN;
+extern long arg_integer (int);
+extern long arg_nonnegative_integer (int);
+extern long arg_index_integer (int, long);
+extern long arg_integer_in_range (int, long, long);
+extern unsigned long arg_ulong_integer (int);
+extern unsigned long arg_ulong_index_integer (int, unsigned long);
+extern unsigned long arg_ulong_integer_in_range
+ (int, unsigned long, unsigned long);
+extern double arg_real_number (int);
+extern double arg_real_in_range (int, double, double);
+extern long arg_ascii_char (int);
+extern long arg_ascii_integer (int);
#define UNSIGNED_FIXNUM_ARG(arg) \
((FIXNUM_P (ARG_REF (arg))) \
? (STRING_POINTER (ARG_REF (arg))) \
: ((error_wrong_type_arg (arg)), ((char *) 0)))
-extern PTR EXFUN (lookup_external_string, (SCHEME_OBJECT, unsigned long *));
-extern PTR EXFUN (arg_extended_string, (unsigned int, unsigned long *));
+extern unsigned char * arg_extended_string (unsigned int, unsigned long *);
#define BOOLEAN_ARG(arg) ((ARG_REF (arg)) != SHARP_F)
/* -*-C-*-
-$Id: primutl.c,v 9.83 2007/01/05 21:19:25 cph Exp $
+$Id: primutl.c,v 9.84 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/*
+/*
* This file contains the support routines for mapping primitive names
* to numbers within the microcode. Primitives are written in C
* and available in Scheme, but not always present in all versions of
#include "cmpgc.h"
#include <ctype.h>
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# include <string.h>
-#else
- extern PTR EXFUN (malloc, (size_t));
- extern PTR EXFUN (realloc, (PTR, size_t));
- extern PTR EXFUN (memcpy, (PTR, CONST PTR, size_t));
- extern char * EXFUN (strcpy, (char *, CONST char *));
-#endif
-
-extern SCHEME_OBJECT * load_renumber_table;
-
#ifndef UPDATE_PRIMITIVE_TABLE_HOOK
# define UPDATE_PRIMITIVE_TABLE_HOOK(low, high) do { } while (0)
#endif
#ifndef GROW_PRIMITIVE_TABLE_HOOK
# define GROW_PRIMITIVE_TABLE_HOOK(size) true
#endif
-\f
-/*
- Exported variables:
- */
+
+static prim_renumber_t * make_prim_renumber_1 (unsigned long);
+static void free_prim_renumber (void *);
+static SCHEME_OBJECT * make_table_entry (unsigned long, SCHEME_OBJECT *);
+static unsigned long table_entry_length (unsigned long);
+
+
+/* Exported variables: */
unsigned long MAX_PRIMITIVE = 0;
int * Primitive_Count_Table = 0;
-CONST char ** Primitive_Name_Table = 0;
+const char ** Primitive_Name_Table = 0;
-CONST char ** Primitive_Documentation_Table = 0;
+const char ** Primitive_Documentation_Table = 0;
SCHEME_OBJECT * load_renumber_table = 0;
-
-/*
- Exported utilities:
- */
-
-extern void
- EXFUN (initialize_primitives, (void)),
- EXFUN (install_primitive_table, (SCHEME_OBJECT *, long));
-
-extern SCHEME_OBJECT
- EXFUN (make_primitive, (char *, int)),
- EXFUN (find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int)),
- EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)),
- * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)),
- * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
- * EXFUN (cons_whole_primitive_table,
- (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
- EXFUN (Prim_unimplemented, (void));
-
-extern int
- EXFUN (strcmp_ci, (char *, char *));
\f
/* Common utilities. */
int
-DEFUN (strcmp_ci, (s1, s2), char * s1 AND char * s2)
+strcmp_ci (const char * s1, const char * s2)
{
const unsigned char * p1 = ((unsigned char *) s1);
const unsigned char * p2 = ((unsigned char *) s2);
- int diff;
-
- while ((*p1 != '\0') && (*p2 != '\0'))
+ while (true)
{
int c1 = (*p1++);
int c2 = (*p2++);
+ if (c1 == '\0')
+ return ((c2 == '\0') ? 0 : (-1));
+ if (c2 == '\0')
+ return (1);
c1 = (toupper (c1));
c2 = (toupper (c2));
- diff = (c1 - c2);
- if (diff != 0)
- return ((diff > 0) ? 1 : -1);
+ if (c1 < c2)
+ return (-1);
+ if (c1 > c2)
+ return (1);
}
- diff = (((int) (*p1)) - ((int) (*p2)));
- return ((diff == 0) ? 0 : (diff > 0) ? 1 : (-1));
}
SCHEME_OBJECT
-DEFUN_VOID (Prim_unimplemented)
+Prim_unimplemented (void)
{
PRIMITIVE_HEADER (-1);
}
\f
static void
-DEFUN (initialization_error, (reason, item), char * reason AND char * item)
+initialization_error (char * reason, char * item)
{
outf_fatal ("initialize_primitives: Error %s %s.\n", reason, item);
termination_init_error ();
} while (0)
static void
-DEFUN_VOID (grow_primitive_tables)
+grow_primitive_tables (void)
{
unsigned long new_size = (MAX_PRIMITIVE + (MAX_PRIMITIVE / 10));
COPY_TABLE (Primitive_Arity_Table, Static_Primitive_Arity_Table, int, int);
COPY_TABLE (Primitive_Name_Table,
Static_Primitive_Name_Table,
char *,
- CONST char *);
+ const char *);
COPY_TABLE (Primitive_Documentation_Table,
Static_Primitive_Documentation_Table,
char *,
- CONST char *);
+ const char *);
COPY_TABLE (Primitive_Procedure_Table,
Static_Primitive_Procedure_Table,
primitive_procedure_t,
static tree_node prim_procedure_tree = ((tree_node) NULL);
void
-DEFUN_VOID (initialize_primitives)
+initialize_primitives (void)
{
unsigned long counter;
{
SCHEME_OBJECT old = (make_primitive (primitive_aliases[counter].name,
UNKNOWN_PRIMITIVE_ARITY));
-
+
if (old == SHARP_F)
{
outf_fatal ("Error declaring unknown primitive %s.\n",
}
\f
static SCHEME_OBJECT
-DEFUN (declare_primitive_internal,
- (override_p, name, code, nargs_lo, nargs_hi, docstr),
- Boolean override_p
- AND CONST char * name
- AND primitive_procedure_t code
- AND int nargs_lo
- AND int nargs_hi
- AND CONST char * docstr)
+declare_primitive_internal (bool override_p,
+ const char * name,
+ primitive_procedure_t code,
+ int nargs_lo,
+ int nargs_hi,
+ const char * docstr)
/* nargs_lo ignored, for now */
{
unsigned long index;
SCHEME_OBJECT primitive;
- CONST char * ndocstr = docstr;
+ const char * ndocstr = docstr;
tree_node prim = (tree_lookup (prim_procedure_tree, name));
if (prim != ((tree_node) NULL))
*/
SCHEME_OBJECT
-DEFUN (declare_primitive, (name, code, nargs_lo, nargs_hi, docstr),
- CONST char * name
- AND primitive_procedure_t code
- AND int nargs_lo
- AND int nargs_hi
- AND CONST char * docstr)
+declare_primitive (const char * name,
+ primitive_procedure_t code,
+ int nargs_lo,
+ int nargs_hi,
+ const char * docstr)
{
return (declare_primitive_internal (false, name, code,
nargs_lo, nargs_hi, docstr));
*/
SCHEME_OBJECT
-DEFUN (install_primitive, (name, code, nargs_lo, nargs_hi, docstr),
- CONST char * name
- AND primitive_procedure_t code
- AND int nargs_lo
- AND int nargs_hi
- AND CONST char * docstr)
+install_primitive (const char * name,
+ primitive_procedure_t code,
+ int nargs_lo,
+ int nargs_hi,
+ const char * docstr)
{
return (declare_primitive_internal (true, name, code,
nargs_lo, nargs_hi, docstr));
}
\f
-/*
- make_primitive returns a primitive object,
- constructing one if necessary.
- */
-
SCHEME_OBJECT
-DEFUN (make_primitive, (name, arity), char * name AND int arity)
+make_primitive (const char * name, int arity)
{
- /* This copies the name (and probes twice) because unstackify'd
- primitive name strings are ephemeral.
- */
-
+ tree_node prim;
+ char * cname;
SCHEME_OBJECT result;
- char * name_to_insert;
- tree_node prim = (tree_lookup (prim_procedure_tree, name));
-
- if (prim != ((tree_node) NULL))
- name_to_insert = ((char *) (prim->name));
- else
- {
- name_to_insert = ((char *) (malloc (1 + (strlen (name)))));
- if (name_to_insert == ((char *) NULL))
- error_in_system_call (syserr_not_enough_space, syscall_malloc);
- strcpy (name_to_insert, name);
- }
- result = (declare_primitive (name_to_insert,
- Prim_unimplemented,
- arity,
- arity,
- ((char *) NULL)));
- return ((result == SHARP_F)
- ? SHARP_F
- : (OBJECT_NEW_TYPE (TC_PRIMITIVE, result)));
+ /* Make sure to copy the name if we will be keeping it. */
+ prim = (tree_lookup (prim_procedure_tree, name));
+ if (prim != 0)
+ cname = ((char *) (prim->name));
+ else
+ {
+ cname = (OS_malloc ((strlen (name)) + 1));
+ strcpy (cname, name);
+ }
+ result = (declare_primitive (cname, Prim_unimplemented, arity, arity, 0));
+ return
+ ((result == SHARP_F)
+ ? SHARP_F
+ : (OBJECT_NEW_TYPE (TC_PRIMITIVE, result)));
}
-/* This returns all sorts of different things that the runtime
- system decodes.
- */
-
SCHEME_OBJECT
-DEFUN (find_primitive, (sname, intern_p, allow_p, arity),
- SCHEME_OBJECT sname AND Boolean intern_p
- AND Boolean allow_p AND int arity)
+find_primitive (SCHEME_OBJECT sname, bool intern_p, bool allow_p, int arity)
{
- tree_node prim = (tree_lookup (prim_procedure_tree,
- ((char *) (STRING_LOC (sname, 0)))));
+ tree_node prim
+ = (tree_lookup (prim_procedure_tree, (STRING_POINTER (sname))));
+ if (prim != 0)
+ {
+ SCHEME_OBJECT primitive = (MAKE_PRIMITIVE_OBJECT (prim->value));
- if (prim != ((tree_node) NULL))
- {
- SCHEME_OBJECT primitive = (MAKE_PRIMITIVE_OBJECT (prim->value));
+ if ((!allow_p) && (!IMPLEMENTED_PRIMITIVE_P (primitive)))
+ return (SHARP_F);
+
+ if ((arity == UNKNOWN_PRIMITIVE_ARITY)
+ || (arity == (PRIMITIVE_ARITY (primitive))))
+ return (primitive);
+
+ if ((PRIMITIVE_ARITY (primitive)) == UNKNOWN_PRIMITIVE_ARITY)
+ {
+ /* We've just learned the arity of the primitive. */
+ (Primitive_Arity_Table[PRIMITIVE_NUMBER (primitive)]) = arity;
+ return (primitive);
+ }
- if ((! allow_p) && (! (IMPLEMENTED_PRIMITIVE_P (primitive))))
- return (SHARP_F);
-
- if ((arity == UNKNOWN_PRIMITIVE_ARITY)
- || (arity == (PRIMITIVE_ARITY (primitive))))
- return (primitive);
- else if ((PRIMITIVE_ARITY (primitive)) == UNKNOWN_PRIMITIVE_ARITY)
- {
- /* We've just learned the arity of the primitive. */
- Primitive_Arity_Table[PRIMITIVE_NUMBER (primitive)] = arity;
- return (primitive);
- }
- else
/* Arity mismatch, notify the runtime system. */
return (LONG_TO_FIXNUM (PRIMITIVE_ARITY (primitive)));
- }
- else if (! intern_p)
+ }
+
+ if (!intern_p)
return (SHARP_F);
- else
+
{
- SCHEME_OBJECT primitive;
- char * cname = ((char *) (malloc (1 + (STRING_LENGTH (sname)))));
-
- if (cname == ((char *) NULL))
- error_in_system_call (syserr_not_enough_space, syscall_malloc);
- strcpy (cname, ((char *) (STRING_LOC (sname, 0))));
- primitive =
- (declare_primitive (cname,
- Prim_unimplemented,
- ((arity < 0) ? 0 : arity),
- arity,
- ((char *) NULL)));
- if (primitive == SHARP_F)
- error_in_system_call (syserr_not_enough_space, syscall_malloc);
- return (primitive);
+ size_t n_bytes = ((STRING_LENGTH (sname)) + 1);
+ char * cname = (OS_malloc (n_bytes));
+ memcpy (cname, (STRING_POINTER (sname)), n_bytes);
+ {
+ SCHEME_OBJECT primitive
+ = (declare_primitive (cname,
+ Prim_unimplemented,
+ ((arity < 0) ? 0 : arity),
+ arity,
+ 0));
+ if (primitive == SHARP_F)
+ error_in_system_call (syserr_not_enough_space, syscall_malloc);
+ return (primitive);
+ }
}
}
\f
/* These are used by fasdump to renumber primitives on the way out.
Only those primitives actually referenced by the object being
- dumped are described in the output. The primitives being
- dumped are renumbered in the output to a contiguous range
- starting at 0.
- */
-
-static SCHEME_OBJECT * internal_renumber_table;
-static SCHEME_OBJECT * external_renumber_table;
-static long next_primitive_renumber;
+ dumped are described in the output. The primitives being dumped
+ are renumbered in the output to a contiguous range starting at 0. */
-/* This is called during fasdump setup. */
-
-SCHEME_OBJECT *
-DEFUN (initialize_primitive_table, (where, end),
- fast SCHEME_OBJECT * where AND SCHEME_OBJECT * end)
+prim_renumber_t *
+make_prim_renumber (void)
{
- SCHEME_OBJECT * top;
- fast long number_of_primitives;
+ return (make_prim_renumber_1 (MAX_PRIMITIVE));
+}
- top = &where[2 * MAX_PRIMITIVE];
- if (top < end)
+static prim_renumber_t *
+make_prim_renumber_1 (unsigned long n_entries)
+{
+ prim_renumber_t * pr = (OS_malloc (sizeof (prim_renumber_t)));
+ (pr->internal) = (OS_malloc (n_entries * (sizeof (unsigned long))));
+ (pr->external) = (OS_malloc (n_entries * (sizeof (unsigned long))));
+ (pr->next_code) = 0;
{
- internal_renumber_table = where;
- external_renumber_table = &where[MAX_PRIMITIVE];
- next_primitive_renumber = 0;
-
- for (number_of_primitives = MAX_PRIMITIVE;
- (--number_of_primitives >= 0);)
- (*where++) = SHARP_F;
+ unsigned long i;
+ for (i = 0; (i < n_entries); i += 1)
+ {
+ ((pr->internal) [i]) = ULONG_MAX;
+ ((pr->external) [i]) = ULONG_MAX;
+ }
}
- return (top);
+ transaction_record_action (tat_always, free_prim_renumber, pr);
+ return (pr);
}
-/* This is called every time fasdump meets a primitive to be renumbered.
- It is called on objects with tag TC_PRIMITIVE or TC_PCOMB0,
- so it preserves the tag of its argument.
- */
+static void
+free_prim_renumber (void * vpr)
+{
+ prim_renumber_t * pr = vpr;
+ OS_free (pr->internal);
+ OS_free (pr->external);
+ OS_free (pr);
+}
SCHEME_OBJECT
-DEFUN (dump_renumber_primitive, (primitive), fast SCHEME_OBJECT primitive)
+renumber_primitive (SCHEME_OBJECT primitive, prim_renumber_t * pr)
{
- fast long number;
- fast SCHEME_OBJECT result;
-
- number = (PRIMITIVE_NUMBER (primitive));
- result = internal_renumber_table[number];
- if (result != SHARP_F)
- return (MAKE_OBJECT_FROM_OBJECTS (primitive, result));
- else
- {
- result = (OBJECT_NEW_DATUM (primitive, next_primitive_renumber));
- internal_renumber_table[number] = result;
- external_renumber_table[next_primitive_renumber] = primitive;
- next_primitive_renumber += 1;
- return (result);
- }
+ unsigned long old = (OBJECT_DATUM (primitive));
+ unsigned long new = ((pr->internal) [old]);
+ if (new == ULONG_MAX)
+ {
+ new = ((pr->next_code)++);
+ ((pr->internal) [old]) = new;
+ ((pr->external) [new]) = old;
+ }
+ return (OBJECT_NEW_DATUM (primitive, new));
}
-\f
-/* Utility for fasdump and dump-band */
-static SCHEME_OBJECT *
-DEFUN (copy_primitive_information, (code, start, end),
- long code AND fast SCHEME_OBJECT * start AND fast SCHEME_OBJECT * end)
+unsigned long
+renumbered_primitives_export_length (prim_renumber_t * pr)
{
- static char null_string [] = "\0";
- CONST char * source;
- char * dest;
- char * limit;
- long char_count, word_count;
- SCHEME_OBJECT * saved;
-
- if (start < end)
- (*start++) = (LONG_TO_FIXNUM (Primitive_Arity_Table [code]));
-
- source = (Primitive_Name_Table [code]);
- saved = start;
- start += STRING_CHARS;
- dest = ((char *) start);
- limit = ((char *) end);
- if (source == ((char *) 0))
- source = ((char *) (& (null_string [0])));
- while ((dest < limit) && (((*dest++) = (*source++)) != '\0'))
- ;
- if (dest >= limit)
- while ((*source++) != '\0')
- dest += 1;
- char_count = ((dest - 1) - ((char *) start));
- word_count = (STRING_LENGTH_TO_GC_LENGTH (char_count));
- start = (saved + 1 + word_count);
- if (start < end)
- {
- (saved [STRING_HEADER]) =
- (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, word_count));
- (saved [STRING_LENGTH_INDEX]) = ((SCHEME_OBJECT) char_count);
- }
- return (start);
+ unsigned long result = 0;
+ unsigned long i;
+
+ for (i = 0; (i < (pr->next_code)); i += 1)
+ result += (table_entry_length ((pr->external) [i]));
+ return (result);
}
-/* This is called at the end of the relocation step to
- allocate the actual table to dump on the output file.
- */
+void
+export_renumbered_primitives (SCHEME_OBJECT * start, prim_renumber_t * pr)
+{
+ unsigned long i;
+ for (i = 0; (i < (pr->next_code)); i += 1)
+ start = (make_table_entry (((pr->external) [i]), start));
+}
-SCHEME_OBJECT *
-DEFUN (cons_primitive_table, (start, end, length),
- SCHEME_OBJECT * start AND SCHEME_OBJECT * end AND long * length)
+/* Like above, but export the whole table. */
+unsigned long
+primitive_table_export_length (void)
{
- SCHEME_OBJECT * saved;
- long count, code;
-
- saved = start;
- * length = next_primitive_renumber;
+ unsigned long result = 0;
+ unsigned long i;
- for (count = 0;
- ((count < next_primitive_renumber) && (start < end));
- count += 1)
- {
- code = (PRIMITIVE_NUMBER (external_renumber_table[count]));
- start = (copy_primitive_information (code, start, end));
- }
- return (start);
+ for (i = 0; (i < MAX_PRIMITIVE); i += 1)
+ result += (table_entry_length (i));
+ return (result);
}
-\f
-/* This is called when a band is dumped.
- All the primitives are dumped unceremoniously.
- */
-SCHEME_OBJECT *
-DEFUN (cons_whole_primitive_table, (start, end, length),
- SCHEME_OBJECT * start AND SCHEME_OBJECT * end AND long * length)
+void
+export_primitive_table (SCHEME_OBJECT * start)
{
- SCHEME_OBJECT * saved;
- long count;
-
- saved = start;
- * length = MAX_PRIMITIVE;
-
- for (count = 0;
- ((count < MAX_PRIMITIVE) && (start < end));
- count += 1)
- start = (copy_primitive_information (count, start, end));
+ unsigned long i;
+ for (i = 0; (i < MAX_PRIMITIVE); i += 1)
+ start = (make_table_entry (i, start));
+}
- return (start);
+static SCHEME_OBJECT *
+make_table_entry (unsigned long code, SCHEME_OBJECT * start)
+{
+ static const char * null_string = "\0";
+ const char * source
+ = (((Primitive_Name_Table[code]) == 0)
+ ? null_string
+ : (Primitive_Name_Table[code]));
+ unsigned long n_chars = (strlen (source));
+ unsigned long n_words = (STRING_LENGTH_TO_GC_LENGTH (n_chars));
+
+ (*start++) = (LONG_TO_FIXNUM (Primitive_Arity_Table[code]));
+ (*start++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, n_words));
+ (*start) = (MAKE_OBJECT (0, n_chars));
+ memcpy ((start + 1), source, (n_chars + 1));
+ return (start + n_words);
}
-/* This is called from fasload and load-band */
+static unsigned long
+table_entry_length (unsigned long code)
+{
+ return
+ ((STRING_LENGTH_TO_GC_LENGTH (((Primitive_Name_Table[code]) == 0)
+ ? 0
+ : (strlen (Primitive_Name_Table[code]))))
+ + 2);
+}
void
-DEFUN (install_primitive_table, (table, length),
- fast SCHEME_OBJECT * table
- AND fast long length)
+import_primitive_table (SCHEME_OBJECT * entries,
+ unsigned long n_entries,
+ SCHEME_OBJECT * primitives)
{
- fast SCHEME_OBJECT * translation_table;
- SCHEME_OBJECT result;
- long arity;
+ unsigned long i;
+ for (i = 0; (i < n_entries); i += 1)
+ {
+ long arity = (FIXNUM_TO_LONG (*entries++));
+ SCHEME_OBJECT prim
+ = (find_primitive
+ ((MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, entries)),
+ true, true, arity));
- translation_table = load_renumber_table;
- while (--length >= 0)
- {
- arity = (FIXNUM_TO_LONG (* table));
- table += 1;
- result =
- (find_primitive ((MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, table)),
- true, true, arity));
- if ((OBJECT_TYPE (result)) != TC_PRIMITIVE)
- signal_error_from_primitive (ERR_WRONG_ARITY_PRIMITIVES);
-
- *translation_table++ = result;
- table += (1 + (OBJECT_DATUM (* table)));
- }
- return;
+ if (!PRIMITIVE_P (prim))
+ signal_error_from_primitive (ERR_WRONG_ARITY_PRIMITIVES);
+
+ (*primitives++) = prim;
+ entries += (1 + (OBJECT_DATUM (*entries)));
+ }
}
+++ /dev/null
-/* -*-C-*-
-
-$Id: prmcon.c,v 1.9 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#define SCM_PRMCON_C
-
-#include "scheme.h"
-#include "prims.h"
-#include "prmcon.h"
-\f
-void
-DEFUN (suspend_primitive,
- (continuation, reentry_record_length, reentry_record),
- int continuation AND
- int reentry_record_length AND
- SCHEME_OBJECT *reentry_record)
-{
- int i;
- long nargs;
- SCHEME_OBJECT primitive;
-
- if (continuation > CONT_MAX_INDEX)
- {
- signal_error_from_primitive (ERR_UNKNOWN_PRIMITIVE_CONTINUATION);
- /* NOTREACHED */
- }
-
- primitive = (Registers[REGBLOCK_PRIMITIVE]);
- if (!PRIMITIVE_P (primitive))
- {
- outf_fatal ("\nsuspend_primitive invoked when not in primitive!\n");
- Microcode_Termination (TERM_BAD_BACK_OUT);
- }
-
- nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
-
- Will_Push (CONTINUATION_SIZE + 3 + reentry_record_length);
- STACK_PUSH (primitive);
- STACK_PUSH (STACK_FRAME_HEADER + nargs);
-
- for (i = (reentry_record_length - 1);
- i >= 0;
- i -= 1)
- {
- STACK_PUSH (reentry_record[i]);
- }
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (reentry_record_length));
- exp_register = (LONG_TO_UNSIGNED_FIXNUM ((long) continuation));
- Store_Return (RC_PRIMITIVE_CONTINUE);
- Save_Cont ();
- Pushed ();
-
- return;
-}
-\f
-SCHEME_OBJECT
-DEFUN_VOID (continue_primitive)
-{
- long nargs;
- int continuation, record_length;
- SCHEME_OBJECT primitive, *buffer, result;
-
- continuation = ((int) (UNSIGNED_FIXNUM_TO_LONG (exp_register)));
- if (continuation > CONT_MAX_INDEX)
- {
- exp_register = (LONG_TO_UNSIGNED_FIXNUM ((long) continuation));
- Store_Return (RC_PRIMITIVE_CONTINUE);
- Save_Cont ();
- immediate_error (ERR_UNKNOWN_PRIMITIVE_CONTINUATION);
- /* NOTREACHED */
- }
- record_length = ((int) (UNSIGNED_FIXNUM_TO_LONG (STACK_POP ())));
- if (GC_Check (record_length))
- {
- Request_GC (record_length);
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM ((long) record_length));
- exp_register = (LONG_TO_UNSIGNED_FIXNUM ((long) continuation));
- Store_Return (RC_PRIMITIVE_CONTINUE);
- Save_Cont ();
- immediate_interrupt ();
- /* NOTREACHED */
- }
-
- buffer = Free;
- while ((--record_length) >= 0)
- {
- *Free++ = (STACK_POP ());
- }
-
- nargs = ((OBJECT_DATUM (STACK_POP ())) -
- (STACK_ENV_FIRST_ARG - 1));
- primitive = (STACK_POP ());
-
- /* Most of the testing here is paranioa in case we disk-save in the
- middle of the suspension and then disk-restore into an incompatible
- microcode.
- It's not complete, but will catch some errors.
- */
-
- if (!IMPLEMENTED_PRIMITIVE_P (primitive))
- {
- STACK_PUSH (primitive);
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs));
- immediate_error (ERR_UNIMPLEMENTED_PRIMITIVE);
- /* NOTREACHED */
- }
-
- if (nargs != (PRIMITIVE_ARITY (primitive)))
- {
- if ((PRIMITIVE_ARITY (primitive)) != LEXPR_PRIMITIVE_ARITY)
- {
- STACK_PUSH (primitive);
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs));
- immediate_error (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- (Registers[REGBLOCK_LEXPR_ACTUALS]) = ((SCHEME_OBJECT) nargs);
- }
- exp_register = primitive;
- (Registers[REGBLOCK_PRIMITIVE]) = primitive;
- result = (*(continuation_procedures[continuation]))(buffer);
- (Registers[REGBLOCK_PRIMITIVE]) = SHARP_F;
- POP_PRIMITIVE_FRAME (nargs);
- return (result);
-}
-\f
-void
-DEFUN_VOID (immediate_interrupt)
-{
- Setup_Interrupt (PENDING_INTERRUPTS ());
- abort_to_interpreter (PRIM_APPLY);
- /* NOTREACHED */
-}
-
-void
-DEFUN (immediate_error, (error_code), long error_code)
-{
- Do_Micro_Error (error_code, false);
- abort_to_interpreter (PRIM_APPLY);
- /* NOTREACHED */
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: prmcon.h,v 1.8 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-\f
-#ifndef SCM_PRMCON_H
-
-#define SCM_PRMCON_H
-
-SCHEME_OBJECT EXFUN (continue_primitive, (void));
-
-void EXFUN (suspend_primitive,
- (int continuation, int reentry_record_length,
- SCHEME_OBJECT *reentry_record));
-
-void EXFUN (immediate_interrupt, (void));
-
-void EXFUN (immediate_error, (long error_code));
-
-/* The tables below should be built automagically (by Findprim?).
- This is a temporary (or permanent) kludge.
- */
-
-/* For each continuable primitive, there should be a constant,
- and an entry in the table below.
-
- IMPORTANT: Primitives that can be suspended must use
- PRIMITIVE_CANONICALIZE_CONTEXT at entry!
- */
-
-#define CONT_FASLOAD 0
-
-#define CONT_MAX_INDEX 0
-
-#ifdef SCM_PRMCON_C
-
-SCHEME_OBJECT EXFUN (continue_fasload, (SCHEME_OBJECT *));
-
-static SCHEME_OBJECT EXFUN
- ((* (continuation_procedures [])), (SCHEME_OBJECT *)) = {
- continue_fasload
-};
-
-#endif /* SCM_PRMCON_C */
-
-#endif /* SCM_PRMCON_H */
/* -*-C-*-
-$Id: prmcrypt.c,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: prmcrypt.c,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "usrdef.h"
#include "os.h"
+/* If mcrypt.h unavailable, ignore it. This helps
+ "makegen/makegen.scm" work properly on systems lacking this
+ library. */
#ifdef HAVE_MCRYPT_H
# include <mcrypt.h>
-#else
-/*
-** Hack: Dependency suppressed to appease "makegen/makegen.scm".
-** This is OK since it cannot link w/o the library anyway.
-*/
#endif
static SCHEME_OBJECT
PRIMITIVE_RETURN
(long_to_integer
(mcrypt_generic_init ((arg_context (1)),
- (STRING_LOC ((ARG_REF (2)), 0)),
+ (STRING_POINTER (ARG_REF (2))),
(STRING_LENGTH (ARG_REF (2))),
(STRING_ARG (3)))));
}
};
static void
-DEFUN (deallocate_list, (environment), PTR environment)
+deallocate_list (void * environment)
{
struct deallocate_list_arg * a = environment;
if ((a -> elements) != 0)
LIST_ITEMS (mcrypt_list_modes)
static void
-DEFUN (deallocate_key_sizes, (environment), PTR environment)
+deallocate_key_sizes (void * environment)
{
if (environment != 0)
mcrypt_free (environment);
#ifdef COMPILE_AS_MODULE
char *
-DEFUN_VOID (dload_initialize_file)
+dload_initialize_file (void)
{
declare_primitive
("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0);
/* -*-C-*-
-$Id: prmd5.c,v 1.11 2007/01/05 21:19:25 cph Exp $
+$Id: prmd5.c,v 1.12 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
{
SCHEME_OBJECT string = (ARG_REF (1));
SCHEME_OBJECT result = (allocate_string (16));
- unsigned char * scan_result = (STRING_LOC (result, 0));
+ unsigned char * scan_result = (STRING_BYTE_PTR (result));
MD5_CTX context;
#ifdef HAVE_LIBCRYPTO
unsigned char digest [MD5_DIGEST_LENGTH];
unsigned char * end_digest;
MD5_INIT (&context);
- MD5_UPDATE ((&context), (STRING_LOC (string, 0)), (STRING_LENGTH (string)));
+ MD5_UPDATE ((&context),
+ (STRING_POINTER (string)),
+ (STRING_LENGTH (string)));
#ifdef HAVE_LIBCRYPTO
MD5_FINAL (digest, (&context));
scan_digest = digest;
PRIMITIVE_HEADER (0);
{
SCHEME_OBJECT context = (allocate_string (sizeof (MD5_CTX)));
- MD5_INIT ((MD5_CTX *) (STRING_LOC (context, 0)));
+ MD5_INIT ((MD5_CTX *) (STRING_POINTER (context)));
PRIMITIVE_RETURN (context);
}
}
static MD5_CTX *
-DEFUN (md5_context_arg, (arg), int arg)
+md5_context_arg (int arg)
{
CHECK_ARG (arg, STRING_P);
if ((STRING_LENGTH (ARG_REF (arg))) != (sizeof (MD5_CTX)))
error_bad_range_arg (arg);
- return ((MD5_CTX *) (STRING_LOC ((ARG_REF (arg)), 0)));
+ return ((MD5_CTX *) (STRING_POINTER (ARG_REF (arg))));
}
DEFINE_PRIMITIVE ("MD5-UPDATE", Prim_md5_update, 4, 4,
#endif
{
SCHEME_OBJECT result = (allocate_string (MD5_DIGEST_LENGTH));
- unsigned char * scan_result = (STRING_LOC (result, 0));
+ unsigned char * scan_result = (STRING_BYTE_PTR (result));
#ifdef HAVE_LIBCRYPTO
unsigned char * scan_digest = digest;
#else
#ifdef COMPILE_AS_MODULE
char *
-DEFUN_VOID (dload_initialize_file)
+dload_initialize_file (void)
{
declare_primitive
("MD5", Prim_md5, 1, 1,
/* -*-C-*-
-$Id: prmhash.c,v 11.11 2007/01/05 21:19:25 cph Exp $
+$Id: prmhash.c,v 11.12 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "usrdef.h"
#include "os.h"
+/* If mhash.h unavailable, ignore it. This helps
+ "makegen/makegen.scm" work properly on systems lacking this
+ library. */
#ifdef HAVE_MHASH_H
# include <mhash.h>
-#else
-/*
-** Hack: Dependency suppressed to appease "makegen/makegen.scm".
-** This is OK since it cannot link w/o the library anyway.
-*/
#endif
#define UNARY_OPERATION(name, get_arg, cvt_val) \
SCHEME_OBJECT key = (ARG_REF (2));
PRIMITIVE_RETURN
(store_context ((mhash_hmac_init (id,
- (STRING_LOC (key, 0)),
+ (STRING_POINTER (key)),
(STRING_LENGTH (key)),
(arg_ulong_integer (3)))),
id));
SCHEME_OBJECT sd = (allocate_string (block_size));
void * digest = (mhash_end (context));
forget_context (index);
- memcpy ((STRING_LOC (sd, 0)), digest, block_size);
+ memcpy ((STRING_POINTER (sd)), digest, block_size);
free (digest);
PRIMITIVE_RETURN (sd);
}
SCHEME_OBJECT sd = (allocate_string (block_size));
void * digest = (mhash_hmac_end (context));
forget_context (index);
- memcpy ((STRING_LOC (sd, 0)), digest, block_size);
+ memcpy ((STRING_POINTER (sd)), digest, block_size);
free (digest);
PRIMITIVE_RETURN (sd);
}
if ((salt_size != 0) && ((STRING_LENGTH (salt)) != salt_size))
error_bad_range_arg (2);
}
- (cparms . salt) = (STRING_LOC (salt, 0));
+ (cparms . salt) = (STRING_BYTE_PTR (salt));
(cparms . salt_size) = (STRING_LENGTH (salt));
}
else if (salt != SHARP_F)
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT
((mhash_keygen_ext (id, cparms,
- (STRING_LOC (keyword, 0)),
+ (STRING_POINTER (keyword)),
(STRING_LENGTH (keyword)),
- (STRING_LOC (passphrase, 0)),
+ (STRING_BYTE_PTR (passphrase)),
(STRING_LENGTH (passphrase))))
== 0));
}
#ifdef COMPILE_AS_MODULE
char *
-DEFUN_VOID (dload_initialize_file)
+dload_initialize_file (void)
{
declare_primitive
("MHASH_COUNT", Prim_mhash_count, 0, 0, 0);
/* -*-C-*-
-$Id: prntenv.c,v 1.15 2007/01/12 03:45:55 cph Exp $
+$Id: prntenv.c,v 1.16 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
{
PRIMITIVE_HEADER (1);
{
- CONST char * variable_value = (getenv (STRING_ARG (1)));
+ const char * variable_value = (getenv (STRING_ARG (1)));
PRIMITIVE_RETURN
((variable_value == 0)
? SHARP_F
case REG_MULTI_SZ:
CHECK_ARG (4, STRING_P);
data_length = ((STRING_LENGTH (ARG_REF (4))) + 1);
- data = ((BYTE *) (STRING_LOC ((ARG_REF (4)), 0)));
+ data = ((BYTE *) (STRING_BYTE_PTR (ARG_REF (4))));
break;
default:
CHECK_ARG (4, STRING_P);
data_length = (STRING_LENGTH (ARG_REF (4)));
- data = ((BYTE *) (STRING_LOC ((ARG_REF (4)), 0)));
+ data = ((BYTE *) (STRING_BYTE_PTR (ARG_REF (4))));
break;
break;
}
LONG code
= (RegEnumKeyEx ((HKEY_ARG (1)),
((DWORD) (arg_ulong_integer (2))),
- ((CHAR *) (STRING_LOC ((ARG_REF (3)), 0))),
+ (STRING_POINTER (ARG_REF (3))),
(&buffer_size),
0, 0, 0, (&last_write_time)));
if (code == ERROR_NO_MORE_ITEMS)
LONG code
= (RegEnumValue ((HKEY_ARG (1)),
((DWORD) (arg_ulong_integer (2))),
- ((LPTSTR) (STRING_LOC ((ARG_REF (3)), 0))),
+ ((LPTSTR) (STRING_POINTER (ARG_REF (3)))),
(&name_size),
0,
(&data_type),
(((ARG_REF (4)) == SHARP_F)
? 0
- : ((LPBYTE) (STRING_LOC ((ARG_REF (4)), 0)))),
+ : ((LPBYTE) (STRING_POINTER (ARG_REF (4))))),
(&data_size)));
if (code == ERROR_NO_MORE_ITEMS)
PRIMITIVE_RETURN (SHARP_F);
case REG_EXPAND_SZ:
case REG_MULTI_SZ:
result = (allocate_string (data_size - 1));
- data = ((BYTE *) (STRING_LOC (result, 0)));
+ data = ((BYTE *) (STRING_BYTE_PTR (result)));
break;
default:
result = (allocate_string (data_size));
- data = ((BYTE *) (STRING_LOC (result, 0)));
+ data = ((BYTE *) (STRING_BYTE_PTR (result)));
break;
}
REGISTRY_API_CALL
CHECK_ARG (2, STRING_P);
{
DWORD n_chars
- = (ExpandEnvironmentStrings (((LPCTSTR) (STRING_LOC ((ARG_REF (1)), 0))),
- ((LPTSTR) (STRING_LOC ((ARG_REF (2)), 0))),
- ((STRING_LENGTH (ARG_REF (2))) + 1)));
+ = (ExpandEnvironmentStrings
+ (((LPCTSTR) (STRING_POINTER (ARG_REF (1)))),
+ ((LPTSTR) (STRING_POINTER (ARG_REF (2)))),
+ ((STRING_LENGTH (ARG_REF (2))) + 1)));
if (n_chars == 0)
NT_error_api_call ((GetLastError ()), apicall_ExpandEnvironmentStrings);
PRIMITIVE_RETURN (ulong_to_integer (n_chars - 1));
/* -*-C-*-
-$Id: prntfs.c,v 1.21 2007/01/05 21:19:25 cph Exp $
+$Id: prntfs.c,v 1.22 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include <sys/utime.h>
#include <memory.h>
-#include <math.h>
-extern void EXFUN (OS_file_copy, (CONST char *, CONST char *));
+extern void OS_file_copy (const char *, const char *);
extern int win32_directory_read (unsigned int, WIN32_FIND_DATA *);
\f
static double ut_zero = 0.0;
{
PRIMITIVE_HEADER (1);
{
- CONST char * filename = (STRING_ARG (1));
+ const char * filename = (STRING_ARG (1));
DWORD attributes = (GetFileAttributes (filename));
if (attributes == 0xFFFFFFFF)
{
}
static unsigned int
-DEFUN (arg_directory_index, (argument), unsigned int argument)
+arg_directory_index (unsigned int argument)
{
- long index = (arg_integer (argument));
- if (! (OS_directory_valid_p (index)))
+ unsigned int index = (arg_ulong_integer (argument));
+ if (!OS_directory_valid_p (index))
error_bad_range_arg (argument);
return (index);
}
/* -*-C-*-
-$Id: prntio.c,v 1.17 2007/01/05 21:19:25 cph Exp $
+$Id: prntio.c,v 1.18 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "ostty.h"
extern HANDLE master_tty_window;
-extern Tchannel EXFUN (arg_to_channel, (SCHEME_OBJECT, int));
+extern Tchannel arg_to_channel (SCHEME_OBJECT, int);
static Tchannel * object_to_channel_vector
(SCHEME_OBJECT, int, unsigned long *, long *);
{
PRIMITIVE_HEADER (8);
{
- CONST char * filename = (STRING_ARG (1));
- CONST char * command_line = (STRING_ARG (2));
- CONST char * env = (((ARG_REF (3)) == SHARP_F) ? 0 : (STRING_ARG (3)));
- CONST char * working_directory
+ const char * filename = (STRING_ARG (1));
+ const char * command_line = (STRING_ARG (2));
+ const char * env = (((ARG_REF (3)) == SHARP_F) ? 0 : (STRING_ARG (3)));
+ const char * working_directory
= (((ARG_REF (4)) == SHARP_F) ? 0 : (STRING_ARG (4)));
enum process_channel_type channel_in_type;
Tchannel channel_in;
/* -*-C-*-
-$Id: pros2fs.c,v 1.22 2007/01/05 21:19:25 cph Exp $
+$Id: pros2fs.c,v 1.23 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
extern char * OS2_drive_type (char);
extern long OS2_timezone (void);
extern long OS2_daylight_savings_p (void);
-extern void EXFUN (OS_file_copy, (CONST char *, CONST char *));
+extern void OS_file_copy (const char *, const char *);
static SCHEME_OBJECT time_to_integer (FDATE *, FTIME *);
static void integer_to_time (SCHEME_OBJECT, FDATE *, FTIME *);
CHECK_ARG (2, STRING_P);
{
unsigned long length = (STRING_LENGTH (ARG_REF (1)));
- const char * s1 = (STRING_LOC ((ARG_REF (1)), 0));
- const char * s2 = (STRING_LOC ((ARG_REF (2)), 0));
+ const char * s1 = (STRING_POINTER (ARG_REF (1)));
+ const char * s2 = (STRING_POINTER (ARG_REF (2)));
const char * e1 = (s1 + length);
if ((STRING_LENGTH (ARG_REF (2))) != length)
PRIMITIVE_RETURN (SHARP_F);
{
unsigned int attr = (info -> attrFile);
SCHEME_OBJECT modes = (allocate_string (5));
- char * s = ((char *) (STRING_LOC (modes, 0)));
+ char * s = (STRING_POINTER (modes));
(s[0]) = (((attr & FILE_DIRECTORY) != 0) ? 'd' : '-');
(s[1]) = (((attr & FILE_READONLY) != 0) ? 'r' : '-');
(s[2]) = (((attr & FILE_HIDDEN) != 0) ? 'h' : '-');
/* -*-C-*-
-$Id: pros2io.c,v 1.15 2007/01/05 21:19:25 cph Exp $
+$Id: pros2io.c,v 1.16 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
if ((STRING_LENGTH (ARG_REF (1))) != (QID_MAX + 1))
error_bad_range_arg (2);
{
- char * registry = (STRING_LOC ((ARG_REF (1)), 0));
- char * results = (STRING_LOC ((ARG_REF (2)), 0));
+ char * registry = (STRING_POINTER (ARG_REF (1)));
+ char * results = (STRING_POINTER (ARG_REF (2)));
int blockp = (BOOLEAN_ARG (3));
int inputp = 0;
int interruptp = 0;
/* -*-C-*-
-$Id: pros2pm.c,v 1.26 2007/01/12 03:45:55 cph Exp $
+$Id: pros2pm.c,v 1.27 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
PRIMITIVE_HEADER (1);
{
SCHEME_OBJECT s = (allocate_string (sizeof (BITMAPINFOHEADER)));
- PBITMAPINFOHEADER params = ((PBITMAPINFOHEADER) (STRING_LOC (s, 0)));
+ PBITMAPINFOHEADER params = ((PBITMAPINFOHEADER) (STRING_POINTER (s)));
(params -> cbFix) = (sizeof (BITMAPINFOHEADER));
OS2_get_bitmap_parameters ((bid_argument (1)), params);
PRIMITIVE_RETURN (s);
/* -*-C-*-
-$Id: prosenv.c,v 1.22 2007/01/12 03:45:55 cph Exp $
+$Id: prosenv.c,v 1.23 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
#include "osenv.h"
#include "ostop.h"
-#include "limits.h"
\f
DEFINE_PRIMITIVE ("ENCODED-TIME", Prim_encoded_time, 0, 0,
"Return the current time as an integer.")
if (! (len >= 10)) \
error_bad_range_arg (1); \
proc (((time_t) (arg_ulong_integer (2))), &ts); \
- FAST_VECTOR_SET (vec, 1, (ulong_to_integer (ts . second))); \
- FAST_VECTOR_SET (vec, 2, (ulong_to_integer (ts . minute))); \
- FAST_VECTOR_SET (vec, 3, (ulong_to_integer (ts . hour))); \
- FAST_VECTOR_SET (vec, 4, (ulong_to_integer (ts . day))); \
- FAST_VECTOR_SET (vec, 5, (ulong_to_integer (ts . month))); \
- FAST_VECTOR_SET (vec, 6, (ulong_to_integer (ts . year))); \
- FAST_VECTOR_SET (vec, 7, (ulong_to_integer (ts . day_of_week))); \
- FAST_VECTOR_SET \
+ VECTOR_SET (vec, 1, (ulong_to_integer (ts . second))); \
+ VECTOR_SET (vec, 2, (ulong_to_integer (ts . minute))); \
+ VECTOR_SET (vec, 3, (ulong_to_integer (ts . hour))); \
+ VECTOR_SET (vec, 4, (ulong_to_integer (ts . day))); \
+ VECTOR_SET (vec, 5, (ulong_to_integer (ts . month))); \
+ VECTOR_SET (vec, 6, (ulong_to_integer (ts . year))); \
+ VECTOR_SET (vec, 7, (ulong_to_integer (ts . day_of_week))); \
+ VECTOR_SET \
(vec, 8, \
(((ts . daylight_savings_time) < 0) \
? SHARP_F \
: (long_to_integer (ts . daylight_savings_time)))); \
- FAST_VECTOR_SET \
+ VECTOR_SET \
(vec, 9, \
(((ts . time_zone) == INT_MAX) \
? SHARP_F \
len = (VECTOR_LENGTH (vec));
if (! (len >= 8))
error_bad_range_arg (1);
- (ts . second) = (integer_to_ulong (FAST_VECTOR_REF (vec, 1)));
- (ts . minute) = (integer_to_ulong (FAST_VECTOR_REF (vec, 2)));
- (ts . hour) = (integer_to_ulong (FAST_VECTOR_REF (vec, 3)));
- (ts . day) = (integer_to_ulong (FAST_VECTOR_REF (vec, 4)));
- (ts . month) = (integer_to_ulong (FAST_VECTOR_REF (vec, 5)));
- (ts . year) = (integer_to_ulong (FAST_VECTOR_REF (vec, 6)));
- (ts . day_of_week) = (integer_to_ulong (FAST_VECTOR_REF (vec, 7)));
+ (ts . second) = (integer_to_ulong (VECTOR_REF (vec, 1)));
+ (ts . minute) = (integer_to_ulong (VECTOR_REF (vec, 2)));
+ (ts . hour) = (integer_to_ulong (VECTOR_REF (vec, 3)));
+ (ts . day) = (integer_to_ulong (VECTOR_REF (vec, 4)));
+ (ts . month) = (integer_to_ulong (VECTOR_REF (vec, 5)));
+ (ts . year) = (integer_to_ulong (VECTOR_REF (vec, 6)));
+ (ts . day_of_week) = (integer_to_ulong (VECTOR_REF (vec, 7)));
(ts . daylight_savings_time)
- = (((len > 8) && (INTEGER_P (FAST_VECTOR_REF (vec, 8))))
- ? (integer_to_long (FAST_VECTOR_REF (vec, 8)))
+ = (((len > 8) && (INTEGER_P (VECTOR_REF (vec, 8))))
+ ? (integer_to_long (VECTOR_REF (vec, 8)))
: (-1));
(ts . time_zone)
= (((len > 9)
- && (INTEGER_P (FAST_VECTOR_REF (vec, 9)))
- && (integer_to_ulong_p (FAST_VECTOR_REF (vec, 9))))
- ? (integer_to_ulong (FAST_VECTOR_REF (vec, 9)))
+ && (INTEGER_P (VECTOR_REF (vec, 9)))
+ && (integer_to_ulong_p (VECTOR_REF (vec, 9))))
+ ? (integer_to_ulong (VECTOR_REF (vec, 9)))
: INT_MAX);
PRIMITIVE_RETURN (ulong_to_integer ((unsigned long) (OS_encode_time (&ts))));
}
{
PRIMITIVE_HEADER (1);
{
- CONST char * message =
- (OS_error_code_to_message (arg_nonnegative_integer (1)));
- PRIMITIVE_RETURN
- ((message == 0) ? SHARP_F : (char_pointer_to_string (message)));
+ const char * message
+ = (OS_error_code_to_message (arg_nonnegative_integer (1)));
+ PRIMITIVE_RETURN ((message == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (message)));
}
}
/* -*-C-*-
-$Id: prosfile.c,v 1.14 2007/01/05 21:19:25 cph Exp $
+$Id: prosfile.c,v 1.15 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
#include "osfile.h"
-extern Tchannel EXFUN (arg_channel, (int));
+extern Tchannel arg_channel (int);
#ifndef OPEN_FILE_HOOK
#define OPEN_FILE_HOOK(channel)
} \
}
-DEFINE_PRIMITIVE ("NEW-FILE-OPEN-INPUT-CHANNEL", Prim_new_file_open_input_channel, 2, 2,
+DEFINE_PRIMITIVE ("NEW-FILE-OPEN-INPUT-CHANNEL",
+ Prim_new_file_open_input_channel, 2, 2,
"Open an input file called FILENAME.\n\
The channel number is saved in the cdr of WEAK-PAIR.")
NEW_OPEN_FILE_PRIMITIVE (OS_open_input_file)
-DEFINE_PRIMITIVE ("NEW-FILE-OPEN-OUTPUT-CHANNEL", Prim_new_file_open_output_channel, 2, 2,
+DEFINE_PRIMITIVE ("NEW-FILE-OPEN-OUTPUT-CHANNEL",
+ Prim_new_file_open_output_channel, 2, 2,
"Open an output file called FILENAME.\n\
The channel number is saved in the cdr of WEAK-PAIR.\n\
If the file exists, it is rewritten.")
NEW_OPEN_FILE_PRIMITIVE (OS_open_output_file)
-DEFINE_PRIMITIVE ("NEW-FILE-OPEN-IO-CHANNEL", Prim_new_file_open_io_channel, 2, 2,
+DEFINE_PRIMITIVE ("NEW-FILE-OPEN-IO-CHANNEL", Prim_new_file_open_io_channel,
+ 2, 2,
"Open a file called FILENAME.\n\
The channel number is saved in the cdr of WEAK-PAIR.\n\
The file is opened for both input and output.\n\
If the file exists, its contents are not disturbed.")
NEW_OPEN_FILE_PRIMITIVE (OS_open_io_file)
-DEFINE_PRIMITIVE ("NEW-FILE-OPEN-APPEND-CHANNEL", Prim_new_file_open_append_channel, 2, 2,
+DEFINE_PRIMITIVE ("NEW-FILE-OPEN-APPEND-CHANNEL",
+ Prim_new_file_open_append_channel, 2, 2,
"Open an output file called FILENAME.\n\
The channel number is saved in the cdr of WEAK-PAIR.\n\
If the file exists, output is appended to its contents.")
} \
}
-DEFINE_PRIMITIVE ("FILE-OPEN-INPUT-CHANNEL", Prim_file_open_input_channel, 1, 1,
+DEFINE_PRIMITIVE ("FILE-OPEN-INPUT-CHANNEL", Prim_file_open_input_channel,
+ 1, 1,
"Open an input file called FILENAME, returning a channel number.")
OPEN_FILE_PRIMITIVE (OS_open_input_file)
-DEFINE_PRIMITIVE ("FILE-OPEN-OUTPUT-CHANNEL", Prim_file_open_output_channel, 1, 1,
+DEFINE_PRIMITIVE ("FILE-OPEN-OUTPUT-CHANNEL", Prim_file_open_output_channel,
+ 1, 1,
"Open an output file called FILENAME, returning a channel number.\n\
If the file exists, it is rewritten.")
OPEN_FILE_PRIMITIVE (OS_open_output_file)
If the file exists, its contents are not disturbed.")
OPEN_FILE_PRIMITIVE (OS_open_io_file)
-DEFINE_PRIMITIVE ("FILE-OPEN-APPEND-CHANNEL", Prim_file_open_append_channel, 1, 1,
+DEFINE_PRIMITIVE ("FILE-OPEN-APPEND-CHANNEL", Prim_file_open_append_channel,
+ 1, 1,
"Open an output file called FILENAME, returning a channel number.\n\
If the file exists, output is appended to its contents.")
OPEN_FILE_PRIMITIVE (OS_open_append_file)
/* -*-C-*-
-$Id: prosfs.c,v 1.22 2007/01/12 03:45:55 cph Exp $
+$Id: prosfs.c,v 1.23 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "osfs.h"
#include "osio.h"
-extern int EXFUN (OS_channel_copy,
- (off_t source_length,
- Tchannel source_channel,
- Tchannel destination_channel));
-extern void EXFUN (OS_file_copy, (CONST char *, CONST char *));
-
-#define STRING_RESULT(expression) \
+#define STRING_RESULT(expression) do \
{ \
- CONST char * result = (expression); \
+ const char * result = (expression); \
PRIMITIVE_RETURN \
((result == 0) \
? SHARP_F \
: (char_pointer_to_string (result))); \
-}
+} while (0)
\f
DEFINE_PRIMITIVE ("FILE-EXISTS?", Prim_file_exists_p, 1, 1,
"Return #T iff FILENAME refers to an existing file.\n\
{
PRIMITIVE_HEADER (3);
{
- CONST char * from_name = (STRING_ARG (1));
- CONST char * to_name = (STRING_ARG (2));
+ const char * from_name = (STRING_ARG (1));
+ const char * to_name = (STRING_ARG (2));
if ((ARG_REF (3)) != SHARP_F)
OS_file_link_hard (from_name, to_name);
else
}
\f
#ifndef FILE_COPY_BUFFER_LENGTH
-#define FILE_COPY_BUFFER_LENGTH 8192
+# define FILE_COPY_BUFFER_LENGTH 8192
#endif
int
-DEFUN (OS_channel_copy, (source_length, source_channel, destination_channel),
- off_t source_length AND
- Tchannel source_channel AND
+OS_channel_copy (off_t source_length,
+ Tchannel source_channel,
Tchannel destination_channel)
{
char buffer [FILE_COPY_BUFFER_LENGTH];
transfer_length = source_length;
}
return (0);
-}
+}
DEFINE_PRIMITIVE ("FILE-COPY", Prim_file_copy, 2, 2,
"Make a new copy of the file FROM-NAME, called TO-NAME.")
{
PRIMITIVE_HEADER (1);
{
- int rc = (OS_file_touch ((CONST char *) (STRING_ARG (1))));
+ int rc = (OS_file_touch ((const char *) (STRING_ARG (1))));
if (rc < 0)
error_bad_range_arg (1);
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (rc));
}
static unsigned int
-DEFUN (arg_directory_index, (argument), unsigned int argument)
+arg_directory_index (unsigned int argument)
{
- long index = (arg_integer (argument));
- if (! (OS_directory_valid_p (index)))
+ unsigned int index = (arg_ulong_integer (argument));
+ if (!OS_directory_valid_p (index))
error_bad_range_arg (argument);
return (index);
}
/* -*-C-*-
-$Id: prosio.c,v 1.27 2007/01/12 03:45:55 cph Exp $
+$Id: prosio.c,v 1.28 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#endif
\f
Tchannel
-DEFUN (arg_to_channel, (argument, arg_number),
- SCHEME_OBJECT argument AND
+arg_to_channel (SCHEME_OBJECT argument,
int arg_number)
{
if (! ((INTEGER_P (argument)) && (integer_to_ulong_p (argument))))
}
Tchannel
-DEFUN (arg_channel, (arg_number), int arg_number)
+arg_channel (int arg_number)
{
Tchannel channel = (arg_to_channel ((ARG_REF (arg_number)), arg_number));
if (!OS_channel_open_p (channel))
{
PRIMITIVE_HEADER (1);
{
- fast Tchannel channel = (arg_to_channel ((ARG_REF (1)), 1));
+ Tchannel channel = (arg_to_channel ((ARG_REF (1)), 1));
if (OS_channel_open_p (channel))
{
CLOSE_CHANNEL_HOOK (channel);
PRIMITIVE_HEADER (4);
{
unsigned long length;
- char * buffer = (arg_extended_string (2, (&length)));
+ unsigned char * buffer = (arg_extended_string (2, (&length)));
unsigned long end = (arg_ulong_index_integer (4, (length + 1)));
unsigned long start = (arg_ulong_index_integer (3, (end + 1)));
long nread =
PRIMITIVE_HEADER (4);
{
unsigned long length;
- CONST char * buffer = (arg_extended_string (2, (&length)));
+ const unsigned char * buffer = (arg_extended_string (2, (&length)));
unsigned long end = (arg_ulong_index_integer (4, (length + 1)));
unsigned long start = (arg_ulong_index_integer (3, (end + 1)));
long nwritten =
/* Select registry */
static select_registry_t
-DEFUN (arg_select_registry, (arg_number), int arg_number)
+arg_select_registry (int arg_number)
{
return ((select_registry_t) (arg_ulong_integer (arg_number)));
}
static unsigned int
-DEFUN (arg_sr_mode, (arg_number), int arg_number)
+arg_sr_mode (int arg_number)
{
unsigned long n = (arg_ulong_integer (arg_number));
if (! ((n >= 1) && (n <= 3)))
/* -*-C-*-
-$Id: prosproc.c,v 1.24 2007/01/12 03:45:55 cph Exp $
+$Id: prosproc.c,v 1.25 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
extern char ** environ;
#endif
-extern Tchannel EXFUN (arg_channel, (int));
+extern Tchannel arg_channel (int);
static Tprocess
-DEFUN (arg_process, (argument_number), int argument_number)
+arg_process (int argument_number)
{
- Tprocess process =
- (arg_index_integer (argument_number, OS_process_table_size));
+ Tprocess process
+ = (arg_index_integer (argument_number, OS_process_table_size));
if (! (OS_process_valid_p (process)))
error_bad_range_arg (argument_number);
return (process);
}
-\f
+
DEFINE_PRIMITIVE ("SCHEME-ENVIRONMENT", Prim_scheme_environment, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
{
char ** scan_environ = environ;
char ** end_environ = scan_environ;
- while ((*end_environ++) != 0) ;
- end_environ -= 1;
+ while ((*end_environ) != 0)
+ end_environ += 1;
{
- SCHEME_OBJECT result =
- (allocate_marked_vector (TC_VECTOR, (end_environ - environ), 1));
+ SCHEME_OBJECT result
+ = (allocate_marked_vector (TC_VECTOR, (end_environ - environ), true));
SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
while (scan_environ < end_environ)
(*scan_result++) = (char_pointer_to_string (*scan_environ++));
}
}
-DEFINE_PRIMITIVE ("PROCESS-ID", Prim_process_id, 1, 1,
+DEFINE_PRIMITIVE ("PROCESS-ID", Prim_process_id, 1, 1,
"Return the process ID of process PROCESS-NUMBER.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (ulong_to_integer (OS_process_id (arg_process (1))));
}
-DEFINE_PRIMITIVE ("PROCESS-JOB-CONTROL-STATUS", Prim_process_jc_status, 1, 1,
+DEFINE_PRIMITIVE ("PROCESS-JOB-CONTROL-STATUS", Prim_process_jc_status, 1, 1,
"Returns the job-control status of process PROCESS-NUMBER:\n\
0 means this system doesn't support job control.\n\
1 means the process doesn't have the same controlling terminal as Scheme.\n\
}
}
-DEFINE_PRIMITIVE ("PROCESS-REASON", Prim_process_reason, 1, 1,
+DEFINE_PRIMITIVE ("PROCESS-REASON", Prim_process_reason, 1, 1,
"Return the termination reason of process PROCESS-NUMBER.\n\
This is a nonnegative integer, which depends on the process's status:\n\
running => zero;\n\
\f
/* This primitive is obsolete. */
-static int EXFUN (string_vector_p, (SCHEME_OBJECT vector));
-static CONST char ** EXFUN (convert_string_vector, (SCHEME_OBJECT vector));
+static int string_vector_p (SCHEME_OBJECT vector);
+static const char ** convert_string_vector (SCHEME_OBJECT vector);
#define PROCESS_CHANNEL_ARG(arg, type, channel) \
{ \
PRIMITIVE_HEADER (7);
CHECK_ARG (2, string_vector_p);
{
- PTR position = dstack_position;
- CONST char * filename = (STRING_ARG (1));
- CONST char ** argv = (convert_string_vector (ARG_REF (2)));
+ void * position = dstack_position;
+ const char * filename = (STRING_ARG (1));
+ const char ** argv = (convert_string_vector (ARG_REF (2)));
SCHEME_OBJECT env_object = (ARG_REF (3));
- CONST char ** env = 0;
- CONST char * working_directory = 0;
+ const char ** env = 0;
+ const char * working_directory = 0;
enum process_ctty_type ctty_type;
char * ctty_name = 0;
enum process_channel_type channel_in_type;
if ((PAIR_P (env_object)) && (STRING_P (PAIR_CDR (env_object))))
{
- working_directory =
- ((CONST char *) (STRING_LOC ((PAIR_CDR (env_object)), 0)));
+ working_directory = (STRING_POINTER (PAIR_CDR (env_object)));
env_object = (PAIR_CAR (env_object));
}
if (env_object != SHARP_F)
}
static int
-DEFUN (string_vector_p, (vector), SCHEME_OBJECT vector)
+string_vector_p (SCHEME_OBJECT vector)
{
if (! (VECTOR_P (vector)))
return (0);
return (1);
}
-static CONST char **
-DEFUN (convert_string_vector, (vector), SCHEME_OBJECT vector)
+static const char **
+convert_string_vector (SCHEME_OBJECT vector)
{
unsigned long length = (VECTOR_LENGTH (vector));
char ** result = (dstack_alloc ((length + 1) * (sizeof (char *))));
SCHEME_OBJECT * end = (scan + length);
char ** scan_result = result;
while (scan < end)
- (*scan_result++) = ((char *) (STRING_LOC ((*scan++), 0)));
+ (*scan_result++) = (STRING_POINTER (*scan++));
(*scan_result) = 0;
- return ((CONST char **) result);
+ return ((const char **) result);
}
/* -*-C-*-
-$Id: prospty.c,v 1.9 2007/01/12 03:45:55 cph Exp $
+$Id: prospty.c,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
+#include "osscheme.h"
#include "osterm.h"
#include "osio.h"
#include "ospty.h"
\f
static Tchannel
-DEFUN (arg_pty_master, (arg), unsigned int arg)
+arg_pty_master (unsigned int arg)
{
Tchannel channel = (arg_channel (1));
if ((OS_channel_type (channel)) != channel_type_unix_pty_master)
PRIMITIVE_HEADER (0);
{
Tchannel channel;
- CONST char * master_name;
- CONST char * slave_name =
+ const char * master_name;
+ const char * slave_name =
(OS_open_pty_master ((&channel), (&master_name)));
transaction_begin ();
OS_channel_close_on_abort (channel);
/* -*-C-*-
-$Id: prosterm.c,v 1.20 2007/01/05 21:19:25 cph Exp $
+$Id: prosterm.c,v 1.21 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
+#include "osscheme.h"
#include "osterm.h"
#include "osio.h"
\f
Tchannel
-DEFUN (arg_terminal, (argument_number), int argument_number)
+arg_terminal (int argument_number)
{
Tchannel channel = (arg_channel (argument_number));
enum channel_type type = (OS_channel_type (channel));
PRIMITIVE_HEADER (1);
{
SCHEME_OBJECT result = (allocate_string (OS_terminal_state_size ()));
- OS_terminal_get_state ((arg_terminal (1)), (STRING_LOC (result, 0)));
+ OS_terminal_get_state ((arg_terminal (1)), (STRING_POINTER (result)));
PRIMITIVE_RETURN (result);
}
}
if (((unsigned int) (STRING_LENGTH (state)))
!= (OS_terminal_state_size ()))
error_bad_range_arg (2);
- OS_terminal_set_state ((arg_terminal (1)), (STRING_LOC (state, 0)));
+ OS_terminal_set_state ((arg_terminal (1)), (STRING_POINTER (state)));
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-$Id: prostty.c,v 1.12 2007/01/12 03:45:55 cph Exp $
+$Id: prostty.c,v 1.13 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
SCHEME_OBJECT result = (allocate_string (num_chars * 2));
cc_t * int_chars = (OS_ctty_get_int_chars ());
cc_t * int_handlers = (OS_ctty_get_int_char_handlers ());
- unsigned char * scan = (STRING_LOC (result, 0));
+ char * scan = (STRING_POINTER (result));
for (i = 0; i < num_chars; i++)
{
- (*scan++) = ((unsigned char) int_chars[i]);
- (*scan++) = ((unsigned char) int_handlers[i]);
+ (*scan++) = (int_chars[i]);
+ (*scan++) = (int_handlers[i]);
}
PRIMITIVE_RETURN (result);
}
cc_t * int_chars = (OS_ctty_get_int_chars ());
cc_t * int_handlers = (OS_ctty_get_int_char_handlers ());
SCHEME_OBJECT argument = (ARG_REF (1));
- unsigned char * scan;
+ char * scan;
if (! ((STRING_P (argument))
&& (((unsigned int) (STRING_LENGTH (argument)))
== (num_chars * 2))))
error_wrong_type_arg (1);
- for (i = 0, scan = (STRING_LOC (argument, 0)); i < num_chars; i++)
- {
- int_chars[i] = (*scan++);
- int_handlers[i] = (*scan++);
- }
+ for (i = 0, scan = (STRING_POINTER (argument)); i < num_chars; i++)
+ {
+ (int_chars[i]) = (*scan++);
+ (int_handlers[i]) = (*scan++);
+ }
OS_ctty_set_int_chars (int_chars);
OS_ctty_set_int_char_handlers (int_handlers);
}
/* -*-C-*-
-$Id: prpgsql.c,v 1.13 2007/02/11 05:55:00 riastradh Exp $
+$Id: prpgsql.c,v 1.14 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
{
size_t escaped_length;
unsigned char * escaped
- = (PQescapeBytea ((STRING_LOC ((ARG_REF (1)), 0)),
+ = (PQescapeBytea ((STRING_BYTE_PTR (ARG_REF (1))),
(STRING_LENGTH (ARG_REF (1))),
(&escaped_length)));
- SCHEME_OBJECT s = (char_pointer_to_string ((char *) escaped));
+ SCHEME_OBJECT s = (memory_to_string ((escaped_length - 1), escaped));
PQfreemem (escaped);
PRIMITIVE_RETURN (s);
}
#ifdef COMPILE_AS_MODULE
char *
-DEFUN_VOID (dload_initialize_file)
+dload_initialize_file (void)
{
declare_primitive ("PQ-CONNECT-DB", Prim_pq_connect_db, 2, 2, 0);
declare_primitive ("PQ-CONNECT-START", Prim_pq_connect_start, 2, 2, 0);
/* -*-C-*-
-$Id: pruxdld.c,v 1.22 2007/01/12 03:45:55 cph Exp $
+$Id: pruxdld.c,v 1.23 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include <dlfcn.h>
static unsigned long
-DEFUN (dld_load, (path), CONST char * path)
+dld_load (const char * path)
{
void * handle = (dlopen (path, (RTLD_LAZY | RTLD_GLOBAL)));
if (handle == 0)
}
static unsigned long
-DEFUN (dld_lookup, (handle, symbol), unsigned long handle AND char * symbol)
+dld_lookup (unsigned long handle, char * symbol)
{
- CONST char * old_error = (dlerror ());
+ const char * old_error = (dlerror ());
void * address = (dlsym (((void *) handle), symbol));
- CONST char * new_error = (dlerror ());
+ const char * new_error = (dlerror ());
if ((address == 0) && (new_error != old_error))
{
SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(ulong_to_integer
- ((* ((unsigned long EXFUN ((*), (void))) (arg_ulong_integer (1))))
+ ((* ((unsigned long (*) (void)) (arg_ulong_integer (1))))
()));
}
/* -*-C-*-
-$Id: pruxenv.c,v 1.26 2007/02/11 18:42:52 riastradh Exp $
+$Id: pruxenv.c,v 1.27 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "ux.h"
#include "uxtrap.h"
+extern const char * OS_current_user_name (void);
+extern const char * OS_current_user_home_directory (void);
+
#ifdef HAVE_SOCKETS
# include "uxsock.h"
#endif
PRIMITIVE_HEADER (1);
{
struct passwd * entry = (UX_getpwnam (STRING_ARG (1)));
- PRIMITIVE_RETURN
- ((entry == 0) ? SHARP_F : (char_pointer_to_string (entry -> pw_dir)));
+ PRIMITIVE_RETURN ((entry == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (entry -> pw_dir)));
}
}
PRIMITIVE_HEADER (1);
{
struct passwd * entry = (UX_getpwuid (arg_nonnegative_integer (1)));
- PRIMITIVE_RETURN
- ((entry == 0) ? SHARP_F : (char_pointer_to_string (entry -> pw_name)));
+ PRIMITIVE_RETURN ((entry == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (entry -> pw_name)));
}
}
PRIMITIVE_HEADER (1);
{
struct group * entry = (UX_getgrgid (arg_nonnegative_integer (1)));
- PRIMITIVE_RETURN
- ((entry == 0) ? SHARP_F : (char_pointer_to_string (entry -> gr_name)));
+ PRIMITIVE_RETURN ((entry == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (entry -> gr_name)));
}
}
\f
DEFINE_PRIMITIVE ("CURRENT-USER-NAME", Prim_current_user_name, 0, 0,
"Return (as a string) the user name of the user running Scheme.")
{
- extern CONST char * EXFUN (OS_current_user_name, (void));
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN (char_pointer_to_string (OS_current_user_name ()));
}
DEFINE_PRIMITIVE ("CURRENT-USER-HOME-DIRECTORY", Prim_current_user_home_directory, 0, 0,
"Return the name of the current user's home directory.")
{
- extern CONST char * EXFUN (OS_current_user_home_directory, (void));
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN
(char_pointer_to_string (OS_current_user_home_directory ()));
{
PRIMITIVE_HEADER (1);
{
- CONST char * variable_value = (UX_getenv (STRING_ARG (1)));
- PRIMITIVE_RETURN
- ((variable_value == 0)
- ? SHARP_F
- : (char_pointer_to_string (variable_value)));
+ const char * variable_value = (UX_getenv (STRING_ARG (1)));
+ PRIMITIVE_RETURN ((variable_value == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (variable_value)));
}
}
\f
{
char this_host_name [HOSTNAMESIZE];
#ifdef HAVE_SOCKETS
- struct hostent * EXFUN (gethostbyname, (CONST char *));
struct hostent * this_host_entry;
STD_VOID_SYSTEM_CALL
#ifdef HAVE_SOCKETS
this_host_entry = (gethostbyname (this_host_name));
- PRIMITIVE_RETURN
- ((this_host_entry == 0)
- ? SHARP_F
- : (char_pointer_to_string (this_host_entry -> h_name)));
+ PRIMITIVE_RETURN ((this_host_entry == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (this_host_entry -> h_name)));
#else
PRIMITIVE_RETURN (char_pointer_to_string (this_host_name));
#endif
Prim_instruction_address_to_compiled_code_block, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
+#ifdef CC_SUPPORT_P
{
SCHEME_OBJECT object = (ARG_REF (1));
unsigned long pc;
}
else
{
- if (! (COMPILED_CODE_ADDRESS_P (object)))
+ if (!CC_ENTRY_P (object))
error_bad_range_arg (1);
- pc = ((unsigned long) (OBJECT_ADDRESS (object)));
+ pc = ((unsigned long) (CC_ENTRY_ADDRESS (object)));
}
PRIMITIVE_RETURN (find_ccblock (pc));
}
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
}
/* -*-C-*-
-$Id: pruxfs.c,v 9.61 2007/01/12 03:45:55 cph Exp $
+$Id: pruxfs.c,v 9.62 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "ux.h"
#include "osfs.h"
-extern int EXFUN
- (UX_read_file_status, (CONST char * filename, struct stat * s));
-extern int EXFUN
- (UX_read_file_status_indirect, (CONST char * filename, struct stat * s));
-extern CONST char * EXFUN (UX_file_system_type, (CONST char * name));
+extern int UX_read_file_status (const char * filename, struct stat * s);
+extern int UX_read_file_status_indirect
+ (const char * filename, struct stat * s);
+extern const char * UX_file_system_type (const char * name);
-static SCHEME_OBJECT EXFUN (file_attributes_internal, (struct stat * s));
-static void EXFUN (file_mode_string, (struct stat * s, char * a));
-static char EXFUN (file_type_letter, (struct stat * s));
-static void EXFUN (rwx, (unsigned short bits, char * chars));
+static SCHEME_OBJECT file_attributes_internal (struct stat * s);
+static void file_mode_string (struct stat * s, char * a);
+static char file_type_letter (struct stat * s);
+static void rwx (unsigned short bits, char * chars);
\f
DEFINE_PRIMITIVE ("FILE-MODES", Prim_file_modes, 1, 1,
"Return mode bits of FILE, as an integer.")
FILE_ATTRIBUTES_PRIMITIVE (UX_read_file_status_indirect)
static SCHEME_OBJECT
-DEFUN (file_attributes_internal, (s), struct stat * s)
+file_attributes_internal (struct stat * s)
{
SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 10, true));
SCHEME_OBJECT modes = (allocate_string (10));
case S_IFLNK:
VECTOR_SET (result, 0,
(char_pointer_to_string
- (OS_file_soft_link_p
- ((CONST char *) (STRING_LOC ((ARG_REF (1)), 0))))));
+ (OS_file_soft_link_p (STRING_POINTER (ARG_REF (1))))));
break;
#endif
default:
VECTOR_SET (result, 5, (long_to_integer (s -> st_mtime)));
VECTOR_SET (result, 6, (long_to_integer (s -> st_ctime)));
VECTOR_SET (result, 7, (long_to_integer (s -> st_size)));
- file_mode_string (s, ((char *) (STRING_LOC (modes, 0))));
+ file_mode_string (s, (STRING_POINTER (modes)));
VECTOR_SET (result, 8, modes);
VECTOR_SET (result, 9, (long_to_integer (s -> st_ino)));
return (result);
be retained in swap space after execution), '-' otherwise. */
static void
-DEFUN (file_mode_string, (s, a), struct stat * s AND char * a)
+file_mode_string (struct stat * s, char * a)
{
(a[0]) = (file_type_letter (s));
rwx ((((s -> st_mode) & 0700) << 0), (& (a [1])));
}
\f
static char
-DEFUN (file_type_letter, (s), struct stat * s)
+file_type_letter (struct stat * s)
{
switch ((s -> st_mode) & S_IFMT)
{
}
static void
-DEFUN (rwx, (bits, chars), unsigned short bits AND char * chars)
+rwx (unsigned short bits, char * chars)
{
(chars[0]) = (((bits & S_IRUSR) != 0) ? 'r' : '-');
(chars[1]) = (((bits & S_IWUSR) != 0) ? 'w' : '-');
{
PRIMITIVE_HEADER (1);
{
- CONST char * result = (UX_file_system_type (STRING_ARG (1)));
+ const char * result = (UX_file_system_type (STRING_ARG (1)));
PRIMITIVE_RETURN
(char_pointer_to_string ((result == 0) ? "unknown" : result));
}
/* -*-C-*-
-$Id: pruxio.c,v 1.12 2007/01/05 21:19:25 cph Exp $
+$Id: pruxio.c,v 1.13 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "uxselect.h"
#include "uxproc.h"
-#ifndef __hp9000s700
-/* Blows up HP 9000/700 compiler (HP-UX 8.05)! */
-extern Tchannel EXFUN (arg_channel, (int arg_number));
-extern int EXFUN (UX_channel_descriptor, (Tchannel channel));
-#endif
+extern int UX_channel_descriptor (Tchannel channel);
-static CONST char ** EXFUN (string_vector_arg, (int arg));
-static int EXFUN (string_vector_p, (SCHEME_OBJECT vector));
-static CONST char ** EXFUN (convert_string_vector, (SCHEME_OBJECT vector));
+static const char ** string_vector_arg (int arg);
+static int string_vector_p (SCHEME_OBJECT vector);
+static const char ** convert_string_vector (SCHEME_OBJECT vector);
\f
DEFINE_PRIMITIVE ("SELECT-REGISTRY-SIZE", Prim_selreg_size, 0, 0, 0)
{
PRIMITIVE_HEADER (3);
CHECK_ARG (3, VECTOR_P);
{
- PTR position = dstack_position;
+ void * position = dstack_position;
unsigned int lub = (UX_select_registry_lub ());
unsigned int * fds = (dstack_alloc ((sizeof (unsigned int)) * lub));
unsigned int nfds;
{
PRIMITIVE_HEADER (8);
{
- PTR position = dstack_position;
- CONST char * filename = (STRING_ARG (1));
- CONST char ** argv = (string_vector_arg (2));
- CONST char ** env
+ void * position = dstack_position;
+ const char * filename = (STRING_ARG (1));
+ const char ** argv = (string_vector_arg (2));
+ const char ** env
= (((ARG_REF (3)) == SHARP_F) ? 0 : (string_vector_arg (3)));
- CONST char * working_directory
+ const char * working_directory
= (((ARG_REF (4)) == SHARP_F) ? 0 : (STRING_ARG (4)));
enum process_ctty_type ctty_type;
char * ctty_name = 0;
}
}
-static CONST char **
-DEFUN (string_vector_arg, (arg), int arg)
+static const char **
+string_vector_arg (int arg)
{
SCHEME_OBJECT vector = (ARG_REF (arg));
if (!string_vector_p (vector))
}
static int
-DEFUN (string_vector_p, (vector), SCHEME_OBJECT vector)
+string_vector_p (SCHEME_OBJECT vector)
{
if (! (VECTOR_P (vector)))
return (0);
return (1);
}
-static CONST char **
-DEFUN (convert_string_vector, (vector), SCHEME_OBJECT vector)
+static const char **
+convert_string_vector (SCHEME_OBJECT vector)
{
unsigned long length = (VECTOR_LENGTH (vector));
char ** result = (dstack_alloc ((length + 1) * (sizeof (char *))));
SCHEME_OBJECT * end = (scan + length);
char ** scan_result = result;
while (scan < end)
- (*scan_result++) = ((char *) (STRING_LOC ((*scan++), 0)));
+ (*scan_result++) = (STRING_POINTER (*scan++));
(*scan_result) = 0;
- return ((CONST char **) result);
+ return ((const char **) result);
}
/* -*-C-*-
-$Id: pruxsock.c,v 1.27 2007/01/20 23:49:18 riastradh Exp $
+$Id: pruxsock.c,v 1.28 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "uxsock.h"
#define SOCKET_CODE(code) code
-static PTR
-DEFUN (arg_host, (arg), unsigned int arg)
+static void *
+arg_host (unsigned int arg)
{
CHECK_ARG (arg, STRING_P);
if ((STRING_LENGTH (ARG_REF (arg))) != (OS_host_address_length ()))
error_bad_range_arg (arg);
- return (STRING_LOC ((ARG_REF (arg)), 0));
+ return (STRING_POINTER (ARG_REF (arg)));
}
static Tchannel
-DEFUN (arg_client_socket, (arg), unsigned int arg)
+arg_client_socket (unsigned int arg)
{
- Tchannel socket = (arg_nonnegative_integer (arg));
+ Tchannel socket = (arg_ulong_integer (arg));
if (! (((OS_channel_type (socket)) == channel_type_tcp_stream_socket)
|| ((OS_channel_type (socket)) == channel_type_unix_stream_socket)))
error_bad_range_arg (arg);
}
static Tchannel
-DEFUN (arg_server_socket, (arg), unsigned int arg)
+arg_server_socket (unsigned int arg)
{
Tchannel server_socket = (arg_nonnegative_integer (arg));
if ((OS_channel_type (server_socket)) != channel_type_tcp_server_socket)
PRIMITIVE_HEADER (0);
SOCKET_CODE
({
- CONST char * host_name = (OS_get_host_name ());
+ const char * host_name = (OS_get_host_name ());
if (host_name == 0)
PRIMITIVE_RETURN (SHARP_F);
{
SCHEME_OBJECT result = (char_pointer_to_string (host_name));
- OS_free ((PTR) host_name);
+ OS_free ((void *) host_name);
PRIMITIVE_RETURN (result);
}
});
PRIMITIVE_HEADER (1);
SOCKET_CODE
({
- CONST char * host_name = (OS_canonical_host_name (STRING_ARG (1)));
+ const char * host_name = (OS_canonical_host_name (STRING_ARG (1)));
if (host_name == 0)
PRIMITIVE_RETURN (SHARP_F);
{
SCHEME_OBJECT result = (char_pointer_to_string (host_name));
- OS_free ((PTR) host_name);
+ OS_free ((void *) host_name);
PRIMITIVE_RETURN (result);
}
});
PRIMITIVE_HEADER (1);
SOCKET_CODE
({
- CONST char * host_name = (OS_get_host_by_address (STRING_ARG (1)));
+ const char * host_name = (OS_get_host_by_address (STRING_ARG (1)));
if (host_name == 0)
PRIMITIVE_RETURN (SHARP_F);
{
SCHEME_OBJECT result = (char_pointer_to_string (host_name));
- OS_free ((PTR) host_name);
+ OS_free ((void *) host_name);
PRIMITIVE_RETURN (result);
}
});
SOCKET_CODE
({
SCHEME_OBJECT result = (allocate_string (OS_host_address_length ()));
- OS_host_address_any (STRING_LOC (result, 0));
+ OS_host_address_any (STRING_POINTER (result));
PRIMITIVE_RETURN (result);
});
}
SOCKET_CODE
({
SCHEME_OBJECT result = (allocate_string (OS_host_address_length ()));
- OS_host_address_loopback (STRING_LOC (result, 0));
+ OS_host_address_loopback (STRING_POINTER (result));
PRIMITIVE_RETURN (result);
});
}
SOCKET_CODE
({
OS_shutdown_socket ((arg_client_socket (1)),
- (arg_integer_in_range (2, 1, 4)));
+ (arg_ulong_integer_in_range (2, 1, 4)));
PRIMITIVE_RETURN (UNSPECIFIC);
});
}
SOCKET_CODE
({
Tchannel channel = (OS_create_tcp_server_socket ());
- PTR address = (OS_malloc (OS_host_address_length ()));
+ void * address = (OS_malloc (OS_host_address_length ()));
OS_host_address_any (address);
OS_bind_tcp_server_socket
(channel, address, (arg_nonnegative_integer (1)));
SOCKET_CODE
({
Tchannel server_socket = (arg_server_socket (1));
- PTR peer_host = (((ARG_REF (2)) == SHARP_F) ? 0 : (arg_host (2)));
+ void * peer_host = (((ARG_REF (2)) == SHARP_F) ? 0 : (arg_host (2)));
Tchannel connection =
(OS_server_connection_accept (server_socket, peer_host, 0));
if (connection == NO_CHANNEL)
+++ /dev/null
-/* -*-C-*-
-
-$Id: psbmap.h,v 9.49 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains macros and declarations for "bintopsb.c"
- and "psbtobin.c".
- */
-
-#ifndef PSBMAP_H_INCLUDED
-#define PSBMAP_H_INCLUDED
-
-/* These definitions insure that the appropriate code is extracted
- from the included files.
-*/
-
-#define fast register
-
-#include "config.h"
-#include <stdio.h>
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-#endif
-#include "types.h"
-#include "object.h"
-#include "bignum.h"
-#include "bignmint.h"
-#include "bitstr.h"
-#include "sdata.h"
-#include "const.h"
-#include "gccode.h"
-#include "cmptype.h"
-#define boolean Boolean
-#include "comlin.h"
-
-#ifndef COMPILER_PROCESSOR_TYPE
-#define COMPILER_PROCESSOR_TYPE COMPILER_NONE_TYPE
-#endif
-\f
-extern double
- EXFUN (frexp, (double, int *)),
- EXFUN (ldexp, (double, int));
-
-#define PORTABLE_VERSION 7
-
-/* Number of objects which, when traced recursively, point at all other
- objects dumped.
- Currently the dumped object, and the compiler utilities.
- */
-
-#define NROOTS 2
-
-/* Types to recognize external object references. Any occurrence of these
- (which are external types and thus handled separately) means a reference
- to an external object.
- */
-
-#define CONSTANT_CODE TC_FIXNUM
-#define HEAP_CODE TC_CHARACTER
-#define PURE_CODE TC_BIG_FIXNUM
-
-#define fixnum_to_bits FIXNUM_LENGTH
-#define hex_digits(nbits) (((nbits) + 3) / 4)
-
-#define to_pointer BYTES_TO_WORDS
-
-#define float_to_pointer \
- BYTES_TO_WORDS(sizeof(double))
-
-#ifndef FLOATING_ALIGNMENT
-
-#define flonum_to_pointer(nfloats) \
- ((nfloats) * (1 + float_to_pointer))
-
-#else /* FLOATING_ALIGNMENT */
-
-/* When computing the space needed for flonums, the worst case is that
- every flonum needs alignment. To estimate the space needed, add
- padding to each flonum to round it up to an alignment boundary. */
-
-#define flonum_to_pointer(nfloats) \
- ((nfloats) \
- * (((((1 + float_to_pointer) * (sizeof (char))) \
- & FLOATING_ALIGNMENT) \
- == 0) \
- ? (1 + float_to_pointer) \
- : ((((1 + float_to_pointer) * (sizeof (char))) \
- + ((FLOATING_ALIGNMENT + 1) \
- - (((1 + float_to_pointer) * (sizeof (char))) \
- & FLOATING_ALIGNMENT))) \
- / (sizeof (char)))))
-
-#endif /* FLOATING_ALIGNMENT */
-
-#define char_to_pointer(nchars) \
- BYTES_TO_WORDS(nchars)
-
-#define pointer_to_char(npoints) \
- ((npoints) * sizeof(SCHEME_OBJECT))
-\f
-/* Status flags */
-
-#define COMPACT_P (1 << 0)
-#define NULL_NMV_P (1 << 1)
-#define COMPILED_P (1 << 2)
-#define NMV_P (1 << 3)
-#define BAND_P (1 << 4)
-#define C_CODE_P (1 << 5)
-
-#define MAKE_FLAGS() \
-( (compact_p ? COMPACT_P : 0) \
- | (null_nmv_p ? NULL_NMV_P : 0) \
- | (compiled_p ? COMPILED_P : 0) \
- | (nmv_p ? NMV_P : 0) \
- | (band_p ? BAND_P : 0) \
- | (c_compiled_p ? C_CODE_P : 0))
-
-#define READ_FLAGS(f) do \
-{ \
- compact_p = ((f) & COMPACT_P); \
- null_nmv_p = ((f) & NULL_NMV_P); \
- compiled_p = ((f) & COMPILED_P); \
- nmv_p = ((f) & NMV_P); \
- band_p = ((f) & BAND_P); \
- c_compiled_p = ((f) & C_CODE_P); \
-} while (0)
-
-/*
- If true, make all integers fixnums if possible, and all strings as
- short as possible (trim extra stuff).
- */
-
-static Boolean compact_p = true;
-
-/* If true, null out all elements of random non-marked vectors. */
-
-static Boolean null_nmv_p = false;
-
-/* If true, the portable file contains compiled code. */
-
-static Boolean compiled_p = false;
-
-/* If true, the portable file contains "random" non-marked vectors. */
-
-static Boolean nmv_p = false;
-
-#define TC_C_COMPILED_TAG TC_MANIFEST_CLOSURE
-#define C_COMPILED_FAKE_NMV 0
-#define C_COMPILED_ENTRY_FORMAT 1
-#define C_COMPILED_ENTRY_CODE 2
-#define C_COMPILED_CLOSURE_HEADER 3
-#define C_COMPILED_MULTI_CLOSURE_HEADER 4
-#define C_COMPILED_LINKAGE_HEADER 5
-#define C_COMPILED_RAW_TRIPLE 6
-#define C_COMPILED_EXECUTE_ENTRY 7
-#define C_COMPILED_EXECUTE_ARITY 8
-
-/* Global data */
-
-#ifndef HEAP_IN_LOW_MEMORY
-SCHEME_OBJECT * memory_base;
-#endif
-
-static long
- compiler_processor_type = COMPILER_PROCESSOR_TYPE,
- compiler_interface_version = 0;
-
-static SCHEME_OBJECT
- compiler_utilities = SHARP_F;
-\f
-/* Utilities */
-
-static char
- *input_file_name = "-",
- *output_file_name = "-";
-
-FILE *input_file, *output_file;
-
-static Boolean
-DEFUN (strequal, (s1, s2), register char * s1 AND register char * s2)
-{
- for ( ; *s1 != '\0'; s1++, s2++)
- if (*s1 != *s2)
- return (false);
- return (*s2 == '\0');
-}
-
-static void
-DEFUN (setup_io, (input_mode, output_mode),
- CONST char * input_mode AND CONST char * output_mode)
-{
- if (strequal (input_file_name, "-"))
- input_file = stdin;
- else
- {
- input_file = (fopen (input_file_name, input_mode));
- if (input_file == ((FILE *) NULL))
- {
- fprintf (stderr, "%s: failed to open %s for input.\n",
- program_name, input_file_name);
- exit (1);
- }
- }
-
- if (strequal (output_file_name, "-"))
- output_file = stdout;
- else
- {
- output_file = (fopen (output_file_name, output_mode));
- if (output_file == ((FILE *) NULL))
- {
- fprintf (stderr, "%s: failed to open %s for output.\n",
- program_name, output_file_name);
- fclose (input_file);
- exit (1);
- }
- }
- return;
-}
-
-static void
-DEFUN (quit, (code), int code)
-{
- fclose(input_file);
- fclose(output_file);
-#ifdef vms
- /* This assumes that it is only invoked with 0 in tail recursive psn. */
- if (code != 0)
- exit(code);
- else
- return;
-#else /* not vms */
- exit(code);
-#endif /*vms */
-}
-\f
-#ifndef TERM_COMPILER_DEATH
-#define TERM_COMPILER_DEATH 0
-#endif
-
-void
-DEFUN (gc_death, (code, message, scan, free),
- long code
- AND char * message
- AND SCHEME_OBJECT * scan
- AND SCHEME_OBJECT * free)
-{
- fprintf (stderr, "%s: %s\n", program_name, message);
- quit (1);
-}
-
-/* Include the command line parser */
-
-#include "comlin.c"
-
-#define INPUT_KEYWORD() \
-KEYWORD("input", &input_file_name, STRING_KYWRD, SFRMT, NULL)
-
-#define OUTPUT_KEYWORD() \
-KEYWORD("output", &output_file_name, STRING_KYWRD, SFRMT, NULL)
-
-#endif /* PSBMAP_H_INCLUDED */
+++ /dev/null
-/* -*-C-*-
-
-$Id: psbtobin.c,v 9.66 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This file contains the code to translate portable format binary
- files to internal format. */
-\f
-/* Cheap renames */
-
-#include "psbmap.h"
-#include "float.h"
-#include "limits.h"
-#define portable_file input_file
-#define internal_file output_file
-
-#undef HEAP_MALLOC
-#define HEAP_MALLOC malloc
-
-static Boolean
- band_p = false,
- allow_compiled_p = false,
- allow_nmv_p = false,
- warn_portable_p = true,
- c_compiled_p = false;
-
-static long
- Dumped_Object_Addr, Dumped_Compiler_Utilities,
- Dumped_Heap_Base, Dumped_Heap_Limit, Heap_Objects, Heap_Count,
- Dumped_Const_Base, Dumped_Const_Limit, Const_Objects, Const_Count,
- Dumped_Pure_Base, Dumped_Pure_Limit, Pure_Objects, Pure_Count,
- Primitive_Table_Length, Max_Stack_Offset,
- C_Code_Table_Length, C_Code_Reserved_Entries;
-
-static SCHEME_OBJECT
- * Heap, * Constant_Space, * Constant_Top, * Stack_Top,
- * Heap_Base, * Heap_Table, * Heap_Object_Limit,
- * Heap_Pointers, * Free,
- * Const_Base, * Const_Table, * Const_Object_Limit,
- * Const_Pointers, * Free_Const,
- * Pure_Base, * Pure_Table, * Pure_Object_Limit,
- * Pure_Pointers, * Free_Pure;
-
-static long
-DEFUN (Write_Data, (Count, From_Where),
- long Count AND
- SCHEME_OBJECT *From_Where)
-{
- return (fwrite (((char *) From_Where),
- (sizeof (SCHEME_OBJECT)),
- Count,
- internal_file));
-}
-
-#include "fasl.h"
-#include "dump.c"
-
-#ifndef MAKE_FORMAT_WORD
-#define MAKE_FORMAT_WORD(h,l) 0
-#endif
-
-#ifndef WRITE_LABEL_DESCRIPTOR
-#define WRITE_LABEL_DESCRIPTOR(e,f,o) do { } while (0)
-#endif
-
-#ifndef MAKE_LINKAGE_SECTION_HEADER
-#define MAKE_LINKAGE_SECTION_HEADER(kind,count) 0
-#endif
-\f
-/*
- The following two lines appears by courtesy of your friendly
- VMS C compiler and runtime library.
-
- Bug in version 4 VMS scanf.
- */
-
-#ifndef vms
-
-#define VMS_BUG(stmt)
-
-#define read_hex_digit(var) \
-{ \
- VMS_BUG (var = 0); \
- fscanf (portable_file, "%1lx", &var); \
-}
-
-#else
-
-#define VMS_BUG(stmt) stmt
-
-#define read_hex_digit (var) \
-{ \
- var = (read_hex_digit_procedure ()); \
-}
-
-long
-read_hex_digit_procedure ()
-{
- long digit;
- int c;
-
- while ((c = fgetc (portable_file)) == ' ')
- {};
- digit = ((c >= 'a') ? (c - 'a' + 10)
- : ((c >= 'A') ? (c - 'A' + 10)
- : ((c >= '0') ? (c - '0')
- : fprintf (stderr, "Losing big: %d\n", c))));
- return (digit);
-}
-
-#endif
-\f
-static void
-DEFUN_VOID (inconsistency)
-{
- /* Provide some context (2 lines). */
- char yow[100];
-
- fgets (&yow[0], 100, portable_file);
- fprintf (stderr, "%s\n", &yow[0]);
- fgets (&yow[0], 100, portable_file);
- fprintf (stderr, "%s\n", &yow[0]);
-
- quit (1);
- /*NOTREACHED*/
-}
-
-#define OUT(c) return ((long) ((c) & UCHAR_MAX))
-
-static long
-DEFUN_VOID (read_a_char)
-{
- fast char C;
-
- C = getc (portable_file);
- if (C != '\\')
- OUT (C);
-
- C = getc (portable_file);
- switch (C)
- {
- case 'n': OUT ('\n');
- case 't': OUT ('\t');
- case 'b': OUT ('\b');
- case 'r': OUT ('\r');
- case 'f': OUT ('\f');
- case '\\': OUT ('\\');
- case '0': OUT ('\0');
- case 'X':
- {
- long Code;
-
- if (warn_portable_p)
- {
- warn_portable_p = false;
- fprintf (stderr,
- "%s: File is not Portable. Character Code Found.\n",
- program_name);
- }
- VMS_BUG (Code = 0);
- fscanf (portable_file, "%ld", &Code);
- getc (portable_file); /* Space */
- OUT (Code);
- }
- default : OUT (C);
- }
-}
-\f
-static SCHEME_OBJECT *
-DEFUN (read_a_char_pointer, (to), SCHEME_OBJECT * to)
-{
- long len, maxlen;
- char * str;
-
- VMS_BUG (len = 0);
- fscanf (portable_file, "%ld", &len);
-
- maxlen = (len + 1); /* null terminated */
- str = ((char *) to);
- getc (portable_file); /* space */
-
- while (--len >= 0)
- *str++ = ((char) (read_a_char ()));
- *str = '\0';
- return (to + (BYTES_TO_WORDS (maxlen)));
-}
-
-static SCHEME_OBJECT *
-DEFUN (read_a_string_internal, (To, maxlen),
- SCHEME_OBJECT * To AND long maxlen)
-{
- long ilen, Pointer_Count;
- fast char *str;
- fast long len;
-
- str = ((char *) (&To[STRING_CHARS]));
- VMS_BUG (ilen = 0);
- fscanf (portable_file, "%ld", &ilen);
- len = ilen;
-
- if (maxlen == -1)
- maxlen = len;
-
- /* Null terminated */
-
- maxlen += 1;
-
- Pointer_Count = (STRING_CHARS + (char_to_pointer (maxlen)));
- To[STRING_HEADER] =
- (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)));
- To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
-
- /* Space */
-
- getc (portable_file);
- while (--len >= 0)
- *str++ = ((char) (read_a_char ()));
- *str = '\0';
- return (To + Pointer_Count);
-}
-
-static SCHEME_OBJECT *
-DEFUN (read_a_string, (To, Slot),
- SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
-{
- long maxlen;
-
- *Slot = (MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, To));
- VMS_BUG (maxlen = 0);
- fscanf (portable_file, "%ld", &maxlen);
- return (read_a_string_internal (To, maxlen));
-}
-\f
-static SCHEME_OBJECT *
-DEFUN (read_an_integer, (The_Type, To, Slot),
- int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
-{
- Boolean negative;
- fast long length_in_bits;
-
- getc (portable_file); /* Space */
- negative = ((getc (portable_file)) == '-');
- {
- long l;
- VMS_BUG (l = 0);
- fscanf (portable_file, "%ld", (&l));
- length_in_bits = l;
- }
- if ((length_in_bits <= fixnum_to_bits)
- && (The_Type == TC_FIXNUM))
- {
- /* The most negative fixnum is handled in the bignum case */
- fast long Value = 0;
- fast int Normalization;
- fast long ndigits;
- long digit;
-
- if (length_in_bits != 0)
- {
- for (Normalization = 0,
- ndigits = hex_digits (length_in_bits);
- --ndigits >= 0;
- Normalization += 4)
- {
- read_hex_digit (digit);
- Value += (digit << Normalization);
- }
- }
- if (negative)
- Value = -Value;
-
- *Slot = (LONG_TO_FIXNUM (Value));
- return (To);
- }
- else if (length_in_bits == 0)
- {
- SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
- long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (0));
- (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
- BIGNUM_SET_HEADER (bignum, 0, 0);
- (*Slot) = bignum;
- return (To + gc_length + 1);
- }
- else
- {
- SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
- bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (length_in_bits));
- long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (length));
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- fast bignum_digit_type accumulator = 0;
- fast int bits_in_digit =
- ((length_in_bits < BIGNUM_DIGIT_LENGTH)
- ? length_in_bits
- : BIGNUM_DIGIT_LENGTH);
- fast int position = 0;
- long original_length_in_bits = length_in_bits;
- long hex_digit, low_digit;
-
- while (length_in_bits > 0)
- {
- read_hex_digit (hex_digit);
- if (bits_in_digit > 4)
- {
- accumulator |= (hex_digit << position);
- length_in_bits -= 4;
- position += 4;
- bits_in_digit -= 4;
- }
- else if (bits_in_digit == 4)
- {
- (*scan++) = (accumulator | (hex_digit << position));
- accumulator = 0;
- position = 0;
- length_in_bits -= 4;
- bits_in_digit =
- ((length_in_bits < BIGNUM_DIGIT_LENGTH)
- ? length_in_bits
- : BIGNUM_DIGIT_LENGTH);
- }
- else
- {
- (*scan++) =
- (accumulator |
- ((hex_digit & ((1 << bits_in_digit) - 1)) << position));
- accumulator = (hex_digit >> bits_in_digit);
- position = (4 - bits_in_digit);
- length_in_bits -= 4;
- if (length_in_bits <= 0)
- {
- (*scan) = accumulator;
- break;
- }
- else if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
- bits_in_digit = BIGNUM_DIGIT_LENGTH;
- else
- bits_in_digit = length_in_bits;
- }
- }
- (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
- BIGNUM_SET_HEADER (bignum, length, negative);
-
- /* The following test depends on BIGNUM_DIGITs being long */
-
- low_digit = (- (BIGNUM_REF (bignum, 0)));
- if (negative
- && (The_Type == TC_FIXNUM)
- && (original_length_in_bits == (fixnum_to_bits + 1))
- && (LONG_TO_FIXNUM_P (low_digit)))
- {
- *Slot = (LONG_TO_FIXNUM (low_digit));
- return (To);
- }
- else
- {
- *Slot = bignum;
- return (To + gc_length + 1);
- }
- }
-}
-
-SCHEME_OBJECT *
-DEFUN (read_a_bignum, (The_Type, To, Slot),
- int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
-{
- return (read_an_integer (The_Type, To, Slot));
-}
-\f
-static SCHEME_OBJECT *
-DEFUN (read_a_bit_string, (To, Slot),
- SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
-{
- long size_in_bits, size_in_words;
- SCHEME_OBJECT the_bit_string;
-
- VMS_BUG (size_in_bits = 0);
- fscanf (portable_file, "%ld", &size_in_bits);
- size_in_words = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (size_in_bits)));
-
- the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, To));
- *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words));
- *To = size_in_bits;
- To += size_in_words;
-
- if (size_in_bits != 0)
- {
- unsigned long temp;
- fast SCHEME_OBJECT *scan;
- fast long bits_remaining, bits_accumulated;
- fast SCHEME_OBJECT accumulator;
-
- accumulator = 0;
- bits_accumulated = 0;
- scan = (BIT_STRING_LOW_PTR (the_bit_string));
- for (bits_remaining = size_in_bits;
- bits_remaining > 0;
- bits_remaining -= 4)
- {
- read_hex_digit (temp);
- if ((bits_accumulated + 4) > OBJECT_LENGTH)
- {
- accumulator |=
- ((temp & LOW_MASK (OBJECT_LENGTH - bits_accumulated)) <<
- bits_accumulated);
- *(INC_BIT_STRING_PTR (scan)) = accumulator;
- accumulator = (temp >> (OBJECT_LENGTH - bits_accumulated));
- bits_accumulated -= (OBJECT_LENGTH - 4);
- temp &= LOW_MASK (bits_accumulated);
- }
- else
- {
- accumulator |= (temp << bits_accumulated);
- bits_accumulated += 4;
- }
- }
- if (bits_accumulated != 0)
- {
- *(INC_BIT_STRING_PTR (scan)) = accumulator;
- }
- }
- *Slot = the_bit_string;
- return (To);
-}
-\f
-/* Underflow and Overflow */
-
-/* dflmax and dflmin exist in the Berserkely FORTRAN library */
-
-static double the_max = 0.0;
-
-#define dflmin() 0.0 /* Cop out */
-#define dflmax() ((the_max == 0.0) ? (compute_max ()) : the_max)
-
-static double
-DEFUN_VOID (compute_max)
-{
- fast double Result;
- fast int expt;
-
- Result = 0.0;
- for (expt = DBL_MAX_EXP; expt != 0; expt >>= 1)
- Result += (ldexp (1.0, expt));
- the_max = Result;
- return (Result);
-}
-
-static long
-DEFUN (read_signed_decimal, (stream), fast FILE * stream)
-{
- fast int c = (getc (stream));
- fast long result = (-1);
- int negative_p = 0;
- while (c == ' ')
- c = (getc (stream));
-
- if (c == '+')
- c = (getc (stream));
- else if (c == '-')
- {
- negative_p = 1;
- c = (getc (stream));
- }
-
- if ((c >= '0') && (c <= '9'))
- {
- result = (c - '0');
- c = (getc (stream));
- while ((c >= '0') && (c <= '9'))
- {
- result = ((result * 10) + (c - '0'));
- c = (getc (stream));
- }
- }
- if (c != EOF)
- ungetc (c, stream);
-
- if (result == (-1))
- {
- fprintf (stderr, "%s: Unable to read expected decimal integer\n",
- program_name);
- inconsistency ();
- }
- return (negative_p ? (-result) : result);
-}
-\f
-static double
-DEFUN_VOID (read_a_flonum)
-{
- Boolean negative;
- long exponent;
- long size_in_bits;
- fast double Result;
-
- getc (portable_file); /* Space */
- negative = ((getc (portable_file)) == '-');
- /* Hair here because portable file format incorrect for flonum 0. */
- exponent = (read_signed_decimal (portable_file));
- if (exponent == 0)
- {
- int c = (getc (portable_file));
- if (c == '\n')
- return (0);
- ungetc (c, portable_file);
- }
- size_in_bits = (read_signed_decimal (portable_file));
- if (size_in_bits == 0)
- return (0);
-
- if ((exponent > DBL_MAX_EXP) || (exponent < DBL_MIN_EXP))
- {
- /* Skip over mantissa */
-
- while ((getc (portable_file)) != '\n')
- ;
- fprintf (stderr,
- "%s: Floating point exponent too %s!\n",
- program_name,
- ((exponent < 0) ? "small" : "large"));
- Result = ((exponent < 0) ? (dflmin ()) : (dflmax ()));
- }
- else
- {
- fast long ndigits;
- fast double Normalization;
- long digit;
-
- if (size_in_bits > DBL_MANT_DIG)
- fprintf (stderr,
- "%s: Some precision may be lost.",
- program_name);
- getc (portable_file); /* Space */
- for (ndigits = (hex_digits (size_in_bits)),
- Result = 0.0,
- Normalization = (1.0 / 16.0);
- --ndigits >= 0;
- Normalization /= 16.0)
- {
- read_hex_digit (digit);
- Result += (((double ) digit) * Normalization);
- }
- Result = (ldexp (Result, ((int) exponent)));
- }
- if (negative)
- Result = -Result;
-
- return (Result);
-}
-\f
-static SCHEME_OBJECT *
-DEFUN (Read_External, (N, Table, To),
- long N
- AND fast SCHEME_OBJECT * Table
- AND SCHEME_OBJECT * To)
-{
- fast SCHEME_OBJECT *Until = &Table[N];
- int The_Type;
-
- while (Table < Until)
- {
- VMS_BUG (The_Type = 0);
- fscanf (portable_file, "%2x", &The_Type);
- switch (The_Type)
- {
- case TC_CHARACTER_STRING:
- To = (read_a_string (To, Table++));
- continue;
-
- case TC_BIT_STRING:
- To = (read_a_bit_string (To, Table++));
- continue;
-
- case TC_FIXNUM:
- To = (read_an_integer (The_Type, To, Table++));
- continue;
-
- case TC_BIG_FIXNUM:
- To = (read_a_bignum (The_Type, To, Table++));
- continue;
-
- case TC_CHARACTER:
- {
- unsigned long the_char_code;
-
- getc (portable_file); /* Space */
- VMS_BUG (the_char_code = 0);
- fscanf (portable_file, "%6lx", &the_char_code);
- *Table++ = (MAKE_OBJECT (TC_CHARACTER, the_char_code));
- continue;
- }
-
- case TC_BIG_FLONUM:
- {
- double The_Flonum = (read_a_flonum ());
-
- ALIGN_FLOAT (To);
- *Table++ = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To));
- *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer)));
- *((double *) To) = The_Flonum;
- To += float_to_pointer;
- continue;
- }
-
- default:
- fprintf (stderr,
- "%s: Unknown external object found; Type = 0x%02x\n",
- program_name, The_Type);
- inconsistency ();
- /*NOTREACHED*/
- }
- }
- return (To);
-}
-\f
-#define DEBUG 0
-
-#if (DEBUG > 2)
-
-static void
-DEFUN (print_external_objects, (area_name, Table, N),
- char * area_name
- AND fast SCHEME_OBJECT * Table
- AND fast long N)
-{
- fast SCHEME_OBJECT * Table_End = &Table[N];
-
- fprintf (stderr, "%s External Objects:\n", area_name);
- fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
-
- for ( ; Table < Table_End; Table++)
- {
- switch (OBJECT_TYPE (*Table))
- {
- case TC_FIXNUM:
- {
- fprintf (stderr,
- "Table[%6d] = Fixnum %d\n",
- (N - (Table_End - Table)),
- (FIXNUM_TO_LONG (*Table)));
- break;
- }
- case TC_CHARACTER:
- fprintf (stderr,
- "Table[%6d] = Character 0x%07x\n",
- (N - (Table_End - Table)),
- (OBJECT_DATUM (*Table)));
- break;
-
- case TC_CHARACTER_STRING:
- fprintf (stderr,
- "Table[%6d] = string \"%s\"\n",
- (N - (Table_End - Table)),
- ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
- break;
-
- case TC_BIG_FIXNUM:
- fprintf (stderr,
- "Table[%6d] = Bignum\n",
- (N - (Table_End - Table)));
- break;
-
- case TC_BIG_FLONUM:
- fprintf (stderr,
- "Table[%6d] = Flonum %lf\n",
- (N - (Table_End - Table)),
- (* ((double *) MEMORY_LOC (*Table, 1))));
- break;
-
- default:
- fprintf (stderr,
- "Table[%6d] = Unknown External Object 0x%8x\n",
- (N - (Table_End - Table)),
- *Table);
- break;
- }
- }
- return;
-}
-
-#endif /* DEBUG > 1 */
-\f
-#if (DEBUG > 0)
-
-#define WHEN(condition, message) when (condition, message)
-
-static void
-DEFUN (when, (what, message), Boolean what AND char * message)
-{
- if (what)
- {
- fprintf (stderr, "%s: Inconsistency: %s!\n",
- program_name, (message));
- inconsistency ();
- }
- return;
-}
-
-#else /* DEBUG <= 0 */
-
-#define WHEN(what, message) do { } while (0)
-
-#endif /* DEBUG > 0 */
-
-#if (DEBUG > 1)
-
-#define DEBUGGING(action) action
-
-#define READ_HEADER_FAILURE(string) do \
-{ \
- fprintf (stderr, "Unable to read header field \"%s\".\n", (string)); \
-} while (0)
-
-#define READ_HEADER_SUCCESS(string, format, value) do \
-{ \
- fprintf (stderr, "%s: ", (string)); \
- fprintf (stderr, (format), (value)); \
- fprintf (stderr, "\n"); \
-} while (0)
-
-#else /* DEBUG <= 1 */
-
-#define DEBUGGING(action) do { } while (0)
-
-#define READ_HEADER_FAILURE(s) do { } while (0)
-#define READ_HEADER_SUCCESS(s,f,v) do { } while (0)
-
-#endif /* DEBUG > 0 */
-
-#if (DEBUG > 2)
-
-#define XDEBUGGING(action) DEBUGGING(action)
-
-#else /* DEBUG <= 2 */
-
-#define XDEBUGGING(action) do { } while (0)
-
-#endif /* DEBUG > 2 */
-\f
-void
-DEFUN (relocation_error, (addr), long addr)
-{
- fprintf (stderr, "%s: Out of range address %ld.\n",
- program_name, addr);
- inconsistency ();
- /*NOTREACHED*/
-}
-
-#define Relocate_Into(Where, Addr) do \
-{ \
- long _addr = (Addr); \
- \
- if ((_addr >= Dumped_Heap_Base) && (_addr < Dumped_Heap_Limit)) \
- (Where) = &Heap_Pointers[_addr - Dumped_Heap_Base]; \
- else if ((_addr >= Dumped_Const_Base) \
- && (_addr < Dumped_Const_Limit)) \
- (Where) = &Const_Pointers[_addr - Dumped_Const_Base]; \
- else if ((_addr >= Dumped_Pure_Base) \
- && (_addr < Dumped_Pure_Limit)) \
- (Where) = &Pure_Pointers[_addr - Dumped_Pure_Base]; \
- else \
- (void) relocation_error (_addr); \
-} while (0)
-
-#ifndef Conditional_Bug
-
-#define Relocate(Addr) \
-((((Addr) >= Dumped_Heap_Base) && ((Addr) < Dumped_Heap_Limit)) \
- ? &Heap_Pointers[(Addr) - Dumped_Heap_Base] \
- : ((((Addr) >= Dumped_Const_Base) && ((Addr) < Dumped_Const_Limit)) \
- ? &Const_Pointers[(Addr) - Dumped_Const_Base] \
- : ((((Addr) >= Dumped_Pure_Base) && ((Addr) < Dumped_Pure_Limit)) \
- ? &Pure_Pointers[(Addr) - Dumped_Pure_Base] \
- : ((relocation_error (Addr)), ((SCHEME_OBJECT *) NULL)))))
-
-#else
-
-static SCHEME_OBJECT * Relocate_Temp;
-
-#define Relocate(Addr) \
- (Relocate_Into (Relocate_Temp, Addr), Relocate_Temp)
-
-#endif
-\f
-static SCHEME_OBJECT *
-DEFUN (Read_Pointers_and_Relocate, (how_many, to),
- fast long how_many AND fast SCHEME_OBJECT * to)
-{
- int The_Type;
- long The_Datum;
-
- while ((--how_many) >= 0)
- {
- VMS_BUG (The_Type = 0);
- VMS_BUG (The_Datum = 0);
- fscanf (portable_file, "%2x %lx", &The_Type, &The_Datum);
- switch (The_Type)
- {
- case CONSTANT_CODE:
- WHEN (((The_Datum < 0) || (The_Datum >= Const_Objects)),
- "CONSTANT_CODE too large");
- *to++ = Const_Table[The_Datum];
- continue;
-
- case HEAP_CODE:
- WHEN (((The_Datum < 0) || (The_Datum >= Heap_Objects)),
- "HEAP_CODE too large");
- *to++ = Heap_Table[The_Datum];
- continue;
-
- case PURE_CODE:
- WHEN (((The_Datum < 0) || (The_Datum >= Pure_Objects)),
- "PURE_CODE too large");
- *to++ = Pure_Table[The_Datum];
- continue;
-
- case TC_MANIFEST_NM_VECTOR:
- *to++ = (MAKE_OBJECT (The_Type, The_Datum));
- {
- fast long count;
-
- count = The_Datum;
- how_many -= count;
- while (--count >= 0)
- {
- VMS_BUG (*to = 0);
- fscanf (portable_file, "%lx", to++);
- }
- }
- continue;
-
- case TC_BROKEN_HEART:
- if (The_Datum != 0)
- {
- fprintf (stderr, "%s: Broken Heart found.\n", program_name);
- inconsistency ();
- }
- /* fall through */
-
- case TC_PCOMB0:
- case TC_PRIMITIVE:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_simple_Non_Pointer:
- *to++ = (MAKE_OBJECT (The_Type, The_Datum));
- continue;
-\f
- case TC_COMPILED_ENTRY:
- {
- SCHEME_OBJECT * temp, * entry_addr;
- long base_type, base_datum;
-
- VMS_BUG (base_type = 0);
- VMS_BUG (base_datum = 0);
- fscanf (portable_file, "%02lx %lx", &base_type, &base_datum);
- temp = (Relocate (base_datum));
- if (c_compiled_p)
- entry_addr = &temp[The_Datum];
- else
- entry_addr = ((SCHEME_OBJECT *) (&(((char *) temp) [The_Datum])));
- *to++ = (MAKE_POINTER_OBJECT (base_type, entry_addr));
- continue;
- }
-
- case TC_C_COMPILED_TAG:
- {
- if (! c_compiled_p)
- {
- fprintf (stderr, "%s: C-compiled code descriptors found.\n",
- program_name);
- inconsistency ();
- }
- switch (The_Datum)
- {
- case C_COMPILED_FAKE_NMV:
- {
- long nmv_length;
-
- VMS_BUG (nmv_length = 0);
- fscanf (portable_file, "%lx", &nmv_length);
- *to++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length));
- continue;
- }
-
- case C_COMPILED_ENTRY_FORMAT:
- {
- long low_byte, high_byte, offset, format;
-
- VMS_BUG (low_byte = 0);
- VMS_BUG (high_byte = 0);
- VMS_BUG (offset = 0);
- fscanf (portable_file, "%ld %ld %lx",
- &low_byte, &high_byte, &offset);
- format = (MAKE_FORMAT_WORD (high_byte, low_byte));
- to += 1;
- WRITE_LABEL_DESCRIPTOR (to, format, offset);
- continue;
- }
-
- case C_COMPILED_ENTRY_CODE:
- {
- long entry_number;
-
- VMS_BUG (entry_number = 0);
- fscanf (portable_file, "%lx", &entry_number);
- *to++ = ((SCHEME_OBJECT) entry_number);
- continue;
- }
-\f
- case C_COMPILED_CLOSURE_HEADER:
- {
- long header_datum;
-
- VMS_BUG (header_datum = 0);
- fscanf (portable_file, "%lx", &header_datum);
- *to++ = (MAKE_OBJECT (TC_MANIFEST_CLOSURE, header_datum));
- continue;
- }
-
- case C_COMPILED_MULTI_CLOSURE_HEADER:
- {
- long nentries;
-
- VMS_BUG (nentries = 0);
- fscanf (portable_file, "%lx", &nentries);
- to += 1;
- WRITE_LABEL_DESCRIPTOR (to, nentries, 0);
- continue;
- }
-
- case C_COMPILED_LINKAGE_HEADER:
- {
- long kind, count;
-
- VMS_BUG (kind = 0);
- VMS_BUG (count = 0);
- fscanf (portable_file, "%lx %lx", &kind, &count);
- *to++ = (MAKE_LINKAGE_SECTION_HEADER (kind, count));
- continue;
- }
-
- case C_COMPILED_RAW_TRIPLE:
- {
- long triple_datum;
-
- VMS_BUG (triple_datum = 0);
- fscanf (portable_file, "%lx", &triple_datum);
- *to++ = (ADDR_TO_SCHEME_ADDR (Relocate (triple_datum)));
- continue;
- }
-
- case C_COMPILED_EXECUTE_ENTRY:
- {
- long offset, block_base;
- SCHEME_OBJECT * temp;
-
- VMS_BUG (offset = 0);
- VMS_BUG (block_base = 0);
- fscanf (portable_file, "%lx %lx", &offset, &block_base);
- temp = (Relocate (block_base));
- *to++ = (ADDR_TO_SCHEME_ADDR (&temp[offset]));
- continue;
- }
-
- case C_COMPILED_EXECUTE_ARITY:
- {
- long arity;
-
- VMS_BUG (arity = 0);
- fscanf (portable_file, "%lx", &arity);
- *to++ = ((SCHEME_OBJECT) arity);
- continue;
- }
-\f
- default:
- {
- fprintf (stderr, "%s: Unknown C compiled tag found.\n",
- program_name);
- inconsistency ();
- }
- }
- continue;
- }
-
- case TC_STACK_ENVIRONMENT:
- *to++ = (MAKE_POINTER_OBJECT (The_Type, (Stack_Top - The_Datum)));
- continue;
-
- case TC_REFERENCE_TRAP:
- if (The_Datum <= TRAP_MAX_IMMEDIATE)
- {
- *to++ = (MAKE_OBJECT (The_Type, The_Datum));
- continue;
- }
- /* It is a pointer, fall through. */
-
- default:
- /* Should be stricter */
- *to++ = (MAKE_POINTER_OBJECT (The_Type, (Relocate (The_Datum))));
- continue;
- }
- }
- return (to);
-}
-\f
-static Boolean primitive_warn = false;
-
-static SCHEME_OBJECT *
-DEFUN (read_primitives, (how_many, where),
- fast long how_many
- AND fast SCHEME_OBJECT * where)
-{
- long arity;
-
- while (--how_many >= 0)
- {
- VMS_BUG (arity = 0);
- fscanf (portable_file, "%ld", &arity);
- if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
- primitive_warn = true;
- *where++ = (LONG_TO_FIXNUM (arity));
- where = (read_a_string_internal (where, ((long) -1)));
- }
- return (where);
-}
-
-static SCHEME_OBJECT *
-DEFUN (read_c_code_blocks, (nreserved, length, area),
- long nreserved AND long length AND SCHEME_OBJECT * area)
-{
- if (length != 0)
- {
- *area++ = (LONG_TO_FIXNUM (nreserved));
- while (--length >= 0)
- {
- long nentries;
-
- VMS_BUG (nentries = 0);
- fscanf (portable_file, "%ld", &nentries);
- *area++ = (LONG_TO_FIXNUM (nentries));
- area = (read_a_char_pointer (area));
- }
- }
- return (area);
-}
-\f
-#define READ_HEADER_NO_ERROR(string, format, value, flag) do \
-{ \
- VMS_BUG (value = 0); \
- if (fscanf (portable_file, format, &(value)) == EOF) \
- { \
- (flag) = (false); \
- READ_HEADER_FAILURE (string); \
- } \
- else \
- { \
- (flag) = (true); \
- READ_HEADER_SUCCESS (string, format, value); \
- } \
-} while (0)
-
-#define READ_HEADER(string, format, value) do \
-{ \
- VMS_BUG (value = 0); \
- if (fscanf (portable_file, format, &(value)) == EOF) \
- { \
- READ_HEADER_FAILURE (string); \
- short_header_read (); \
- } \
- else \
- READ_HEADER_SUCCESS (string, format, value); \
-} while (0)
-
-static void
-DEFUN_VOID (short_header_read)
-{
- fprintf (stderr, "%s: Header is not complete!\n", program_name);
- quit (1);
-}
-\f
-/* Header:
-
- Portable Version
- Machine
- Version
- Sub Version
- Flags
- Heap Count
- Heap Base
- Heap Objects
- Constant Count
- Constant Base
- Constant Objects
- Pure Count
- Pure Base
- Pure Objects
- & Dumped Object
- Maximum Stack Offset
- Number of flonums
- Number of integers
- Number of bits in integers
- Number of bit strings
- Number of bits in bit strings
- Number of character strings
- Number of characters in strings
- Number of primitives
- Number of characters in primitives
- CPU type
- Compiled code interface version
- Compiler utilities vector
- Number of C code blocks
- Number of characters in C code blocks
- Number of reserved C entries
-
- */
-\f
-static SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address;
-
-static long
-DEFUN_VOID (Read_Header_and_Allocate)
-{
- Boolean ok;
-
- long
- Portable_Version, Machine,
- Version, Sub_Version, Flags,
- NFlonums, NIntegers, NBits,
- NBitstrs, NBBits, NStrings, NChars,
- NPChars, NCChars, Size, initial_delta;
-
- /* We don't use READ_HEADER here because it is not an error if
- there is no first word.
- .bin (and .psb) files can contain multiple objects.
- */
-
- compiler_utilities = SHARP_F;
- READ_HEADER_NO_ERROR ("Portable Version", "%ld", Portable_Version, ok);
- if (! ok)
- return (-1);
-
- if (Portable_Version != PORTABLE_VERSION)
- {
- fprintf (stderr, "%s: Portable version mismatch:\n", program_name);
- fprintf (stderr, "Portable File Version %4ld\n", Portable_Version);
- fprintf (stderr, "Expected: Version %4ld\n", PORTABLE_VERSION);
- quit (1);
- }
-
- READ_HEADER ("Machine", "%ld", Machine);
- READ_HEADER ("Version", "%ld", Version);
- READ_HEADER ("Sub Version", "%ld", Sub_Version);
-
- if ((Version != FASL_FORMAT_VERSION) ||
- (Sub_Version != FASL_SUBVERSION))
- {
- fprintf (stderr, "%s: Binary version mismatch:\n", program_name);
- fprintf (stderr,
- "Portable File Version %4ld;"
- " Binary Version %4d; Subversion %4ld\n",
- Portable_Version, Version, Sub_Version);
- fprintf (stderr,
- "Expected: Version %4d; Binary Version %4d; Subversion %4d\n",
- PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
- quit (1);
- }
-
- READ_HEADER ("Flags", "%ld", Flags);
- READ_FLAGS (Flags);
-
- if (band_p)
- allow_nmv_p = true;
- if ((Machine != FASL_INTERNAL_FORMAT)
- && ((nmv_p && (! allow_nmv_p))
- || (compiled_p && (! allow_compiled_p) && (! c_compiled_p))))
- {
- if (compiled_p)
- fprintf (stderr, "%s: %s\n", program_name,
- "Portable file contains \"non-portable\" compiled code.");
- else
- fprintf (stderr, "%s: %s\n", program_name,
- "Portable file contains \"unexpected\" non-marked vectors.");
- fprintf (stderr, "Machine specified in the portable file: %4ld\n",
- Machine);
- fprintf (stderr, "Machine Expected: %4d\n",
- FASL_INTERNAL_FORMAT);
- quit (1);
- }
-\f
- if (compiled_p
- && c_compiled_p
- && (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE))
- {
- fprintf (stderr,
- "Portable file contains descriptors for code compiled to C.\n");
- fprintf (stderr,
- "The microcode is not configured to handle such code.\n");
- quit (1);
- }
-
- READ_HEADER ("Heap Count", "%ld", Heap_Count);
- READ_HEADER ("Dumped Heap Base", "%ld", Dumped_Heap_Base);
- READ_HEADER ("Heap Objects", "%ld", Heap_Objects);
-
- READ_HEADER ("Constant Count", "%ld", Const_Count);
- READ_HEADER ("Dumped Constant Base", "%ld", Dumped_Const_Base);
- READ_HEADER ("Constant Objects", "%ld", Const_Objects);
-
- READ_HEADER ("Pure Count", "%ld", Pure_Count);
- READ_HEADER ("Dumped Pure Base", "%ld", Dumped_Pure_Base);
- READ_HEADER ("Pure Objects", "%ld", Pure_Objects);
-
- READ_HEADER ("& Dumped Object", "%ld", Dumped_Object_Addr);
- READ_HEADER ("Max Stack Offset", "%ld", Max_Stack_Offset);
-
- READ_HEADER ("Number of flonums", "%ld", NFlonums);
- READ_HEADER ("Number of integers", "%ld", NIntegers);
- READ_HEADER ("Number of bits in integers", "%ld", NBits);
- READ_HEADER ("Number of bit strings", "%ld", NBitstrs);
- READ_HEADER ("Number of bits in bit strings", "%ld", NBBits);
- READ_HEADER ("Number of character strings", "%ld", NStrings);
- READ_HEADER ("Number of characters in strings", "%ld", NChars);
-
- READ_HEADER ("Primitive Table Length", "%ld", Primitive_Table_Length);
- READ_HEADER ("Number of characters in primitives", "%ld", NPChars);
-
- READ_HEADER ("CPU type", "%ld", compiler_processor_type);
- READ_HEADER ("Compiled code interface version", "%ld",
- compiler_interface_version);
- READ_HEADER ("Compiler utilities vector", "%ld", Dumped_Compiler_Utilities);
-
- READ_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length);
- READ_HEADER ("Number of characters in C code blocks", "%ld", NCChars);
- READ_HEADER ("Number of reserved C entries", "%ld", C_Code_Reserved_Entries);
-\f
- Dumped_Heap_Limit = Dumped_Heap_Base + Heap_Count;
- Dumped_Const_Limit = Dumped_Const_Base + Const_Count;
- Dumped_Pure_Limit = Dumped_Pure_Base + Pure_Count;
-
- initial_delta = (TRAP_MAX_IMMEDIATE + 1);
- if (Max_Stack_Offset > initial_delta)
- initial_delta = Max_Stack_Offset;
-
- Size = (
- /* SNMV headers for constant and pure space */
- 6
- /* Float alignment of the different arenas */
- + (5 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))))
- /* All pointers must have datum greater than this */
- + initial_delta
- /* Incoming heap */
- + (Heap_Count + Heap_Objects)
- /* Incoming constant space */
- + (Const_Count + Const_Objects)
- /* Incoming pure space */
- + (Pure_Count + Pure_Objects)
- /* Maximum space taken up by flonums */
- + (flonum_to_pointer (NFlonums))
- /* Maximum space taken up by integers */
- + ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type)))))
- + (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits))))
- /* Maximum space taken up by strings */
- + ((NStrings * (1 + STRING_CHARS))
- + (char_to_pointer (NChars)))
- /* Maximum space taken up by bit strings */
- + ((NBitstrs * (1 + BIT_STRING_FIRST_WORD))
- + (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits)))
- /* space taken by the primitive table */
- + ((Primitive_Table_Length * (2 + STRING_CHARS))
- + (char_to_pointer (NPChars)))
- /* Space taken up by the C code block IDs */
- + (1 + (2 * C_Code_Table_Length) + (char_to_pointer (NCChars))));
-
- ALLOCATE_HEAP_SPACE (Size,
- Lowest_Allocated_Address,
- Highest_Allocated_Address);
- if (Lowest_Allocated_Address == NULL)
- {
- fprintf (stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
- program_name, Size);
- quit (1);
- }
- Heap = (Lowest_Allocated_Address + initial_delta);
- return (Size - initial_delta);
-}
-\f
-static void
-DEFUN_VOID (do_it)
-{
- while (1)
- {
- SCHEME_OBJECT
- * primitive_table, * primitive_table_end,
- * c_code_table, * c_code_table_end,
- * Dumped_Object = ((SCHEME_OBJECT *) NULL);
- Boolean result;
- long Size;
-
- Size = (Read_Header_and_Allocate ());
- if (Size < 0)
- return;
-
- if (band_p)
- warn_portable_p = false;
- Stack_Top = Heap;
- DEBUGGING (fprintf (stderr, "Stack_Top: 0x%x\n", Stack_Top));
-
- Heap_Table = &Heap[Size - Heap_Objects];
- Const_Table = &Heap_Table[- Const_Objects];
- Pure_Table = &Const_Table[- Pure_Objects];
-
- /* The various 2s below are for SNMV headers in constant/pure markers. */
-
- Constant_Space = &Heap[0];
- ALIGN_FLOAT (Constant_Space);
-
- Pure_Base = &Constant_Space[2];
- Pure_Object_Limit
- = (Read_External (Pure_Objects, Pure_Table, Pure_Base));
- Pure_Pointers = Pure_Object_Limit;
- ALIGN_FLOAT (Pure_Pointers);
-
- XDEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
- DEBUGGING (fprintf (stderr, "Pure_Base: 0x%x\n", Pure_Base));
- DEBUGGING (fprintf (stderr, "Pure_Pointers: 0x%x\n", Pure_Pointers));
-
- Const_Base = &Pure_Pointers[Pure_Count + 2];
- Const_Object_Limit
- = (Read_External (Const_Objects, Const_Table, Const_Base));
- Const_Pointers = Const_Object_Limit;
- ALIGN_FLOAT (Const_Pointers);
-
- XDEBUGGING (print_external_objects ("Constant", Const_Table,
- Const_Objects));
- DEBUGGING (fprintf (stderr, "Const_Base: 0x%x\n", Const_Base));
- DEBUGGING (fprintf (stderr, "Const_Pointers: 0x%x\n", Const_Pointers));
-
- Constant_Top = &Const_Pointers[Const_Count + 2];
-
- Heap_Base = Constant_Top;
- ALIGN_FLOAT (Heap_Base);
- Heap_Object_Limit
- = (Read_External (Heap_Objects, Heap_Table, Heap_Base));
- Heap_Pointers = Heap_Object_Limit;
- ALIGN_FLOAT (Heap_Pointers);
-
- XDEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
- DEBUGGING (fprintf (stderr, "Heap_Base: 0x%x\n", Heap_Base));
- DEBUGGING (fprintf (stderr, "Heap_Pointers: 0x%x\n", Heap_Pointers));
-
- primitive_table = &Heap_Pointers[Heap_Count];
-
- WHEN ((primitive_table > &Heap[Size]), "primitive_table overran memory.");
-
- /* Read the normal objects */
-
- Free_Pure = (Read_Pointers_and_Relocate (Pure_Count, Pure_Pointers));
- WHEN ((Free_Pure > (Const_Base - 2)),
- "Free_Pure overran Const_Base");
- WHEN ((Free_Pure < (Const_Base - 2)),
- "Free_Pure did not reach Const_Base");
-
- Free_Const = (Read_Pointers_and_Relocate (Const_Count, Const_Pointers));
- WHEN ((Free_Const > (Constant_Top - 2)),
- "Free_Const overran Constant_Top");
- WHEN ((Free_Const < (Constant_Top - 2)),
- "Free_Const did not reach Constant_Top");
-
- Free = (Read_Pointers_and_Relocate (Heap_Count, Heap_Pointers));
-
- WHEN ((Free > primitive_table), "Free overran primitive_table");
- WHEN ((Free < primitive_table), "Free did not reach primitive_table");
-
- primitive_table_end
- = (read_primitives (Primitive_Table_Length, primitive_table));
-
- if (primitive_warn)
- {
- fprintf (stderr, "%s:\n", program_name);
- fprintf
- (stderr,
- "NOTE: The binary file contains primitives with unknown arity.\n");
- }
-
- c_code_table = primitive_table_end;
- c_code_table_end
- = (read_c_code_blocks (C_Code_Reserved_Entries,
- C_Code_Table_Length,
- c_code_table));
-
- WHEN ((c_code_table_end > Pure_Table),
- "c_code_table_end overran Pure_Table");
- /*
- c_code_table_end can be well below Pure_Table, since
- the memory allocation is conservative (it rounds up), and all
- the slack ends up between them.
- */
-
- /* Dump the objects */
-
- Relocate_Into (Dumped_Object, Dumped_Object_Addr);
-
- DEBUGGING (fprintf (stderr, "Dumping:\n"));
- DEBUGGING (fprintf (stderr,
- "Heap = 0x%x; Heap Count = %d\n",
- Heap_Base, (Free - Heap_Base)));
- DEBUGGING (fprintf (stderr,
- "Pure Space = 0x%x; Pure Count = %d\n",
- Pure_Base, (Free_Pure - Pure_Base)));
- DEBUGGING (fprintf (stderr,
- "Constant Space = 0x%x; Constant Count = %d\n",
- Const_Base, (Free_Const - Const_Base)));
- DEBUGGING (fprintf (stderr,
- "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, * Dumped_Object));
- DEBUGGING (fprintf (stderr, "Primitive_Table_Length = %ld; ",
- Primitive_Table_Length));
- DEBUGGING (fprintf (stderr, "Primitive_Table_Size = %ld\n",
- (primitive_table_end - primitive_table)));
-
- if (Dumped_Compiler_Utilities != 0)
- {
- /* This knows the format of the utilities vector. */
- SCHEME_OBJECT * uv = (Relocate (Dumped_Compiler_Utilities));
- unsigned long len = uv[0];
-
- uv[len - 1] = ((SCHEME_OBJECT)
- (((unsigned long) uv[len - 1])
- * (sizeof (SCHEME_OBJECT))));
- uv[len - 0] = ((SCHEME_OBJECT)
- (((unsigned long) uv[len - 0])
- * (sizeof (SCHEME_OBJECT))));
- compiler_utilities = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, uv));
- }
-
- /* Is there a Pure/Constant block? */
-
- if ((Const_Objects == 0) && (Const_Count == 0)
- && (Pure_Objects == 0) && (Pure_Count == 0))
- result = (Write_File (Dumped_Object,
- (Free - Heap_Base), Heap_Base,
- 0, Stack_Top,
- primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)),
- c_code_table, C_Code_Table_Length,
- ((long) (c_code_table_end - c_code_table)),
- compiled_p, band_p));
- else
- {
- long Pure_Length, Total_Length;
-
- Pure_Length = ((Const_Base - Pure_Base) + 1);
- Total_Length = ((Constant_Top - Pure_Base) + 1);
- Pure_Base[-2] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR,
- Pure_Length));
- Pure_Base[-1] = (MAKE_OBJECT (PURE_PART, Total_Length));
- Const_Base[-2] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- Const_Base[-1] = (MAKE_OBJECT (CONSTANT_PART, Pure_Length));
- Free_Const[0] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- Free_Const[1] = (MAKE_OBJECT (END_OF_BLOCK, Total_Length));
-
- result = (Write_File (Dumped_Object,
- (Free - Heap_Base), Heap_Base,
- (Total_Length + 1), (Pure_Base - 2),
- primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)),
- c_code_table, C_Code_Table_Length,
- ((long) (c_code_table_end - c_code_table)),
- compiled_p, band_p));
- }
-
- if (!result)
- {
- fprintf (stderr, "%s: Error writing the output file.\n", program_name);
- quit (1);
- }
- free ((char *) Lowest_Allocated_Address);
- }
-}
-\f
-/* Top level */
-
-static Boolean
- help_p = false,
- help_sup_p;
-
-static struct keyword_struct
- options[] = {
- KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
- OUTPUT_KEYWORD (),
- INPUT_KEYWORD (),
- END_KEYWORD ()
- };
-
-int
-DEFUN (main, (argc, argv),
- int argc AND
- char **argv)
-{
- parse_keywords (argc, argv, options, false);
- if (help_sup_p && help_p)
- print_usage_and_exit (options, 0);
- /*NOTREACHED*/
-
- allow_nmv_p = (allow_nmv_p || allow_compiled_p);
-
- setup_io ("r", "wb");
- do_it ();
- quit (0);
- return (0);
-}
/* -*-C-*-
-$Id: ptrvec.c,v 1.8 2007/01/05 21:19:25 cph Exp $
+$Id: ptrvec.c,v 1.9 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
+#include "config.h"
#include "outf.h"
#include "dstack.h"
-
-#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__)
-#else
-extern PTR EXFUN (malloc, (unsigned int length));
-extern PTR EXFUN (realloc, (PTR ptr, unsigned int length));
-#endif
-
-static PTR
-DEFUN (xmalloc, (length), unsigned int length)
-{
- PTR result = (malloc (length));
- if (result == 0)
- {
- outf_fatal ("malloc: memory allocation failed\n");
- outf_flush_fatal ();
- abort ();
- }
- return (result);
-}
-
-static PTR
-DEFUN (xrealloc, (ptr, length), PTR ptr AND unsigned int length)
-{
- PTR result = (realloc (ptr, length));
- if (result == 0)
- {
- outf_fatal ("realloc: memory allocation failed\n");
- outf_flush_fatal ();
- abort ();
- }
- return (result);
-}
+#include "os.h"
Tptrvec
-DEFUN (ptrvec_allocate, (length), Tptrvec_length length)
+ptrvec_allocate (Tptrvec_length length)
{
- Tptrvec ptrvec = (xmalloc (sizeof (struct struct_ptrvec)));
+ Tptrvec ptrvec = (OS_malloc (sizeof (struct struct_ptrvec)));
(ptrvec -> length) = length;
- (ptrvec -> elements) =
- ((length > 0) ? (xmalloc (length * (sizeof (PTR)))) : 0);
+ (ptrvec -> elements)
+ = ((length > 0) ? (OS_malloc (length * (sizeof (void *)))) : 0);
return (ptrvec);
}
void
-DEFUN (ptrvec_deallocate, (ptrvec), Tptrvec ptrvec)
+ptrvec_deallocate (Tptrvec ptrvec)
{
if ((ptrvec -> length) > 0)
- free (ptrvec -> elements);
- free (ptrvec);
+ OS_free (ptrvec -> elements);
+ OS_free (ptrvec);
}
void
-DEFUN (ptrvec_set_length, (ptrvec, length),
- Tptrvec ptrvec AND
+ptrvec_set_length (Tptrvec ptrvec,
Tptrvec_length length)
{
(ptrvec -> length) = length;
- (ptrvec -> elements) =
- ((length > 0)
- ? (xrealloc ((ptrvec -> elements), (length * (sizeof (PTR)))))
- : 0);
+ (ptrvec -> elements)
+ = ((length > 0)
+ ? (OS_realloc ((ptrvec -> elements), (length * (sizeof (void *)))))
+ : 0);
}
Tptrvec
-DEFUN (ptrvec_copy, (ptrvec), Tptrvec ptrvec)
+ptrvec_copy (Tptrvec ptrvec)
{
Tptrvec_length length = (PTRVEC_LENGTH (ptrvec));
Tptrvec result = (ptrvec_allocate (length));
- PTR * scan_source = (PTRVEC_START (ptrvec));
- PTR * end_source = (scan_source + length);
- PTR * scan_result = (PTRVEC_START (result));
+ void ** scan_source = (PTRVEC_START (ptrvec));
+ void ** end_source = (scan_source + length);
+ void ** scan_result = (PTRVEC_START (result));
while (scan_source < end_source)
(*scan_result++) = (*scan_source++);
return (result);
}
void
-DEFUN (ptrvec_adjoin, (ptrvec, element), Tptrvec ptrvec AND PTR element)
+ptrvec_adjoin (Tptrvec ptrvec, void * element)
{
Tptrvec_length length = (PTRVEC_LENGTH (ptrvec));
ptrvec_set_length (ptrvec, (length + 1));
}
int
-DEFUN (ptrvec_memq, (ptrvec, element), Tptrvec ptrvec AND PTR element)
+ptrvec_memq (Tptrvec ptrvec, void * element)
{
- PTR * scan = (PTRVEC_START (ptrvec));
- PTR * end = (scan + (PTRVEC_LENGTH (ptrvec)));
+ void ** scan = (PTRVEC_START (ptrvec));
+ void ** end = (scan + (PTRVEC_LENGTH (ptrvec)));
while (scan < end)
if (element == (*scan++))
return (1);
}
void
-DEFUN (ptrvec_move_left,
- (source, source_start, source_end, target, target_start),
- Tptrvec source AND
- Tptrvec_index source_start AND
- Tptrvec_index source_end AND
- Tptrvec target AND
- Tptrvec_index target_start)
+ptrvec_move_left (Tptrvec source,
+ Tptrvec_index source_start,
+ Tptrvec_index source_end,
+ Tptrvec target,
+ Tptrvec_index target_start)
{
- PTR * scan_source = (PTRVEC_LOC (source, source_start));
- PTR * end_source = (PTRVEC_LOC (source, source_end));
- PTR * scan_target = (PTRVEC_LOC (target, target_start));
+ void ** scan_source = (PTRVEC_LOC (source, source_start));
+ void ** end_source = (PTRVEC_LOC (source, source_end));
+ void ** scan_target = (PTRVEC_LOC (target, target_start));
while (scan_source < end_source)
(*scan_target++) = (*scan_source++);
}
void
-DEFUN (ptrvec_move_right,
- (source, source_start, source_end, target, target_start),
- Tptrvec source AND
- Tptrvec_index source_start AND
- Tptrvec_index source_end AND
- Tptrvec target AND
- Tptrvec_index target_start)
+ptrvec_move_right (Tptrvec source,
+ Tptrvec_index source_start,
+ Tptrvec_index source_end,
+ Tptrvec target,
+ Tptrvec_index target_start)
{
- PTR * end_source = (PTRVEC_LOC (source, source_start));
- PTR * scan_source = (PTRVEC_LOC (source, source_end));
- PTR * scan_target =
- (PTRVEC_LOC (target, (target_start + (source_end - source_start))));
+ void ** end_source = (PTRVEC_LOC (source, source_start));
+ void ** scan_source = (PTRVEC_LOC (source, source_end));
+ void ** scan_target
+ = (PTRVEC_LOC (target, (target_start + (source_end - source_start))));
while (scan_source > end_source)
(*--scan_target) = (*--scan_source);
}
/* -*-C-*-
-$Id: purify.c,v 9.67 2007/01/05 21:19:25 cph Exp $
+$Id: purify.c,v 9.68 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* This file contains the code that copies objects into pure
- and constant space. */
+/* Copy objects into constant/pure space. */
#include "scheme.h"
#include "prims.h"
#include "gccode.h"
-#include "zones.h"
-/* Imports */
-
-extern void EXFUN (GC, (void));
-extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
-\f
-/* This is a copy of GCLoop, with mode handling added, and
- debugging printout removed.
-*/
-
-/* Purify modes */
-
-#define NORMAL_GC 0
-#define PURE_COPY 1
-#define CONSTANT_COPY 2
-
-#define Purify_Pointer(Code) \
-{ \
- Old = (OBJECT_ADDRESS (Temp)); \
- if ((GC_Mode == CONSTANT_COPY) \
- && (Old < low_heap)) \
- continue; \
- Code; \
-}
-
-#define PURIFY_RAW_POINTER(Code) \
-{ \
- Old = (SCHEME_ADDR_TO_ADDR (Temp)); \
- if ((GC_Mode == CONSTANT_COPY) \
- && (Old < low_heap)) \
- continue; \
- Code; \
-}
-
-#define Setup_Pointer_for_Purify(Extra_Code) \
-{ \
- Purify_Pointer (Setup_Pointer (false, Extra_Code)); \
-}
-
-#define Indirect_BH(In_GC) \
-{ \
- if ((OBJECT_TYPE (* Old)) == TC_BROKEN_HEART) \
- continue; \
-}
-
-#define Transport_Vector_Indirect() \
-{ \
- Real_Transport_Vector (); \
- *(OBJECT_ADDRESS (Temp)) = New_Address; \
-}
-\f
-SCHEME_OBJECT *
-DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode),
- fast SCHEME_OBJECT *Scan AND
- SCHEME_OBJECT **To_Pointer AND
- int GC_Mode)
-{
- fast SCHEME_OBJECT
- * To, * Old, Temp,
- * low_heap, New_Address;
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
- SCHEME_OBJECT object_referencing;
-#endif
-
- To = * To_Pointer;
- low_heap = Constant_Top;
- for ( ; Scan != To; Scan++)
- {
- Temp = * Scan;
-#ifdef ENABLE_GC_DEBUGGING_TOOLS
- object_referencing = Temp;
-#endif
- Switch_by_GC_Type(Temp)
- {
- case TC_BROKEN_HEART:
- if (Scan == (OBJECT_ADDRESS (Temp)))
- {
- *To_Pointer = To;
- return Scan;
- }
- sprintf(gc_death_message_buffer,
- "purifyloop: broken heart (0x%lx) in scan",
- Temp);
- gc_death(TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
- /*NOTREACHED*/
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += OBJECT_DATUM (Temp);
- break;
-\f
- /* Compiled code relocation. */
-
- case TC_LINKAGE_SECTION:
- {
- if (GC_Mode == PURE_COPY)
- {
- gc_death (TERM_COMPILER_DEATH,
- "purifyloop: linkage section in pure area",
- Scan, To);
- /*NOTREACHED*/
- }
-
- switch (READ_LINKAGE_KIND (Temp))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- /* Assumes that all others are objects of type TC_QUAD without
- their type codes.
- */
-
- fast long count;
-
- Scan++;
- for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
- --count >= 0;
- Scan += 1)
- {
- Temp = (* Scan);
- PURIFY_RAW_POINTER (Setup_Internal (false,
- TRANSPORT_RAW_TRIPLE (),
- RAW_BH (false, continue)));
- }
- Scan -= 1;
- break;
- }
-\f
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- {
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * end_scan;
-
- START_OPERATOR_RELOCATION (Scan);
- count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
- word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
- end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
-
- while(--count >= 0)
- {
- Scan = ((SCHEME_OBJECT *) word_ptr);
- word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
- EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
- PURIFY_RAW_POINTER (Setup_Aligned
- (false,
- TRANSPORT_RAW_COMPILED (),
- RAW_COMPILED_BH (false,
- goto next_operator)));
- next_operator:
- STORE_OPERATOR_LINKAGE_ADDRESS(Temp, Scan);
- }
- Scan = end_scan;
- END_OPERATOR_RELOCATION (Scan);
- break;
- }
-
- case CLOSURE_PATTERN_LINKAGE_KIND:
- Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
- break;
-
- default:
- {
- gc_death (TERM_EXIT,
- "purifyloop: Unknown compiler linkage kind.",
- Scan, Free);
- /*NOTREACHED*/
- }
- }
- break;
- }
-\f
- case TC_MANIFEST_CLOSURE:
- {
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * area_end;
-
- if (GC_Mode == PURE_COPY)
- {
- gc_death (TERM_COMPILER_DEATH,
- "purifyloop: manifest closure in pure area",
- Scan, To);
- /*NOTREACHED*/
- }
-
- START_CLOSURE_RELOCATION (Scan);
- Scan += 1;
- count = (MANIFEST_CLOSURE_COUNT (Scan));
- word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan));
- area_end = ((MANIFEST_CLOSURE_END (Scan, count)) - 1);
-
- while ((--count) >= 0)
- {
- Scan = ((SCHEME_OBJECT *) (word_ptr));
- word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
- EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
- PURIFY_RAW_POINTER (Setup_Aligned
- (false,
- TRANSPORT_RAW_COMPILED (),
- RAW_COMPILED_BH (false,
- goto next_closure)));
- next_closure:
- STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
- }
- Scan = area_end;
- END_CLOSURE_RELOCATION (Scan);
- break;
- }
-
- case_compiled_entry_point:
- if (GC_Mode != PURE_COPY)
- {
- Purify_Pointer (Setup_Aligned (false,
- Transport_Compiled (),
- Compiled_BH (false,
- goto after_entry)));
- after_entry:
- *Scan = Temp;
- }
- break;
-
- case_Cell:
- Setup_Pointer_for_Purify (Transport_Cell ());
- break;
-
- case TC_WEAK_CONS:
- Setup_Pointer_for_Purify (Transport_Weak_Cons ());
- break;
-\f
- /*
- Symbols, variables, and reference traps cannot be put into
- pure space. The strings contained in the first two can, on the
- other hand.
- */
-
- case TC_REFERENCE_TRAP:
- if (((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
- || (GC_Mode == PURE_COPY))
- {
- /* It is a non pointer. */
- break;
- }
- goto purify_pair;
-
- case TC_INTERNED_SYMBOL:
- case TC_UNINTERNED_SYMBOL:
- if (GC_Mode == PURE_COPY)
- {
- Temp = MEMORY_REF (Temp, SYMBOL_NAME);
- Purify_Pointer (Setup_Internal (false,
- Transport_Vector_Indirect (),
- Indirect_BH (false)));
- break;
- }
-
- /* Fall through */
-
- case_Fasdump_Pair:
- purify_pair:
- Setup_Pointer_for_Purify (Transport_Pair ());
- break;
-
- case TC_VARIABLE:
- case_Triple:
- Setup_Pointer_for_Purify (Transport_Triple ());
- break;
-
- case_Quadruple:
- Setup_Pointer_for_Purify (Transport_Quadruple ());
- break;
-
- case TC_COMPILED_CODE_BLOCK:
- if (GC_Mode == PURE_COPY)
- break;
- /* fall through */
-
- case TC_BIG_FLONUM:
- Purify_Pointer (Setup_Aligned (false,
- goto Move_Vector,
- Normal_BH (false, continue)));
- break;
+static void purify (SCHEME_OBJECT);
\f
- /* No need to handle futures specially here, since purifyloop
- is always invoked after running GCLoop, which will have
- spliced all spliceable futures unless the GC itself of the
- GC dameons spliced them, but this should not occur.
- */
-
- case TC_FUTURE:
- case TC_ENVIRONMENT:
- if (GC_Mode == PURE_COPY)
- {
- /* For environments, this should actually do an indirect pair
- transport of the procedure, at least.
- */
- break;
- }
- /* Fall through */
-
- case_Purify_Vector:
- Setup_Pointer_for_Purify (Transport_Vector ());
- break;
-
- default:
- GC_BAD_TYPE ("purifyloop", Temp);
- /* Fall Through */
-
- case_Non_Pointer:
- break;
-
- } /* Switch_by_GC_Type */
- } /* For loop */
-
- *To_Pointer = To;
- return (To);
-
-} /* purifyloop */
-\f
-/* Description of the algorithm for PURIFY:
-
- Purify increases the size of constant space at the expense of both
- heaps. A GC-like relocation is performed with the object being
+/* Purify increases the size of constant space at the expense of the
+ heap. A GC-like relocation is performed with the object being
purified as the root. The object is copied and relocated from the
- high heap to the area adjacent to constant space. Then the GC is
- finished after changing the end of constant-space marker.
+ heap to the area adjacent to constant space. Then a normal GC is
+ finished after changing the end of constant-space marker. */
- In order to make a pure object, the copy process proceeds in two
- halves. During the first half (which collects the pure part)
- Compiled Code, Environments, Symbols, and Variables (i.e. things
- whose contents change) are NOT copied. Then a header is put down
- indicating constant (not pure) area, and then they ARE copied.
-
- The constant area contains a contiguous set of blocks of the
- following format:
-
- >>Heap above here<<
+DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3,
+ "(OBJECT PURE? SAFETY-MARGIN)\n\
+Copy OBJECT from the heap into constant/pure space.\n\
+PURE? is ignored.")
+{
+ SCHEME_OBJECT object;
+ unsigned long safety_margin;
+ SCHEME_OBJECT daemon;
+ PRIMITIVE_HEADER (3);
- . (direction of growth)
- . ^
- . / \
- . |
- . |
- |----------------------|...
- | END | Total Size M | . Where END = TC_FIXNUM
- |----------------------| . SNMH = TC_MANIFEST_SPECIAL_...
- | SNMH | 1 | | CONST = TC_CONSTANT
- |----------------------| | PURE = TC_NULL
- | | |
- | | |
- | CONSTANT AREA | |
- | | |
- | | .
- ...|----------------------| > M
- . | CONST | Pure Size N | .
- . |----------------------| |
- | | SNMH | 1 | |
- | |----------------------| |
- | | | |
-N < | | |
- | | PURE AREA | |
- | | | |
- . | | .
- . |----------------------| .
- ...| PURE | Total Size M |...
- |----------------------|
- | SNMH | Pure Size N |
- |----------------------|
+ canonicalize_primitive_context ();
+ STACK_CHECK_FATAL ("PURIFY");
- >>Top of Stack (Stack below here)<<
+ object = (ARG_REF (1));
+ safety_margin = (ARG_HEAP_RESERVED (3));
+ POP_PRIMITIVE_FRAME (3);
-*/
-\f
-static void
-DEFUN (purify, (object, purify_mode),
- SCHEME_OBJECT object AND Boolean purify_mode)
-{
- long length, pure_length;
- SCHEME_OBJECT * new_object, * result;
- extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *));
+ ENTER_CRITICAL_SECTION ("purify");
+ heap_reserved = safety_margin;
+ purify (object);
- run_pre_gc_hooks ();
- STACK_SANITY_CHECK ("PURIFY");
- Weak_Chain = EMPTY_WEAK_CHAIN;
- Constant_Top = Free_Constant;
- new_object = Free_Constant;
- *Free_Constant++ = SHARP_F; /* Will hold pure space header */
- *Free_Constant++ = object;
- if (! (purify_mode))
- pure_length = 3;
- else
- {
- result = (purifyloop ((new_object + 1), &Free_Constant, PURE_COPY));
+ Will_Push (CONTINUATION_SIZE);
+ SET_RC (RC_NORMAL_GC_DONE);
+ SET_EXP
+ (cons (SHARP_T,
+ (ULONG_TO_FIXNUM ((HEAP_AVAILABLE > gc_space_needed)
+ ? (HEAP_AVAILABLE - gc_space_needed)
+ : 0))));
+ SAVE_CONT ();
+ Pushed ();
- if (result != Free_Constant)
- {
-purification_failure:
- outf_fatal ("\nPurify: Pure Copy ended too early.\n");
- Microcode_Termination (TERM_BROKEN_HEART);
- }
- pure_length = ((Free_Constant - new_object) + 1);
- }
- *Free_Constant++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- *Free_Constant++ = (MAKE_OBJECT (CONSTANT_PART, pure_length));
- Constant_Top = Free_Constant;
- if (purify_mode)
- {
- result = (purifyloop ((new_object + 1), &Free_Constant, CONSTANT_COPY));
- if (result != Free_Constant)
+ RENAME_CRITICAL_SECTION ("purify daemon");
+ daemon = (VECTOR_REF (fixed_objects, GC_DAEMON));
+ if (daemon != SHARP_F)
{
- outf_fatal ("\nPurify: Pure Copy ended too early.\n");
- Microcode_Termination (TERM_BROKEN_HEART);
+ Will_Push (2);
+ STACK_PUSH (daemon);
+ PUSH_APPLY_FRAME_HEADER (0);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
}
- }
- else
- {
- result = (GCLoop ((new_object + 1), &Free_Constant));
- if (result != Free_Constant)
- goto purification_failure;
- }
-
- length = ((Free_Constant - new_object) - 4);
- *Free_Constant++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- *Free_Constant++ = (MAKE_OBJECT (END_OF_BLOCK, (length + 5)));
- *new_object++ =
- (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length));
- *new_object = (MAKE_OBJECT (PURE_PART, (length + 5)));
- if (! (update_allocator_parameters (Free_Constant)))
- gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL);
- /*NOTREACHED*/
-
- SET_CONSTANT_TOP ();
- ALIGN_FLOAT (Free);
- SET_MEMTOP (Heap_Top - GC_Reserve);
- GC ();
- run_post_gc_hooks ();
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
+ /*NOTREACHED*/
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
-/* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN)
- Copy an object from the heap into constant space. This requires
- a spare heap, and is tricky to use -- it should only be used
- through the wrapper provided in the Scheme runtime system.
-
- To purify an object we just copy it into Pure Space in two
- parts with the appropriate headers and footers. The actual
- copying is done by purifyloop above.
-
- Once the copy is complete we run a full GC which handles the
- broken hearts which now point into pure space. On a
- multiprocessor, this primitive uses the master-gc-loop and it
- should only be used as one would use master-gc-loop i.e. with
- everyone else halted.
-
- This primitive always "returns" by escaping to the interpreter
- because some of its cached registers (e.g. history_register) have
- changed. */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0)
+static void
+purify (SCHEME_OBJECT object)
{
- Boolean purify_mode;
- SCHEME_OBJECT object, result, daemon;
- PRIMITIVE_HEADER (3);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ SCHEME_OBJECT * start_copy;
+ SCHEME_OBJECT * new_constant_alloc_next;
+ SCHEME_OBJECT * heap_copy_start;
- STACK_SANITY_CHECK ("PURIFY");
- Save_Time_Zone (Zone_Purify);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- CHECK_ARG (2, BOOLEAN_P);
- purify_mode = (BOOLEAN_ARG (2));
- GC_Reserve = (arg_nonnegative_integer (3));
+ STACK_CHECK_FATAL ("PURIFY");
- /* Purify only works from the high heap.
- If in the low heap, tell the runtime system.
- */
+ open_tospace (constant_alloc_next);
+ initialize_weak_chain ();
- if (Heap_Bottom < Unused_Heap_Bottom)
- PRIMITIVE_RETURN (SHARP_F);
+ start_copy = (get_newspace_ptr ());
+ add_to_tospace (object);
- POP_PRIMITIVE_FRAME (3);
+ current_gc_table = (std_gc_table ());
+ gc_scan_tospace (start_copy, 0);
- ENTER_CRITICAL_SECTION ("purify");
- purify (object, purify_mode);
- result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
- Free += 2;
- Free[-2] = SHARP_T;
- Free[-1] = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
+ new_constant_alloc_next = (get_newspace_ptr ());
+ increment_tospace_ptr (CONSTANT_SPACE_FUDGE);
+ heap_copy_start = (get_newspace_ptr ());
- Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_NORMAL_GC_DONE);
- exp_register = result;
- Save_Cont ();
- Pushed ();
+ std_gc_pt1 ();
- RENAME_CRITICAL_SECTION ("purify daemon");
- daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
- if (daemon == SHARP_F)
- PRIMITIVE_ABORT (PRIM_POP_RETURN);
- /*NOTREACHED*/
+ constant_alloc_next = new_constant_alloc_next;
+ constant_end = heap_copy_start;
+ heap_start = constant_end;
- Will_Push (2);
- STACK_PUSH (daemon);
- STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- return (0);
+ std_gc_pt2 ();
+
+ resize_tospace (heap_end - heap_start);
}
/* -*-C-*-
-$Id: purutl.c,v 9.56 2007/01/05 21:19:25 cph Exp $
+$Id: purutl.c,v 9.57 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* Pure/Constant space utilities. */
+/* Pure/constant space utilities. */
#include "scheme.h"
#include "prims.h"
-#include "gccode.h"
-#include "zones.h"
-#include "cmpint.h"
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-#endif
-\f
-static void
-DEFUN (update, (From, To, Was, Will_Be),
- fast SCHEME_OBJECT * From
- AND fast SCHEME_OBJECT * To
- AND fast SCHEME_OBJECT * Was
- AND fast SCHEME_OBJECT * Will_Be)
-{
- fast long count;
-
- for (; From < To; From++)
- {
- if (GC_Type_Special (* From))
- {
- switch (OBJECT_TYPE (* From))
- {
- case TC_MANIFEST_NM_VECTOR:
- From += (OBJECT_DATUM (* From));
- break;
-
- /* The following two type codes assume that none of the protected
- objects can be updated.
- This may be seriously wrong!
- */
- case TC_LINKAGE_SECTION:
- switch (READ_LINKAGE_KIND (* From))
- {
- case ASSIGNMENT_LINKAGE_KIND:
- case CLOSURE_PATTERN_LINKAGE_KIND:
- case REFERENCE_LINKAGE_KIND:
- {
- From += (READ_CACHE_LINKAGE_COUNT (* From));
- break;
- }
-
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- case OPERATOR_LINKAGE_KIND:
- {
- count = (READ_OPERATOR_LINKAGE_COUNT (* From));
- From = (END_OPERATOR_LINKAGE_AREA (From, count));
- break;
- }
-\f
- default:
-#ifdef BAD_TYPES_LETHAL
- {
- gc_death (TERM_EXIT,
- "Impurify: Unknown compiler linkage kind.",
- From, NULL);
- /*NOTREACHED*/
- }
-#else /* not BAD_TYPES_LETHAL */
- outf_error ("\nImpurify: Bad linkage section (0x%lx).\n",
- (* From));
-#endif /* BAD_TYPES_LETHAL */
- }
- break;
-
- case TC_MANIFEST_CLOSURE:
- {
- fast long count;
-
- From += 1;
- count = (MANIFEST_CLOSURE_COUNT (From));
- From = ((MANIFEST_CLOSURE_END (From, count)) - 1);
- break;
- }
-
- default:
- break;
- }
- }
- else if ((! (GC_Type_Non_Pointer (* From)))
- && ((OBJECT_ADDRESS (* From)) == Was))
- * From = (MAKE_POINTER_OBJECT (OBJECT_TYPE (* From), Will_Be));
- }
- return;
-}
-\f
-extern SCHEME_OBJECT * EXFUN (find_constant_space_block, (SCHEME_OBJECT *));
-
-long
-DEFUN (make_impure, (Object, New_Object),
- SCHEME_OBJECT Object AND SCHEME_OBJECT * New_Object)
-{
- fast SCHEME_OBJECT * Obj_Address, * Constant_Address;
- SCHEME_OBJECT * New_Address, * End_Of_Area;
- long Length, Block_Length;
- fast long i;
-
- /* Calculate size of object to be "impurified".
- Note that this depends on the fact that Compiled Entries CANNOT
- be pure.
- */
-
- Switch_by_GC_Type (Object)
- {
- case TC_BROKEN_HEART:
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_Non_Pointer:
-#if FALSE
- outf_fatal ("\nImpurify Non-Pointer (0x%lx)\n", Object);
- Microcode_Termination (TERM_NON_POINTER_RELOCATION);
- /* fall through */
-#endif
- case TC_BIG_FLONUM:
- return (ERR_ARG_1_WRONG_TYPE);
-
- case TC_FUTURE:
- case_Vector:
- Length = ((VECTOR_LENGTH (Object)) + 1);
- break;
-
- case_Quadruple:
- Length = 4;
- break;
-
- case TC_VARIABLE:
- case_Triple:
- Length = 3;
- break;
-
- case TC_WEAK_CONS:
- case_Pair:
- Length = 2;
- break;
-
- case_Cell:
- Length = 1;
- break;
-\f
- case TC_LINKAGE_SECTION:
- case TC_MANIFEST_CLOSURE:
- case_compiled_entry_point:
- default:
-#ifdef BAD_TYPES_LETHAL
- outf_fatal ("\nImpurify: Bad type code = 0x%02x.\n",
- OBJECT_TYPE (Object));
- Microcode_Termination (TERM_INVALID_TYPE_CODE);
- /*NOTREACHED*/
-#else /* not BAD_TYPES_LETHAL */
- outf_error ("\nImpurify: Bad type code = 0x%02x.\n",
- OBJECT_TYPE (Object));
- return (ERR_ARG_1_WRONG_TYPE);
-#endif /* BAD_TYPES_LETHAL */
- }
-
- Constant_Address = Free_Constant;
-
-#ifdef FLOATING_ALIGNMENT
-
- /* Undo ALIGN_FLOAT(Free_Constant) in SET_CONSTANT_TOP (). */
-
- while ((* (Constant_Address - 1))
- == (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)))
- Constant_Address -= 1;
-
-#endif /* FLOATING_ALIGNMENT */
-
- Obj_Address = (OBJECT_ADDRESS (Object));
-
- if (! (TEST_CONSTANT_TOP (Constant_Address + Length)))
- {
- /* Make the whole block impure! */
-
- SCHEME_OBJECT * block = (find_constant_space_block (Obj_Address));
-
- if (block == ((SCHEME_OBJECT *) NULL))
- return (ERR_IMPURIFY_OUT_OF_SPACE);
-
- * block = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- * New_Object = Object;
- return (PRIM_DONE);
- }
-
- /*
- Add a copy of the object to the last constant block in memory.
- */
-
- Block_Length = (OBJECT_DATUM (* (Constant_Address - 1)));
- Constant_Address -= 2;
- New_Address = Constant_Address;
-
- for (i = Length; --i >= 0; )
- {
- *Constant_Address++ = *Obj_Address;
- *Obj_Address++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, i));
- }
-
- *Constant_Address++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- *Constant_Address++ = (MAKE_OBJECT (END_OF_BLOCK, Block_Length + Length));
- *(New_Address + 2 - Block_Length) =
- (MAKE_OBJECT (PURE_PART, Block_Length + Length));
- Obj_Address -= Length;
- Free_Constant = Constant_Address;
- SET_CONSTANT_TOP ();
-
- /* Run through memory relocating pointers to this object, including
- * those in pure areas.
- */
-
- Terminate_Old_Stacklet ();
- SEAL_CONSTANT_SPACE ();
- End_Of_Area = (CONSTANT_AREA_END ());
-
- ENTER_CRITICAL_SECTION ("impurify");
-
- update (Heap_Bottom, Free, Obj_Address, New_Address);
- update ((CONSTANT_AREA_START ()), End_Of_Area, Obj_Address, New_Address);
-
- EXIT_CRITICAL_SECTION ({});
-
- * New_Object = (MAKE_POINTER_OBJECT (OBJECT_TYPE (Object), New_Address));
- return (PRIM_DONE);
-}
-\f
DEFINE_PRIMITIVE ("PRIMITIVE-IMPURIFY", Prim_impurify, 1, 1,
- "(object)\n\
-Remove OBJECT from pure space so it can be side effected.\n\
-The object is placed in constant space instead if it fits,\n\
-otherwise the whole block where it lives in pure space is marked\n\
-as being in constant space.")
+ "(OBJECT)\n\
+Remove OBJECT from pure space, allowing it to be modified.")
{
PRIMITIVE_HEADER (1);
- {
- fast SCHEME_OBJECT old_object;
- SCHEME_OBJECT new_object;
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), old_object);
- {
- long result = (make_impure (old_object, (&new_object)));
- if (result != PRIM_DONE)
- signal_error_from_primitive (result);
- }
- PRIMITIVE_RETURN (new_object);
- }
-}
-
-SCHEME_OBJECT *
-DEFUN (find_constant_space_block, (obj_address),
- fast SCHEME_OBJECT * obj_address)
-{
- fast SCHEME_OBJECT * where, * low_constant;
-
- low_constant = Constant_Space;
- where = (Free_Constant - 1);
-
- while (where >= low_constant)
- {
-#if FALSE
- /* Skip backwards over turds left over by ALIGN_FLOAT */
-
- /* This should be #ifdef FLOATING_ALIGNMENT, but
- works by serendipity since the padding turds have a
- datum of 0 and are correctly skipped over.
- */
-
- if (* where = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)))
- {
- where -= 1;
- continue;
- }
-#endif
- where -= (1 + (OBJECT_DATUM (* where)));
- if (where < obj_address)
- return (where + 1);
- }
- return ((SCHEME_OBJECT *) NULL);
+ PRIMITIVE_RETURN (ARG_REF (1));
}
-Boolean
-DEFUN (Pure_Test, (obj_address), SCHEME_OBJECT * obj_address)
-{
- SCHEME_OBJECT * block;
-
- block = (find_constant_space_block (obj_address));
- if (block == ((SCHEME_OBJECT *) NULL))
- return (false);
- return
- ((Boolean) (obj_address <= (block + (OBJECT_DATUM (* block)))));
-}
-\f
-DEFINE_PRIMITIVE ("PURE?", Prim_pure_p, 1, 1,
- "Return #T if OBJECT is pure (i.e. it doesn't point to any other object,\n\
-or it is in a pure section of the constant space).")
+DEFINE_PRIMITIVE ("CONSTANT?", Prim_constant_p, 1, 1,
+ "(OBJECT)\n\
+Returns #T iff OBJECT is in constant space.")
{
PRIMITIVE_HEADER (1);
- {
- fast SCHEME_OBJECT object = (ARG_REF (1));
- if ((GC_Type_Non_Pointer (object)) ||
- (GC_Type_Special (object)))
- PRIMITIVE_RETURN (SHARP_T);
- TOUCH_IN_PRIMITIVE (object, object);
- {
- SCHEME_OBJECT * address =
- ((GC_Type_Compiled (object))
- ? (compiled_entry_to_block_address (object))
- : (OBJECT_ADDRESS (object)));
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (ADDRESS_PURE_P (address)));
- }
- }
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT (object_in_constant_space_p (ARG_REF (1))));
}
-DEFINE_PRIMITIVE ("CONSTANT?", Prim_constant_p, 1, 1,
- "Return #T if OBJECT is in constant space or isn't a pointer.")
+DEFINE_PRIMITIVE ("PURE?", Prim_pure_p, 1, 1,
+ "(OBJECT)\n\
+Returns #T iff OBJECT is in constant space and is 'pure'.")
{
PRIMITIVE_HEADER (1);
- {
- fast SCHEME_OBJECT object = (ARG_REF (1));
- if ((GC_Type_Non_Pointer (object)) || (GC_Type_Special (object)))
- PRIMITIVE_RETURN (SHARP_T);
- TOUCH_IN_PRIMITIVE (object, object);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT (ADDRESS_CONSTANT_P (OBJECT_ADDRESS (object))));
- }
+ PRIMITIVE_RETURN (SHARP_F);
}
-DEFINE_PRIMITIVE ("GET-NEXT-CONSTANT", Prim_get_next_constant, 0, 0,
- "Return the next free address in constant space.")
+bool
+object_in_constant_space_p (SCHEME_OBJECT object)
{
- SCHEME_OBJECT * next_address = (Free_Constant + 1);
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (next_address)));
+ SCHEME_OBJECT * address = (get_object_address (object));
+ return ((address != 0) && (ADDRESS_IN_CONSTANT_P (address)));
}
-\f
-/* copy_to_constant_space is a microcode utility procedure.
- It takes care of making legal constant space blocks.
- The microcode kills itself if there is not enough constant
- space left.
- */
-
-extern SCHEME_OBJECT *copy_to_constant_space();
SCHEME_OBJECT *
-DEFUN (copy_to_constant_space,
- (source, nobjects),
- fast SCHEME_OBJECT *source AND
- long nobjects)
+copy_to_constant_space (SCHEME_OBJECT * source, unsigned long n_words)
{
- fast long i;
- fast SCHEME_OBJECT * dest;
SCHEME_OBJECT * result;
+ SCHEME_OBJECT * limit;
- dest = Free_Constant;
- if (!(TEST_CONSTANT_TOP (dest + nobjects + 6)))
- {
- outf_fatal ("copy_to_constant_space: Not enough constant space!\n");
- Microcode_Termination (TERM_NO_SPACE);
- }
- *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 3));
- *dest++ = (MAKE_OBJECT (PURE_PART, nobjects + 5));
- *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- *dest++ = (MAKE_OBJECT (CONSTANT_PART, 3));
- result = dest;
- for (i = nobjects; --i >= 0; )
- *dest++ = *source++;
- *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
- *dest++ = (MAKE_OBJECT (END_OF_BLOCK, nobjects + 5));
- Free_Constant = dest;
- SET_CONSTANT_TOP ();
-
+ if (n_words > (constant_end - constant_alloc_next))
+ {
+ outf_fatal ("\nInsufficient constant space!\n");
+ Microcode_Termination (TERM_NO_SPACE);
+ }
+ result = constant_alloc_next;
+ limit = (constant_alloc_next + n_words);
+ while (constant_alloc_next < limit)
+ (*constant_alloc_next++) = (*source++);
return (result);
}
-\f
-gc_hook_list pre_gc_hooks = ((gc_hook_list) NULL);
-gc_hook_list post_gc_hooks = ((gc_hook_list) NULL);
-
-static int
-DEFUN (add_gc_hook, (cell, hook),
- gc_hook_list * cell AND void EXFUN ((* hook), (void)))
-{
- gc_hook_list new = ((gc_hook_list)
- (malloc (sizeof (struct gc_hook_list_s))));
- if (new == ((gc_hook_list) NULL))
- return (-1);
-
- new->hook = hook;
- new->next = ((gc_hook_list) NULL);
-
- while ((* cell) != ((gc_hook_list) NULL))
- cell = (& ((* cell)->next));
-
- * cell = new;
- return (0);
-}
-
-static void
-DEFUN (run_gc_hooks, (gc_hooks), gc_hook_list gc_hooks)
-{
- while (gc_hooks != ((gc_hook_list) NULL))
- {
- (* (gc_hooks->hook)) ();
- gc_hooks = gc_hooks->next;
- }
- return;
-}
-
-int
-DEFUN (add_pre_gc_hook, (hook),
- void EXFUN ((* hook), (void)))
-{
- return (add_gc_hook ((& pre_gc_hooks), hook));
-}
-
-int
-DEFUN (add_post_gc_hook, (hook),
- void EXFUN ((* hook), (void)))
-{
- return (add_gc_hook ((& post_gc_hooks), hook));
-}
-
-void
-DEFUN_VOID (run_pre_gc_hooks)
-{
- run_gc_hooks (pre_gc_hooks);
- return;
-}
-
-void
-DEFUN_VOID (run_post_gc_hooks)
-{
- run_gc_hooks (post_gc_hooks);
- return;
-}
/* -*-C-*-
-$Id: regex.c,v 1.24 2007/01/05 21:19:25 cph Exp $
+$Id: regex.c,v 1.25 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* Regular expression matching and search. */
+/* Regular expression matching and search */
/* NOTE: This program was created by translation from the regular
-expression code of GNU Emacs; it was translated from the original C to
-68000 assembly language (in 1986), and then translated back from 68000
-assembly language to C (in 1987). Users should be aware that the GNU
-GENERAL PUBLIC LICENSE may apply to this code. A copy of that license
-should have been included along with this file. */
+ expression code of GNU Emacs; it was translated from the original C
+ to 68000 assembly language (in 1986), and then translated back from
+ 68000 assembly language to C (in 1987). */
#include "scheme.h"
#include "syntax.h"
#include "regex.h"
-
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-#else
- extern char * malloc ();
- extern char * realloc ();
- extern void free ();
-#endif
\f
#if defined(__IRIX__) || defined(_AIX)
-#define SIGN_EXTEND_CHAR(x) ((((int) (x)) >= 0x80) \
- ? (((int) (x)) - 0x100) \
- : ((int) (x)))
+#define SIGN_EXTEND_CHAR(x) \
+ ((((int) (x)) >= 0x80) ? (((int) (x)) - 0x100) : ((int) (x)))
#endif
#ifndef SIGN_EXTEND_CHAR
#define READ_PATTERN_OFFSET(target) do \
{ \
- SIGNED char _fetched; \
+ signed char _fetched; \
if ((pattern_pc + 1) >= pattern_end) \
BAD_PATTERN (); \
(target) = (*pattern_pc++); \
- _fetched = (* ((SIGNED char *) (pattern_pc++))); \
+ _fetched = (* ((signed char *) (pattern_pc++))); \
(target) += ((SIGN_EXTEND_CHAR (_fetched)) << ASCII_LENGTH); \
if (((pattern_pc + (target)) < pattern_start) || \
((pattern_pc + (target)) > pattern_end)) \
}
\f
void
-DEFUN (re_buffer_initialize,
- (buffer, translation, syntax_table, text,
- text_start_index, text_end_index,
- gap_start_index, gap_end_index),
- struct re_buffer * buffer
- AND unsigned char * translation
- AND SYNTAX_TABLE_TYPE syntax_table
- AND unsigned char * text
- AND unsigned long text_start_index
- AND unsigned long text_end_index
- AND unsigned long gap_start_index
- AND unsigned long gap_end_index)
+re_buffer_initialize (struct re_buffer * buffer,
+ unsigned char * translation,
+ SYNTAX_TABLE_TYPE syntax_table,
+ unsigned char * text,
+ unsigned long text_start_index,
+ unsigned long text_end_index,
+ unsigned long gap_start_index,
+ unsigned long gap_end_index)
{
unsigned char *text_start, *text_end, *gap_start, *gap_end;
#define FASTMAP_TRUE '\1'
int
-DEFUN (re_compile_fastmap,
- (pattern_start, pattern_end, translation, syntax_table, fastmap),
- unsigned char * pattern_start
- AND fast unsigned char * pattern_end
- AND unsigned char * translation
- AND SYNTAX_TABLE_TYPE syntax_table
- AND fast unsigned char * fastmap)
+re_compile_fastmap (unsigned char * pattern_start,
+ unsigned char * pattern_end,
+ unsigned char * translation,
+ SYNTAX_TABLE_TYPE syntax_table,
+ unsigned char * fastmap)
{
- fast unsigned char *pattern_pc;
+ unsigned char *pattern_pc;
unsigned char *stack_start[RE_NFAILURES];
unsigned char **stack_pointer;
int return_value;
stack_pointer = stack_start;
{
- fast int i;
+ int i;
FOR_ALL_ASCII (i)
(fastmap [i]) = FASTMAP_FALSE;
case regexpcode_exact_1:
{
- fast int ascii;
+ int ascii;
READ_PATTERN_CHAR (ascii);
(fastmap [(TRANSLATE_CHAR (ascii))]) = FASTMAP_TRUE;
case regexpcode_exact_n:
{
- fast int length;
+ int length;
READ_PATTERN_LENGTH (length);
if (length == 0)
case regexpcode_any_char:
{
- fast int ascii;
+ int ascii;
FOR_ALL_ASCII_SUCH_THAT (ascii, (ascii != '\n'))
(fastmap [(TRANSLATE_CHAR (ascii))]) = FASTMAP_TRUE;
case regexpcode_char_set:
{
- fast int length;
- fast int ascii;
+ int length;
+ int ascii;
READ_PATTERN_LENGTH (length);
length = (length * ASCII_LENGTH);
case regexpcode_not_char_set:
{
- fast int length;
- fast int ascii;
+ int length;
+ int ascii;
READ_PATTERN_LENGTH (length);
length = (length * ASCII_LENGTH);
case regexpcode_word_char:
{
- fast int ascii;
+ int ascii;
FOR_ALL_ASCII_SUCH_THAT (ascii, (WORD_CONSTITUENT_P (ascii)))
(fastmap [(TRANSLATE_CHAR (ascii))]) = FASTMAP_TRUE;
case regexpcode_not_word_char:
{
- fast int ascii;
+ int ascii;
FOR_ALL_ASCII_SUCH_THAT (ascii, (! (WORD_CONSTITUENT_P (ascii))))
(fastmap [(TRANSLATE_CHAR (ascii))]) = FASTMAP_TRUE;
case regexpcode_syntax_spec:
{
- fast enum syntaxcode code;
- fast int ascii;
+ enum syntaxcode code;
+ int ascii;
READ_PATTERN_SYNTAXCODE (code);
FOR_ALL_ASCII_SUCH_THAT (ascii, (SYNTAX_CONSTITUENT_P (code, ascii)))
case regexpcode_not_syntax_spec:
{
- fast enum syntaxcode code;
- fast int ascii;
+ enum syntaxcode code;
+ int ascii;
READ_PATTERN_SYNTAXCODE (code);
FOR_ALL_ASCII_SUCH_THAT (ascii,
case regexpcode_start_memory:
case regexpcode_stop_memory:
{
- fast int register_number;
+ int register_number;
READ_PATTERN_REGISTER (register_number);
goto loop;
case regexpcode_duplicate:
{
- fast int register_number;
- fast int ascii;
+ int register_number;
+ int ascii;
READ_PATTERN_REGISTER (register_number);
FOR_ALL_ASCII (ascii)
case regexpcode_maybe_finalize_jump:
case regexpcode_dummy_failure_jump:
{
- fast int offset;
+ int offset;
return_value = 1;
READ_PATTERN_OFFSET (offset);
case regexpcode_on_failure_jump:
{
- fast int offset;
+ int offset;
READ_PATTERN_OFFSET (offset);
(*stack_pointer++) = (pattern_pc + offset);
match_pc = gap_end; \
} while (0)
-static Boolean
-DEFUN (beq_translate, (scan1, scan2, length, translation),
- unsigned char * scan1 AND
- unsigned char * scan2 AND
- long length AND
+static bool
+beq_translate (unsigned char * scan1,
+ unsigned char * scan2,
+ long length,
unsigned char * translation)
{
while ((length--) > 0)
int re_max_failures = 1000;
int
-DEFUN (re_match,
- (pattern_start, pattern_end, buffer, registers, match_start, match_end),
- unsigned char * pattern_start
- AND unsigned char * pattern_end
- AND struct re_buffer * buffer
- AND struct re_registers * registers
- AND unsigned char * match_start
- AND unsigned char * match_end)
+re_match (unsigned char * pattern_start,
+ unsigned char * pattern_end,
+ struct re_buffer * buffer,
+ struct re_registers * registers,
+ unsigned char * match_start,
+ unsigned char * match_end)
{
- fast unsigned char *pattern_pc, *match_pc;
+ unsigned char *pattern_pc, *match_pc;
unsigned char *gap_start, *gap_end;
unsigned char *translation;
SYNTAX_TABLE_TYPE syntax_table;
stack_pointer = stack_start;
{
- fast int i;
+ int i;
FOR_INDEX_BELOW (i, RE_NREGS)
{
/* Reaching here indicates that match was successful. */
if (registers != NULL)
{
- fast int i;
+ int i;
(register_start [0]) = match_start;
(register_end [0]) = match_pc;
case regexpcode_exact_1:
{
- fast int ascii;
- fast int ascii_p;
+ int ascii;
+ int ascii_p;
READ_MATCH_CHAR (ascii);
READ_PATTERN_CHAR (ascii_p);
case regexpcode_exact_n:
{
- fast int length;
- fast int ascii;
+ int length;
+ int ascii;
READ_PATTERN_LENGTH (length);
while ((length--) > 0)
case regexpcode_any_char:
{
- fast int ascii;
+ int ascii;
READ_MATCH_CHAR (ascii);
if (ascii == '\n')
#define RE_MATCH_CHAR_SET(winning_label, losing_label) \
{ \
- fast int ascii; \
- fast int length; \
+ int ascii; \
+ int length; \
\
READ_MATCH_CHAR (ascii); \
READ_PATTERN_LENGTH (length); \
case regexpcode_start_memory:
{
- fast int register_number;
+ int register_number;
READ_PATTERN_REGISTER (register_number);
(register_start [register_number]) = match_pc;
case regexpcode_stop_memory:
{
- fast int register_number;
+ int register_number;
READ_PATTERN_REGISTER (register_number);
(register_end [register_number]) =
case regexpcode_duplicate:
{
- fast int register_number;
+ int register_number;
unsigned char *start, *end, *new_end;
long length;
case regexpcode_syntax_spec:
{
- fast int ascii;
- fast enum syntaxcode code;
+ int ascii;
+ enum syntaxcode code;
READ_MATCH_CHAR (ascii);
READ_PATTERN_SYNTAXCODE (code);
case regexpcode_not_syntax_spec:
{
- fast int ascii;
- fast enum syntaxcode code;
+ int ascii;
+ enum syntaxcode code;
READ_MATCH_CHAR (ascii);
READ_PATTERN_SYNTAXCODE (code);
case regexpcode_word_char:
{
- fast int ascii;
+ int ascii;
READ_MATCH_CHAR (ascii);
if (WORD_CONSTITUENT_P (ascii))
case regexpcode_not_word_char:
{
- fast int ascii;
+ int ascii;
READ_MATCH_CHAR (ascii);
if (! (WORD_CONSTITUENT_P (ascii)))
case regexpcode_on_failure_jump:
{
- fast long offset;
+ long offset;
READ_PATTERN_OFFSET (offset);
PUSH_FAILURE_POINT ((pattern_pc + offset), match_pc);
case regexpcode_maybe_finalize_jump:
{
- fast long offset;
- fast long ascii;
+ long offset;
+ long ascii;
READ_PATTERN_OFFSET (offset);
if (pattern_pc == pattern_end)
case regexpcode_jump:
re_match_jump:
{
- fast long offset;
+ long offset;
READ_PATTERN_OFFSET (offset);
pattern_pc += offset;
\f
#define DEFINE_RE_SEARCH(name) \
int \
-DEFUN (name, \
- (pattern_start, pattern_end, buffer, registers, \
- match_start, match_end), \
- unsigned char * pattern_start \
- AND unsigned char * pattern_end \
- AND struct re_buffer * buffer \
- AND struct re_registers * registers \
- AND unsigned char * match_start \
- AND unsigned char * match_end)
+name (unsigned char * pattern_start, \
+ unsigned char * pattern_end, \
+ struct re_buffer * buffer, \
+ struct re_registers * registers, \
+ unsigned char * match_start, \
+ unsigned char * match_end)
#define INITIALIZE_RE_SEARCH(pc, limit, gap_limit) \
int can_be_null; \
unsigned char *translation; \
int match_result; \
\
- fast unsigned char *match_pc; \
- fast unsigned char *match_limit; \
- fast unsigned char *gap_limit; \
- fast unsigned char *fastmap; \
+ unsigned char *match_pc; \
+ unsigned char *match_limit; \
+ unsigned char *gap_limit; \
+ unsigned char *fastmap; \
unsigned char fastmap_array[MAX_ASCII]; \
\
fastmap = &fastmap_array[0]; \
/* -*-C-*-
-$Id: regex.h,v 1.11 2007/01/05 21:19:25 cph Exp $
+$Id: regex.h,v 1.12 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
/* NOTE: This program was created by translation from the regular
-expression code of GNU Emacs; it was translated from the original C to
-68000 assembly language (in 1986), and then translated back from 68000
-assembly language to C (in 1987). Users should be aware that the GNU
-GENERAL PUBLIC LICENSE may apply to this code. A copy of that license
-should have been included along with this file. */
+ expression code of GNU Emacs; it was translated from the original C
+ to 68000 assembly language (in 1986), and then translated back from
+ 68000 assembly language to C (in 1987). */
\f
/* Structure to represent a buffer of text to match against.
This contains the information that an editor buffer would have
};
extern void
- EXFUN (re_buffer_initialize,
- (struct re_buffer *, unsigned char *, SYNTAX_TABLE_TYPE,
+ re_buffer_initialize (struct re_buffer *, unsigned char *, SYNTAX_TABLE_TYPE,
unsigned char *, unsigned long, unsigned long,
- unsigned long, unsigned long));
+ unsigned long, unsigned long);
extern int
- EXFUN (re_compile_fastmap,
- (unsigned char *, unsigned char *, unsigned char *,
- SYNTAX_TABLE_TYPE, unsigned char *));
+ re_compile_fastmap (unsigned char *, unsigned char *, unsigned char *,
+ SYNTAX_TABLE_TYPE, unsigned char *);
extern int
- EXFUN (re_match,
- (unsigned char *, unsigned char *, struct re_buffer *,
- struct re_registers *, unsigned char *, unsigned char *));
+ re_match (unsigned char *, unsigned char *, struct re_buffer *,
+ struct re_registers *, unsigned char *, unsigned char *);
extern int
- EXFUN (re_search_forward,
- (unsigned char *, unsigned char *, struct re_buffer *,
- struct re_registers *, unsigned char *, unsigned char *));
+ re_search_forward (unsigned char *, unsigned char *, struct re_buffer *,
+ struct re_registers *, unsigned char *, unsigned char *);
extern int
- EXFUN (re_search_backward,
- (unsigned char *, unsigned char *, struct re_buffer *,
- struct re_registers *, unsigned char *, unsigned char *));
+ re_search_backward (unsigned char *, unsigned char *, struct re_buffer *,
+ struct re_registers *, unsigned char *, unsigned char *);
/* -*-C-*-
-$Id: returns.h,v 9.47 2007/01/05 21:19:25 cph Exp $
+$Id: returns.h,v 9.48 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* Return codes. These are placed in ret_register when an
+/* Return codes. These are placed in GET_RET when an
interpreter operation needs to operate in several phases. */
\f
#define RC_END_OF_COMPUTATION 0x00
-/* formerly RC_RESTORE_CONTROL_POINT 0x01 */
+/* RC_RESTORE_CONTROL_POINT 0x01 */
#define RC_JOIN_STACKLETS 0x01
-#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */
+/* RC_RESTORE_CONTINUATION 0x02 */
#define RC_INTERNAL_APPLY 0x03
-#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */
+/* RC_BAD_INTERRUPT_CONTINUE 0x04 */
#define RC_RESTORE_HISTORY 0x05
#define RC_INVOKE_STACK_THREAD 0x06
-#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */
+/* RC_RESTART_EXECUTION 0x07 */
#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08
#define RC_EXECUTE_DEFINITION_FINISH 0x09
#define RC_EXECUTE_ACCESS_FINISH 0x0A
#define RC_PCOMB3_APPLY 0x1B
#define RC_SNAP_NEED_THUNK 0x1C
#define RC_REENTER_COMPILED_CODE 0x1D
-/* formerly RC_GET_CHAR_REPEAT 0x1E */
-#define RC_COMP_REFERENCE_RESTART 0x1F
+/* RC_GET_CHAR_REPEAT 0x1E */
+/* RC_COMP_REFERENCE_RESTART 0x1F */
#define RC_NORMAL_GC_DONE 0x20
-#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */
+/* RC_COMPLETE_GC_DONE 0x21 */
#define RC_PURIFY_GC_1 0x22
#define RC_PURIFY_GC_2 0x23
-#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */
-#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */
-/* formerly RC_GET_CHAR 0x26 */
-/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */
-#define RC_COMP_ASSIGNMENT_RESTART 0x28
+/* RC_AFTER_MEMORY_UPDATE 0x24 */
+/* RC_RESTARTABLE_EXIT 0x25 */
+/* RC_GET_CHAR 0x26 */
+/* RC_GET_CHAR_IMMEDIATE 0x27 */
+/* RC_COMP_ASSIGNMENT_RESTART 0x28 */
#define RC_POP_FROM_COMPILED_CODE 0x29
#define RC_RETURN_TRAP_POINT 0x2A
-#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */
+/* RC_RESTORE_STEPPER 0x2B */
#define RC_RESTORE_TO_STATE_POINT 0x2C
#define RC_MOVE_TO_ADJACENT_POINT 0x2D
#define RC_RESTORE_VALUE 0x2E
#define RC_RESTORE_DONT_COPY_HISTORY 0x2F
-/* The following are not used in the 68000 implementation */
#define RC_POP_RETURN_ERROR 0x40
#define RC_EVAL_ERROR 0x41
#define RC_STACK_MARKER 0x42
#define RC_COMP_INTERRUPT_RESTART 0x43
-/* formerly RC_COMP_RECURSION_GC 0x44 */
+/* RC_COMP_RECURSION_GC 0x44 */
#define RC_RESTORE_INT_MASK 0x45
#define RC_HALT 0x46
-#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */
+/* RC_FINISH_GLOBAL_INT 0x47 */
#define RC_REPEAT_DISPATCH 0x48
#define RC_GC_CHECK 0x49
-#define RC_RESTORE_FLUIDS 0x4A
-#define RC_COMP_LOOKUP_APPLY_RESTART 0x4B
-#define RC_COMP_ACCESS_RESTART 0x4C
-#define RC_COMP_UNASSIGNED_P_RESTART 0x4D
-#define RC_COMP_UNBOUND_P_RESTART 0x4E
-#define RC_COMP_DEFINITION_RESTART 0x4F
-/* formerly RC_COMP_LEXPR_INTERRUPT_RESTART 0x50 */
-#define RC_COMP_SAFE_REFERENCE_RESTART 0x51
-/* formerly RC_COMP_CACHE_LOOKUP_RESTART 0x52 */
+/* RC_RESTORE_FLUIDS 0x4A */
+/* RC_COMP_LOOKUP_APPLY_RESTART 0x4B */
+/* RC_COMP_ACCESS_RESTART 0x4C */
+/* RC_COMP_UNASSIGNED_P_RESTART 0x4D */
+/* RC_COMP_UNBOUND_P_RESTART 0x4E */
+/* RC_COMP_DEFINITION_RESTART 0x4F */
+/* RC_COMP_LEXPR_INTERRUPT_RESTART 0x50 */
+/* RC_COMP_SAFE_REFERENCE_RESTART 0x51 */
+/* RC_COMP_CACHE_LOOKUP_RESTART 0x52 */
#define RC_COMP_LOOKUP_TRAP_RESTART 0x53
#define RC_COMP_ASSIGNMENT_TRAP_RESTART 0x54
-/* formerly RC_COMP_CACHE_OPERATOR_RESTART 0x55 */
+/* RC_COMP_CACHE_OPERATOR_RESTART 0x55 */
#define RC_COMP_OP_REF_TRAP_RESTART 0x56
#define RC_COMP_CACHE_REF_APPLY_RESTART 0x57
#define RC_COMP_SAFE_REF_TRAP_RESTART 0x58
#define RC_COMP_UNASSIGNED_TRAP_RESTART 0x59
-/* formerly RC_COMP_CACHE_ASSIGN_RESTART 0x5A */
+/* RC_COMP_CACHE_ASSIGN_RESTART 0x5A */
#define RC_COMP_LINK_CACHES_RESTART 0x5B
#define RC_HARDWARE_TRAP 0x5C
#define RC_INTERNAL_APPLY_VAL 0x5D
/* 0x01 */ "JOIN_STACKLETS", \
/* 0x02 */ "RESTORE_CONTINUATION", \
/* 0x03 */ "INTERNAL_APPLY", \
-/* 0x04 */ "BAD_INTERRUPT_CONTINUE", \
+/* 0x04 */ "", \
/* 0x05 */ "RESTORE_HISTORY", \
/* 0x06 */ "INVOKE_STACK_THREAD", \
-/* 0x07 */ "RESTART_EXECUTION", \
+/* 0x07 */ "", \
/* 0x08 */ "EXECUTE_ASSIGNMENT_FINISH", \
/* 0x09 */ "EXECUTE_DEFINITION_FINISH", \
/* 0x0A */ "EXECUTE_ACCESS_FINISH", \
/* 0x1E */ "", \
/* 0x1F */ "COMP_REFERENCE_RESTART", \
/* 0x20 */ "NORMAL_GC_DONE", \
-/* 0x21 */ "COMPLETE_GC_DONE", \
+/* 0x21 */ "" , \
/* 0x22 */ "PURIFY_GC_1", \
/* 0x23 */ "PURIFY_GC_2", \
/* 0x24 */ "AFTER_MEMORY_UPDATE", \
/* 0x28 */ "COMP_ASSIGNMENT_RESTART", \
/* 0x29 */ "POP_FROM_COMPILED_CODE", \
/* 0x2A */ "RETURN_TRAP_POINT", \
-/* 0x2B */ "RESTORE_STEPPER", \
+/* 0x2B */ "", \
/* 0x2C */ "RESTORE_TO_STATE_POINT", \
/* 0x2D */ "MOVE_TO_ADJACENT_POINT", \
/* 0x2E */ "RESTORE_VALUE", \
/* 0x44 */ "", \
/* 0x45 */ "RESTORE_INT_MASK", \
/* 0x46 */ "HALT", \
-/* 0x47 */ "FINISH_GLOBAL_INT", \
+/* 0x47 */ "", \
/* 0x48 */ "REPEAT_DISPATCH", \
/* 0x49 */ "GC_CHECK", \
-/* 0x4A */ "RESTORE_FLUIDS", \
+/* 0x4A */ "", \
/* 0x4B */ "COMPILER_LOOKUP_APPLY_RESTART", \
/* 0x4C */ "COMPILER_ACCESS_RESTART", \
/* 0x4D */ "COMPILER_UNASSIGNED_P_RESTART", \
/* 0x5B */ "COMPILER_LINK_CACHES_RESTART", \
/* 0x5C */ "HARDWARE_TRAP", \
/* 0x5D */ "INTERNAL_APPLY_VAL", \
-/* 0x5E */ "COMPILER_ERROR_RESTARRT", \
+/* 0x5E */ "COMPILER_ERROR_RESTART", \
/* 0x5F */ "PRIMITIVE_CONTINUE" \
}
/* -*-C-*-
-$Id: rgxprim.c,v 1.18 2007/04/01 17:33:07 riastradh Exp $
+$Id: rgxprim.c,v 1.19 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
DEFINE_PRIMITIVE ("RE-COMPILE-FASTMAP", Prim_re_compile_fastmap, 4, 4, 0)
{
- fast SCHEME_OBJECT pattern;
- fast int can_be_null;
+ SCHEME_OBJECT pattern;
+ int can_be_null;
PRIMITIVE_HEADER (4);
CHECK_ARG (1, STRING_P);
pattern = (ARG_REF (1));
#define RE_SUBSTRING_PRIMITIVE(procedure) \
{ \
- fast SCHEME_OBJECT regexp; \
+ SCHEME_OBJECT regexp; \
long match_start, match_end, text_end; \
unsigned char * text; \
struct re_buffer buffer; \
\f
#define RE_BUFFER_PRIMITIVE(procedure) \
{ \
- fast SCHEME_OBJECT regexp, group; \
+ SCHEME_OBJECT regexp, group; \
long match_start, match_end, text_start, text_end, gap_start; \
unsigned char * text; \
struct re_buffer buffer; \
group = (ARG_REF (5)); \
match_start = (arg_nonnegative_integer (6)); \
match_end = (arg_nonnegative_integer (7)); \
- text = (GROUP_TEXT_LOC (group, 0)); \
+ text = (GROUP_TEXT (group, 0)); \
text_start = (MARK_INDEX (GROUP_START_MARK (group))); \
text_end = (MARK_INDEX (GROUP_END_MARK (group))); \
gap_start = (GROUP_GAP_START (group)); \
/* -*-C-*-
+$Id: sample.c,v 9.31 2007/04/22 16:31:23 cph Exp $
+
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007 Massachusetts Institute of Technology
*/
-/* $Id: sample.c,v 9.30 2007/01/05 21:19:25 cph Exp $ */
-\f
/* This file is intended to help you find out how to write primitives.
Many concepts needed to write primitives can be found by looking
at actual primitives in the system. Hence this file will often
#include "scheme.h"
#include "prims.h"
-/* Scheme.h supplies useful macros that are used throughout the
- system, and prims.h supplies macros that are used in defining
+/* "scheme.h" supplies useful macros that are used throughout the
+ system, and "prims.h" supplies macros that are used in defining
primitives. */
-
+\f
/* To make a primitive, you must use the macro DEFINE_PRIMITIVE
with six arguments, followed by the body of C source code
that you want the primitive to execute.
/* -*-C-*-
-$Id: scheme.h,v 9.44 2007/01/05 21:19:25 cph Exp $
+$Id: scheme.h,v 9.45 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* General declarations for the SCode interpreter. This
file is INCLUDED by others and contains declarations only. */
-\f
+
#ifndef SCM_SCHEME_H
#define SCM_SCHEME_H 1
-/* Don't use this any more -- trust the compiler. */
-#define fast
-
-/* For forward references */
-#define forward extern
-
-#ifndef __GNUC__
-# define __inline__
-#endif
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-# define Consistency_Check (1)
-# define ENABLE_PRIMITIVE_PROFILING
-#else
-# define Consistency_Check (0)
-# undef ENABLE_PRIMITIVE_PROFILING
-#endif
-
#include "config.h"
-
-#include <stdio.h>
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-#endif
-
-#include "dstack.h" /* Dynamic stack support package */
-#include "obstack.h" /* Obstack package */
-#include "types.h" /* Type code numbers */
-#include "const.h" /* Various named constants */
-#include "object.h" /* Scheme object representation */
-#include "intrpt.h" /* Interrupt processing macros */
-#include "critsec.h" /* Critical sections */
-#include "gc.h" /* Memory management related macros */
-#include "scode.h" /* Scheme scode representation */
-#include "sdata.h" /* Scheme user data representation */
-#include "futures.h" /* Support macros, etc. for FUTURE */
-#include "errors.h" /* Error code numbers */
-#include "returns.h" /* Return code numbers */
-#include "fixobj.h" /* Format of fixed objects vector */
-#include "stack.h" /* Macros for stack (stacklet) manipulation */
-#include "interp.h" /* Macros for interpreter */
-
-#ifdef butterfly
-# include "butterfly.h"
-#endif
-
-#include "outf.h" /* Formatted output for errors */
-#include "bkpt.h" /* Shadows some defaults */
-#include "default.h" /* Defaults for various hooks. */
-#include "extern.h" /* External declarations */
-#include "bignum.h" /* Bignum declarations */
-#include "prim.h" /* Declarations for primitives. */
-#include "float.h" /* Floating-point parameters */
-
-#if (FLT_RADIX != 2)
-# include "error: floating point radix not 2! Arithmetic won't work."
-#endif
+#include "dstack.h" /* Dynamic stack support package */
+#include "obstack.h" /* Obstack package */
+#include "types.h" /* Type code numbers */
+#include "const.h" /* Various named constants */
+#include "object.h" /* Scheme object representation */
+#include "intrpt.h" /* Interrupt processing macros */
+#include "critsec.h" /* Critical sections */
+#include "gc.h" /* Memory management related macros */
+#include "memmag.h"
+#include "scode.h" /* Scheme scode representation */
+#include "sdata.h" /* Scheme user data representation */
+#include "errors.h" /* Error code numbers */
+#include "returns.h" /* Return code numbers */
+#include "fixobj.h" /* Format of fixed objects vector */
+#include "stack.h" /* Macros for stack (stacklet) manipulation */
+#include "interp.h" /* Macros for interpreter */
+#include "outf.h" /* Formatted output for errors */
+#include "bkpt.h" /* Shadows some defaults */
+#include "extern.h" /* External declarations */
+#include "bignum.h" /* Bignum declarations */
+#include "prim.h" /* Declarations for primitives. */
+#include "cmpint.h" /* compiled-code interface */
#endif /* SCM_SCHEME_H */
/* -*-C-*-
-$Id: scode.h,v 9.31 2007/01/05 21:19:25 cph Exp $
+$Id: scode.h,v 9.32 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Selectors */
-#define Get_Body_Elambda(Addr) (FAST_MEMORY_REF (Addr, ELAMBDA_SCODE))
-#define Get_Names_Elambda(Addr) (FAST_MEMORY_REF (Addr, ELAMBDA_NAMES))
-#define Get_Count_Elambda(Addr) (FAST_MEMORY_REF (Addr, ELAMBDA_ARG_COUNT))
+#define Get_Body_Elambda(Addr) (MEMORY_REF (Addr, ELAMBDA_SCODE))
+#define Get_Names_Elambda(Addr) (MEMORY_REF (Addr, ELAMBDA_NAMES))
+#define Get_Count_Elambda(Addr) (MEMORY_REF (Addr, ELAMBDA_ARG_COUNT))
#define Elambda_Formals_Count(Addr) \
((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
#define Elambda_Opts_Count(Addr) \
/* -*-C-*-
-$Id: sdata.h,v 9.44 2007/01/05 21:19:25 cph Exp $
+$Id: sdata.h,v 9.45 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define CONTINUATION_RETURN_CODE 0
#define CONTINUATION_SIZE 2
#define HISTORY_SIZE (CONTINUATION_SIZE + 2)
-\f
-/* CONTROL_POINT
- * Points to a copy of the control stack at the time a control point is
- * created. This is the saved state of the interpreter, and can be
- * restored later by APPLYing the control point to an argument (i.e. a
- * throw). Format is that of an ordinary vector. They are linked
- * together by using the return code RC_JOIN_STACKLETS.
- */
-
-/* If USE_STACKLETS is defined, then a stack (i.e. control point) is
- actually made from smaller units allocated from the heap and linked
- together. The format is:
-
- 0 memory address
-
- _______________________________________
- |MAN. VECT.| n |
- _ _______________________________________
- / | #T if it does not need to be copied |
- | _______________________________________
- | | NM VECT | m at GC or when full |
- | _______________________________________
- | | ... |\
- | | not yet in use -- garbage | > m
- n < _______________________________________/
- | | Top of Stack, useful contents | <---sp_register
- | _______________________________________
- \ | ... |
- \ | useful stuff |
- \_ ________________________________________
- <---Stack_Top
- infinite memory address
-
-*/
-
-#define STACKLET_HEADER_SIZE 3
-#define STACKLET_LENGTH 0
-#define STACKLET_REUSE_FLAG 1
-#define STACKLET_UNUSED_LENGTH 2
-/* Aliases */
-#define STACKLET_FREE_LIST_LINK STACKLET_REUSE_FLAG
-\f
/* DELAYED
* The object returned by a DELAY operation. Consists initially of a
* procedure to be APPLYed and environment. After the FORCE primitive
#define SET_SYMBOL_GLOBAL_VALUE(symbol, value) \
((* (SYMBOL_GLOBAL_VALUE_CELL (symbol))) = (value))
+#define GET_SYMBOL_NAME(symbol) (MEMORY_REF ((symbol), SYMBOL_NAME))
+
+#define SET_SYMBOL_NAME(symbol, name) \
+ MEMORY_SET ((symbol), SYMBOL_NAME, (name))
+
/* LIST
* Ordinary CONS cell as supplied to a user. Perhaps this data type is
* misnamed ... CONS or PAIR would be better.
+++ /dev/null
-/* -*-C-*-
-
-$Id: sgraph.h,v 1.11 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include <starbase.c.h>
-\f
-/* Bobcat graphics primitives. Interface to the Starbase package*/
-
-#define SINGLE_ECHO 0
-#define NO_ECHO 0
-#define SMALL_TRACKING_CROSS 3
-#define RUBBER_BAND_LINE 4
-#define RUBBER_BAND_RECTANGLE 5
-#define MAX_NUMBER_OF_CORNERS 512
-#define TWICE_MAX_NUMBER_OF_CORNERS (2 * MAX_NUMBER_OF_CORNERS)
-
-extern int screen_handle;
-extern long replacement_rule;
-extern float xposition;
-extern float yposition;
-
-extern char * sb_device;
-extern char * sb_driver;
-extern float sb_xmin;
-extern float sb_xmax;
-extern float sb_ymin;
-extern float sb_ymax;
-extern float sb_zmin;
-extern float sb_zmax;
-
-extern void sb_close_device ();
+++ /dev/null
-/* -*-C-*-
-
-$Id: sgraph_a.c,v 1.21 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "scheme.h"
-#include "prims.h"
-#include "sgraph.h"
-#include "array.h"
-#include "x11.h"
-\f
-#define SB_DEVICE_ARG(arg) (arg_nonnegative_integer (arg))
-
-#ifndef STARBASE_COLOR_TABLE_START
-#define STARBASE_COLOR_TABLE_START 0
-#endif
-
-#ifndef STARBASE_COLOR_TABLE_SIZE
-#define STARBASE_COLOR_TABLE_SIZE 16
-#endif
-
-float Color_Table [STARBASE_COLOR_TABLE_SIZE] [3];
-
-static void
-arg_plotting_box (arg_number, plotting_box)
- int arg_number;
- float * plotting_box;
-{
- fast SCHEME_OBJECT object;
- fast int i;
- TOUCH_IN_PRIMITIVE ((ARG_REF (arg_number)), object);
- for (i = 0; (i < 4); i += 1)
- {
- if (! (PAIR_P (object)))
- error_wrong_type_arg (arg_number);
- {
- fast SCHEME_OBJECT number = (PAIR_CAR (object));
- if (! (REAL_P (number)))
- error_wrong_type_arg (arg_number);
- if (! (real_number_to_double_p (number)))
- error_bad_range_arg (arg_number);
- (plotting_box [i]) = (real_number_to_double (number));
- }
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (object)), object);
- }
- if (!EMPTY_LIST_P (object))
- error_wrong_type_arg (arg_number);
- return;
-}
-\f
-DEFINE_PRIMITIVE ("XPLOT-ARRAY-0",
- Prim_xplot_array_0, 6, 6,
- "(XPLOT-ARRAY-0 WINDOW ARRAY BOX OFFSET SCALE FILL)")
-{
- SCHEME_OBJECT array;
- float plotting_box [4];
- REAL offset, scale;
- PRIMITIVE_HEADER (6);
- {
- struct xwindow * xw = (x_window_arg (1));
- CHECK_ARG (2, ARRAY_P);
- array = (ARG_REF (2));
- arg_plotting_box (3, plotting_box);
- offset = (arg_real (4)); /* arg_real is defined in array.h */
- scale = (arg_real (5));
- XPlot_C_Array_With_Offset_Scale
- (xw,
- (ARRAY_CONTENTS (array)),
- (ARRAY_LENGTH (array)),
- plotting_box,
- (arg_index_integer (6, 2)),
- offset,
- scale);
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-
-/* The following are taken from x11graphics.c
- */
-
-struct gw_extra
-{
- float x_left;
- float x_right;
- float y_bottom;
- float y_top;
- float x_slope;
- float y_slope;
- int x_cursor;
- int y_cursor;
-};
-
-#define XW_EXTRA(xw) ((struct gw_extra *) ((xw) -> extra))
-
-#define XW_X_LEFT(xw) ((XW_EXTRA (xw)) -> x_left)
-#define XW_X_RIGHT(xw) ((XW_EXTRA (xw)) -> x_right)
-#define XW_Y_BOTTOM(xw) ((XW_EXTRA (xw)) -> y_bottom)
-#define XW_Y_TOP(xw) ((XW_EXTRA (xw)) -> y_top)
-#define XW_X_SLOPE(xw) ((XW_EXTRA (xw)) -> x_slope)
-#define XW_Y_SLOPE(xw) ((XW_EXTRA (xw)) -> y_slope)
-#define XW_X_CURSOR(xw) ((XW_EXTRA (xw)) -> x_cursor)
-#define XW_Y_CURSOR(xw) ((XW_EXTRA (xw)) -> y_cursor)
-
-#define ROUND_FLOAT(flonum) \
- ((int) (((flonum) >= 0.0) ? ((flonum) + 0.5) : ((flonum) - 0.5)))
-
-static int
-xmake_x_coord (xw, virtual_device_x)
- struct xwindow * xw;
- float virtual_device_x;
-{
- float device_x = ((XW_X_SLOPE (xw)) * (virtual_device_x - (XW_X_LEFT (xw))));
- return (ROUND_FLOAT (device_x));
-}
-
-static int
-xmake_y_coord (xw, virtual_device_y)
- struct xwindow * xw;
- float virtual_device_y;
-{
- float device_y =
- ((XW_Y_SLOPE (xw)) * (virtual_device_y - (XW_Y_BOTTOM (xw))));
- return (((XW_Y_SIZE (xw)) - 1) + (ROUND_FLOAT (device_y)));
-}
-\f
-XPlot_C_Array_With_Offset_Scale (xw, Array, Length, Plotting_Box,
- fill_with_lines, Offset, Scale)
- struct xwindow * xw;
- float *Plotting_Box;
- long Length;
- int fill_with_lines; /* plots filled with lines from 0 to y(t) */
- REAL *Array, Scale, Offset;
-{
- float box_x_min = Plotting_Box[0];
- float box_y_min = Plotting_Box[1];
- float box_x_max = Plotting_Box[2];
- float box_y_max = Plotting_Box[3];
- float Box_Length = box_x_max - box_x_min;
- float Box_Height = box_y_max - box_y_min;
- long i;
- float v_d_clipped_offset;
- fast float v_d_x, v_d_y, v_d_x_increment; /* virtual device coordinates */
- fast int x, y, clipped_offset; /* X window coordinates */
- fast int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
-
- v_d_x = box_x_min; /* horizontal starting point */
- v_d_x_increment = ((float) Box_Length/Length);
-
- if (fill_with_lines == 0)
- { /* plot just the points */
- for (i = 0; i < Length; i++)
- {
- x = (xmake_x_coord (xw, v_d_x));
- v_d_y = ((float) (Offset + (Scale * Array[i])));
- y = (xmake_y_coord (xw, v_d_y));
-
- XDrawPoint
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + x),
- (internal_border_width + y));
-
- v_d_x = v_d_x + v_d_x_increment;
-
- /* Can not use INTEGERS x+x_increment because x_increment
- may round to 0 and we'll never move the cursor from
- starting point. Also Array[i+skip] will not work well,
- say 1024 points for 1000 places => last 24 are chopped
- whereas the costly loop we do, downsamples in between
- more gracefully. i.e. loop over v_d_coordinates - in
- floats. */
- }
- }
- else
- { /* fill with lines */
- v_d_clipped_offset = min( max(box_y_min, ((float) Offset)), box_y_max);
- clipped_offset = (xmake_y_coord (xw, v_d_clipped_offset));
- /* The above allows us to
- fill with vertical bars from the zero-line to the graphed point y(x)
- and never go outside box.
- */
- for (i = 0; i < Length; i++)
- {
- x = (xmake_x_coord (xw, v_d_x));
- v_d_y = ((float) (Offset + (Scale * Array[i])));
- y = (xmake_y_coord (xw, v_d_y));
-
- XDrawLine
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + x),
- (internal_border_width + clipped_offset),
- (internal_border_width + x),
- (internal_border_width + y));
-
- v_d_x = v_d_x + v_d_x_increment;
- }
- }
-}
-\f
-/* plot-array-0 is suffixed -0 in case we need more versions of array plot */
-
-DEFINE_PRIMITIVE ("PLOT-ARRAY-0",
- Prim_plot_array_0, 6, 6,
- "(PLOT-ARRAY-0 DEVICE ARRAY BOX OFFSET SCALE FILL)")
-{
- SCHEME_OBJECT array;
- float plotting_box [4];
- REAL offset, scale;
- int device;
- PRIMITIVE_HEADER (6);
- device = (SB_DEVICE_ARG (1));
-
- CHECK_ARG (2, ARRAY_P);
- array = (ARG_REF (2));
- arg_plotting_box (3, plotting_box);
- offset = (arg_real (4)); /* arg_real is defined in array.h */
- scale = (arg_real (5));
- Plot_C_Array_With_Offset_Scale
- (device,
- (ARRAY_CONTENTS (array)),
- (ARRAY_LENGTH (array)),
- plotting_box,
- (arg_index_integer (6, 2)),
- offset,
- scale);
- PRIMITIVE_RETURN
- (cons ((double_to_flonum ((double) (offset))),
- (cons ((double_to_flonum ((double) (scale))),
- EMPTY_LIST))));
-}
-
-Plot_C_Array_With_Offset_Scale (device, Array, Length, Plotting_Box,
- fill_with_lines, Offset, Scale)
- int device;
- float *Plotting_Box; long Length;
- int fill_with_lines; /* plots filled with lines from 0 to y(t) */
- REAL *Array, Scale, Offset;
-{
- float box_x_min = Plotting_Box[0];
- float box_y_min=Plotting_Box[1];
- float box_x_max = Plotting_Box[2];
- float box_y_max = Plotting_Box[3];
- float Box_Length = box_x_max - box_x_min;
- float Box_Height = box_y_max - box_y_min;
- fast float x_position, y_position, index_inc, clipped_offset;
- long i;
-
- index_inc = ((float) Box_Length/Length);
- x_position = box_x_min;
- if (fill_with_lines == 0)
- { /* plot just the points */
- for (i = 0; i < Length; i++)
- {
- y_position = ((float) (Offset + (Scale * Array[i])));
- move2d(device, x_position, y_position);
- draw2d(device, x_position, y_position);
- x_position = x_position + index_inc;
- }
- }
- else
- { /* fill with lines */
- clipped_offset = min( max(box_y_min, ((float) Offset)), box_y_max);
- /* Fill from zero-line but do not go outside box,
- (Don't bother with starbase clipping)
- */
- for (i = 0; i < Length; i++)
- {
- y_position = ((float) (Offset + (Scale * Array[i])));
- move2d(device, x_position, clipped_offset);
- draw2d(device, x_position, y_position);
- x_position = x_position + index_inc;
- }
- }
- make_picture_current(device);
-}
-\f
-DEFINE_PRIMITIVE ("POLYGON2D", Prim_polygon2d, 2,2, 0)
-{
- float clist [TWICE_MAX_NUMBER_OF_CORNERS];
- int count;
- fast SCHEME_OBJECT object;
- int device;
- PRIMITIVE_HEADER (2);
-
- device = (SB_DEVICE_ARG (1));
- CHECK_ARG (2, PAIR_P);
- count = 0;
-
- TOUCH_IN_PRIMITIVE ((ARG_REF (2)), object);
- while (PAIR_P (object))
- {
- fast SCHEME_OBJECT number = (PAIR_CAR (object));
- if (! (REAL_P (number)))
- error_wrong_type_arg (2);
- if (! (real_number_to_double_p (number)))
- error_bad_range_arg (2);
- (clist [count]) = (real_number_to_double (number));
- count += 1;
- if (count == (TWICE_MAX_NUMBER_OF_CORNERS - 2))
- error_bad_range_arg (2);
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (object)), object);
- }
- if (!EMPTY_LIST_P (object))
- error_wrong_type_arg (2);
-
- (clist [count]) = (clist [0]);
- (clist [count + 1]) = (clist [1]);
- polygon2d (device, clist, ((long) ((count + 2) / 2)), 0);
- make_picture_current (device);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-
-DEFINE_PRIMITIVE ("BOX-MOVE", Prim_box_move, 3,3, 0)
-{
- int device;
- float From_Box[4]; /* x_min, y_min, x_max, y_max */
- float To_Box[4];
- float x_source, y_source, x_dest, y_dest, x_length, y_length;
- PRIMITIVE_HEADER (3);
- device = (SB_DEVICE_ARG (1));
- arg_plotting_box (2, From_Box);
- arg_plotting_box (3, To_Box);
- x_source = From_Box[0]; y_source = From_Box[3];
- x_dest = To_Box[0]; y_dest = To_Box[3];
- /* notice convention of matrix row, column! */
- y_length = From_Box[3] - From_Box[1] + 1;
- x_length = From_Box[2] - From_Box[0] + 1;
- if ((y_length != (To_Box[3]-To_Box[1]+1)) ||
- (x_length != (To_Box[2]-To_Box[0]+1)))
- error_bad_range_arg (3);
- block_move
- (device,
- x_source, y_source,
- ((int) x_length), ((int) y_length),
- x_dest, y_dest);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* Image Drawing (halftoning)
- HG = Hard Grey levels (i.e. output device greys)
- SG = Soft Grey levels (i.e. simulated grey levels)
- There are 3 methods: PSAM, OD, BN (see below)
- There are also the old 16-color drawing routines. */
-
-/* PSAM (Pulse-Surface-Area Modulation) works only for 2 HG grey
- levels. It maps 1 pxl to a square of 16 pxls. The distribution of
- on/off pxls in the square gives 16 grey levels. It's the most
- efficient for B&W monitors, but see below for better quality
- drawing using OD and BN. Halftoning using OD and BN works for any
- number of grey levels, and there are many methods available (see
- below).
-
- IMAGE-PSAM-ATXY-WMM fixed magnification 1pxl->16pxls Draw line
- (width 4) by line. Pdata space needed = (4 * ncols * 16). The
- following 2 primitives simply take in arguments, and allocate
- space, They call C_image_psam_atxy_wmm to do the actual drawing. */
-
-DEFINE_PRIMITIVE ("IMAGE-PSAM-ATXY-WMM", Prim_image_psam_atxy_wmm, 6,6, 0)
-{
- int device;
- long nrows, ncols;
- REAL * Array;
- PRIMITIVE_HEADER (6);
- device = (SB_DEVICE_ARG (1));
- arg_image (2, (&nrows), (&ncols), (&Array));
- Primitive_GC_If_Needed (BYTES_TO_WORDS (16 * ncols));
- C_image_psam_atxy_wmm
- (device, Array,
- ((unsigned char *) Free),
- nrows,
- ncols,
- ((float) (arg_real (3))),
- ((float) (arg_real (4))),
- (arg_real (5)),
- (arg_real (6)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("IMAGE-PSAM-ATXY-WOMM", Prim_image_psam_atxy_womm, 6,6, 0)
-{
- int device;
- long nrows, ncols;
- REAL * Array;
- PRIMITIVE_HEADER (6);
- device = (SB_DEVICE_ARG (1));
- arg_image (2, (&nrows), (&ncols), (&Array));
- Primitive_GC_If_Needed (BYTES_TO_WORDS (16 * ncols));
- C_image_psam_atxy_womm
- (device, Array,
- ((unsigned char *) Free),
- nrows,
- ncols,
- ((float) (arg_real (3))),
- ((float) (arg_real (4))),
- (arg_real (5)),
- (arg_real (6)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("IMAGE-HT-OD-ATXY-WMM", Prim_image_ht_od_atxy_wmm, 8,8, 0)
-{
- int device;
- long nrows, ncols;
- REAL * Array;
- PRIMITIVE_HEADER (8);
- device = (SB_DEVICE_ARG (1));
- arg_image (2, (&nrows), (&ncols), (&Array));
- Primitive_GC_If_Needed (BYTES_TO_WORDS (ncols));
- C_image_ht_od_atxy_wmm
- (device, Array,
- ((unsigned char *) Free),
- nrows,
- ncols,
- ((float) (arg_real (3))),
- ((float) (arg_real (4))),
- (arg_real (5)),
- (arg_real (6)),
- (arg_integer_in_range (7, 1, 257)),
- (arg_integer_in_range (8, 0, 8)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("IMAGE-HT-BN-ATXY-WMM", Prim_image_ht_bn_atxy_wmm, 8,8, 0)
-{
- int device;
- long nrows, ncols;
- REAL * Array;
- unsigned char * pdata;
- float ** er_rows;
- PRIMITIVE_HEADER (8);
- device = (SB_DEVICE_ARG (1));
- arg_image (2, (&nrows), (&ncols), (&Array));
- Primitive_GC_If_Needed
- (BYTES_TO_WORDS
- (/* pdata */
- ncols +
- /* er_rows header */
- (3 * (sizeof (float *))) +
- /* er_rows data */
- (3 * (ncols + 4) * (sizeof (float)))));
- pdata = ((unsigned char *) Free);
- er_rows = ((float **) (pdata + ncols));
- (er_rows [0]) = ((float *) (er_rows + 3));
- (er_rows [1]) = ((er_rows [0]) + (ncols + 4));
- (er_rows [2]) = ((er_rows [1]) + (ncols + 4));
- C_image_ht_bn_atxy_wmm
- (device, Array,
- pdata,
- nrows,
- ncols,
- ((float) (arg_real (3))),
- ((float) (arg_real (4))),
- (arg_real (5)),
- (arg_real (6)),
- (arg_integer_in_range (7, 1, 257)),
- (arg_nonnegative_integer (8)),
- er_rows);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-#define MINTEGER long
-
-DEFINE_PRIMITIVE ("IMAGE-HT-IBN-ATXY-WMM", Prim_image_ht_ibn_atxy_wmm, 9,9, 0)
-{
- int device;
- long nrows, ncols;
- REAL * Array;
- unsigned char * pdata;
- MINTEGER ** er_rows;
- PRIMITIVE_HEADER (9);
- device = (SB_DEVICE_ARG (1));
- arg_image (2, (&nrows), (&ncols), (&Array));
- Primitive_GC_If_Needed
- (BYTES_TO_WORDS
- (/* pdata */
- ncols +
- /* er_rows header */
- (3 * (sizeof (MINTEGER *))) +
- /* er_rows data */
- (3 * (ncols + 4) * (sizeof (MINTEGER)))));
- pdata = ((unsigned char *) Free);
- er_rows = ((MINTEGER **) (pdata + ncols));
- (er_rows [0]) = ((MINTEGER *) (er_rows + 3));
- (er_rows [1]) = (er_rows [0]) + (ncols + 4);
- (er_rows [2]) = (er_rows [1]) + (ncols + 4);
- C_image_ht_ibn_atxy_wmm
- (device, Array,
- pdata,
- nrows,
- ncols,
- ((float) (arg_real (3))),
- ((float) (arg_real (4))),
- (arg_real (5)),
- (arg_real (6)),
- (arg_integer_in_range (7, 1, 257)),
- (arg_index_integer (8, 3)),
- er_rows,
- (arg_integer_in_range
- (9, 1, ((1 << ((8 * (sizeof (MINTEGER))) - 2)) / 64))));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* THE FOLLOWING 3 ROUTINES ARE THE OLD 16-color drawing routines
- they also do magnification. */
-
-/* color_table entries 0 and 1 are not used */
-/* Just like in array-plotting,
- Use Min,Max and Offset,Scale s.t. values map into [2,15] */
-
-#define SCREEN_BACKGROUND_COLOR 0
-#define MINIMUM_INTENSITY_INDEX 2
-#define MAXIMUM_INTENSITY_INDEX 15
-
-/* ARGS = (device image x_at y_at magnification)
- magnification can be 1, 2, or 3 */
-
-DEFINE_PRIMITIVE ("DRAW-MAGNIFY-IMAGE-AT-XY", Prim_draw_magnify_image_at_xy, 5, 5, 0)
-{
- int device;
- long nrows, ncols, Length;
- REAL * Array;
- long Magnification;
- REAL Offset, Scale;
- REAL Array_Min, Array_Max;
- long nmin, nmax;
- PRIMITIVE_HEADER (5);
- device = (SB_DEVICE_ARG (1));
- arg_image (2, (&nrows), (&ncols), (&Array));
- Magnification = (arg_integer_in_range (5, 1, 101));
- Length = (nrows * ncols);
- {
- C_Array_Find_Min_Max (Array, Length, &nmin, &nmax);
- Array_Min = (Array [nmin]);
- Array_Max = (Array [nmax]);
- /* Do not use colors 0 and 1 */
- Find_Offset_Scale_For_Linear_Map
- (Array_Min, Array_Max, 2.0, 15.0, &Offset, &Scale);
- Primitive_GC_If_Needed (BYTES_TO_WORDS (Magnification * ncols));
- Image_Draw_Magnify_N_Times_With_Offset_Scale
- (device, Array,
- ((unsigned char *) Free),
- nrows,
- ncols,
- ((float) (arg_real (3))),
- ((float) (arg_real (4))),
- Offset,
- Scale,
- Magnification);
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-\f
-DEFINE_PRIMITIVE ("DRAW-MAGNIFY-IMAGE-AT-XY-WITH-MIN-MAX",
- Prim_draw_magnify_image_at_xy_with_min_max, 7,7, 0)
-{
- int device;
- long nrows, ncols;
- REAL * Array;
- REAL Offset, Scale;
- long Magnification;
- PRIMITIVE_HEADER (7);
- device = (SB_DEVICE_ARG (1));
- arg_image (2, (&nrows), (&ncols), (&Array));
- Magnification = (arg_integer_in_range (5, 1, 101));
- /* Do not use colors 0 and 1 */
- Find_Offset_Scale_For_Linear_Map
- ((arg_real (6)), (arg_real (7)), 2.0, 15.0, &Offset, &Scale);
- Primitive_GC_If_Needed (BYTES_TO_WORDS (Magnification * ncols));
- Image_Draw_Magnify_N_Times_With_Offset_Scale
- (device, Array,
- ((unsigned char *) Free),
- nrows,
- ncols,
- ((float) (arg_real (3))),
- ((float) (arg_real (4))),
- Offset,
- Scale,
- Magnification);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("DRAW-MAGNIFY-IMAGE-AT-XY-ONLY-BETWEEN-MIN-MAX",
- Prim_draw_magnify_image_at_xy_only_between_min_max, 7,7, 0)
-{
- int device;
- long nrows, ncols;
- REAL * Array;
- REAL Offset, Scale;
- long Magnification;
- PRIMITIVE_HEADER (7);
- device = (SB_DEVICE_ARG (1));
- arg_image (2, (&nrows), (&ncols), (&Array));
- Magnification = (arg_integer_in_range (5, 1, 101));
- /* Do not use colors 0 and 1 */
- Find_Offset_Scale_For_Linear_Map
- ((arg_real (6)), (arg_real (7)), 2.0, 15.0, &Offset, &Scale);
- Primitive_GC_If_Needed (BYTES_TO_WORDS (Magnification * ncols));
- Image_Draw_Magnify_N_Times_With_Offset_Scale_Only
- (device, Array,
- ((unsigned char *) Free),
- nrows,
- ncols,
- ((float) (arg_real (3))),
- ((float) (arg_real (4))),
- Offset,
- Scale,
- Magnification);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* Below are the real drawing routines */
-
-/* ht = halftoning
- od = ordered-dither (dispersed dot), Ulichney terminology
- bn = blue noise (also called: minimized average error)
- psam = pulse surface area modulation
- Also, there are the old drawing routines for 16 colors, which are basically
- fixed threshold ordered dither. */
-
-/* The macro Adjust_Value_Wmm is used by most drawing routines.
- The macro Adjust_Value_Womm is used only by psam-atxy-womm.
- REAL value, newvalue, ngreys_min, ngreys_max, Vmin,Vmax, offset,scale;
- offset, scale must be such as to map (min,max)
- into (ngreys_min,ngreys_max) */
-
-#define Adjust_Value_Wmm(value, newvalue, ngreys_min, ngreys_max, Vmin, Vmax, offset, scale) \
-{ \
- if (value >= Vmax) \
- newvalue = ngreys_max; \
- else if (value <= Vmin) \
- newvalue = ngreys_min; \
- else \
- newvalue = offset + (value * scale); \
-}
-
-#define Adjust_Value_Womm(value, newvalue, ngreys_min, ngreys_max, Vmin, Vmax, offset, scale) \
-{ \
- if (value >= Vmax) \
- newvalue = ngreys_min; \
- else if (value <= Vmin) \
- newvalue = ngreys_min; \
- else \
- newvalue = offset + (value * scale); \
-}
-
-#define Round_REAL(x) ((long) ((x >= 0) ? (x+.5) : (x-.5)))
-
-/* Ordered Dither MASKS
- A mask is a SQUARE matrix of threshold values,
- that is effectively replicated periodically all over the image.
-
- ht_od_table[][0] ---> int SG; number of soft greys
- ht_od_table[][1] ---> int SGarray_nrows;
- nrows=ncols i.e. square matrix of threshold values
- ht_od_table[][2+i] ----> int SGarray[36];
- threshold values with range [0,SG).
-
- ATTENTION: Currently, the LARGEST SGarray is 6X6 MATRIX
- */
-
-static int ht_od_table[8][2+36] =
-{ {2,1, 1}, /* fixed threshold at halfpoint */
- /* this one and following 4 come from Ulichney p.135 */
- {3,2, 1,2,2,1},
- {5,3, 2,3,2, 4,1,4, 2,3,2},
- {9,4, 1,8,2,7, 5,3,6,4, 2,7,1,8, 6,4,5,3},
- {17,5, 2,16,3,13,2, 10,6,11,7,10, 4,14,1,15,4, 12,8,9,5,12, 2,16,3,13,2},
- {33,6, 1,30,8,28,2,29, 17,9,24,16,18,10, 5,25,3,32,6,26, 21,13,19,11,22,14,
- 2,29,7,27,1,30, 18,10,23,15,17,9},
- /* this one and following 1 come from Jarvis,Judice,Ninke: CGIP 5, p.23 */
- {4,2, 0,2,3,1},
- {17,4, 0,8,2,10, 12,4,14,6, 3,11,1,9, 15,7,13,5}
-};
-#define HT_OD_TABLE_MAX_INDEX 7
-\f
-/* ordered dither
- pdata must have length ncols
- HG= Hardware Grey levels (output pixel values 0,HG-1)
- ODmethod is index for ht_od method
- */
-
-C_image_ht_od_atxy_wmm (device, Array, pdata, nrows,ncols, x_at,y_at, Min,Max,
- HG,ODmethod)
- int device;
- REAL Array[], Min,Max;
- unsigned char *pdata;
- int nrows,ncols,HG,ODmethod;
- float x_at,y_at;
-{ int i,j, SG, *SGarray, SGarray_nrows, dither, pixel, array_index;
- REAL REAL_pixel, value, offset,scale, HG1_SG;
- /* static int ht_od_table[][]; */
- /* void Find_Offset_Scale_For_Linear_Map(); */
-
- if (ODmethod>HT_OD_TABLE_MAX_INDEX)
- error_external_return ();
- SG = ht_od_table[ODmethod][0];
- SGarray_nrows = ht_od_table[ODmethod][1]; /* nrows=ncols */
- SGarray = &(ht_od_table[ODmethod][2]); /* square matrix */
-
- HG1_SG = ((REAL) ((HG-1)*SG));
- Find_Offset_Scale_For_Linear_Map
- (Min, Max, 0.0, HG1_SG, &offset, &scale); /* HG output greys */
- array_index=0;
- for (i=0; i<nrows; i++)
- { for (j=0; j<ncols; j++)
- { value = Array[array_index++];
- Adjust_Value_Wmm(value, REAL_pixel, 0.0, HG1_SG, Min,Max, offset,scale);
- /* Turn into integer--- integer arithmetic gives speed */
- pixel = ((long) REAL_pixel);
- /* this special case is necessary to avoid ouput_pxl greater than.. */
- if (pixel == HG1_SG) pixel = pixel-1;
- dither = SGarray[ (i%SGarray_nrows)*SGarray_nrows + (j%SGarray_nrows) ];
- /* integer division */ }
- pdata[j] = ((unsigned char) ((pixel + SG - dither) / SG));
- block_write(device, x_at, (y_at-((float) i)), ncols, 1, pdata, 0);
- }
-}
-\f
-/* Blue Noise (minimized average error)
- pdata must have length ncols
- HG= Hardware Grey levels (output pixel values 0,HG-1)
- BNmethod is index for ht_bn method
-
- er_rows[][] should be 3 arrays of integers, of length (ncols+2*ER_C),
- which store previous errors, (ALLOCATED STORAGE)
- ER_R is number of error rows, (currently 3)
- ER_C is number of extra columns (to the left and to the right)
- of each er_row, they always contain ZEROS and serve to simplify the
- error summing process, i.e. we don't have to check for i,j bounds
- at edges, (no conditionals in the sum loop). Also, the code handles
- all cases in a uniform manner (for better explanation get PAS
- halftoning notes). */
-
-C_image_ht_bn_atxy_wmm (device, Array, pdata, nrows, ncols, x_at, y_at,
- Min, Max, HG, BNmethod, er_rows)
- int device;
- REAL Array [], Min, Max;
- unsigned char * pdata;
- int nrows, ncols;
- int HG, BNmethod;
- float x_at, y_at;
- float ** er_rows;
-{
- if (BNmethod == 0)
- C_image_ht_bn_atxy_wmm_0_
- (device, Array, pdata, nrows, ncols, x_at, y_at, Min, Max, HG, er_rows);
- else if (BNmethod == 1)
- C_image_ht_bn_atxy_wmm_1_
- (device, Array, pdata, nrows, ncols, x_at, y_at, Min, Max, HG, er_rows);
- else if (BNmethod == 2)
- C_image_ht_bn_atxy_wmm_2_
- (device, Array, pdata, nrows, ncols, x_at, y_at, Min, Max, HG, er_rows);
- else
- {
- fprintf (stderr, "\nHT_BN methods 0,1,2 only\n");
- fflush (stderr);
- }
-}
-\f
-/* the following 3 routines are identical,
- except for the mask weight numbers in computing ersum,
- the sole reason for this duplication is speed (if any) */
-
-/* FLOYD-STEINBERG-75 */
-C_image_ht_bn_atxy_wmm_0_ (device, Array, pdata, nrows, ncols, x_at, y_at,
- Min, Max, HG, er_rows)
- int device;
- REAL Array[], Min,Max;
- unsigned char *pdata;
- int nrows,ncols,HG;
- float x_at,y_at, **er_rows;
-{
- int i, j, m, array_index;
- int row_offset, col_offset, INT_pixel;
- REAL REAL_pixel, value, offset,scale, HG1_2;
- float ersum, weight, pixel;
- static int
- ER_R = 3,
- ER_R1 = 2,
- ER_C = 2,
- ER_C1 = 1;
-
- /* initialize error rows */
- for (i = 0; (i < ER_R); i += 1)
- for (j = 0; (j < (ncols + (2 * ER_C))); j += 1)
- (er_rows [i] [j]) = 0.0;
- /* notice this is REAL number */
- HG1_2 = ((REAL) ((HG - 1) * 2));
- /* HG output greys */
- Find_Offset_Scale_For_Linear_Map (Min, Max, 0.0, HG1_2, &offset, &scale);
- array_index = 0;
- for (i = 0; (i < nrows); i += 1)
- {
- for (j = 0; (j < ncols); j += 1)
- {
- ersum =
- (((1.0 / 16.0) * (er_rows [ER_R1 - 1] [ER_C + j - 1])) +
- ((5.0 / 16.0) * (er_rows [ER_R1 - 1] [ER_C + j])) +
- ((3.0 / 16.0) * (er_rows [ER_R1 - 1] [ER_C + j + 1])) +
- ((7.0 / 16.0) * (er_rows [ER_R1] [ER_C + j - 1])));
- /* this encodes the FLOYD-STEINBERG-75 mask for computing
- the average error correction */
- value = (Array [array_index++]);
- Adjust_Value_Wmm
- (value, REAL_pixel, 0.0, HG1_2, Min, Max, offset, scale);
- /* corrected intensity */
- pixel = (((float) REAL_pixel) + ersum);
- /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
- INT_pixel = ((long) ((pixel + 1) / 2.0));
- /* output pixel to be painted */
- (pdata [j]) = ((unsigned char) INT_pixel);
- /* error estimate */
- (er_rows [ER_R1] [ER_C + j]) = ((pixel / 2.0) - ((float) INT_pixel));
- }
- /* paint a row */
- block_write
- (device, x_at, (y_at - ((float) i)), ncols, 1, pdata, 0);
- /* rotate rows */
- {
- float * temp = (er_rows [0]);
- (er_rows [0]) = (er_rows [1]);
- (er_rows [1]) = (er_rows [2]);
- (er_rows [2]) = temp;
- }
- /* initialize (clean up) the new error row */
- for (m = ER_C; (m < ncols); m += 1)
- (er_rows [2] [m]) = 0.0;
- }
-}
-\f
-/* JARVIS-JUDICE-NINKE-76 mask */
-C_image_ht_bn_atxy_wmm_1_ (device, Array, pdata, nrows,ncols, x_at,y_at,
- Min,Max, HG, er_rows)
- int device;
- REAL Array[], Min,Max;
- unsigned char *pdata;
- int nrows,ncols,HG;
- float x_at,y_at, **er_rows;
-{ int i,j, m, array_index;
- int row_offset, col_offset, INT_pixel;
- REAL REAL_pixel, value, offset,scale, HG1_2;
- float ersum, weight, pixel, *temp;
- static int ER_R=3, ER_R1=2, ER_C=2, ER_C1=1;
-
- /* initialize error rows */
- for (i=0;i<ER_R;i++)
- for (j=0;j<ncols+(2*ER_C);j++)
- er_rows[i][j] = 0.0;
- HG1_2 = ((REAL) ((HG-1)*2)); /* notice this is REAL number */
- /* HG output greys */
- Find_Offset_Scale_For_Linear_Map
- (Min, Max, 0.0, HG1_2, &offset, &scale);
- array_index=0;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- ersum =
- ((1.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(-2)+j] +
- (3.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(-1)+j] +
- (5.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(0)+j] +
- (3.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(1)+j] +
- (1.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(2)+j] +
- (3.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(-2)+j] +
- (5.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(-1)+j] +
- (7.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(0)+j] +
- (5.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(1)+j] +
- (3.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(2)+j] +
- (5.0/48.0)*er_rows[ER_R1+(0)][ER_C+(-2)+j] +
- (7.0/48.0)*er_rows[ER_R1+(0)][ER_C+(-1)+j]);
- /* this encodes the JARVIS-JUDICE-NINKE-76 mask
- for computating the average error correction */
- value = Array[array_index++];
- Adjust_Value_Wmm(value, REAL_pixel, 0.0, HG1_2, Min,Max, offset,scale);
- /* */
- pixel = ((float) REAL_pixel) + ersum; /* corrected intensity */
- /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
- INT_pixel = ((long) ((pixel + 1) / 2.0));
- pdata[j] = ((unsigned char) INT_pixel); /* output pixel to be painted */
- /* error estimate */
- er_rows[ER_R1][ER_C +j] = (pixel/2.0) - ((float) INT_pixel);
- }
- /* paint a row */
- block_write(device, x_at, (y_at-((float) i)), ncols, 1, pdata, 0);
- temp = er_rows[0]; /* rotate rows */
- er_rows[0] = er_rows[1];
- er_rows[1] = er_rows[2];
- er_rows[2] = temp;
- /* initialize (clean up) the new error row */
- for (m=ER_C;m<ncols;m++) er_rows[2][m]=0.0;
- }
-}
-\f
-/* STUCKI-81 mask */
-C_image_ht_bn_atxy_wmm_2_ (device, Array, pdata, nrows,ncols, x_at,y_at,
- Min,Max, HG, er_rows)
- int device;
- REAL Array[], Min,Max;
- unsigned char *pdata;
- int nrows,ncols,HG;
- float x_at,y_at, **er_rows;
-{ int i,j, m, array_index;
- int row_offset, col_offset, INT_pixel;
- REAL REAL_pixel, value, offset,scale, HG1_2;
- float ersum, weight, pixel, *temp;
- static int ER_R=3, ER_R1=2, ER_C=2, ER_C1=1;
-
- for (i=0;i<ER_R;i++)
- for (j=0;j<ncols+(2*ER_C);j++)
- er_rows[i][j] = 0.0;
- HG1_2 = ((REAL) ((HG-1)*2));
- Find_Offset_Scale_For_Linear_Map(Min, Max, 0.0, HG1_2, &offset, &scale);
- array_index=0;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- ersum =
- ((1.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(-2)+j] +
- (2.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(-1)+j] +
- (4.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(0)+j] +
- (2.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(1)+j] +
- (1.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(2)+j] +
- (2.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(-2)+j] +
- (4.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(-1)+j] +
- (8.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(0)+j] +
- (4.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(1)+j] +
- (2.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(2)+j] +
- (4.0/42.0)*er_rows[ER_R1+(0)][ER_C+(-2)+j] +
- (8.0/42.0)*er_rows[ER_R1+(0)][ER_C+(-1)+j]);
- /* this encodes the STUCKI-81 mask
- for computating the average error correction */
- value = Array[array_index++];
- Adjust_Value_Wmm(value, REAL_pixel, 0.0, HG1_2, Min,Max, offset,scale);
- /* */
- pixel = ((float) REAL_pixel) + ersum; /* corrected intensity */
- /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
- INT_pixel = ((long) ((pixel + 1) / 2.0));
- pdata[j] = ((unsigned char) INT_pixel); /* output pixel to be painted */
- /* error estimate */
- er_rows[ER_R1][ER_C +j] = (pixel/2.0) - ((float) INT_pixel);
- }
- block_write (device, x_at, (y_at-((float) i)), ncols, 1, pdata, 0);
- temp = er_rows[0]; /* rotate rows */
- er_rows[0] = er_rows[1];
- er_rows[1] = er_rows[2];
- er_rows[2] = temp;
- /* initialize (clean up) the new error row */
- for (m=ER_C;m<ncols;m++)
- er_rows[2][m]=0.0;
- }
-}
-\f
-/* INTEGER BLUE NOISE
- pdata must have length ncols
- HG= Hardware Grey levels (output pixel values 0,HG-1)
- BNmethod is index for ht_ibn method
-
- IBN = integer blue noise
- uses integer arithmetic for speed, but also has different effect
- depending on the scaling of the integer intensities and error-corrections.
- A scale of PREC_SCALE=4 gives a very clear picture, with EDGE-INHANCEMENT.
- */
-
-/*
- ht_ibn_table[][0] ---> int BN; sum of error weights
- ht_ibn_table[][1] ---> int BNentries; number of weight entries
- ht_ibn_table[][2+i+0,1,2] ----> int row_offset,col_offset,weight;
- */
-
-static int ht_ibn_table[3][2+(3*12)] =
-{ {16,4, -1,-1,1, -1,0,5, -1,1,3, 0,-1,7},
- {48,12, -2,-2,1, -2,-1,3, -2,0,5, -2,1,3, -2,2,1,
- -1,-2,3, -1,-1,5, -1,0,7, -1,1,5, -1,2,3,
- 0,-2,5, 0,-1,7},
- {42,12, -2,-2,1, -2,-1,2, -2,0,4, -2,1,2, -2,2,1,
- -1,-2,2, -1,-1,4, -1,0,8, -1,1,4, -1,2,2,
- 0,-2,4, 0,-1,8}
-};
-\f
-/*
- er_rows[][] should be 3 arrays of integers, of length (ncols+2*ER_C),
- which store previous errors, (ALLOCATED STORAGE)
- ER_R is number of error rows, (currently 3)
- ER_C is number of extra columns (to the left and right) of each er_row,
- they always contain ZEROS and serve to simplify the error summing process,
- i.e. we don't have to check for i,j bounds at edges
- (no conditionals in the sum loop).
- Also, the code handles all cases in a uniform manner.
- (for better explanation get pas halftoning notes) */
-
-C_image_ht_ibn_atxy_wmm (device, Array, pdata, nrows,ncols, x_at,y_at, Min,Max,
- HG,BNmethod, er_rows, PREC_SCALE)
- int device;
- REAL Array[], Min,Max;
- unsigned char *pdata;
- int nrows,ncols,HG,BNmethod;
- MINTEGER **er_rows, PREC_SCALE;
- float x_at,y_at;
-{ int i,j, m, BNentries, array_index, row_offset, col_offset;
- MINTEGER BN, ersum, weight, PREC_2, PREC, *temp, pixel;
- /* PREC is a scale factor that varies the precision in ersum
- -- using integer arithmetic for speed */
- REAL REAL_pixel, value, offset,scale, HG1_2_PREC;
- static int ER_R=3, ER_R1=2, ER_C=2, ER_C1=1;
-
- for (i=0;i<ER_R;i++)
- for (j=0;j<ncols+(2*ER_C);j++) er_rows[i][j] = 0;
- BN = ((MINTEGER) ht_ibn_table[BNmethod][0]);
- BNentries = ht_ibn_table[BNmethod][1];
- HG1_2_PREC = ((REAL) PREC_SCALE);
- /* HG1_2_PREC = ((REAL) ( (1<<( 8*(sizeof(MINTEGER))-1 )) / BN)); */
- /* max_intensity maps to (max_integer/BN), so that */
- /* neither ersum*BN nor (max_intensity + ersum) overflow */
- PREC_2 = ((MINTEGER) HG1_2_PREC) / ((MINTEGER) (HG-1));
- PREC = PREC_2 / 2;
- Find_Offset_Scale_For_Linear_Map
- (Min, Max, 0.0, HG1_2_PREC, &offset, &scale);
- array_index=0;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- ersum=0;
- for (m=0;m<(3*BNentries); m=m+3)
- {
- row_offset = ht_ibn_table[BNmethod][2+m+0]; /* should be 0,1,2 */
- col_offset = ht_ibn_table[BNmethod][2+m+1];
- weight = ((MINTEGER) ht_ibn_table[BNmethod][2+m+2]);
- ersum += weight * er_rows[ER_R1+row_offset][ER_C +j+ col_offset];
- }
- ersum = ersum / BN;
- value = Array[array_index++];
- Adjust_Value_Wmm
- (value, REAL_pixel, 0.0, HG1_2_PREC, Min,Max, offset,scale);
- pixel = ((MINTEGER) REAL_pixel);
- pixel = pixel + ersum; /* corrected intensity */
- ersum = ((pixel + PREC) / PREC_2);
- pdata[j] = ((unsigned char) ersum);
- er_rows[ER_R1][ER_C +j] = pixel - (PREC_2*ersum);
- }
- block_write (device, x_at, (y_at-((float) i)), ncols, 1, pdata, 0);
- temp = er_rows[0]; /* rotate rows */
- er_rows[0] = er_rows[1];
- er_rows[1] = er_rows[2];
- er_rows[2] = temp;
- for (m=0;m<(ncols+(2*ER_C));m++) er_rows[2][m]=0;
- }
-}
-\f
-/* PSAM drawing (see scheme primitives definition for description)
- Pdata must be (16 * ncols) bytes in size. */
-
-C_image_psam_atxy_wmm(device, Array, pdata, nrows, ncols, x_origin, y_origin,
- Min,Max)
- int device;
- REAL Array[], Min,Max;
- unsigned char *pdata; /* pdata should have length 16*4*ncols */
- long nrows, ncols;
- float x_origin, y_origin;
-{ register long i,j, i4;
- register long array_index, pdata_index;
- long ncols4 = 4 * ncols;
- long color_index;
- REAL REAL_pixel, value, offset,scale;
-
- Find_Offset_Scale_For_Linear_Map
- (Min, Max, 0.0, 15.0, &offset, &scale); /* 16 grey levels */
-
- array_index=0; i4=0;
- for (i=0; i<nrows; i++)
- { pdata_index = 0;
- for (j=0; j<ncols; j++)
- { value = Array[array_index++];
- Adjust_Value_Wmm(value, REAL_pixel, 0.0, 15.0, Min,Max, offset,scale);
- color_index = ((long) (REAL_pixel + .5)); /* integer between 0 and 15 */
- /* */
- my_write_dither(pdata, pdata_index, ncols4, color_index);
- /* dependency between this and my_write_dither */
- pdata_index = pdata_index + 4;
- }
- block_write(device, x_origin, y_origin-i4, ncols4, 4, pdata, 0);
- i4 = i4+4;
- }
- /* A(i,j) --> Array[i*ncols + j] */
-}
-
-/* Same as above, except use Adjust_Value_Womm.
- */
-C_image_psam_atxy_womm(device, Array, pdata, nrows, ncols, x_origin, y_origin,
- Min,Max)
- int device;
- REAL Array[], Min,Max;
- unsigned char *pdata; /* pdata should have length 16*4*ncols */
- long nrows, ncols;
- float x_origin, y_origin;
-{ register long i,j, i4;
- register long array_index, pdata_index;
- long ncols4 = 4*ncols;
- long color_index;
- REAL REAL_pixel, value, offset,scale;
-
- Find_Offset_Scale_For_Linear_Map
- (Min, Max, 0.0, 15.0, &offset, &scale); /* 16 grey levels */
- array_index=0; i4=0;
- for (i=0; i<nrows; i++)
- { pdata_index = 0;
- for (j=0; j<ncols; j++)
- { value = Array[array_index++];
- Adjust_Value_Womm(value, REAL_pixel, 0.0, 15.0, Min,Max, offset,scale);
- /* ONLY DIFFERENCE WITH PREVIOUS ONE */
- color_index = ((long) (REAL_pixel + .5)); /* integer between 0 and 15 */
- /* */
- my_write_dither(pdata, pdata_index, ncols4, color_index);
- /* dependency between this and my_write_dither */
- pdata_index = pdata_index + 4;
- }
- block_write(device, x_origin, y_origin-i4, ncols4, 4, pdata, 0);
- i4 = i4+4;
- }
- /* A(i,j) --> Array[i*ncols + j] */
-}
-\f
-/* psam dither[11] is left out, { 1,1,0,1, 1,1,1,0, 0,1,1,0, 1,0,1,1 } */
-
-/* The following routine writes a 4x4 dither cell
- in 4 consecutive rows of pdata. It assumes a lot about
- pdata and the other args passed to it. READ carefully.
- Designed TO BE USED BY C_image_psam_atxy_wmm
-*/
-
-my_write_dither(pdata, pdata_row_index, ncols , color_index)
- unsigned char *pdata;
- long pdata_row_index, ncols;
- long color_index; /* should be 0 to 15 */
-{ static unsigned char dither_table[16][16] =
- {{ 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0 },
- { 0,0,0,0, 0,1,0,0, 0,0,0,0, 0,0,0,0 },
- { 0,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,0 },
- { 0,0,0,0, 0,1,1,0, 0,0,1,0, 0,0,0,0 },
- { 0,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,0 },
- { 1,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,0 },
- { 1,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,1 },
- { 1,0,0,1, 0,1,1,0, 0,1,1,0, 0,0,0,1 },
- { 1,0,0,1, 0,1,1,0, 0,1,1,0, 1,0,0,1 },
- { 1,1,0,1, 0,1,1,0, 0,1,1,0, 1,0,0,1 },
- { 1,1,0,1, 1,1,1,0, 0,1,1,0, 1,0,0,1 },
- { 1,1,0,1, 1,1,1,0, 0,1,1,1, 1,0,1,1 },
- { 1,1,0,1, 1,1,1,0, 1,1,1,1, 1,0,1,1 },
- { 1,1,1,1, 1,1,1,0, 1,1,1,1, 1,0,1,1 },
- { 1,1,1,1, 1,1,1,0, 1,1,1,1, 1,1,1,1 },
- { 1,1,1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1 }};
- long i, row_start,m;
- long dither_index; /* do not mix up the counters, indexes */
- dither_index=0;
- for (i=0;i<4;i++) { row_start = pdata_row_index + (i*ncols);
- for (m=row_start; m<row_start+4; m++)
- pdata[m] = dither_table[color_index][dither_index++]; }
-}
-\f
-/* Below are the OLD DRAWING ROUTINES for 16 color monitors.
- In effect they are fixed threshold, with 16 HG levels.
- The only difference is they also do magnification by replicating pixels.
- */
-
-/* Image_Draw_Magnify_N_Times : N^2 in area
- */
-Image_Draw_Magnify_N_Times_With_Offset_Scale
- (device, Array, pdata, nrows, ncols, x_origin,y_origin,Offset,Scale,N)
- int device;
- REAL Array[], Offset, Scale;
- unsigned char *pdata;
- long nrows, ncols, N;
- float x_origin, y_origin;
-{ fast long i,j,m;
- fast long array_index;
- long ncolsN= N * ncols;
- long nrowsN= N * nrows;
- fast unsigned char pixel;
- fast REAL REAL_pixel;
-
- array_index = 0;
- for (i = 0; i < nrowsN;) /* note that i is NOT incremented here */
- { for (j = 0; j < ncolsN;) /* note that j is NOT incremented here */
- { REAL_pixel = Offset + (Array[array_index++] * Scale);
- if (REAL_pixel > 15.0)
- pixel = MAXIMUM_INTENSITY_INDEX;
- else if (REAL_pixel < 2.0)
- pixel = MINIMUM_INTENSITY_INDEX;
- else
- pixel = ((unsigned char) (Round_REAL(REAL_pixel)));
- for (m=0; m<N; m++) { pdata[j] = pixel;
- j++; }
- }
- for (m=0; m<N; m++) {
- block_write(device, x_origin, y_origin-i, ncolsN, 1, pdata, 0);
- i++; }
- /* A(i,j) --> Array[i*ncols + j] */
- }
-}
-
-/* Image_Draw_Magnify_N_Times_Only : N^2 in area
- This procedure throws away (i.e. maps to SCREEN_BACKGROUND_COLOR)
- all values outside the range given by Offset,Scale.
- */
-Image_Draw_Magnify_N_Times_With_Offset_Scale_Only
- (device, Array, pdata, nrows, ncols, x_origin, y_origin, Offset, Scale, N)
- int device;
- REAL Array[], Offset, Scale;
- unsigned char *pdata;
- long nrows, ncols, N;
- float x_origin, y_origin;
-{ fast long i,j,m;
- fast long array_index;
- long ncolsN= N * ncols;
- long nrowsN= N * nrows;
- fast unsigned char pixel;
- fast REAL REAL_pixel;
-
- array_index = 0;
- for (i=0; i<nrowsN;) /* note that i is NOT incremented here */
- { for (j=0; j<ncolsN;) /* note that j is NOT incremented here */
- { REAL_pixel = Offset + (Array[array_index++] * Scale);
- if (REAL_pixel > 15.0)
- pixel = SCREEN_BACKGROUND_COLOR;
- else if (REAL_pixel < 2.0)
- pixel = SCREEN_BACKGROUND_COLOR;
- else
- pixel = ((unsigned char) (Round_REAL(REAL_pixel)));
- for (m=0; m<N; m++)
- { pdata[j] = pixel;
- j++; }
- }
- for (m=0; m<N; m++) {
- block_write(device, x_origin, y_origin - i, ncolsN, 1, pdata, 0);
- i++; }
- /* A(i,j) --> Array[i*ncols + j] */
- }
-}
-\f
-/* Grey Level Manipulations */
-
-DEFINE_PRIMITIVE ("NEW-COLOR", Prim_new_color, 5,5, 0)
-{
- int device;
- long index;
- PRIMITIVE_HEADER (5);
- device = (SB_DEVICE_ARG (1));
- index =
- (arg_integer_in_range
- (2, STARBASE_COLOR_TABLE_START, STARBASE_COLOR_TABLE_SIZE));
- inquire_color_table
- (device,
- STARBASE_COLOR_TABLE_START,
- STARBASE_COLOR_TABLE_SIZE,
- Color_Table);
- (Color_Table [index] [0]) =
- (arg_real_in_range (3, ((double) 0), ((double) 1)));
- (Color_Table [index] [1]) =
- (arg_real_in_range (4, ((double) 0), ((double) 1)));
- (Color_Table [index] [2]) =
- (arg_real_in_range (5, ((double) 0), ((double) 1)));
- define_color_table
- (device,
- STARBASE_COLOR_TABLE_START,
- STARBASE_COLOR_TABLE_SIZE,
- Color_Table);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("INQUIRE-COLOR", Prim_inquire_color, 2,2, 0)
-{
- int device, index;
- PRIMITIVE_HEADER (2);
- device = (SB_DEVICE_ARG (1));
- index =
- (arg_integer_in_range
- (2, STARBASE_COLOR_TABLE_START, STARBASE_COLOR_TABLE_SIZE));
- inquire_color_table
- (device,
- STARBASE_COLOR_TABLE_START,
- STARBASE_COLOR_TABLE_SIZE,
- Color_Table);
- PRIMITIVE_RETURN
- (cons ((double_to_flonum ((double) (Color_Table[index][0]))),
- (cons ((double_to_flonum ((double) (Color_Table[index][1]))),
- (cons ((double_to_flonum ((double) (Color_Table[index][2]))),
- EMPTY_LIST))))));
-}
-\f
-DEFINE_PRIMITIVE ("READ-COLORS-FROM-FILE", Prim_read_colors_from_file, 2,2, 0)
-{
- int device;
- long i;
- FILE * fp;
- PRIMITIVE_HEADER (2);
- device = (SB_DEVICE_ARG (1));
- CHECK_ARG (2, STRING_P);
-
- fp = (fopen (((char *) (STRING_LOC ((ARG_REF (2)), 0))), "r"));
- if (fp == ((FILE *) 0))
- error_bad_range_arg (2);
- if (feof (fp))
- {
- fprintf (stderr, "\nColor Datafile is empty!\n");
- error_external_return ();
- }
- for (i = 0; (i < STARBASE_COLOR_TABLE_SIZE); i += 1)
- fscanf (fp, "%f %f %f\n",
- (& (Color_Table [i] [0])),
- (& (Color_Table [i] [1])),
- (& (Color_Table [i] [2])));
- if ((fclose (fp)) != 0)
- error_external_return ();
- define_color_table
- (device,
- STARBASE_COLOR_TABLE_START,
- STARBASE_COLOR_TABLE_SIZE,
- Color_Table);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("SAVE-COLORS-IN-FILE", Prim_save_colors_in_file, 2,2, 0)
-{
- int device;
- long i;
- FILE * fp;
- PRIMITIVE_HEADER (2);
- device = (SB_DEVICE_ARG (1));
- CHECK_ARG (2, STRING_P);
- fp = (fopen (((char *) (STRING_LOC ((ARG_REF (2)), 0))), "w"));
- if (fp == ((FILE *) 0))
- error_bad_range_arg (2);
- inquire_color_table
- (device,
- STARBASE_COLOR_TABLE_START,
- STARBASE_COLOR_TABLE_SIZE,
- Color_Table);
- for (i = 0; (i < STARBASE_COLOR_TABLE_SIZE); i += 1)
- fprintf (fp, "%f %f %f\n",
- (Color_Table [i] [0]),
- (Color_Table [i] [1]),
- (Color_Table [i] [2]));
- if ((fclose (fp)) != 0)
- error_external_return ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: sgx.c,v 1.13 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Simple X graphics for HP 9000 series 300 machines. */
-
-#include <X/Xlib.h>
-#include <X/Xhp.h>
-#include "scheme.h"
-#include "prims.h"
-#include "sgraph.h"
-\f
-static Display * display = NULL;
-static Window window = 0;
-static char filename [1024] = "";
-static int raster_state = 0;
-
-static void close_display ();
-static void close_window ();
-static void delete_raster ();
-
-#define GUARANTEE_DISPLAY() \
-{ \
- if (display == NULL) \
- error_external_return (); \
-}
-
-#define GUARANTEE_WINDOW() \
-{ \
- if (window == 0) \
- error_external_return (); \
-}
-
-#define GUARANTEE_RASTER() \
-{ \
- GUARANTEE_WINDOW (); \
- if (raster_state == 0) \
- error_external_return (); \
-}
-
-static int
-x_io_error_handler (display)
- Display *display;
-{
- fprintf (stderr, "\nX IO Error\n");
- error_external_return ();
-}
-
-static int
-x_error_handler (display, error_event)
- Display *display;
- XErrorEvent *error_event;
-{
- fprintf (stderr, "\nX Error: %s\n",
- (XErrDescrip (error_event -> error_code)));
- fprintf (stderr, " Request code: %d\n",
- (error_event -> request_code));
- fprintf (stderr, " Request function: %d\n", (error_event -> func));
- fprintf (stderr, " Request window: %x\n", (error_event -> window));
- fprintf (stderr, " Error serial: %x\n", (error_event -> serial));
- error_external_return ();
-}
-\f
-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\n\
-default display is opened (based on the DISPLAY environment\n\
-variable). Returns #T if the open succeeds, #F otherwise.\n\
-\n\
-This primitive is additionally useful for determining whether the\n\
-X server is running on the named display.")
-{
- PRIMITIVE_HEADER (1);
- /* Only one display at a time. */
- close_display ();
- /* Grab error handlers. */
- XErrorHandler (x_error_handler);
- XIOErrorHandler (x_io_error_handler);
- display =
- (XOpenDisplay (((ARG_REF (1)) == SHARP_F) ? NULL : (STRING_ARG (1))));
- window = 0;
- (filename [0]) = '\0';
- raster_state = 0;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (display != NULL));
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-CLOSE-DISPLAY", Prim_x_graphics_close_display, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- close_display ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-static void
-close_display ()
-{
- if (display != NULL)
- {
- close_window ();
- XCloseDisplay (display);
- display = NULL;
- }
- return;
-}
-\f
-/* (X-GRAPHICS-OLD-OPEN-WINDOW x y width height border-width)
- Opens a window at the given position, with the given border width,
- on the current display. If another window was previously opened
- using this primitive, it is closed. */
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-OLD-OPEN-WINDOW", Prim_x_graphics_old_open_window, 5, 5, 0)
-{
- XhpArgItem arglist [7];
- PRIMITIVE_HEADER (5);
- GUARANTEE_DISPLAY ();
- /* Allow only one window open at a time. */
- close_window ();
- /* Open the window with the given arguments. */
- window =
- (XCreateWindow (RootWindow,
- (arg_nonnegative_integer (1)),
- (arg_nonnegative_integer (2)),
- (arg_nonnegative_integer (3)),
- (arg_nonnegative_integer (4)),
- (arg_nonnegative_integer (5)),
- WhitePixmap,
- BlackPixmap));
- if (window == 0)
- error_external_return ();
- XStoreName (window, "scheme-graphics");
- XFlush ();
- (filename [0]) = '\0';
- raster_state = 0;
- /* Create a starbase device file. */
- if ((XhpFile ((& (filename [0])), window, display)) == 0)
- {
- (filename [0]) = '\0';
- close_window ();
- error_external_return ();
- }
- /* Return the filename so it can be passed to starbase. */
- PRIMITIVE_RETURN (char_pointer_to_string (& (filename [0])));
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-CLOSE-WINDOW", Prim_x_graphics_close_window, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- close_window ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-static void
-close_window ()
-{
- sb_close_device ();
- if ((filename [0]) != '\0')
- {
- XhpDestroy (filename);
- (filename [0]) = '\0';
- }
- if (window != 0)
- {
- delete_raster ();
- XDestroyWindow (window);
- XFlush ();
- window = 0;
- }
- return;
-}
-\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-WINDOW", Prim_x_graphics_map_window, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- GUARANTEE_WINDOW ();
- XMapWindow (window);
- XFlush ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-UNMAP-WINDOW", Prim_x_graphics_unmap_window, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- GUARANTEE_WINDOW ();
- XUnmapWindow (window);
- XFlush ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-RAISE-WINDOW", Prim_x_graphics_raise_window, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- GUARANTEE_WINDOW ();
- XRaiseWindow (window);
- XFlush ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-LOWER-WINDOW", Prim_x_graphics_lower_window, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- GUARANTEE_WINDOW ();
- XLowerWindow (window);
- XFlush ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-CONFIGURE-WINDOW", Prim_x_graphics_configure_window, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- GUARANTEE_WINDOW ();
- if (raster_state != 0)
- error_external_return ();
- XConfigureWindow
- (window,
- (arg_nonnegative_integer (1)),
- (arg_nonnegative_integer (2)),
- (arg_nonnegative_integer (3)),
- (arg_nonnegative_integer (4)));
- XFlush ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* Routines to control the backup raster. */
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-CREATE-RASTER", Prim_x_graphics_create_raster, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- GUARANTEE_WINDOW ();
- delete_raster ();
- XhpRetainWindow (window, XhpCREATE_RASTER);
- XFlush ();
- raster_state = 1;
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-DELETE-RASTER", Prim_x_graphics_delete_raster, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- GUARANTEE_WINDOW ();
- delete_raster ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-static void
-delete_raster ()
-{
- if (raster_state != 0)
- {
- XhpRetainWindow (window, XhpDELETE_RASTER);
- XFlush ();
- raster_state = 0;
- }
- return;
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-START-RETAIN", Prim_x_graphics_start_retain, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- GUARANTEE_WINDOW ();
- GUARANTEE_RASTER ();
- XhpRetainWindow (window, XhpSTART_RETAIN);
- XFlush ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-STOP-RETAIN", Prim_x_graphics_stop_retain, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- GUARANTEE_WINDOW ();
- GUARANTEE_RASTER ();
- XhpRetainWindow (window, XhpSTOP_RETAIN);
- XFlush ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
+++ /dev/null
-/* -*-C-*-
-
-$Id: sgx11.c,v 1.8 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Simple X11 graphics for HP 9000 series 300 machines. */
-
-#include <X11/Xlib.h>
-#include "scheme.h"
-#include "prims.h"
-#include "sgraph.h"
-\f
-static int
-x_io_error_handler (display)
- Display * display;
-{
- fprintf (stderr, "\nX IO Error\n");
- error_external_return ();
-}
-
-static int
-x_error_handler (display, error_event)
- Display * display;
- XErrorEvent * error_event;
-{
- char buffer [2048];
-
- XGetErrorText (display, (error_event -> error_code),
- (& buffer), (sizeof (buffer)));
- fprintf (stderr, "\nX Error: %s\n", buffer);
- fprintf (stderr, " Request code: %d\n",
- (error_event -> request_code));
- fprintf (stderr, " Error serial: %x\n", (error_event -> serial));
- error_external_return ();
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-DISPLAY-NAME", Prim_x_graphics_display_name, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (char_pointer_to_string
- (XDisplayName (((ARG_REF (1)) == SHARP_F) ? NULL : (STRING_ARG (1)))));
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-GRAB-ERROR-HANDLERS", Prim_x_graphics_grab_error_handlers, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- XSetErrorHandler (x_error_handler);
- XSetIOErrorHandler (x_io_error_handler);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
/* -*-C-*-
-$Id: stack.h,v 9.46 2007/01/05 21:19:25 cph Exp $
+$Id: stack.h,v 9.47 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* This file contains macros for manipulating stacks and stacklets. */
-\f
-#ifndef STACK_RESET
-# define STACK_RESET() do {} while (0)
-#endif /* STACK_RESET */
-
-#ifdef USE_STACKLETS
+/* Stack abstraction */
-/*
- Stack is made up of linked small parts, each in the heap
- */
-
-#define INITIALIZE_STACK() do \
+#define SET_STACK_LIMITS(addr, n_words) do \
{ \
- if (GC_Check(Default_Stacklet_Size)) \
- Microcode_Termination(TERM_STACK_ALLOCATION_FAILED); \
- SET_STACK_GUARD (Free + STACKLET_HEADER_SIZE); \
- *Free = \
- (MAKE_OBJECT (TC_MANIFEST_VECTOR, (Default_Stacklet_Size - 1))); \
- Free += Default_Stacklet_Size; \
- sp_register = Free; \
- Free_Stacklets = NULL; \
- Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0; \
+ stack_start = (addr); \
+ stack_end = (stack_start + (n_words)); \
} while (0)
-/* This is a lie, but OK in the context in which it is used. */
-
-#define STACK_OVERFLOWED_P() FALSE
-
-#define Internal_Will_Push(N) \
-{ \
- if ((sp_register - (N)) < Stack_Guard) \
- { \
- Allocate_New_Stacklet((N)); \
- } \
-}
-
-/* No space required independent of the heap for the stacklets */
-
-#define STACK_ALLOCATION_SIZE(Stack_Blocks) 0
-
-#define Current_Stacklet (Stack_Guard - STACKLET_HEADER_SIZE)
-
-/* Make the unused portion of the old stacklet invisible to garbage
- * collection. This also allows the stack pointer to be reconstructed.
- */
-
-#define Internal_Terminate_Old_Stacklet() \
-{ \
- Current_Stacklet[STACKLET_REUSE_FLAG] = SHARP_T; \
- Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
- MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (sp_register - Stack_Guard)); \
-}
-\f
-#ifdef ENABLE_DEBUGGING_TOOLS
-
-#define Terminate_Old_Stacklet() \
-{ \
- if (sp_register < Stack_Guard) \
- { \
- outf_fatal ("\nsp_register: 0x%lx, Guard: 0x%lx\n", \
- ((long) sp_register), ((long) Stack_Guard)); \
- Microcode_Termination(TERM_EXIT); \
- } \
- Internal_Terminate_Old_Stacklet(); \
-}
-
-#else /* not ENABLE_DEBUGGING_TOOLS */
-
-#define Terminate_Old_Stacklet() Internal_Terminate_Old_Stacklet()
-
-#endif /* ENABLE_DEBUGGING_TOOLS */
-
-/* Used by garbage collector to detect the end of constant space */
-
-#define CONSTANT_AREA_START() Constant_Space
-
-#define Get_Current_Stacklet() \
- (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Current_Stacklet))
-
-#define Previous_Stack_Pointer(Where) \
- (MEMORY_LOC \
- (Where, \
- (STACKLET_HEADER_SIZE + \
- (OBJECT_DATUM (MEMORY_REF (Where, STACKLET_UNUSED_LENGTH))))))
-
-#define Set_Current_Stacklet(Where) \
-{ \
- SCHEME_OBJECT Our_Where; \
- \
- Our_Where = (Where); \
- SET_STACK_GUARD (MEMORY_LOC (Our_Where, STACKLET_HEADER_SIZE)); \
- sp_register = Previous_Stack_Pointer(Our_Where); \
-}
-
-#define STACKLET_SLACK (STACKLET_HEADER_SIZE + CONTINUATION_SIZE)
-
-#define Default_Stacklet_Size (Stack_Size + STACKLET_SLACK)
+#define STACK_BOTTOM stack_end
+#define STACK_TOP stack_start
-#define New_Stacklet_Size(N) \
- (STACKLET_SLACK + Stack_Size * (((N) + Stack_Size - 1) / Stack_Size))
-
-#define Get_End_Of_Stacklet() \
- (&(Current_Stacklet[1 + OBJECT_DATUM (Current_Stacklet[STACKLET_LENGTH])]))
-\f
-#define Apply_Stacklet_Backout() \
-Will_Push((2 * CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 2)); \
- exp_register = SHARP_F; \
- Store_Return(RC_END_OF_COMPUTATION); \
- Save_Cont(); \
- STACK_PUSH (val_register); \
- STACK_PUSH (Previous_Stacklet); \
- STACK_PUSH (STACK_FRAME_HEADER + 1); \
- Store_Return(RC_INTERNAL_APPLY); \
- Save_Cont(); \
-Pushed()
-
-#define Join_Stacklet_Backout() Apply_Stacklet_Backout()
-
-/* This depends on the fact that Within_Control_Point is going to
- * push an apply frame immediately after Return_To_Previous_Stacklet
- * "returns". This apply will cause the GC, then the 2nd argument to
- * Within_Control_Point will be invoked, and finally the control point
- * will be entered.
- */
-
-#define Within_Stacklet_Backout() \
-{ \
- SCHEME_OBJECT Old_Expression; \
- \
- Old_Expression = exp_register; \
- exp_register = Previous_Stacklet; \
- Store_Return(RC_JOIN_STACKLETS); \
- Save_Cont(); \
- exp_register = Old_Expression; \
-}
-\f
-/* Our_Throw is used in chaining from one stacklet to another. In
- * order to improve efficiency, the entire stack is copied neither on
- * catch or throw, but is instead copied one stacklet at a time as
- * needed. The need to copy a stacklet is signified by the object in
- * the STACKLET_REUSE_FLAG of a stacklet. If this object is #F, the
- * stacklet is copied when it is "returned into", and the word is set
- * to #F in the stacklet into which the copied one will return. When a
- * stacklet is returned from, it is no longer needed for anything so it
- * can be deallocated. A free list of deallocate stacklets is kept in
- * order to improve the efficiencty of their use.
- */
-
-#define Our_Throw(From_Pop_Return, Stacklet) \
+#define INITIALIZE_STACK() do \
{ \
- SCHEME_OBJECT Previous_Stacklet; \
- SCHEME_OBJECT *Stacklet_Top; \
- \
- Previous_Stacklet = (Stacklet); \
- Stacklet_Top = Current_Stacklet; \
- Stacklet_Top[STACKLET_FREE_LIST_LINK] = \
- ((SCHEME_OBJECT) Free_Stacklets); \
- Free_Stacklets = Stacklet_Top; \
- if (!(From_Pop_Return)) \
- { \
- Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0; \
- } \
- if ((MEMORY_REF (Previous_Stacklet, STACKLET_REUSE_FLAG)) == SHARP_F) \
- { \
- /* We need to copy the stacklet into which we are \
- returning. \
- */ \
- \
- if (GC_Check(VECTOR_LENGTH (Previous_Stacklet) + 1)) \
- { \
- /* We don't have enough space to copy the stacklet. */ \
- \
- Free_Stacklets = \
- ((SCHEME_OBJECT *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \
- sp_register = Get_End_Of_Stacklet(); \
- Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0
+ stack_pointer = STACK_BOTTOM; \
+ (*STACK_TOP) = (MAKE_BROKEN_HEART (STACK_TOP)); \
+ stack_guard = (STACK_TOP + STACK_GUARD_SIZE); \
+ COMPILER_SETUP_INTERRUPT (); \
+} while (0)
- /* Backout code inserted here by macro user */
-\f
-#define Our_Throw_Part_2() \
- Request_GC(VECTOR_LENGTH (Previous_Stacklet) + 1); \
- } \
- else \
- { \
- /* There is space available to copy the stacklet. */ \
- \
- long Unused_Length; \
- fast Used_Length; \
- fast SCHEME_OBJECT *Old_Stacklet_Top, *temp; \
- SCHEME_OBJECT *First_Continuation; \
- \
- Old_Stacklet_Top = OBJECT_ADDRESS (Previous_Stacklet); \
- First_Continuation = \
- MEMORY_LOC (Previous_Stacklet, \
- ((1 + VECTOR_LENGTH (Previous_Stacklet)) - \
- CONTINUATION_SIZE)); \
- if (Old_Stacklet_Top == Prev_Restore_History_Stacklet) \
- Prev_Restore_History_Stacklet = NULL; \
- if (First_Continuation[CONTINUATION_RETURN_CODE] == \
- MAKE_OBJECT (TC_RETURN_CODE, RC_JOIN_STACKLETS)) \
- { \
- SCHEME_OBJECT Older_Stacklet; \
- \
- Older_Stacklet = First_Continuation[CONTINUATION_EXPRESSION]; \
- MEMORY_SET (Older_Stacklet, STACKLET_REUSE_FLAG, SHARP_F); \
- } \
- temp = Free; \
- SET_STACK_GUARD (& (temp[STACKLET_HEADER_SIZE])); \
- temp[STACKLET_LENGTH] = Old_Stacklet_Top[STACKLET_LENGTH]; \
- Unused_Length = \
- OBJECT_DATUM (Old_Stacklet_Top[STACKLET_UNUSED_LENGTH]) + \
- STACKLET_HEADER_SIZE; \
- temp += Unused_Length; \
- sp_register = temp; \
- Used_Length = \
- (OBJECT_DATUM (Old_Stacklet_Top[STACKLET_LENGTH]) - \
- Unused_Length) + 1; \
- Old_Stacklet_Top += Unused_Length; \
- while (--Used_Length >= 0) \
- *temp++ = *Old_Stacklet_Top++; \
- Free = temp; \
- } \
- } \
- else \
- { \
- /* No need to copy the stacklet we are going into */ \
- \
- if (OBJECT_ADDRESS (Previous_Stacklet)== \
- Prev_Restore_History_Stacklet) \
- Prev_Restore_History_Stacklet = NULL; \
- Set_Current_Stacklet(Previous_Stacklet); \
- } \
-}
-\f
-#else /* not USE_STACKLETS */
+#define STACK_OVERFLOWED_P() \
+ ((*STACK_TOP) != (MAKE_BROKEN_HEART (STACK_TOP)))
-/*
- Full size stack in a statically allocated area
- */
+#ifndef STACK_RESET
+# define STACK_RESET() do {} while (0)
+#endif
-#define Stack_Check(P) do \
+#define STACK_CHECK(n) do \
{ \
- if ((P) <= Stack_Guard) \
+ if (!CAN_PUSH_P (n)) \
{ \
- extern void EXFUN (stack_death, (CONST char *)); \
- if (STACK_OVERFLOWED_P ()) \
- stack_death ("Stack_Check"); \
+ STACK_CHECK_FATAL ("STACK_CHECK"); \
REQUEST_INTERRUPT (INT_Stack_Overflow); \
} \
} while (0)
-#define Internal_Will_Push(N) Stack_Check(sp_register - (N))
-
-#define Terminate_Old_Stacklet()
-
-#define Get_Current_Stacklet() SHARP_F
-
-#define Set_Current_Stacklet(Where) {}
-
-#define Previous_Stack_Pointer(Where) \
- (MEMORY_LOC \
- (Where, \
- (STACKLET_HEADER_SIZE + \
- (OBJECT_DATUM (MEMORY_REF (Where, STACKLET_UNUSED_LENGTH))))))
-
-/* Never allocate more space */
-#define New_Stacklet_Size(N) 0
-
-#define Get_End_Of_Stacklet() Stack_Top
-
-/* Not needed in this version */
-
-#define Join_Stacklet_Backout()
-#define Apply_Stacklet_Backout()
-#define Within_Stacklet_Backout()
-\f
-/* This piece of code KNOWS which way the stack grows.
- The assumption is that successive pushes modify decreasing addresses.
- */
-
-/* Clear the stack and replace it with a copy of the contents of the
- control point. Also disables the history collection mechanism,
- since the saved history would be incorrect on the new stack. */
-
-#define Our_Throw(From_Pop_Return, P) do \
+#define STACK_CHECK_FATAL(s) do \
{ \
- SCHEME_OBJECT Control_Point; \
- fast SCHEME_OBJECT *To_Where, *From_Where; \
- fast long len, valid, invalid; \
- \
- Control_Point = (P); \
- if ((Consistency_Check) \
- && (OBJECT_TYPE (Control_Point) != TC_CONTROL_POINT)) \
- Microcode_Termination (TERM_BAD_STACK); \
- len = VECTOR_LENGTH (Control_Point); \
- invalid = ((OBJECT_DATUM (MEMORY_REF (Control_Point, \
- STACKLET_UNUSED_LENGTH))) + \
- STACKLET_HEADER_SIZE); \
- valid = ((len + 1) - invalid); \
- CLEAR_INTERRUPT(INT_Stack_Overflow); \
- To_Where = (Stack_Top - valid); \
- From_Where = MEMORY_LOC (Control_Point, invalid); \
- Stack_Check (To_Where); \
- sp_register = To_Where; \
- while (--valid >= 0) \
- *To_Where++ = *From_Where++; \
- if (Consistency_Check) \
- { \
- if ((To_Where != Stack_Top) || \
- (From_Where != \
- MEMORY_LOC (Control_Point, (1 + len)))) \
- Microcode_Termination (TERM_BAD_STACK); \
- } \
- STACK_RESET (); \
- if (!(From_Pop_Return)) \
- { \
- Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0; \
- if ((!Valid_Fixed_Obj_Vector ()) || \
- (Get_Fixed_Obj_Slot (Dummy_History) == SHARP_F)) \
- history_register = Make_Dummy_History (); \
- else \
- history_register \
- = OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)); \
- } \
- else if (Prev_Restore_History_Stacklet == \
- OBJECT_ADDRESS (Control_Point)) \
- Prev_Restore_History_Stacklet = NULL; \
-} while (0)
-
-#define Our_Throw_Part_2()
-
-#endif /* USE_STACKLETS */
+ if (STACK_OVERFLOWED_P ()) \
+ stack_death (s); \
+} while (false)
+
+#define CAN_PUSH_P(n) (SP_OK_P (STACK_LOC (- (n))))
+#define SP_OK_P(sp) ((sp) >= stack_guard)
+
+#define STACK_LOCATIVE_DECREMENT(locative) (-- (locative))
+#define STACK_LOCATIVE_INCREMENT(locative) ((locative) ++)
+#define STACK_LOCATIVE_OFFSET(locative, offset) ((locative) + (offset))
+#define STACK_LOCATIVE_REFERENCE(locative, offset) ((locative) [(offset)])
+#define STACK_LOCATIVE_DIFFERENCE(newer, older) ((older) - (newer))
+#define STACK_LOCATIVE_LESS_P(loc1, loc2) ((loc1) < (loc2))
+
+#define ADDRESS_IN_STACK_REGION_P(address, lower_limit, upper_limit) \
+ (((address) >= (lower_limit)) && ((address) < (upper_limit)))
+
+#define STACK_N_PUSHED (stack_end - stack_pointer)
+#define SP_TO_N_PUSHED(sp, start, end) ((end) - (sp))
+#define N_PUSHED_TO_SP(np, start, end) ((end) - (np))
+
+#define STACK_LOCATIVE_PUSH(locative) (* (STACK_LOCATIVE_DECREMENT (locative)))
+#define STACK_LOCATIVE_POP(locative) (* (STACK_LOCATIVE_INCREMENT (locative)))
+
+#define STACK_PUSH(object) (STACK_LOCATIVE_PUSH (stack_pointer)) = (object)
+#define STACK_POP() (STACK_LOCATIVE_POP (stack_pointer))
+#define STACK_LOC(offset) (STACK_LOCATIVE_OFFSET (stack_pointer, (offset)))
+#define STACK_REF(offset) (STACK_LOCATIVE_REFERENCE (stack_pointer, (offset)))
-/* Emacs: this is -*- C -*- code. */
+/* Emacs: this is -*- C -*- code.
-#ifndef STACKOPS_H
-#define STACKOPS_H
-
-/*
-
-$Id: stackops.h,v 11.3 2007/01/05 21:19:25 cph Exp $
+$Id: stackops.h,v 11.4 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
+#ifndef STACKOPS_H
+#define STACKOPS_H 1
+
/* C code produced
- Thursday August 24, 2006 at 6:20:11 PM
- */
+ Thursday August 24, 2006 at 6:20:11 PM */
typedef enum
{
- stackify_opcode_illegal = 0,
- stackify_opcode_escape = 01,
- stackify_opcode_push_Pfixnum = 02,
- stackify_opcode_push__fixnum = 03,
- stackify_opcode_push_Pinteger = 04,
- stackify_opcode_push__integer = 05,
- stackify_opcode_push_false = 06,
- stackify_opcode_push_true = 07,
- stackify_opcode_push_nil = 010,
- stackify_opcode_push_flonum = 011,
- stackify_opcode_push_cons_ratnum = 012,
- stackify_opcode_push_cons_recnum = 013,
- stackify_opcode_push_string = 014,
- stackify_opcode_push_symbol = 015,
- stackify_opcode_push_uninterned_symbol = 016,
- stackify_opcode_push_char = 017,
- stackify_opcode_push_bit_string = 020,
- stackify_opcode_push_empty_cons = 021,
- stackify_opcode_pop_and_set_car = 022,
- stackify_opcode_pop_and_set_cdr = 023,
- stackify_opcode_push_consS = 024,
- stackify_opcode_push_empty_vector = 025,
- stackify_opcode_pop_and_vector_set = 026,
- stackify_opcode_push_vector = 027,
- stackify_opcode_push_empty_record = 030,
- stackify_opcode_pop_and_record_set = 031,
- stackify_opcode_push_record = 032,
- stackify_opcode_push_lookup = 033,
- stackify_opcode_store = 034,
- stackify_opcode_push_constant = 035,
- stackify_opcode_push_unassigned = 036,
- stackify_opcode_push_primitive = 037,
- stackify_opcode_push_primitive_lexpr = 040,
- stackify_opcode_push_nm_header = 041,
- stackify_opcode_push_label_entry = 042,
- stackify_opcode_push_linkage_header_operator = 043,
- stackify_opcode_push_linkage_header_reference = 044,
- stackify_opcode_push_linkage_header_assignment = 045,
- stackify_opcode_push_linkage_header_global = 046,
- stackify_opcode_push_linkage_header_closure = 047,
- stackify_opcode_push_ulong = 050,
- stackify_opcode_push_label_descriptor = 051,
- stackify_opcode_cc_block_to_entry = 052,
- stackify_opcode_retag_cc_block = 053,
- stackify_opcode_push_return_code = 054,
- stackify_opcode_push_0 = 0200,
- stackify_opcode_push_1 = 0201,
- stackify_opcode_push_2 = 0202,
- stackify_opcode_push_3 = 0203,
- stackify_opcode_push_4 = 0204,
- stackify_opcode_push_5 = 0205,
- stackify_opcode_push_6 = 0206,
- stackify_opcode_push__1 = 0207,
- stackify_opcode_push_consS_0 = 0210,
- stackify_opcode_push_consS_1 = 0211,
- stackify_opcode_push_consS_2 = 0212,
- stackify_opcode_push_consS_3 = 0213,
- stackify_opcode_push_consS_4 = 0214,
- stackify_opcode_push_consS_5 = 0215,
- stackify_opcode_push_consS_6 = 0216,
- stackify_opcode_push_consS_7 = 0217,
- stackify_opcode_pop_and_vector_set_0 = 0220,
- stackify_opcode_pop_and_vector_set_1 = 0221,
- stackify_opcode_pop_and_vector_set_2 = 0222,
- stackify_opcode_pop_and_vector_set_3 = 0223,
- stackify_opcode_pop_and_vector_set_4 = 0224,
- stackify_opcode_pop_and_vector_set_5 = 0225,
- stackify_opcode_pop_and_vector_set_6 = 0226,
- stackify_opcode_pop_and_vector_set_7 = 0227,
- stackify_opcode_push_vector_1 = 0230,
- stackify_opcode_push_vector_2 = 0231,
- stackify_opcode_push_vector_3 = 0232,
- stackify_opcode_push_vector_4 = 0233,
- stackify_opcode_push_vector_5 = 0234,
- stackify_opcode_push_vector_6 = 0235,
- stackify_opcode_push_vector_7 = 0236,
- stackify_opcode_push_vector_8 = 0237,
- stackify_opcode_pop_and_record_set_0 = 0240,
- stackify_opcode_pop_and_record_set_1 = 0241,
- stackify_opcode_pop_and_record_set_2 = 0242,
- stackify_opcode_pop_and_record_set_3 = 0243,
- stackify_opcode_pop_and_record_set_4 = 0244,
- stackify_opcode_pop_and_record_set_5 = 0245,
- stackify_opcode_pop_and_record_set_6 = 0246,
- stackify_opcode_pop_and_record_set_7 = 0247,
- stackify_opcode_push_record_1 = 0250,
- stackify_opcode_push_record_2 = 0251,
- stackify_opcode_push_record_3 = 0252,
- stackify_opcode_push_record_4 = 0253,
- stackify_opcode_push_record_5 = 0254,
- stackify_opcode_push_record_6 = 0255,
- stackify_opcode_push_record_7 = 0256,
- stackify_opcode_push_record_8 = 0257,
- stackify_opcode_push_lookup_0 = 0260,
- stackify_opcode_push_lookup_1 = 0261,
- stackify_opcode_push_lookup_2 = 0262,
- stackify_opcode_push_lookup_3 = 0263,
- stackify_opcode_push_lookup_4 = 0264,
- stackify_opcode_push_lookup_5 = 0265,
- stackify_opcode_push_lookup_6 = 0266,
- stackify_opcode_push_lookup_7 = 0267,
- stackify_opcode_store_0 = 0270,
- stackify_opcode_store_1 = 0271,
- stackify_opcode_store_2 = 0272,
- stackify_opcode_store_3 = 0273,
- stackify_opcode_store_4 = 0274,
- stackify_opcode_store_5 = 0275,
- stackify_opcode_store_6 = 0276,
- stackify_opcode_store_7 = 0277,
- stackify_opcode_push_primitive_0 = 0300,
- stackify_opcode_push_primitive_1 = 0301,
- stackify_opcode_push_primitive_2 = 0302,
- stackify_opcode_push_primitive_3 = 0303,
- stackify_opcode_push_primitive_4 = 0304,
- stackify_opcode_push_primitive_5 = 0305,
- stackify_opcode_push_primitive_6 = 0306,
- stackify_opcode_push_primitive_7 = 0307,
- N_STACKIFY_OPCODE = 200
+ stackify_opcode_illegal = 0000,
+ stackify_opcode_escape = 0001,
+ stackify_opcode_push_Pfixnum = 0002,
+ stackify_opcode_push__fixnum = 0003,
+ stackify_opcode_push_Pinteger = 0004,
+ stackify_opcode_push__integer = 0005,
+ stackify_opcode_push_false = 0006,
+ stackify_opcode_push_true = 0007,
+ stackify_opcode_push_nil = 0010,
+ stackify_opcode_push_flonum = 0011,
+ stackify_opcode_push_cons_ratnum = 0012,
+ stackify_opcode_push_cons_recnum = 0013,
+ stackify_opcode_push_string = 0014,
+ stackify_opcode_push_symbol = 0015,
+ stackify_opcode_push_uninterned_symbol = 0016,
+ stackify_opcode_push_char = 0017,
+ stackify_opcode_push_bit_string = 0020,
+ stackify_opcode_push_empty_cons = 0021,
+ stackify_opcode_pop_and_set_car = 0022,
+ stackify_opcode_pop_and_set_cdr = 0023,
+ stackify_opcode_push_consS = 0024,
+ stackify_opcode_push_empty_vector = 0025,
+ stackify_opcode_pop_and_vector_set = 0026,
+ stackify_opcode_push_vector = 0027,
+ stackify_opcode_push_empty_record = 0030,
+ stackify_opcode_pop_and_record_set = 0031,
+ stackify_opcode_push_record = 0032,
+ stackify_opcode_push_lookup = 0033,
+ stackify_opcode_store = 0034,
+ stackify_opcode_push_constant = 0035,
+ stackify_opcode_push_unassigned = 0036,
+ stackify_opcode_push_primitive = 0037,
+ stackify_opcode_push_primitive_lexpr = 0040,
+ stackify_opcode_push_nm_header = 0041,
+ stackify_opcode_push_label_entry = 0042,
+ stackify_opcode_push_linkage_header_operator = 0043,
+ stackify_opcode_push_linkage_header_reference = 0044,
+ stackify_opcode_push_linkage_header_assignment = 0045,
+ stackify_opcode_push_linkage_header_global = 0046,
+ stackify_opcode_push_linkage_header_closure = 0047,
+ stackify_opcode_push_ulong = 0050,
+ stackify_opcode_push_label_descriptor = 0051,
+ stackify_opcode_cc_block_to_entry = 0052,
+ stackify_opcode_retag_cc_block = 0053,
+ stackify_opcode_push_return_code = 0054,
+ stackify_opcode_push_0 = 0200,
+ stackify_opcode_push_1 = 0201,
+ stackify_opcode_push_2 = 0202,
+ stackify_opcode_push_3 = 0203,
+ stackify_opcode_push_4 = 0204,
+ stackify_opcode_push_5 = 0205,
+ stackify_opcode_push_6 = 0206,
+ stackify_opcode_push__1 = 0207,
+ stackify_opcode_push_consS_0 = 0210,
+ stackify_opcode_push_consS_1 = 0211,
+ stackify_opcode_push_consS_2 = 0212,
+ stackify_opcode_push_consS_3 = 0213,
+ stackify_opcode_push_consS_4 = 0214,
+ stackify_opcode_push_consS_5 = 0215,
+ stackify_opcode_push_consS_6 = 0216,
+ stackify_opcode_push_consS_7 = 0217,
+ stackify_opcode_pop_and_vector_set_0 = 0220,
+ stackify_opcode_pop_and_vector_set_1 = 0221,
+ stackify_opcode_pop_and_vector_set_2 = 0222,
+ stackify_opcode_pop_and_vector_set_3 = 0223,
+ stackify_opcode_pop_and_vector_set_4 = 0224,
+ stackify_opcode_pop_and_vector_set_5 = 0225,
+ stackify_opcode_pop_and_vector_set_6 = 0226,
+ stackify_opcode_pop_and_vector_set_7 = 0227,
+ stackify_opcode_push_vector_1 = 0230,
+ stackify_opcode_push_vector_2 = 0231,
+ stackify_opcode_push_vector_3 = 0232,
+ stackify_opcode_push_vector_4 = 0233,
+ stackify_opcode_push_vector_5 = 0234,
+ stackify_opcode_push_vector_6 = 0235,
+ stackify_opcode_push_vector_7 = 0236,
+ stackify_opcode_push_vector_8 = 0237,
+ stackify_opcode_pop_and_record_set_0 = 0240,
+ stackify_opcode_pop_and_record_set_1 = 0241,
+ stackify_opcode_pop_and_record_set_2 = 0242,
+ stackify_opcode_pop_and_record_set_3 = 0243,
+ stackify_opcode_pop_and_record_set_4 = 0244,
+ stackify_opcode_pop_and_record_set_5 = 0245,
+ stackify_opcode_pop_and_record_set_6 = 0246,
+ stackify_opcode_pop_and_record_set_7 = 0247,
+ stackify_opcode_push_record_1 = 0250,
+ stackify_opcode_push_record_2 = 0251,
+ stackify_opcode_push_record_3 = 0252,
+ stackify_opcode_push_record_4 = 0253,
+ stackify_opcode_push_record_5 = 0254,
+ stackify_opcode_push_record_6 = 0255,
+ stackify_opcode_push_record_7 = 0256,
+ stackify_opcode_push_record_8 = 0257,
+ stackify_opcode_push_lookup_0 = 0260,
+ stackify_opcode_push_lookup_1 = 0261,
+ stackify_opcode_push_lookup_2 = 0262,
+ stackify_opcode_push_lookup_3 = 0263,
+ stackify_opcode_push_lookup_4 = 0264,
+ stackify_opcode_push_lookup_5 = 0265,
+ stackify_opcode_push_lookup_6 = 0266,
+ stackify_opcode_push_lookup_7 = 0267,
+ stackify_opcode_store_0 = 0270,
+ stackify_opcode_store_1 = 0271,
+ stackify_opcode_store_2 = 0272,
+ stackify_opcode_store_3 = 0273,
+ stackify_opcode_store_4 = 0274,
+ stackify_opcode_store_5 = 0275,
+ stackify_opcode_store_6 = 0276,
+ stackify_opcode_store_7 = 0277,
+ stackify_opcode_push_primitive_0 = 0300,
+ stackify_opcode_push_primitive_1 = 0301,
+ stackify_opcode_push_primitive_2 = 0302,
+ stackify_opcode_push_primitive_3 = 0303,
+ stackify_opcode_push_primitive_4 = 0304,
+ stackify_opcode_push_primitive_5 = 0305,
+ stackify_opcode_push_primitive_6 = 0306,
+ stackify_opcode_push_primitive_7 = 0307,
+ N_STACKIFY_OPCODE = 0310
} stackify_opcode_t;
-#endif /* STACKOPS_H */
+#endif /* !STACKOPS_H */
+++ /dev/null
-/* -*-C-*-
-
-$Id: starbase.c,v 1.11 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Starbase graphics for HP 9000 machines. */
-
-#include "scheme.h"
-#include "prims.h"
-#include <starbase.c.h>
-\f
-static void
-set_vdc_extent (descriptor, xmin, ymin, xmax, ymax)
- int descriptor;
- float xmin, ymin, xmax, ymax;
-{
- vdc_extent (descriptor, xmin, ymin, (0.0), xmax, ymax, (0.0));
- clip_indicator (descriptor, CLIP_TO_VDC);
- clear_control (descriptor, CLEAR_VDC_EXTENT);
- return;
-}
-
-static void
-set_line_color_index (descriptor, color_index)
- int descriptor;
- long color_index;
-{
- line_color_index (descriptor, color_index);
- text_color_index (descriptor, color_index);
- perimeter_color_index (descriptor, color_index);
- fill_color_index (descriptor, color_index);
- return;
-}
-
-static int
-inquire_cmap_size (fildes)
- int fildes;
-{
- float physical_limits [2][3];
- float resolution [3];
- float p1 [3];
- float p2 [3];
- int cmap_size;
- inquire_sizes (fildes, physical_limits, resolution, p1, p2, (& cmap_size));
- return (cmap_size);
-}
-
-#define SB_DEVICE_ARG(arg) (arg_nonnegative_integer (arg))
-\f
-DEFINE_PRIMITIVE ("STARBASE-OPEN-DEVICE", Prim_starbase_open_device, 2, 2,
- "(STARBASE-OPEN-DEVICE DEVICE-NAME DRIVER-NAME)")
-{
- PRIMITIVE_HEADER (2);
- gerr_print_control (NO_ERROR_PRINTING);
- {
- int descriptor = (gopen ((STRING_ARG (1)), OUTDEV, (STRING_ARG (2)), 0));
- gerr_print_control (PRINT_ERRORS);
- if (descriptor == (-1))
- PRIMITIVE_RETURN (SHARP_F);
- set_vdc_extent (descriptor, (-1.0), (-1.0), (1.0), (1.0));
- mapping_mode (descriptor, DISTORT);
- set_line_color_index (descriptor, 1);
- line_type (descriptor, 0);
- drawing_mode (descriptor, 3);
- text_alignment
- (descriptor, TA_NORMAL_HORIZONTAL, TA_NORMAL_VERTICAL, (0.0), (0.0));
- interior_style (descriptor, INT_HOLLOW, 1);
- PRIMITIVE_RETURN (long_to_integer (descriptor));
- }
-}
-
-DEFINE_PRIMITIVE ("STARBASE-CLOSE-DEVICE", Prim_starbase_close_device, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- gclose (SB_DEVICE_ARG (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-FLUSH", Prim_starbase_flush, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- make_picture_current (SB_DEVICE_ARG (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-CLEAR", Prim_starbase_clear, 1, 1,
- "(STARBASE-CLEAR DEVICE)\n\
-Clear the graphics section of the screen.\n\
-Uses the Starbase CLEAR_VIEW_SURFACE procedure.")
-{
- PRIMITIVE_HEADER (1);
- clear_view_surface (SB_DEVICE_ARG (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-DRAW-POINT", Prim_starbase_draw_point, 3, 3,
- "(STARBASE-DRAW-POINT DEVICE X Y)\n\
-Draw one point at the given coordinates.\n\
-Subsequently move the graphics cursor to those coordinates.\n\
-Uses the starbase procedures `move2d' and `draw2d'.")
-{
- PRIMITIVE_HEADER (3);
- {
- int descriptor = (SB_DEVICE_ARG (1));
- fast float x = (arg_real_number (2));
- fast float y = (arg_real_number (3));
- move2d (descriptor, x, y);
- draw2d (descriptor, x, y);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("STARBASE-MOVE-CURSOR", Prim_starbase_move_cursor, 3, 3,
- "(STARBASE-MOVE-CURSOR DEVICE X Y)\n\
-Move the graphics cursor to the given coordinates.\n\
-Uses the starbase procedure `move2d'.")
-{
- PRIMITIVE_HEADER (3);
- move2d ((SB_DEVICE_ARG (1)), (arg_real_number (2)), (arg_real_number (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-DRAG-CURSOR", Prim_starbase_drag_cursor, 3, 3,
- "(STARBASE-DRAG-CURSOR DEVICE X Y)\n\
-Draw a line from the graphics cursor to the given coordinates.\n\
-Subsequently move the graphics cursor to those coordinates.\n\
-Uses the starbase procedure `draw2d'.")
-{
- PRIMITIVE_HEADER (3);
- draw2d ((SB_DEVICE_ARG (1)), (arg_real_number (2)), (arg_real_number (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-DRAW-LINE", Prim_starbase_draw_line, 5, 5,
- "(STARBASE-DRAW-LINE DEVICE X-START Y-START X-END Y-END)\n\
-Draw a line from the start coordinates to the end coordinates.\n\
-Subsequently move the graphics cursor to the end coordinates.\n\
-Uses the starbase procedures `move2d' and `draw2d'.")
-{
- PRIMITIVE_HEADER (5);
- {
- int descriptor = (SB_DEVICE_ARG (1));
- fast float x_start = (arg_real_number (2));
- fast float y_start = (arg_real_number (3));
- fast float x_end = (arg_real_number (4));
- fast float y_end = (arg_real_number (5));
- move2d (descriptor, x_start, y_start);
- draw2d (descriptor, x_end, y_end);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-LINE-STYLE", Prim_starbase_set_line_style, 2, 2,
- "(STARBASE-SET-LINE-STYLE DEVICE STYLE)\n\
-Changes the line drawing style.\n\
-The STYLE argument is an integer in the range 0-7 inclusive.\n\
-See the description of the starbase procedure `line_type'.")
-{
- PRIMITIVE_HEADER (2);
- line_type ((SB_DEVICE_ARG (1)), (arg_index_integer (2, 8)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-DRAWING-MODE", Prim_starbase_set_drawing_mode, 2, 2,
- "(STARBASE-SET-DRAWING-MODE DEVICE MODE)\n\
-Changes the replacement rule used when drawing.\n\
-The MODE argument is an integer in the range 0-15 inclusive.\n\
-See the description of the starbase procedure `drawing_mode'.")
-{
- PRIMITIVE_HEADER (2);
- drawing_mode ((SB_DEVICE_ARG (1)), (arg_index_integer (2, 16)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("STARBASE-DEVICE-COORDINATES", Prim_starbase_device_coordinates, 1, 1, 0)
-{
- float physical_limits [2][3];
- float resolution [3];
- float p1 [3];
- float p2 [3];
- int cmap_size;
- PRIMITIVE_HEADER (1);
- inquire_sizes
- ((SB_DEVICE_ARG (1)), physical_limits, resolution, p1, p2, (& cmap_size));
- {
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
- VECTOR_SET (result, 0, (FLOAT_TO_FLONUM (physical_limits[0][0])));
- VECTOR_SET (result, 1, (FLOAT_TO_FLONUM (physical_limits[0][1])));
- VECTOR_SET (result, 2, (FLOAT_TO_FLONUM (physical_limits[1][0])));
- VECTOR_SET (result, 3, (FLOAT_TO_FLONUM (physical_limits[1][1])));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-VDC-EXTENT", Prim_starbase_set_vdc_extent, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- set_vdc_extent
- ((SB_DEVICE_ARG (1)),
- (arg_real_number (2)),
- (arg_real_number (3)),
- (arg_real_number (4)),
- (arg_real_number (5)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-RESET-CLIP-RECTANGLE", Prim_starbase_reset_clip_rectangle, 1, 1,
- "(STARBASE-RESET-CLIP-RECTANGLE DEVICE)\n\
-Undo the clip rectangle. Subsequently, clipping is not affected by it.")
-{
- PRIMITIVE_HEADER (1);
- {
- int descriptor = (SB_DEVICE_ARG (1));
- clip_indicator (descriptor, CLIP_TO_VDC);
- clear_control (descriptor, CLEAR_VDC_EXTENT);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-CLIP-RECTANGLE", Prim_starbase_set_clip_rectangle, 5, 5,
- "(STARBASE-SET-CLIP-RECTANGLE X-LEFT Y-BOTTOM X-RIGHT Y-TOP)\n\
-Restrict the graphics drawing primitives to the area in the given rectangle.")
-{
- PRIMITIVE_HEADER (5);
- {
- int descriptor = (SB_DEVICE_ARG (1));
- fast float x_left = (arg_real_number (2));
- fast float y_bottom = (arg_real_number (3));
- fast float x_right = (arg_real_number (4));
- fast float y_top = (arg_real_number (5));
- clip_rectangle (descriptor, x_left, x_right, y_bottom, y_top);
- clip_indicator (descriptor, CLIP_TO_RECT);
- clear_control (descriptor, CLEAR_CLIP_RECTANGLE);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("STARBASE-DRAW-TEXT", Prim_starbase_draw_text, 4, 4,
- "(STARBASE-DRAW-TEXT DEVICE X Y STRING)")
-{
- PRIMITIVE_HEADER (4);
- text2d
- ((SB_DEVICE_ARG (1)),
- (arg_real_number (2)),
- (arg_real_number (3)),
- (STRING_ARG (4)),
- VDC_TEXT,
- FALSE);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-HEIGHT", Prim_starbase_set_text_height, 2, 2,
- "(STARBASE-SET-TEXT-HEIGHT DEVICE HEIGHT)")
-{
- PRIMITIVE_HEADER (2);
- character_height ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-ASPECT", Prim_starbase_set_text_aspect, 2, 2,
- "(STARBASE-SET-TEXT-ASPECT DEVICE ASPECT)")
-{
- PRIMITIVE_HEADER (2);
- character_expansion_factor ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-SLANT", Prim_starbase_set_text_slant, 2, 2,
- "(STARBASE-SET-TEXT-SLANT DEVICE SLANT)")
-{
- PRIMITIVE_HEADER (2);
- character_slant ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-ROTATION", Prim_starbase_set_text_rotation, 2, 2,
- "(STARBASE-SET-TEXT-ROTATION DEVICE ANGLE)")
-{
- PRIMITIVE_HEADER (2);
- {
- fast float angle = (arg_real_number (2));
- fast int path_style;
- if ((angle > 315.0) || (angle <= 45.0))
- path_style = PATH_RIGHT;
- else if ((angle > 45.0) && (angle <= 135.0))
- path_style = PATH_DOWN;
- else if ((angle > 135.0) && (angle <= 225.0))
- path_style = PATH_LEFT;
- else if ((angle > 225.0) && (angle <= 315.0))
- path_style = PATH_UP;
- text_path ((SB_DEVICE_ARG (1)), path_style);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("STARBASE-COLOR-MAP-SIZE", Prim_starbase_color_map_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (long_to_integer (inquire_cmap_size (SB_DEVICE_ARG (1))));
-}
-
-DEFINE_PRIMITIVE ("STARBASE-DEFINE-COLOR", Prim_starbase_define_color, 5, 5,
- "(STARBASE-DEFINE-COLOR DEVICE COLOR-INDEX RED GREEN BLUE)\n\
-COLOR-INDEX must be a valid index for the current device's color map.\n\
-RED, GREEN, and BLUE must be numbers between 0 and 1 inclusive.\n\
-Changes the color map, defining COLOR-INDEX to be the given RGB color.")
-{
- int descriptor;
- float colors [1][3];
- PRIMITIVE_HEADER (5);
- descriptor = (SB_DEVICE_ARG (1));
- (colors [0] [0]) = (arg_real_number (3));
- (colors [0] [1]) = (arg_real_number (4));
- (colors [0] [2]) = (arg_real_number (5));
- define_color_table
- (descriptor,
- (arg_index_integer (2, (inquire_cmap_size (descriptor)))),
- 1,
- colors);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("STARBASE-SET-LINE-COLOR", Prim_starbase_set_line_color, 2, 2,
- "(STARBASE-SET-LINE-COLOR DEVICE COLOR-INDEX)\n\
-COLOR-INDEX must be a valid index for the current device's color map.\n\
-Changes the color used for drawing most things.\n\
-Does not take effect until the next starbase output operation.")
-{
- int descriptor;
- PRIMITIVE_HEADER (2);
- descriptor = (SB_DEVICE_ARG (1));
- set_line_color_index
- (descriptor, (arg_index_integer (2, (inquire_cmap_size (descriptor)))));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* Graphics Screen Dump */
-
-static void print_graphics ();
-
-DEFINE_PRIMITIVE ("STARBASE-WRITE-IMAGE-FILE", Prim_starbase_write_image_file, 3, 3,
- "(STARBASE-WRITE-IMAGE-FILE DEVICE FILENAME INVERT?)\n\
-Write a file containing an image of the DEVICE's screen, in a format\n\
-suitable for printing on an HP laserjet printer.\n\
-If INVERT? is not #F, invert black and white in the output.")
-{
- PRIMITIVE_HEADER (3);
- print_graphics ((SB_DEVICE_ARG (1)), (STRING_ARG (2)), (BOOLEAN_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-static char rasres[] = "\033*t100R";
-static char rastop[] = "\033&l2E";
-static char raslft[] = "\033&a2L";
-static char rasbeg[] = "\033*r0A";
-static char raslen[] = "\033*b96W";
-static char rasend[] = "\033*rB";
-
-static int
-inquire_cmap_mask (fildes)
- int fildes;
-{
- int cmap_size = (inquire_cmap_size (fildes));
- return
- (((cmap_size >= 0) && (cmap_size < 8))
- ? ((1 << cmap_size) - 1)
- : (-1));
-}
-
-static int
-open_dumpfile (dumpname)
- char * dumpname;
-{
- int dumpfile = (creat (dumpname, 0666));
- if (dumpfile == (-1))
- {
- fprintf (stderr, "\nunable to create graphics dump file.");
- fflush (stderr);
- error_external_return ();
- }
- dumpfile = (open (dumpname, OUTINDEV));
- if (dumpfile == (-1))
- {
- fprintf (stderr, "\nunable to open graphics dump file.");
- fflush (stderr);
- error_external_return ();
- }
- return (dumpfile);
-}
-\f
-static void
-print_graphics (descriptor, dumpname, inverse_p)
- int descriptor;
- char * dumpname;
- int inverse_p;
-{
- int dumpfile = (open_dumpfile (dumpname));
- write (dumpfile, rasres, (strlen (rasres)));
- write (dumpfile, rastop, (strlen (rastop)));
- write (dumpfile, raslft, (strlen (raslft)));
- write (dumpfile, rasbeg, (strlen (rasbeg)));
- {
- fast unsigned char mask = (inquire_cmap_mask (descriptor));
- int col;
- for (col = (1024 - 16); (col >= 0); col = (col - 16))
- {
- unsigned char pixdata [(16 * 768)];
- {
- fast unsigned char * p = (& (pixdata [0]));
- fast unsigned char * pe = (& (pixdata [sizeof (pixdata)]));
- while (p < pe)
- (*p++) = '\0';
- }
- dcblock_read (descriptor, col, 0, 16, 768, pixdata, 0);
- {
- int x;
- for (x = (16 - 1); (x >= 0); x -= 1)
- {
- unsigned char rasdata [96];
- fast unsigned char * p = (& (pixdata [x]));
- fast unsigned char * r = rasdata;
- int n;
- for (n = 0; (n < 96); n += 1)
- {
- fast unsigned char c = 0;
- int nn;
- for (nn = 0; (nn < 8); nn += 1)
- {
- c <<= 1;
- if (((* p) & mask) != 0)
- c |= 1;
- p += 16;
- }
- (*r++) = (inverse_p ? (~ c) : c);
- }
- write (dumpfile, raslen, (strlen (raslen)));
- write (dumpfile, rasdata, 96);
- }
- }
- }
- }
- write (dumpfile, rasend, (strlen (rasend)));
- close (dumpfile);
- return;
-}
/* -*-C-*-
-$Id: step.c,v 9.41 2007/01/05 21:19:25 cph Exp $
+$Id: step.c,v 9.42 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
-\f
- /**********************************/
- /* Support of stepping primitives */
- /**********************************/
/* UGLY ... this knows (a) that it is called with the primitive frame
- already popped off the stack; and (b) the order in which Save_Cont
- stores things on the stack.
-*/
+ already popped off the stack; and (b) the order in which SAVE_CONT
+ stores things on the stack. */
static void
-DEFUN (Install_Traps, (Hunk3), SCHEME_OBJECT Hunk3)
+install_traps (SCHEME_OBJECT state)
{
- SCHEME_OBJECT Eval_Hook, Apply_Hook, Return_Hook;
-
- Stop_Trapping();
- Eval_Hook = MEMORY_REF (Hunk3, HUNK_CXR0);
- Apply_Hook = MEMORY_REF (Hunk3, HUNK_CXR1);
- Return_Hook = MEMORY_REF (Hunk3, HUNK_CXR2);
- Set_Fixed_Obj_Slot(Stepper_State, Hunk3);
- Trapping = ((Eval_Hook != SHARP_F) |
- (Apply_Hook != SHARP_F) |
- (Return_Hook != SHARP_F));
- return;
+ VECTOR_SET (fixed_objects, STEPPER_STATE, state);
+ trapping
+ = ((OBJECT_TO_BOOLEAN (MEMORY_REF (state, HUNK_CXR0)))
+ || (OBJECT_TO_BOOLEAN (MEMORY_REF (state, HUNK_CXR1)))
+ || (OBJECT_TO_BOOLEAN (MEMORY_REF (state, HUNK_CXR2))));
}
-\f
+
/* (PRIMITIVE-EVAL-STEP EXPRESSION ENV HUNK3)
Evaluates EXPRESSION in ENV and intalls the eval-trap,
apply-trap, and return-trap from HUNK3. If any
trap is #F, it is a null trap that does a normal EVAL,
- APPLY or return.
-*/
+ APPLY or return. */
DEFINE_PRIMITIVE ("PRIMITIVE-EVAL-STEP", Prim_eval_step, 3, 3, 0)
{
SCHEME_OBJECT expression = (ARG_REF (1));
SCHEME_OBJECT environment = (ARG_REF (2));
SCHEME_OBJECT hooks = (ARG_REF (3));
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
POP_PRIMITIVE_FRAME (3);
- Install_Traps (hooks);
- exp_register = expression;
- env_register = environment;
+ install_traps (hooks);
+ SET_EXP (expression);
+ SET_ENV (environment);
}
PRIMITIVE_ABORT (PRIM_NO_TRAP_EVAL);
/*NOTREACHED*/
PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
/* (PRIMITIVE-APPLY-STEP OPERATOR OPERANDS HUNK3)
Applies OPERATOR to OPERANDS and intalls the eval-trap,
apply-trap, and return-trap from HUNK3. If any
DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
CHECK_ARG (3, HUNK3_P);
{
SCHEME_OBJECT hooks = (ARG_REF (3));
- fast long number_of_args = 0;
+ long number_of_args = 0;
{
SCHEME_OBJECT procedure = (ARG_REF (1));
SCHEME_OBJECT argument_list = (ARG_REF (2));
{
- fast SCHEME_OBJECT scan_list;
- TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+ SCHEME_OBJECT scan_list;
+ scan_list = argument_list;
while (PAIR_P (scan_list))
{
number_of_args += 1;
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ scan_list = (PAIR_CDR (scan_list));
}
if (!EMPTY_LIST_P (scan_list))
error_wrong_type_arg (2);
}
POP_PRIMITIVE_FRAME (3);
- Install_Traps (hooks);
+ install_traps (hooks);
{
- fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
- fast SCHEME_OBJECT scan_list;
- fast long i;
+ SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
+ SCHEME_OBJECT scan_list;
+ long i;
Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
- sp_register = scan_stack;
- TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+ stack_pointer = scan_stack;
+ scan_list = argument_list;
for (i = number_of_args; (i > 0); i -= 1)
{
(*scan_stack++) = (PAIR_CAR (scan_list));
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ scan_list = (PAIR_CDR (scan_list));
}
STACK_PUSH (procedure);
- STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
+ PUSH_APPLY_FRAME_HEADER (number_of_args);
Pushed ();
}
}
/*NOTREACHED*/
PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
/* (PRIMITIVE-RETURN-STEP VALUE HUNK3)
Returns VALUE and intalls the eval-trap, apply-trap, and
return-trap from HUNK3. If any trap is #F, it is a null trap
DEFINE_PRIMITIVE ("PRIMITIVE-RETURN-STEP", Prim_return_step, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ canonicalize_primitive_context ();
CHECK_ARG (2, HUNK3_P);
{
SCHEME_OBJECT value = (ARG_REF (1));
SCHEME_OBJECT hooks = (ARG_REF (2));
- POP_PRIMITIVE_FRAME (2);
- Install_Traps (hooks);
- val_register = value;
+ POP_PRIMITIVE_FRAME (2);
+ install_traps (hooks);
+ SET_VAL (value);
PRIMITIVE_ABORT (PRIM_NO_TRAP_POP_RETURN);
PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-$Id: storage.c,v 9.62 2007/01/05 21:19:25 cph Exp $
+$Id: storage.c,v 9.63 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* This file defines the storage for the interpreter's global variables. */
+/* Global-variable storage */
#include "scheme.h"
-#include "gctype.c"
\f
- /*************/
- /* REGISTERS */
- /*************/
-
-SCHEME_OBJECT
- * MemTop, /* Top of free space available */
- * Free, /* Next free word in heap */
- * Heap_Top, /* Top of current heap */
- * Heap_Bottom, /* Bottom of current heap */
- * Unused_Heap_Top, /* Top of unused heap */
- * Unused_Heap_Bottom, /* Bottom of unused heap */
- * Stack_Guard, /* Guard area at end of stack */
- * sp_register, /* Next available slot in control stack */
- * Stack_Bottom, /* Bottom of control stack */
- * Stack_Top, /* Top of control stack */
- * Free_Constant, /* Next free word in constant space */
- * Constant_Space, /* Bottom of constant+pure space */
- * Constant_Top, /* Top of constant+pure space */
- * Local_Heap_Base, /* Per-processor CONSing area */
- * Free_Stacklets, /* Free list of stacklets */
- * history_register, /* History register */
- Current_State_Point, /* Dynamic state point */
- Fluid_Bindings, /* Fluid bindings AList */
- * last_return_code; /* Address of the most recent return code in the stack.
- This is only meaningful while in compiled code.
- *** This must be changed when stacklets are used. */
-
-long
- temp_long, /* temporary for sign extension */
- GC_Reserve, /* Scheme pointer overflow space in heap */
- GC_Space_Needed; /* Amount of space needed when GC triggered */
-
-Declare_Fixed_Objects ();
-
-Boolean Trapping;
-
-SCHEME_OBJECT Old_Return_Code;
-SCHEME_OBJECT * Return_Hook_Address;
-
-SCHEME_OBJECT * Prev_Restore_History_Stacklet;
-long Prev_Restore_History_Offset;
-
-long Heap_Size;
-long Constant_Size;
-long Stack_Size;
-SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address;
-#ifndef HEAP_IN_LOW_MEMORY
-SCHEME_OBJECT * memory_base;
+#ifndef CC_SUPPORT_P
+ SCHEME_OBJECT Registers [REGBLOCK_MINIMUM_LENGTH];
#endif
-\f
- /**********************/
- /* DEBUGGING SWITCHES */
- /**********************/
-
-#ifdef ENABLE_DEBUGGING_FLAGS
-
-Boolean Eval_Debug = false;
-Boolean Hex_Input_Debug = false;
-Boolean File_Load_Debug = false;
-Boolean Reloc_Debug = false;
-Boolean Intern_Debug = false;
-Boolean Cont_Debug = false;
-Boolean Primitive_Debug = false;
-Boolean Lookup_Debug = false;
-Boolean Define_Debug = false;
-Boolean GC_Debug = false;
-Boolean Upgrade_Debug = false;
-Boolean Dump_Debug = false;
-Boolean Trace_On_Error = false;
-Boolean Bignum_Debug = false;
-Boolean Per_File = false;
-Boolean Fluids_Debug = false;
-More_Debug_Flag_Allocs();
-
-int debug_slotno = 0;
-int debug_nslots = 0;
-int local_slotno = 0;
-int local_nslots = 0;
-
-#if FALSE /* MHWU */
-int debug_circle[debug_maxslots];
-int local_circle[debug_maxslots];
-#endif /* false */
-
-int debug_circle[100];
-int local_circle[100];
-#endif /* ENABLE_DEBUGGING_FLAGS */
-
- /****************************/
- /* Debugging Macro Messages */
- /****************************/
-
-char *CONT_PRINT_RETURN_MESSAGE = "Save_Cont, return code";
-char *CONT_PRINT_EXPR_MESSAGE = "Save_Cont, expression";
-char *RESTORE_CONT_RETURN_MESSAGE = "Restore_Cont, return code";
-char *RESTORE_CONT_EXPR_MESSAGE = "Restore_Cont, expression";
-\f
-/* Interpreter code name and message tables */
-long MAX_RETURN = MAX_RETURN_CODE;
+/* next free word in heap */
+SCHEME_OBJECT * Free;
+
+/* strict limit for Free */
+SCHEME_OBJECT * heap_alloc_limit;
+
+/* limits of active heap */
+SCHEME_OBJECT * heap_start;
+SCHEME_OBJECT * heap_end;
+
+/* pointer to most-recently pushed item */
+SCHEME_OBJECT * stack_pointer;
+
+/*-strict limit for stack_pointer */
+SCHEME_OBJECT * stack_guard;
+
+/* limits of stack */
+SCHEME_OBJECT * stack_start;
+SCHEME_OBJECT * stack_end;
+
+/* next free word in constant space */
+SCHEME_OBJECT * constant_alloc_next;
+
+/* limits of constant space */
+SCHEME_OBJECT * constant_start;
+SCHEME_OBJECT * constant_end;
-extern char *Return_Names[];
-char *Return_Names[] = RETURN_NAME_TABLE; /* in returns.h */
+/* dynamic state point */
+SCHEME_OBJECT current_state_point;
-extern char *Type_Names[];
-char *Type_Names[] = TYPE_NAME_TABLE; /* in types.h */
+/* Address of the most recent return code in the stack.
+ This is only meaningful while in compiled code. */
+SCHEME_OBJECT * last_return_code;
-extern char *Abort_Names[];
-char *Abort_Names[] = ABORT_NAME_TABLE; /* in const.h */
+SCHEME_OBJECT fixed_objects;
-extern char *Error_Names[];
-char *Error_Names[] = ERROR_NAME_TABLE; /* in errors.h */
+bool trapping;
+
+unsigned long n_heap_blocks;
+unsigned long n_constant_blocks;
+unsigned long n_stack_blocks;
+SCHEME_OBJECT * memory_block_start;
+SCHEME_OBJECT * memory_block_end;
+
+unsigned long heap_reserved;
+
+/* Amount of space needed when GC requested */
+unsigned long gc_space_needed;
+
+#ifndef HEAP_IN_LOW_MEMORY
+ SCHEME_OBJECT * memory_base;
+#endif
+\f
+#ifdef ENABLE_DEBUGGING_TOOLS
+ bool Eval_Debug = false;
+ bool Hex_Input_Debug = false;
+ bool File_Load_Debug = false;
+ bool Reloc_Debug = false;
+ bool Intern_Debug = false;
+ bool Cont_Debug = false;
+ bool Primitive_Debug = false;
+ bool Lookup_Debug = false;
+ bool Define_Debug = false;
+ bool GC_Debug = false;
+ bool Upgrade_Debug = false;
+ bool Dump_Debug = false;
+ bool Trace_On_Error = false;
+ bool Bignum_Debug = false;
+ bool Per_File = false;
+ unsigned int debug_slotno = 0;
+ unsigned int debug_nslots = 0;
+ unsigned int local_slotno = 0;
+ unsigned int local_nslots = 0;
+ unsigned int debug_circle [100];
+ unsigned int local_circle [100];
+#endif
+
+char * CONT_PRINT_RETURN_MESSAGE = "SAVE_CONT, return code";
+char * CONT_PRINT_EXPR_MESSAGE = "SAVE_CONT, expression";
+char * RESTORE_CONT_RETURN_MESSAGE = "RESTORE_CONT, return code";
+char * RESTORE_CONT_EXPR_MESSAGE = "RESTORE_CONT, expression";
+
+/* Interpreter code name and message tables */
-extern char *Term_Names[];
-char *Term_Names[] = TERM_NAME_TABLE; /* in errors.h */
+unsigned long MAX_RETURN = MAX_RETURN_CODE;
-extern char *Term_Messages[];
-char *Term_Messages[] = TERM_MESSAGE_TABLE; /* in errors.h */
+const char * Return_Names [] = RETURN_NAME_TABLE; /* in returns.h */
+const char * type_names [] = TYPE_NAME_TABLE; /* in types.h */
+const char * Abort_Names [] = ABORT_NAME_TABLE; /* in const.h */
+const char * Error_Names [] = ERROR_NAME_TABLE; /* in errors.h */
+const char * Term_Names [] = TERM_NAME_TABLE; /* in errors.h */
+const char * term_messages [] = TERM_MESSAGE_TABLE; /* in errors.h */
/* -*-C-*-
-$Id: string.c,v 9.53 2007/04/01 17:33:07 riastradh Exp $
+$Id: string.c,v 9.54 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
-
-#ifndef STDC_HEADERS
-# ifdef HAVE_MALLOC_H
-# include <malloc.h>
-# else
- extern PTR EXFUN (malloc, (size_t));
- extern PTR EXFUN (realloc, (PTR, size_t));
-# endif
-#endif
\f
SCHEME_OBJECT
-DEFUN (allocate_string, (nbytes), unsigned long nbytes)
+allocate_string (unsigned long nbytes)
{
SCHEME_OBJECT result
- = (allocate_non_marked_vector
- (TC_CHARACTER_STRING,
- (STRING_LENGTH_TO_GC_LENGTH (nbytes)),
- 1));
+ = (allocate_non_marked_vector (TC_CHARACTER_STRING,
+ (STRING_LENGTH_TO_GC_LENGTH (nbytes)),
+ true));
SET_STRING_LENGTH (result, nbytes);
return (result);
}
SCHEME_OBJECT
-DEFUN (allocate_string_no_gc, (nbytes), unsigned long nbytes)
+allocate_string_no_gc (unsigned long nbytes)
{
SCHEME_OBJECT result
- = (allocate_non_marked_vector
- (TC_CHARACTER_STRING,
- (STRING_LENGTH_TO_GC_LENGTH (nbytes)),
- 0));
+ = (allocate_non_marked_vector (TC_CHARACTER_STRING,
+ (STRING_LENGTH_TO_GC_LENGTH (nbytes)),
+ false));
SET_STRING_LENGTH (result, nbytes);
return (result);
}
SCHEME_OBJECT
-DEFUN (memory_to_string, (nbytes, data),
- unsigned long nbytes AND
- CONST void * data)
-{
- SCHEME_OBJECT result = (allocate_string (nbytes));
- unsigned char * scan_result = (STRING_LOC (result, 0));
- unsigned char * end_result = (scan_result + nbytes);
- CONST unsigned char * scan_data = data;
- while (scan_result < end_result)
- (*scan_result++) = (*scan_data++);
+memory_to_string (unsigned long n_bytes, const void * vp)
+{
+ SCHEME_OBJECT result = (allocate_string (n_bytes));
+ memcpy ((STRING_POINTER (result)), vp, n_bytes);
return (result);
}
SCHEME_OBJECT
-DEFUN (memory_to_string_no_gc, (nbytes, data),
- unsigned long nbytes AND
- CONST void * data)
-{
- SCHEME_OBJECT result = (allocate_string_no_gc (nbytes));
- unsigned char * scan_result = (STRING_LOC (result, 0));
- unsigned char * end_result = (scan_result + nbytes);
- CONST unsigned char * scan_data = data;
- while (scan_result < end_result)
- (*scan_result++) = (*scan_data++);
+memory_to_string_no_gc (unsigned long n_bytes, const void * vp)
+{
+ SCHEME_OBJECT result = (allocate_string_no_gc (n_bytes));
+ memcpy ((STRING_POINTER (result)), vp, n_bytes);
return (result);
}
SCHEME_OBJECT
-DEFUN (char_pointer_to_string, (char_pointer),
- CONST char * char_pointer)
+char_pointer_to_string (const char * cp)
{
- CONST char * scan = char_pointer;
+ const char * scan = cp;
if (scan == 0)
scan += 1;
else
while ((*scan++) != '\0')
;
- return (memory_to_string (((scan - 1) - char_pointer), char_pointer));
+ return (memory_to_string (((scan - 1) - cp), cp));
}
SCHEME_OBJECT
-DEFUN (char_pointer_to_string_no_gc, (char_pointer),
- CONST char * char_pointer)
+char_pointer_to_string_no_gc (const char * cp)
{
- CONST char * scan = char_pointer;
+ const char * scan = cp;
if (scan == 0)
scan += 1;
else
while ((*scan++) != '\0')
;
- return (memory_to_string_no_gc (((scan - 1) - char_pointer), char_pointer));
+ return (memory_to_string_no_gc (((scan - 1) - cp), cp));
}
\f
/* Currently the strings used in symbols have type codes in the length
- field. They should be changed to have just longwords there. */
+ field. They should be changed to have just longwords there. */
DEFINE_PRIMITIVE ("STRING-ALLOCATE", Prim_string_allocate, 1, 1, 0)
{
}
\f
static long
-DEFUN (substring_length_min, (start1, end1, start2, end2),
- long start1
- AND long end1
- AND long start2
- AND long end2)
+substring_length_min (long start1,
+ long end1,
+ long start2,
+ long end2)
{
long length1 = (end1 - start1);
long length2 = (end2 - start2);
unsigned long n_bytes;
};
-#define HT_RECORD_PTR(record) ((PTR) ((record) + 1))
+#define HT_RECORD_PTR(record) ((void *) ((record) + 1))
#define HT_RECORD_KEY(record) ((unsigned long) ((record) + 1))
#define HT_RECORD_NEXT(record) ((record) -> next)
#define HT_RECORD_N_BYTES(record) ((record) -> n_bytes)
#define HT_BUCKET_REF(table, index) ((HT_BUCKETS (table)) [(index)])
#define HT_SHRINK_POINT(table) ((((HT_N_BUCKETS (table)) + 1) / 2) - 1)
-static hash_table_t * EXFUN (make_hash_table, (void));
-static void EXFUN (ht_resize, (hash_table_t *, unsigned long));
-static void EXFUN (zero_ht_buckets, (hash_table_t *));
-static ht_record_t * EXFUN (ht_records_list, (hash_table_t *));
-static ht_record_t * EXFUN (ht_lookup, (hash_table_t *, unsigned long));
-static unsigned long EXFUN (ht_insert, (hash_table_t *, ht_record_t *));
-static ht_record_t * EXFUN (ht_delete, (hash_table_t *, unsigned long));
+static hash_table_t * make_hash_table (void);
+static void ht_resize (hash_table_t *, unsigned long);
+static void zero_ht_buckets (hash_table_t *);
+static ht_record_t * ht_records_list (hash_table_t *);
+static ht_record_t * ht_lookup (hash_table_t *, unsigned long);
+static unsigned long ht_insert (hash_table_t *, ht_record_t *);
+static ht_record_t * ht_delete (hash_table_t *, unsigned long);
static hash_table_t * external_strings = 0;
}
}
-PTR
-DEFUN (lookup_external_string, (descriptor, lp),
- SCHEME_OBJECT descriptor AND
- unsigned long * lp)
+unsigned char *
+lookup_external_string (SCHEME_OBJECT descriptor, unsigned long * lp)
{
ht_record_t * record;
if (external_strings == 0)
external_strings = (make_hash_table ());
record = (ht_lookup (external_strings, (integer_to_ulong (descriptor))));
if (record == 0)
- return NULL;
+ return (0);
if (lp != 0)
(*lp) = (HT_RECORD_N_BYTES (record));
return (HT_RECORD_PTR (record));
}
-PTR
-DEFUN (arg_extended_string, (n, lp), unsigned int n AND unsigned long * lp)
+unsigned char *
+arg_extended_string (unsigned int n, unsigned long * lp)
{
SCHEME_OBJECT object = (ARG_REF (n));
if (STRING_P (object))
{
if (lp != 0)
(*lp) = (STRING_LENGTH (object));
- return (STRING_LOC (object, 0));
+ return ((unsigned char *) (STRING_POINTER (object)));
}
else if ((INTEGER_P (object)) && (integer_to_ulong_p (object)))
{
- PTR result = (lookup_external_string (object, lp));
- if (result == NULL)
+ unsigned char * result = (lookup_external_string (object, lp));
+ if (result == 0)
error_wrong_type_arg (n);
- return result;
+ return (result);
}
else
{
#define EXPT_TO_N(e) ((1 << (e)) - 1)
static hash_table_t *
-DEFUN_VOID (make_hash_table)
+make_hash_table (void)
{
unsigned long n = (EXPT_TO_N (HT_MIN_EXPT));
hash_table_t * table = (malloc (sizeof (hash_table_t)));
}
static void
-DEFUN (ht_resize, (table, new_n_buckets),
- hash_table_t * table AND
+ht_resize (hash_table_t * table,
unsigned long new_n_buckets)
{
ht_record_t ** new_buckets
}
static void
-DEFUN (zero_ht_buckets, (table), hash_table_t * table)
+zero_ht_buckets (hash_table_t * table)
{
ht_record_t ** scan = (HT_BUCKETS (table));
ht_record_t ** end = (scan + (HT_N_BUCKETS (table)));
}
static ht_record_t *
-DEFUN (ht_records_list, (table), hash_table_t * table)
+ht_records_list (hash_table_t * table)
{
ht_record_t ** scan_buckets = (HT_BUCKETS (table));
ht_record_t ** end_buckets = (scan_buckets + (HT_N_BUCKETS (table)));
}
static ht_record_t *
-DEFUN (ht_lookup, (table, key),
- hash_table_t * table AND
+ht_lookup (hash_table_t * table,
unsigned long key)
{
unsigned long index = (HT_BUCKET_INDEX (table, key));
}
static unsigned long
-DEFUN (ht_insert, (table, record),
- hash_table_t * table AND
+ht_insert (hash_table_t * table,
ht_record_t * record)
{
unsigned long index = (HT_BUCKET_INDEX (table, (HT_RECORD_KEY (record))));
}
static ht_record_t *
-DEFUN (ht_delete, (table, key),
- hash_table_t * table AND
+ht_delete (hash_table_t * table,
unsigned long key)
{
unsigned long index = (HT_BUCKET_INDEX (table, key));
--- /dev/null
+/* -*-C-*-
+
+DO NOT EDIT: this file was generated by a program.
+
+$Id: svm1-defns.h,v 11.1 2007/04/22 16:31:23 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Instructions for SVM version 1 */
+
+#ifndef SCM_SVM1_DEFNS_H
+#define SCM_SVM1_DEFNS_H 1
+
+#define SVM1_REG_STACK_POINTER 0
+#define SVM1_REG_DYNAMIC_LINK 1
+#define SVM1_REG_FREE_POINTER 2
+#define SVM1_REG_VALUE 3
+#define SVM1_REG_ENVIRONMENT 4
+
+#define SVM1_ADDR_START_CODE 0x01
+#define SVM1_ADDR_END_CODE 0x1d
+
+#define SVM1_ADDR_BINDINGS(binder) \
+ binder (SVM1_ADDR_INDIR, indir); \
+ binder (SVM1_ADDR_OFFSET_B, offset_b); \
+ binder (SVM1_ADDR_OFFSET_W, offset_w); \
+ binder (SVM1_ADDR_OFFSET_F, offset_f); \
+ binder (SVM1_ADDR_INDEX_B_B, index_b_b); \
+ binder (SVM1_ADDR_INDEX_B_W, index_b_w); \
+ binder (SVM1_ADDR_INDEX_B_F, index_b_f); \
+ binder (SVM1_ADDR_INDEX_W_B, index_w_b); \
+ binder (SVM1_ADDR_INDEX_W_W, index_w_w); \
+ binder (SVM1_ADDR_INDEX_W_F, index_w_f); \
+ binder (SVM1_ADDR_INDEX_F_B, index_f_b); \
+ binder (SVM1_ADDR_INDEX_F_W, index_f_w); \
+ binder (SVM1_ADDR_INDEX_F_F, index_f_f); \
+ binder (SVM1_ADDR_PREDEC_B, predec_b); \
+ binder (SVM1_ADDR_PREDEC_W, predec_w); \
+ binder (SVM1_ADDR_PREDEC_F, predec_f); \
+ binder (SVM1_ADDR_PREINC_B, preinc_b); \
+ binder (SVM1_ADDR_PREINC_W, preinc_w); \
+ binder (SVM1_ADDR_PREINC_F, preinc_f); \
+ binder (SVM1_ADDR_POSTDEC_B, postdec_b); \
+ binder (SVM1_ADDR_POSTDEC_W, postdec_w); \
+ binder (SVM1_ADDR_POSTDEC_F, postdec_f); \
+ binder (SVM1_ADDR_POSTINC_B, postinc_b); \
+ binder (SVM1_ADDR_POSTINC_W, postinc_w); \
+ binder (SVM1_ADDR_POSTINC_F, postinc_f); \
+ binder (SVM1_ADDR_PCR_S8, pcr_s8); \
+ binder (SVM1_ADDR_PCR_S16, pcr_s16); \
+ binder (SVM1_ADDR_PCR_S32, pcr_s32)
+
+#define SVM1_ADDR_INDIR 0x01
+#define DECODE_SVM1_ADDR_INDIR(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_OFFSET_B 0x02
+#define DECODE_SVM1_ADDR_OFFSET_B(base, offset) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset)
+
+#define SVM1_ADDR_OFFSET_W 0x03
+#define DECODE_SVM1_ADDR_OFFSET_W(base, offset) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset)
+
+#define SVM1_ADDR_OFFSET_F 0x04
+#define DECODE_SVM1_ADDR_OFFSET_F(base, offset) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset)
+
+#define SVM1_ADDR_INDEX_B_B 0x05
+#define DECODE_SVM1_ADDR_INDEX_B_B(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_INDEX_B_W 0x06
+#define DECODE_SVM1_ADDR_INDEX_B_W(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_INDEX_B_F 0x07
+#define DECODE_SVM1_ADDR_INDEX_B_F(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_INDEX_W_B 0x08
+#define DECODE_SVM1_ADDR_INDEX_W_B(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_INDEX_W_W 0x09
+#define DECODE_SVM1_ADDR_INDEX_W_W(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_INDEX_W_F 0x0a
+#define DECODE_SVM1_ADDR_INDEX_W_F(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_INDEX_F_B 0x0b
+#define DECODE_SVM1_ADDR_INDEX_F_B(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_INDEX_F_W 0x0c
+#define DECODE_SVM1_ADDR_INDEX_F_W(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_INDEX_F_F 0x0d
+#define DECODE_SVM1_ADDR_INDEX_F_F(base, offset, index) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_UNSIGNED_8 (offset); \
+ DECODE_WORD_REGISTER (index)
+
+#define SVM1_ADDR_PREDEC_B 0x0e
+#define DECODE_SVM1_ADDR_PREDEC_B(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_PREDEC_W 0x0f
+#define DECODE_SVM1_ADDR_PREDEC_W(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_PREDEC_F 0x10
+#define DECODE_SVM1_ADDR_PREDEC_F(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_PREINC_B 0x11
+#define DECODE_SVM1_ADDR_PREINC_B(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_PREINC_W 0x12
+#define DECODE_SVM1_ADDR_PREINC_W(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_PREINC_F 0x13
+#define DECODE_SVM1_ADDR_PREINC_F(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_POSTDEC_B 0x14
+#define DECODE_SVM1_ADDR_POSTDEC_B(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_POSTDEC_W 0x15
+#define DECODE_SVM1_ADDR_POSTDEC_W(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_POSTDEC_F 0x16
+#define DECODE_SVM1_ADDR_POSTDEC_F(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_POSTINC_B 0x17
+#define DECODE_SVM1_ADDR_POSTINC_B(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_POSTINC_W 0x18
+#define DECODE_SVM1_ADDR_POSTINC_W(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_POSTINC_F 0x19
+#define DECODE_SVM1_ADDR_POSTINC_F(base) \
+ DECODE_WORD_REGISTER (base)
+
+#define SVM1_ADDR_PCR_S8 0x1a
+#define DECODE_SVM1_ADDR_PCR_S8(value) \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_ADDR_PCR_S16 0x1b
+#define DECODE_SVM1_ADDR_PCR_S16(value) \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_ADDR_PCR_S32 0x1c
+#define DECODE_SVM1_ADDR_PCR_S32(value) \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_START_CODE 0x01
+#define SVM1_INST_END_CODE 0xce
+
+#define SVM1_INST_BINDINGS(binder) \
+ binder (SVM1_INST_STORE_B_WR_ADDR, store_b_wr_addr); \
+ binder (SVM1_INST_STORE_W_WR_ADDR, store_w_wr_addr); \
+ binder (SVM1_INST_STORE_F_FR_ADDR, store_f_fr_addr); \
+ binder (SVM1_INST_LOAD_B_WR_ADDR, load_b_wr_addr); \
+ binder (SVM1_INST_LOAD_W_WR_ADDR, load_w_wr_addr); \
+ binder (SVM1_INST_LOAD_F_FR_ADDR, load_f_fr_addr); \
+ binder (SVM1_INST_LOAD_ADDRESS_ADDR, load_address_addr); \
+ binder (SVM1_INST_LOAD_IMMEDIATE_WR_S8, load_immediate_wr_s8); \
+ binder (SVM1_INST_LOAD_IMMEDIATE_WR_S16, load_immediate_wr_s16); \
+ binder (SVM1_INST_LOAD_IMMEDIATE_WR_S32, load_immediate_wr_s32); \
+ binder (SVM1_INST_LOAD_IMMEDIATE_WR_U8, load_immediate_wr_u8); \
+ binder (SVM1_INST_LOAD_IMMEDIATE_WR_U16, load_immediate_wr_u16); \
+ binder (SVM1_INST_LOAD_IMMEDIATE_WR_U32, load_immediate_wr_u32); \
+ binder (SVM1_INST_LOAD_IMMEDIATE_FR_FLT, load_immediate_fr_flt); \
+ binder (SVM1_INST_COPY_BLOCK_U8_W, copy_block_u8_w); \
+ binder (SVM1_INST_COPY_BLOCK_WR_W, copy_block_wr_w); \
+ binder (SVM1_INST_LOAD_NON_POINTER_TC_U8, load_non_pointer_tc_u8); \
+ binder (SVM1_INST_LOAD_NON_POINTER_WR_U8, load_non_pointer_wr_u8); \
+ binder (SVM1_INST_LOAD_NON_POINTER_TC_U16, load_non_pointer_tc_u16); \
+ binder (SVM1_INST_LOAD_NON_POINTER_WR_U16, load_non_pointer_wr_u16); \
+ binder (SVM1_INST_LOAD_NON_POINTER_TC_U32, load_non_pointer_tc_u32); \
+ binder (SVM1_INST_LOAD_NON_POINTER_WR_U32, load_non_pointer_wr_u32); \
+ binder (SVM1_INST_LOAD_NON_POINTER_TC_WR, load_non_pointer_tc_wr); \
+ binder (SVM1_INST_LOAD_NON_POINTER, load_non_pointer); \
+ binder (SVM1_INST_LOAD_POINTER_TC_WR, load_pointer_tc_wr); \
+ binder (SVM1_INST_LOAD_POINTER, load_pointer); \
+ binder (SVM1_INST_JUMP_PCR_S8, jump_pcr_s8); \
+ binder (SVM1_INST_JUMP_PCR_S16, jump_pcr_s16); \
+ binder (SVM1_INST_JUMP_PCR_S32, jump_pcr_s32); \
+ binder (SVM1_INST_JUMP_INDIR_WR, jump_indir_wr); \
+ binder (SVM1_INST_IJUMP_U8, ijump_u8); \
+ binder (SVM1_INST_IJUMP_U16, ijump_u16); \
+ binder (SVM1_INST_IJUMP_U32, ijump_u32); \
+ binder (SVM1_INST_ICALL_U8, icall_u8); \
+ binder (SVM1_INST_ICALL_U16, icall_u16); \
+ binder (SVM1_INST_ICALL_U32, icall_u32); \
+ binder (SVM1_INST_CJUMP_EQ_WR_WR_PCR_S8, cjump_eq_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S8, cjump_neq_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_LT_WR_WR_PCR_S8, cjump_lt_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_GE_WR_WR_PCR_S8, cjump_ge_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_GT_WR_WR_PCR_S8, cjump_gt_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_LE_WR_WR_PCR_S8, cjump_le_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_SLT_WR_WR_PCR_S8, cjump_slt_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_SGE_WR_WR_PCR_S8, cjump_sge_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_SGT_WR_WR_PCR_S8, cjump_sgt_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_SLE_WR_WR_PCR_S8, cjump_sle_wr_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_EQ_WR_WR_PCR_S16, cjump_eq_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S16, cjump_neq_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_LT_WR_WR_PCR_S16, cjump_lt_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_GE_WR_WR_PCR_S16, cjump_ge_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_GT_WR_WR_PCR_S16, cjump_gt_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_LE_WR_WR_PCR_S16, cjump_le_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_SLT_WR_WR_PCR_S16, cjump_slt_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_SGE_WR_WR_PCR_S16, cjump_sge_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_SGT_WR_WR_PCR_S16, cjump_sgt_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_SLE_WR_WR_PCR_S16, cjump_sle_wr_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_EQ_WR_WR_PCR_S32, cjump_eq_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S32, cjump_neq_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_LT_WR_WR_PCR_S32, cjump_lt_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_GE_WR_WR_PCR_S32, cjump_ge_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_GT_WR_WR_PCR_S32, cjump_gt_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_LE_WR_WR_PCR_S32, cjump_le_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_SLT_WR_WR_PCR_S32, cjump_slt_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_SGE_WR_WR_PCR_S32, cjump_sge_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_SGT_WR_WR_PCR_S32, cjump_sgt_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_SLE_WR_WR_PCR_S32, cjump_sle_wr_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_EQ_WR_PCR_S8, cjump_eq_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_NEQ_WR_PCR_S8, cjump_neq_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_SLT_WR_PCR_S8, cjump_slt_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_SGE_WR_PCR_S8, cjump_sge_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_SGT_WR_PCR_S8, cjump_sgt_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_SLE_WR_PCR_S8, cjump_sle_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_EQ_WR_PCR_S16, cjump_eq_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_NEQ_WR_PCR_S16, cjump_neq_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_SLT_WR_PCR_S16, cjump_slt_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_SGE_WR_PCR_S16, cjump_sge_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_SGT_WR_PCR_S16, cjump_sgt_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_SLE_WR_PCR_S16, cjump_sle_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_EQ_WR_PCR_S32, cjump_eq_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_NEQ_WR_PCR_S32, cjump_neq_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_SLT_WR_PCR_S32, cjump_slt_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_SGE_WR_PCR_S32, cjump_sge_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_SGT_WR_PCR_S32, cjump_sgt_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_SLE_WR_PCR_S32, cjump_sle_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_FIX_WR_PCR_S8, cjump_fix_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_NFIX_WR_PCR_S8, cjump_nfix_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_IFIX_WR_PCR_S8, cjump_ifix_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_NIFIX_WR_PCR_S8, cjump_nifix_wr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_FIX_WR_PCR_S16, cjump_fix_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_NFIX_WR_PCR_S16, cjump_nfix_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_IFIX_WR_PCR_S16, cjump_ifix_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_NIFIX_WR_PCR_S16, cjump_nifix_wr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_FIX_WR_PCR_S32, cjump_fix_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_NFIX_WR_PCR_S32, cjump_nfix_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_IFIX_WR_PCR_S32, cjump_ifix_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_NIFIX_WR_PCR_S32, cjump_nifix_wr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_EQ_FR_FR_PCR_S8, cjump_eq_fr_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S8, cjump_neq_fr_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_LT_FR_FR_PCR_S8, cjump_lt_fr_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_GT_FR_FR_PCR_S8, cjump_gt_fr_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_LE_FR_FR_PCR_S8, cjump_le_fr_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_GE_FR_FR_PCR_S8, cjump_ge_fr_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_CMP_FR_FR_PCR_S8, cjump_cmp_fr_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S8, cjump_ncmp_fr_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_EQ_FR_FR_PCR_S16, cjump_eq_fr_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S16, cjump_neq_fr_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_LT_FR_FR_PCR_S16, cjump_lt_fr_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_GT_FR_FR_PCR_S16, cjump_gt_fr_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_LE_FR_FR_PCR_S16, cjump_le_fr_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_GE_FR_FR_PCR_S16, cjump_ge_fr_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_CMP_FR_FR_PCR_S16, cjump_cmp_fr_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S16, cjump_ncmp_fr_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_EQ_FR_FR_PCR_S32, cjump_eq_fr_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S32, cjump_neq_fr_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_LT_FR_FR_PCR_S32, cjump_lt_fr_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_GT_FR_FR_PCR_S32, cjump_gt_fr_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_LE_FR_FR_PCR_S32, cjump_le_fr_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_GE_FR_FR_PCR_S32, cjump_ge_fr_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_CMP_FR_FR_PCR_S32, cjump_cmp_fr_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S32, cjump_ncmp_fr_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_EQ_FR_PCR_S8, cjump_eq_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_NEQ_FR_PCR_S8, cjump_neq_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_LT_FR_PCR_S8, cjump_lt_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_GT_FR_PCR_S8, cjump_gt_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_LE_FR_PCR_S8, cjump_le_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_GE_FR_PCR_S8, cjump_ge_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_CMP_FR_PCR_S8, cjump_cmp_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_NCMP_FR_PCR_S8, cjump_ncmp_fr_pcr_s8); \
+ binder (SVM1_INST_CJUMP_EQ_FR_PCR_S16, cjump_eq_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_NEQ_FR_PCR_S16, cjump_neq_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_LT_FR_PCR_S16, cjump_lt_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_GT_FR_PCR_S16, cjump_gt_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_LE_FR_PCR_S16, cjump_le_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_GE_FR_PCR_S16, cjump_ge_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_CMP_FR_PCR_S16, cjump_cmp_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_NCMP_FR_PCR_S16, cjump_ncmp_fr_pcr_s16); \
+ binder (SVM1_INST_CJUMP_EQ_FR_PCR_S32, cjump_eq_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_NEQ_FR_PCR_S32, cjump_neq_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_LT_FR_PCR_S32, cjump_lt_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_GT_FR_PCR_S32, cjump_gt_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_LE_FR_PCR_S32, cjump_le_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_GE_FR_PCR_S32, cjump_ge_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_CMP_FR_PCR_S32, cjump_cmp_fr_pcr_s32); \
+ binder (SVM1_INST_CJUMP_NCMP_FR_PCR_S32, cjump_ncmp_fr_pcr_s32); \
+ binder (SVM1_INST_TRAP_TRAP_0, trap_trap_0); \
+ binder (SVM1_INST_TRAP_TRAP_1_WR, trap_trap_1_wr); \
+ binder (SVM1_INST_TRAP_TRAP_2_WR, trap_trap_2_wr); \
+ binder (SVM1_INST_TRAP_TRAP_3_WR, trap_trap_3_wr); \
+ binder (SVM1_INST_INTERRUPT_TEST_PROCEDURE, interrupt_test_procedure); \
+ binder (SVM1_INST_INTERRUPT_TEST_DYNAMIC_LINK, interrupt_test_dynamic_link); \
+ binder (SVM1_INST_INTERRUPT_TEST_CLOSURE, interrupt_test_closure); \
+ binder (SVM1_INST_INTERRUPT_TEST_IC_PROCEDURE, interrupt_test_ic_procedure); \
+ binder (SVM1_INST_INTERRUPT_TEST_CONTINUATION, interrupt_test_continuation); \
+ binder (SVM1_INST_FLONUM_HEADER_U8, flonum_header_u8); \
+ binder (SVM1_INST_FLONUM_HEADER_U16, flonum_header_u16); \
+ binder (SVM1_INST_FLONUM_HEADER_U32, flonum_header_u32); \
+ binder (SVM1_INST_FLONUM_HEADER, flonum_header); \
+ binder (SVM1_INST_COPY_WR, copy_wr); \
+ binder (SVM1_INST_COPY_FR, copy_fr); \
+ binder (SVM1_INST_NEGATE_WR, negate_wr); \
+ binder (SVM1_INST_NEGATE_FR, negate_fr); \
+ binder (SVM1_INST_INCREMENT_WR, increment_wr); \
+ binder (SVM1_INST_INCREMENT_FR, increment_fr); \
+ binder (SVM1_INST_DECREMENT_WR, decrement_wr); \
+ binder (SVM1_INST_DECREMENT_FR, decrement_fr); \
+ binder (SVM1_INST_ABS_WR, abs_wr); \
+ binder (SVM1_INST_ABS_FR, abs_fr); \
+ binder (SVM1_INST_OBJECT_TYPE, object_type); \
+ binder (SVM1_INST_OBJECT_DATUM, object_datum); \
+ binder (SVM1_INST_OBJECT_ADDRESS, object_address); \
+ binder (SVM1_INST_FIXNUM_TO_INTEGER, fixnum_to_integer); \
+ binder (SVM1_INST_INTEGER_TO_FIXNUM, integer_to_fixnum); \
+ binder (SVM1_INST_NOT, not); \
+ binder (SVM1_INST_FLONUM_ALIGN, flonum_align); \
+ binder (SVM1_INST_FLONUM_LENGTH, flonum_length); \
+ binder (SVM1_INST_SQRT, sqrt); \
+ binder (SVM1_INST_ROUND, round); \
+ binder (SVM1_INST_CEILING, ceiling); \
+ binder (SVM1_INST_FLOOR, floor); \
+ binder (SVM1_INST_TRUNCATE, truncate); \
+ binder (SVM1_INST_LOG, log); \
+ binder (SVM1_INST_EXP, exp); \
+ binder (SVM1_INST_COS, cos); \
+ binder (SVM1_INST_SIN, sin); \
+ binder (SVM1_INST_TAN, tan); \
+ binder (SVM1_INST_ACOS, acos); \
+ binder (SVM1_INST_ASIN, asin); \
+ binder (SVM1_INST_ATAN, atan); \
+ binder (SVM1_INST_ADD_WR, add_wr); \
+ binder (SVM1_INST_ADD_FR, add_fr); \
+ binder (SVM1_INST_SUBTRACT_WR, subtract_wr); \
+ binder (SVM1_INST_SUBTRACT_FR, subtract_fr); \
+ binder (SVM1_INST_MULTIPLY_WR, multiply_wr); \
+ binder (SVM1_INST_MULTIPLY_FR, multiply_fr); \
+ binder (SVM1_INST_QUOTIENT, quotient); \
+ binder (SVM1_INST_REMAINDER, remainder); \
+ binder (SVM1_INST_LSH, lsh); \
+ binder (SVM1_INST_AND, and); \
+ binder (SVM1_INST_ANDC, andc); \
+ binder (SVM1_INST_OR, or); \
+ binder (SVM1_INST_XOR, xor); \
+ binder (SVM1_INST_MAX_UNSIGNED, max_unsigned); \
+ binder (SVM1_INST_MIN_UNSIGNED, min_unsigned); \
+ binder (SVM1_INST_DIVIDE, divide); \
+ binder (SVM1_INST_ATAN2, atan2)
+
+#define SVM1_INST_STORE_B_WR_ADDR 0x01
+#define DECODE_SVM1_INST_STORE_B_WR_ADDR(source, target) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_ADDRESS (target)
+
+#define SVM1_INST_STORE_W_WR_ADDR 0x02
+#define DECODE_SVM1_INST_STORE_W_WR_ADDR(source, target) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_ADDRESS (target)
+
+#define SVM1_INST_STORE_F_FR_ADDR 0x03
+#define DECODE_SVM1_INST_STORE_F_FR_ADDR(source, target) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_ADDRESS (target)
+
+#define SVM1_INST_LOAD_B_WR_ADDR 0x04
+#define DECODE_SVM1_INST_LOAD_B_WR_ADDR(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_ADDRESS (source)
+
+#define SVM1_INST_LOAD_W_WR_ADDR 0x05
+#define DECODE_SVM1_INST_LOAD_W_WR_ADDR(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_ADDRESS (source)
+
+#define SVM1_INST_LOAD_F_FR_ADDR 0x06
+#define DECODE_SVM1_INST_LOAD_F_FR_ADDR(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_ADDRESS (source)
+
+#define SVM1_INST_LOAD_ADDRESS_ADDR 0x07
+#define DECODE_SVM1_INST_LOAD_ADDRESS_ADDR(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_ADDRESS (source)
+
+#define SVM1_INST_LOAD_IMMEDIATE_WR_S8 0x08
+#define DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_S8(target, value_1) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_SIGNED_8 (value_1)
+
+#define SVM1_INST_LOAD_IMMEDIATE_WR_S16 0x09
+#define DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_S16(target, value_1) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_SIGNED_16 (value_1)
+
+#define SVM1_INST_LOAD_IMMEDIATE_WR_S32 0x0a
+#define DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_S32(target, value_1) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_SIGNED_32 (value_1)
+
+#define SVM1_INST_LOAD_IMMEDIATE_WR_U8 0x0b
+#define DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_U8(target, value_1) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_UNSIGNED_8 (value_1)
+
+#define SVM1_INST_LOAD_IMMEDIATE_WR_U16 0x0c
+#define DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_U16(target, value_1) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_UNSIGNED_16 (value_1)
+
+#define SVM1_INST_LOAD_IMMEDIATE_WR_U32 0x0d
+#define DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_U32(target, value_1) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_UNSIGNED_32 (value_1)
+
+#define SVM1_INST_LOAD_IMMEDIATE_FR_FLT 0x0e
+#define DECODE_SVM1_INST_LOAD_IMMEDIATE_FR_FLT(target, value) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT (value)
+
+#define SVM1_INST_COPY_BLOCK_U8_W 0x0f
+#define DECODE_SVM1_INST_COPY_BLOCK_U8_W(to, from, size) \
+ DECODE_WORD_REGISTER (to); \
+ DECODE_WORD_REGISTER (from); \
+ DECODE_UNSIGNED_8 (size)
+
+#define SVM1_INST_COPY_BLOCK_WR_W 0x10
+#define DECODE_SVM1_INST_COPY_BLOCK_WR_W(to, from, size) \
+ DECODE_WORD_REGISTER (to); \
+ DECODE_WORD_REGISTER (from); \
+ DECODE_WORD_REGISTER (size)
+
+#define SVM1_INST_LOAD_NON_POINTER_TC_U8 0x11
+#define DECODE_SVM1_INST_LOAD_NON_POINTER_TC_U8(target, type_1, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_TYPE_WORD (type_1); \
+ DECODE_UNSIGNED_8 (value)
+
+#define SVM1_INST_LOAD_NON_POINTER_WR_U8 0x12
+#define DECODE_SVM1_INST_LOAD_NON_POINTER_WR_U8(target, source, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_UNSIGNED_8 (value)
+
+#define SVM1_INST_LOAD_NON_POINTER_TC_U16 0x13
+#define DECODE_SVM1_INST_LOAD_NON_POINTER_TC_U16(target, type_1, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_TYPE_WORD (type_1); \
+ DECODE_UNSIGNED_16 (value)
+
+#define SVM1_INST_LOAD_NON_POINTER_WR_U16 0x14
+#define DECODE_SVM1_INST_LOAD_NON_POINTER_WR_U16(target, source, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_UNSIGNED_16 (value)
+
+#define SVM1_INST_LOAD_NON_POINTER_TC_U32 0x15
+#define DECODE_SVM1_INST_LOAD_NON_POINTER_TC_U32(target, type_1, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_TYPE_WORD (type_1); \
+ DECODE_UNSIGNED_32 (value)
+
+#define SVM1_INST_LOAD_NON_POINTER_WR_U32 0x16
+#define DECODE_SVM1_INST_LOAD_NON_POINTER_WR_U32(target, source, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_UNSIGNED_32 (value)
+
+#define SVM1_INST_LOAD_NON_POINTER_TC_WR 0x17
+#define DECODE_SVM1_INST_LOAD_NON_POINTER_TC_WR(target, type_1, datum) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_TYPE_WORD (type_1); \
+ DECODE_WORD_REGISTER (datum)
+
+#define SVM1_INST_LOAD_NON_POINTER 0x18
+#define DECODE_SVM1_INST_LOAD_NON_POINTER(target, source, datum) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_WORD_REGISTER (datum)
+
+#define SVM1_INST_LOAD_POINTER_TC_WR 0x19
+#define DECODE_SVM1_INST_LOAD_POINTER_TC_WR(target, type_1, address) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_TYPE_WORD (type_1); \
+ DECODE_WORD_REGISTER (address)
+
+#define SVM1_INST_LOAD_POINTER 0x1a
+#define DECODE_SVM1_INST_LOAD_POINTER(target, source, address) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_WORD_REGISTER (address)
+
+#define SVM1_INST_JUMP_PCR_S8 0x1b
+#define DECODE_SVM1_INST_JUMP_PCR_S8(value) \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_JUMP_PCR_S16 0x1c
+#define DECODE_SVM1_INST_JUMP_PCR_S16(value) \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_JUMP_PCR_S32 0x1d
+#define DECODE_SVM1_INST_JUMP_PCR_S32(value) \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_JUMP_INDIR_WR 0x1e
+#define DECODE_SVM1_INST_JUMP_INDIR_WR(address) \
+ DECODE_WORD_REGISTER (address)
+
+#define SVM1_INST_IJUMP_U8 0x1f
+#define DECODE_SVM1_INST_IJUMP_U8(value) \
+ DECODE_UNSIGNED_8 (value)
+
+#define SVM1_INST_IJUMP_U16 0x20
+#define DECODE_SVM1_INST_IJUMP_U16(value) \
+ DECODE_UNSIGNED_16 (value)
+
+#define SVM1_INST_IJUMP_U32 0x21
+#define DECODE_SVM1_INST_IJUMP_U32(value) \
+ DECODE_UNSIGNED_32 (value)
+
+#define SVM1_INST_ICALL_U8 0x22
+#define DECODE_SVM1_INST_ICALL_U8(value) \
+ DECODE_UNSIGNED_8 (value)
+
+#define SVM1_INST_ICALL_U16 0x23
+#define DECODE_SVM1_INST_ICALL_U16(value) \
+ DECODE_UNSIGNED_16 (value)
+
+#define SVM1_INST_ICALL_U32 0x24
+#define DECODE_SVM1_INST_ICALL_U32(value) \
+ DECODE_UNSIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_EQ_WR_WR_PCR_S8 0x25
+#define DECODE_SVM1_INST_CJUMP_EQ_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S8 0x26
+#define DECODE_SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_LT_WR_WR_PCR_S8 0x27
+#define DECODE_SVM1_INST_CJUMP_LT_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_GE_WR_WR_PCR_S8 0x28
+#define DECODE_SVM1_INST_CJUMP_GE_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_GT_WR_WR_PCR_S8 0x29
+#define DECODE_SVM1_INST_CJUMP_GT_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_LE_WR_WR_PCR_S8 0x2a
+#define DECODE_SVM1_INST_CJUMP_LE_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_SLT_WR_WR_PCR_S8 0x2b
+#define DECODE_SVM1_INST_CJUMP_SLT_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_SGE_WR_WR_PCR_S8 0x2c
+#define DECODE_SVM1_INST_CJUMP_SGE_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_SGT_WR_WR_PCR_S8 0x2d
+#define DECODE_SVM1_INST_CJUMP_SGT_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_SLE_WR_WR_PCR_S8 0x2e
+#define DECODE_SVM1_INST_CJUMP_SLE_WR_WR_PCR_S8(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_EQ_WR_WR_PCR_S16 0x2f
+#define DECODE_SVM1_INST_CJUMP_EQ_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S16 0x30
+#define DECODE_SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_LT_WR_WR_PCR_S16 0x31
+#define DECODE_SVM1_INST_CJUMP_LT_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_GE_WR_WR_PCR_S16 0x32
+#define DECODE_SVM1_INST_CJUMP_GE_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_GT_WR_WR_PCR_S16 0x33
+#define DECODE_SVM1_INST_CJUMP_GT_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_LE_WR_WR_PCR_S16 0x34
+#define DECODE_SVM1_INST_CJUMP_LE_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_SLT_WR_WR_PCR_S16 0x35
+#define DECODE_SVM1_INST_CJUMP_SLT_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_SGE_WR_WR_PCR_S16 0x36
+#define DECODE_SVM1_INST_CJUMP_SGE_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_SGT_WR_WR_PCR_S16 0x37
+#define DECODE_SVM1_INST_CJUMP_SGT_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_SLE_WR_WR_PCR_S16 0x38
+#define DECODE_SVM1_INST_CJUMP_SLE_WR_WR_PCR_S16(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_EQ_WR_WR_PCR_S32 0x39
+#define DECODE_SVM1_INST_CJUMP_EQ_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S32 0x3a
+#define DECODE_SVM1_INST_CJUMP_NEQ_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_LT_WR_WR_PCR_S32 0x3b
+#define DECODE_SVM1_INST_CJUMP_LT_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_GE_WR_WR_PCR_S32 0x3c
+#define DECODE_SVM1_INST_CJUMP_GE_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_GT_WR_WR_PCR_S32 0x3d
+#define DECODE_SVM1_INST_CJUMP_GT_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_LE_WR_WR_PCR_S32 0x3e
+#define DECODE_SVM1_INST_CJUMP_LE_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_SLT_WR_WR_PCR_S32 0x3f
+#define DECODE_SVM1_INST_CJUMP_SLT_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_SGE_WR_WR_PCR_S32 0x40
+#define DECODE_SVM1_INST_CJUMP_SGE_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_SGT_WR_WR_PCR_S32 0x41
+#define DECODE_SVM1_INST_CJUMP_SGT_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_SLE_WR_WR_PCR_S32 0x42
+#define DECODE_SVM1_INST_CJUMP_SLE_WR_WR_PCR_S32(source1, source2, value) \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_EQ_WR_PCR_S8 0x43
+#define DECODE_SVM1_INST_CJUMP_EQ_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_NEQ_WR_PCR_S8 0x44
+#define DECODE_SVM1_INST_CJUMP_NEQ_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_SLT_WR_PCR_S8 0x45
+#define DECODE_SVM1_INST_CJUMP_SLT_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_SGE_WR_PCR_S8 0x46
+#define DECODE_SVM1_INST_CJUMP_SGE_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_SGT_WR_PCR_S8 0x47
+#define DECODE_SVM1_INST_CJUMP_SGT_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_SLE_WR_PCR_S8 0x48
+#define DECODE_SVM1_INST_CJUMP_SLE_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_EQ_WR_PCR_S16 0x49
+#define DECODE_SVM1_INST_CJUMP_EQ_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_NEQ_WR_PCR_S16 0x4a
+#define DECODE_SVM1_INST_CJUMP_NEQ_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_SLT_WR_PCR_S16 0x4b
+#define DECODE_SVM1_INST_CJUMP_SLT_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_SGE_WR_PCR_S16 0x4c
+#define DECODE_SVM1_INST_CJUMP_SGE_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_SGT_WR_PCR_S16 0x4d
+#define DECODE_SVM1_INST_CJUMP_SGT_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_SLE_WR_PCR_S16 0x4e
+#define DECODE_SVM1_INST_CJUMP_SLE_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_EQ_WR_PCR_S32 0x4f
+#define DECODE_SVM1_INST_CJUMP_EQ_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_NEQ_WR_PCR_S32 0x50
+#define DECODE_SVM1_INST_CJUMP_NEQ_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_SLT_WR_PCR_S32 0x51
+#define DECODE_SVM1_INST_CJUMP_SLT_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_SGE_WR_PCR_S32 0x52
+#define DECODE_SVM1_INST_CJUMP_SGE_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_SGT_WR_PCR_S32 0x53
+#define DECODE_SVM1_INST_CJUMP_SGT_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_SLE_WR_PCR_S32 0x54
+#define DECODE_SVM1_INST_CJUMP_SLE_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_FIX_WR_PCR_S8 0x55
+#define DECODE_SVM1_INST_CJUMP_FIX_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_NFIX_WR_PCR_S8 0x56
+#define DECODE_SVM1_INST_CJUMP_NFIX_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_IFIX_WR_PCR_S8 0x57
+#define DECODE_SVM1_INST_CJUMP_IFIX_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_NIFIX_WR_PCR_S8 0x58
+#define DECODE_SVM1_INST_CJUMP_NIFIX_WR_PCR_S8(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_FIX_WR_PCR_S16 0x59
+#define DECODE_SVM1_INST_CJUMP_FIX_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_NFIX_WR_PCR_S16 0x5a
+#define DECODE_SVM1_INST_CJUMP_NFIX_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_IFIX_WR_PCR_S16 0x5b
+#define DECODE_SVM1_INST_CJUMP_IFIX_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_NIFIX_WR_PCR_S16 0x5c
+#define DECODE_SVM1_INST_CJUMP_NIFIX_WR_PCR_S16(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_FIX_WR_PCR_S32 0x5d
+#define DECODE_SVM1_INST_CJUMP_FIX_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_NFIX_WR_PCR_S32 0x5e
+#define DECODE_SVM1_INST_CJUMP_NFIX_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_IFIX_WR_PCR_S32 0x5f
+#define DECODE_SVM1_INST_CJUMP_IFIX_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_NIFIX_WR_PCR_S32 0x60
+#define DECODE_SVM1_INST_CJUMP_NIFIX_WR_PCR_S32(source, value) \
+ DECODE_WORD_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_EQ_FR_FR_PCR_S8 0x61
+#define DECODE_SVM1_INST_CJUMP_EQ_FR_FR_PCR_S8(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S8 0x62
+#define DECODE_SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S8(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_LT_FR_FR_PCR_S8 0x63
+#define DECODE_SVM1_INST_CJUMP_LT_FR_FR_PCR_S8(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_GT_FR_FR_PCR_S8 0x64
+#define DECODE_SVM1_INST_CJUMP_GT_FR_FR_PCR_S8(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_LE_FR_FR_PCR_S8 0x65
+#define DECODE_SVM1_INST_CJUMP_LE_FR_FR_PCR_S8(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_GE_FR_FR_PCR_S8 0x66
+#define DECODE_SVM1_INST_CJUMP_GE_FR_FR_PCR_S8(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_CMP_FR_FR_PCR_S8 0x67
+#define DECODE_SVM1_INST_CJUMP_CMP_FR_FR_PCR_S8(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S8 0x68
+#define DECODE_SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S8(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_EQ_FR_FR_PCR_S16 0x69
+#define DECODE_SVM1_INST_CJUMP_EQ_FR_FR_PCR_S16(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S16 0x6a
+#define DECODE_SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S16(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_LT_FR_FR_PCR_S16 0x6b
+#define DECODE_SVM1_INST_CJUMP_LT_FR_FR_PCR_S16(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_GT_FR_FR_PCR_S16 0x6c
+#define DECODE_SVM1_INST_CJUMP_GT_FR_FR_PCR_S16(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_LE_FR_FR_PCR_S16 0x6d
+#define DECODE_SVM1_INST_CJUMP_LE_FR_FR_PCR_S16(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_GE_FR_FR_PCR_S16 0x6e
+#define DECODE_SVM1_INST_CJUMP_GE_FR_FR_PCR_S16(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_CMP_FR_FR_PCR_S16 0x6f
+#define DECODE_SVM1_INST_CJUMP_CMP_FR_FR_PCR_S16(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S16 0x70
+#define DECODE_SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S16(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_EQ_FR_FR_PCR_S32 0x71
+#define DECODE_SVM1_INST_CJUMP_EQ_FR_FR_PCR_S32(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S32 0x72
+#define DECODE_SVM1_INST_CJUMP_NEQ_FR_FR_PCR_S32(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_LT_FR_FR_PCR_S32 0x73
+#define DECODE_SVM1_INST_CJUMP_LT_FR_FR_PCR_S32(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_GT_FR_FR_PCR_S32 0x74
+#define DECODE_SVM1_INST_CJUMP_GT_FR_FR_PCR_S32(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_LE_FR_FR_PCR_S32 0x75
+#define DECODE_SVM1_INST_CJUMP_LE_FR_FR_PCR_S32(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_GE_FR_FR_PCR_S32 0x76
+#define DECODE_SVM1_INST_CJUMP_GE_FR_FR_PCR_S32(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_CMP_FR_FR_PCR_S32 0x77
+#define DECODE_SVM1_INST_CJUMP_CMP_FR_FR_PCR_S32(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S32 0x78
+#define DECODE_SVM1_INST_CJUMP_NCMP_FR_FR_PCR_S32(source1, source2, value) \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_EQ_FR_PCR_S8 0x79
+#define DECODE_SVM1_INST_CJUMP_EQ_FR_PCR_S8(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_NEQ_FR_PCR_S8 0x7a
+#define DECODE_SVM1_INST_CJUMP_NEQ_FR_PCR_S8(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_LT_FR_PCR_S8 0x7b
+#define DECODE_SVM1_INST_CJUMP_LT_FR_PCR_S8(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_GT_FR_PCR_S8 0x7c
+#define DECODE_SVM1_INST_CJUMP_GT_FR_PCR_S8(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_LE_FR_PCR_S8 0x7d
+#define DECODE_SVM1_INST_CJUMP_LE_FR_PCR_S8(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_GE_FR_PCR_S8 0x7e
+#define DECODE_SVM1_INST_CJUMP_GE_FR_PCR_S8(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_CMP_FR_PCR_S8 0x7f
+#define DECODE_SVM1_INST_CJUMP_CMP_FR_PCR_S8(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_NCMP_FR_PCR_S8 0x80
+#define DECODE_SVM1_INST_CJUMP_NCMP_FR_PCR_S8(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_8 (value)
+
+#define SVM1_INST_CJUMP_EQ_FR_PCR_S16 0x81
+#define DECODE_SVM1_INST_CJUMP_EQ_FR_PCR_S16(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_NEQ_FR_PCR_S16 0x82
+#define DECODE_SVM1_INST_CJUMP_NEQ_FR_PCR_S16(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_LT_FR_PCR_S16 0x83
+#define DECODE_SVM1_INST_CJUMP_LT_FR_PCR_S16(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_GT_FR_PCR_S16 0x84
+#define DECODE_SVM1_INST_CJUMP_GT_FR_PCR_S16(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_LE_FR_PCR_S16 0x85
+#define DECODE_SVM1_INST_CJUMP_LE_FR_PCR_S16(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_GE_FR_PCR_S16 0x86
+#define DECODE_SVM1_INST_CJUMP_GE_FR_PCR_S16(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_CMP_FR_PCR_S16 0x87
+#define DECODE_SVM1_INST_CJUMP_CMP_FR_PCR_S16(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_NCMP_FR_PCR_S16 0x88
+#define DECODE_SVM1_INST_CJUMP_NCMP_FR_PCR_S16(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_16 (value)
+
+#define SVM1_INST_CJUMP_EQ_FR_PCR_S32 0x89
+#define DECODE_SVM1_INST_CJUMP_EQ_FR_PCR_S32(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_NEQ_FR_PCR_S32 0x8a
+#define DECODE_SVM1_INST_CJUMP_NEQ_FR_PCR_S32(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_LT_FR_PCR_S32 0x8b
+#define DECODE_SVM1_INST_CJUMP_LT_FR_PCR_S32(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_GT_FR_PCR_S32 0x8c
+#define DECODE_SVM1_INST_CJUMP_GT_FR_PCR_S32(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_LE_FR_PCR_S32 0x8d
+#define DECODE_SVM1_INST_CJUMP_LE_FR_PCR_S32(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_GE_FR_PCR_S32 0x8e
+#define DECODE_SVM1_INST_CJUMP_GE_FR_PCR_S32(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_CMP_FR_PCR_S32 0x8f
+#define DECODE_SVM1_INST_CJUMP_CMP_FR_PCR_S32(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_CJUMP_NCMP_FR_PCR_S32 0x90
+#define DECODE_SVM1_INST_CJUMP_NCMP_FR_PCR_S32(source, value) \
+ DECODE_FLOAT_REGISTER (source); \
+ DECODE_SIGNED_32 (value)
+
+#define SVM1_INST_TRAP_TRAP_0 0x91
+#define DECODE_SVM1_INST_TRAP_TRAP_0(code) \
+ DECODE_TRAP_0 (code)
+
+#define SVM1_INST_TRAP_TRAP_1_WR 0x92
+#define DECODE_SVM1_INST_TRAP_TRAP_1_WR(code, arg0) \
+ DECODE_TRAP_1 (code); \
+ DECODE_WORD_REGISTER (arg0)
+
+#define SVM1_INST_TRAP_TRAP_2_WR 0x93
+#define DECODE_SVM1_INST_TRAP_TRAP_2_WR(code, arg0, arg1) \
+ DECODE_TRAP_2 (code); \
+ DECODE_WORD_REGISTER (arg0); \
+ DECODE_WORD_REGISTER (arg1)
+
+#define SVM1_INST_TRAP_TRAP_3_WR 0x94
+#define DECODE_SVM1_INST_TRAP_TRAP_3_WR(code, arg0, arg1, arg2) \
+ DECODE_TRAP_3 (code); \
+ DECODE_WORD_REGISTER (arg0); \
+ DECODE_WORD_REGISTER (arg1); \
+ DECODE_WORD_REGISTER (arg2)
+
+#define SVM1_INST_INTERRUPT_TEST_PROCEDURE 0x95
+
+#define SVM1_INST_INTERRUPT_TEST_DYNAMIC_LINK 0x96
+
+#define SVM1_INST_INTERRUPT_TEST_CLOSURE 0x97
+
+#define SVM1_INST_INTERRUPT_TEST_IC_PROCEDURE 0x98
+
+#define SVM1_INST_INTERRUPT_TEST_CONTINUATION 0x99
+
+#define SVM1_INST_FLONUM_HEADER_U8 0x9a
+#define DECODE_SVM1_INST_FLONUM_HEADER_U8(target, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_UNSIGNED_8 (value)
+
+#define SVM1_INST_FLONUM_HEADER_U16 0x9b
+#define DECODE_SVM1_INST_FLONUM_HEADER_U16(target, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_UNSIGNED_16 (value)
+
+#define SVM1_INST_FLONUM_HEADER_U32 0x9c
+#define DECODE_SVM1_INST_FLONUM_HEADER_U32(target, value) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_UNSIGNED_32 (value)
+
+#define SVM1_INST_FLONUM_HEADER 0x9d
+#define DECODE_SVM1_INST_FLONUM_HEADER(target, n_elts) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (n_elts)
+
+#define SVM1_INST_COPY_WR 0x9e
+#define DECODE_SVM1_INST_COPY_WR(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_COPY_FR 0x9f
+#define DECODE_SVM1_INST_COPY_FR(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_NEGATE_WR 0xa0
+#define DECODE_SVM1_INST_NEGATE_WR(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_NEGATE_FR 0xa1
+#define DECODE_SVM1_INST_NEGATE_FR(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_INCREMENT_WR 0xa2
+#define DECODE_SVM1_INST_INCREMENT_WR(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_INCREMENT_FR 0xa3
+#define DECODE_SVM1_INST_INCREMENT_FR(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_DECREMENT_WR 0xa4
+#define DECODE_SVM1_INST_DECREMENT_WR(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_DECREMENT_FR 0xa5
+#define DECODE_SVM1_INST_DECREMENT_FR(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_ABS_WR 0xa6
+#define DECODE_SVM1_INST_ABS_WR(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_ABS_FR 0xa7
+#define DECODE_SVM1_INST_ABS_FR(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_OBJECT_TYPE 0xa8
+#define DECODE_SVM1_INST_OBJECT_TYPE(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_OBJECT_DATUM 0xa9
+#define DECODE_SVM1_INST_OBJECT_DATUM(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_OBJECT_ADDRESS 0xaa
+#define DECODE_SVM1_INST_OBJECT_ADDRESS(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_FIXNUM_TO_INTEGER 0xab
+#define DECODE_SVM1_INST_FIXNUM_TO_INTEGER(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_INTEGER_TO_FIXNUM 0xac
+#define DECODE_SVM1_INST_INTEGER_TO_FIXNUM(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_NOT 0xad
+#define DECODE_SVM1_INST_NOT(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_FLONUM_ALIGN 0xae
+#define DECODE_SVM1_INST_FLONUM_ALIGN(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_FLONUM_LENGTH 0xaf
+#define DECODE_SVM1_INST_FLONUM_LENGTH(target, source) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source)
+
+#define SVM1_INST_SQRT 0xb0
+#define DECODE_SVM1_INST_SQRT(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_ROUND 0xb1
+#define DECODE_SVM1_INST_ROUND(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_CEILING 0xb2
+#define DECODE_SVM1_INST_CEILING(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_FLOOR 0xb3
+#define DECODE_SVM1_INST_FLOOR(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_TRUNCATE 0xb4
+#define DECODE_SVM1_INST_TRUNCATE(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_LOG 0xb5
+#define DECODE_SVM1_INST_LOG(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_EXP 0xb6
+#define DECODE_SVM1_INST_EXP(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_COS 0xb7
+#define DECODE_SVM1_INST_COS(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_SIN 0xb8
+#define DECODE_SVM1_INST_SIN(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_TAN 0xb9
+#define DECODE_SVM1_INST_TAN(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_ACOS 0xba
+#define DECODE_SVM1_INST_ACOS(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_ASIN 0xbb
+#define DECODE_SVM1_INST_ASIN(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_ATAN 0xbc
+#define DECODE_SVM1_INST_ATAN(target, source) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source)
+
+#define SVM1_INST_ADD_WR 0xbd
+#define DECODE_SVM1_INST_ADD_WR(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_ADD_FR 0xbe
+#define DECODE_SVM1_INST_ADD_FR(target, source1, source2) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2)
+
+#define SVM1_INST_SUBTRACT_WR 0xbf
+#define DECODE_SVM1_INST_SUBTRACT_WR(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_SUBTRACT_FR 0xc0
+#define DECODE_SVM1_INST_SUBTRACT_FR(target, source1, source2) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2)
+
+#define SVM1_INST_MULTIPLY_WR 0xc1
+#define DECODE_SVM1_INST_MULTIPLY_WR(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_MULTIPLY_FR 0xc2
+#define DECODE_SVM1_INST_MULTIPLY_FR(target, source1, source2) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2)
+
+#define SVM1_INST_QUOTIENT 0xc3
+#define DECODE_SVM1_INST_QUOTIENT(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_REMAINDER 0xc4
+#define DECODE_SVM1_INST_REMAINDER(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_LSH 0xc5
+#define DECODE_SVM1_INST_LSH(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_AND 0xc6
+#define DECODE_SVM1_INST_AND(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_ANDC 0xc7
+#define DECODE_SVM1_INST_ANDC(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_OR 0xc8
+#define DECODE_SVM1_INST_OR(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_XOR 0xc9
+#define DECODE_SVM1_INST_XOR(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_MAX_UNSIGNED 0xca
+#define DECODE_SVM1_INST_MAX_UNSIGNED(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_MIN_UNSIGNED 0xcb
+#define DECODE_SVM1_INST_MIN_UNSIGNED(target, source1, source2) \
+ DECODE_WORD_REGISTER (target); \
+ DECODE_WORD_REGISTER (source1); \
+ DECODE_WORD_REGISTER (source2)
+
+#define SVM1_INST_DIVIDE 0xcc
+#define DECODE_SVM1_INST_DIVIDE(target, source1, source2) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2)
+
+#define SVM1_INST_ATAN2 0xcd
+#define DECODE_SVM1_INST_ATAN2(target, source1, source2) \
+ DECODE_FLOAT_REGISTER (target); \
+ DECODE_FLOAT_REGISTER (source1); \
+ DECODE_FLOAT_REGISTER (source2)
+
+#define SVM1_TRAP_0_START_CODE 0x01
+#define SVM1_TRAP_0_END_CODE 0x20
+
+#define SVM1_TRAP_0_BINDINGS(binder) \
+ binder (SVM1_TRAP_0_ADD, add); \
+ binder (SVM1_TRAP_0_DECREMENT, decrement); \
+ binder (SVM1_TRAP_0_DIVIDE, divide); \
+ binder (SVM1_TRAP_0_EQUAL_P, equal_p); \
+ binder (SVM1_TRAP_0_GREATER_P, greater_p); \
+ binder (SVM1_TRAP_0_INCREMENT, increment); \
+ binder (SVM1_TRAP_0_LESS_P, less_p); \
+ binder (SVM1_TRAP_0_MODULO, modulo); \
+ binder (SVM1_TRAP_0_MULTIPLY, multiply); \
+ binder (SVM1_TRAP_0_NEGATIVE_P, negative_p); \
+ binder (SVM1_TRAP_0_OPERATOR_1_0, operator_1_0); \
+ binder (SVM1_TRAP_0_OPERATOR_2_0, operator_2_0); \
+ binder (SVM1_TRAP_0_OPERATOR_2_1, operator_2_1); \
+ binder (SVM1_TRAP_0_OPERATOR_3_0, operator_3_0); \
+ binder (SVM1_TRAP_0_OPERATOR_3_1, operator_3_1); \
+ binder (SVM1_TRAP_0_OPERATOR_3_2, operator_3_2); \
+ binder (SVM1_TRAP_0_OPERATOR_4_0, operator_4_0); \
+ binder (SVM1_TRAP_0_OPERATOR_4_1, operator_4_1); \
+ binder (SVM1_TRAP_0_OPERATOR_4_2, operator_4_2); \
+ binder (SVM1_TRAP_0_OPERATOR_4_3, operator_4_3); \
+ binder (SVM1_TRAP_0_OPERATOR_APPLY, operator_apply); \
+ binder (SVM1_TRAP_0_OPERATOR_LEXPR, operator_lexpr); \
+ binder (SVM1_TRAP_0_OPERATOR_LOOKUP, operator_lookup); \
+ binder (SVM1_TRAP_0_OPERATOR_PRIMITIVE, operator_primitive); \
+ binder (SVM1_TRAP_0_POSITIVE_P, positive_p); \
+ binder (SVM1_TRAP_0_QUOTIENT, quotient); \
+ binder (SVM1_TRAP_0_REFLECT_TO_INTERFACE, reflect_to_interface); \
+ binder (SVM1_TRAP_0_REMAINDER, remainder); \
+ binder (SVM1_TRAP_0_RETURN_TO_INTERPRETER, return_to_interpreter); \
+ binder (SVM1_TRAP_0_SUBTRACT, subtract); \
+ binder (SVM1_TRAP_0_ZERO_P, zero_p)
+
+#define SVM1_TRAP_0_ADD 0x01
+#define SVM1_TRAP_0_DECREMENT 0x02
+#define SVM1_TRAP_0_DIVIDE 0x03
+#define SVM1_TRAP_0_EQUAL_P 0x04
+#define SVM1_TRAP_0_GREATER_P 0x05
+#define SVM1_TRAP_0_INCREMENT 0x06
+#define SVM1_TRAP_0_LESS_P 0x07
+#define SVM1_TRAP_0_MODULO 0x08
+#define SVM1_TRAP_0_MULTIPLY 0x09
+#define SVM1_TRAP_0_NEGATIVE_P 0x0a
+#define SVM1_TRAP_0_OPERATOR_1_0 0x0b
+#define SVM1_TRAP_0_OPERATOR_2_0 0x0c
+#define SVM1_TRAP_0_OPERATOR_2_1 0x0d
+#define SVM1_TRAP_0_OPERATOR_3_0 0x0e
+#define SVM1_TRAP_0_OPERATOR_3_1 0x0f
+#define SVM1_TRAP_0_OPERATOR_3_2 0x10
+#define SVM1_TRAP_0_OPERATOR_4_0 0x11
+#define SVM1_TRAP_0_OPERATOR_4_1 0x12
+#define SVM1_TRAP_0_OPERATOR_4_2 0x13
+#define SVM1_TRAP_0_OPERATOR_4_3 0x14
+#define SVM1_TRAP_0_OPERATOR_APPLY 0x15
+#define SVM1_TRAP_0_OPERATOR_LEXPR 0x16
+#define SVM1_TRAP_0_OPERATOR_LOOKUP 0x17
+#define SVM1_TRAP_0_OPERATOR_PRIMITIVE 0x18
+#define SVM1_TRAP_0_POSITIVE_P 0x19
+#define SVM1_TRAP_0_QUOTIENT 0x1a
+#define SVM1_TRAP_0_REFLECT_TO_INTERFACE 0x1b
+#define SVM1_TRAP_0_REMAINDER 0x1c
+#define SVM1_TRAP_0_RETURN_TO_INTERPRETER 0x1d
+#define SVM1_TRAP_0_SUBTRACT 0x1e
+#define SVM1_TRAP_0_ZERO_P 0x1f
+
+#define SVM1_TRAP_1_START_CODE 0x01
+#define SVM1_TRAP_1_END_CODE 0x07
+
+#define SVM1_TRAP_1_BINDINGS(binder) \
+ binder (SVM1_TRAP_1_ERROR, error); \
+ binder (SVM1_TRAP_1_LOOKUP, lookup); \
+ binder (SVM1_TRAP_1_PRIMITIVE_APPLY, primitive_apply); \
+ binder (SVM1_TRAP_1_PRIMITIVE_LEXPR_APPLY, primitive_lexpr_apply); \
+ binder (SVM1_TRAP_1_SAFE_LOOKUP, safe_lookup); \
+ binder (SVM1_TRAP_1_UNASSIGNED_P, unassigned_p)
+
+#define SVM1_TRAP_1_ERROR 0x01
+#define SVM1_TRAP_1_LOOKUP 0x02
+#define SVM1_TRAP_1_PRIMITIVE_APPLY 0x03
+#define SVM1_TRAP_1_PRIMITIVE_LEXPR_APPLY 0x04
+#define SVM1_TRAP_1_SAFE_LOOKUP 0x05
+#define SVM1_TRAP_1_UNASSIGNED_P 0x06
+
+#define SVM1_TRAP_2_START_CODE 0x01
+#define SVM1_TRAP_2_END_CODE 0x05
+
+#define SVM1_TRAP_2_BINDINGS(binder) \
+ binder (SVM1_TRAP_2_APPLY, apply); \
+ binder (SVM1_TRAP_2_ASSIGNMENT, assignment); \
+ binder (SVM1_TRAP_2_LEXPR_APPLY, lexpr_apply); \
+ binder (SVM1_TRAP_2_PRIMITIVE_ERROR, primitive_error)
+
+#define SVM1_TRAP_2_APPLY 0x01
+#define SVM1_TRAP_2_ASSIGNMENT 0x02
+#define SVM1_TRAP_2_LEXPR_APPLY 0x03
+#define SVM1_TRAP_2_PRIMITIVE_ERROR 0x04
+
+#define SVM1_TRAP_3_START_CODE 0x01
+#define SVM1_TRAP_3_END_CODE 0x03
+
+#define SVM1_TRAP_3_BINDINGS(binder) \
+ binder (SVM1_TRAP_3_CACHE_REFERENCE_APPLY, cache_reference_apply); \
+ binder (SVM1_TRAP_3_LINK, link)
+
+#define SVM1_TRAP_3_CACHE_REFERENCE_APPLY 0x01
+#define SVM1_TRAP_3_LINK 0x02
+
+#endif /* not SCM_SVM1_DEFNS_H */
--- /dev/null
+/* -*-C-*-
+
+$Id: svm1-interp.c,v 11.1 2007/04/22 16:31:23 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Scheme Virtual Machine version 1 */
+
+#include "scheme.h"
+#include "svm1-defns.h"
+
+#define SVM1_REG_SP 0
+\f
+typedef SCHEME_OBJECT word_t; /* convenience abbreviation */
+
+#define N_WORD_REGISTERS 0x100
+#define N_FLOAT_REGISTERS 0x100
+
+#if (N_WORD_REGISTERS < (UCHAR_MAX + 1))
+# define WORD_REGISTER_P(b) ((b) < N_WORD_REGISTERS)
+#else
+# define WORD_REGISTER_P(b) true
+#endif
+#if (N_FLOAT_REGISTERS < (UCHAR_MAX + 1))
+# define FLOAT_REGISTER_P(b) ((b) < N_FLOAT_REGISTERS)
+#else
+# define FLOAT_REGISTER_P(b) true
+#endif
+
+static byte_t * program_counter;
+static word_t word_registers [N_WORD_REGISTERS];
+static double float_registers [N_FLOAT_REGISTERS];
+
+#define SBYTE (sizeof (byte_t))
+#define SWORD (sizeof (word_t))
+#define SFLOAT (sizeof (double))
+
+#define PC program_counter
+#define NEXT_BYTE (*program_counter++)
+
+typedef byte_t wreg_t;
+typedef byte_t freg_t;
+typedef byte_t tc_t;
+
+#define WREG_REF(wr) (word_registers [(wr)])
+#define FREG_REF(fr) (float_registers [(fr)])
+
+#define WREG_SET(wr, w) ((word_registers [(wr)]) = (w))
+#define FREG_SET(fr, f) ((float_registers [(fr)]) = (f))
+
+#define BYTE_ADDR(a) ((byte_t *) a)
+#define WORD_ADDR(a) ((word_t *) a)
+#define FLOAT_ADDR(a) ((double *) a)
+
+#define BYTE_REF(a) (* (BYTE_ADDR (a)))
+#define WORD_REF(a) (* (WORD_ADDR (a)))
+#define FLOAT_REF(a) (* (FLOAT_ADDR (a)))
+
+
+typedef byte_t * inst_defn_t (void);
+static inst_defn_t * inst_defns [256];
+
+#define DEFINE_INST(name) static byte_t * insn_##name (void)
+#define NEXT_PC return (PC)
+#define OFFSET_PC(o) return (PC + (o))
+#define COND_OFFSET_PC(p, o) return ((p) ? (PC + (o)) : PC)
+#define NEW_PC(addr) return (addr)
+static long svm1_result;
+
+#define EXIT_VM(code) do \
+{ \
+ svm1_result = (code); \
+ return (0); \
+} while (0)
+
+typedef struct address_s address_t;
+typedef word_t address_value_t (address_t *);
+typedef void address_decoder_t (address_t *);
+static address_decoder_t * address_decoders [256];
+
+struct address_s
+{
+ wreg_t r1;
+ wreg_t r2;
+ word_t n1;
+ long n2;
+ address_value_t * value;
+};
+#define ADDRESS_VALUE(name) ((name.value) (&name))
+
+#define DEFINE_ADDRESS_DECODER(name) \
+ static void decode_addr_##name (address_t * address)
+#define DECODE_ADDRESS(name) address_t name; decode_address (&name)
+static void decode_address (address_t *);
+
+typedef byte_t * trap_0_t (void);
+typedef byte_t * trap_1_t (wreg_t);
+typedef byte_t * trap_2_t (wreg_t, wreg_t);
+typedef byte_t * trap_3_t (wreg_t, wreg_t, wreg_t);
+
+static trap_0_t * traps_0 [256];
+static trap_1_t * traps_1 [256];
+static trap_2_t * traps_2 [256];
+static trap_3_t * traps_3 [256];
+
+#define DECODE_TRAP_0(name) byte_t name = NEXT_BYTE
+#define DECODE_TRAP_1(name) byte_t name = NEXT_BYTE
+#define DECODE_TRAP_2(name) byte_t name = NEXT_BYTE
+#define DECODE_TRAP_3(name) byte_t name = NEXT_BYTE
+
+static void signal_illegal_instruction (void);
+static void initialize_decoder_tables (void);
+\f
+static int initialized_p = 0;
+static int little_endian_p;
+
+static byte_t * execute_instruction (void);
+
+static void
+compute_little_endian_p (void)
+{
+ union
+ {
+ unsigned long n;
+ char b [(sizeof (unsigned long))];
+ } ue;
+ (ue.n) = 1;
+ little_endian_p = (((ue.b) [0]) == 1);
+}
+
+void
+initialize_svm1 (void)
+{
+ unsigned int i;
+
+ if (!initialized_p)
+ {
+ compute_little_endian_p ();
+ initialize_decoder_tables ();
+ initialized_p = 1;
+ }
+ for (i = 0; (i < N_WORD_REGISTERS); i += 1)
+ WREG_SET (i, 0);
+ for (i = 0; (i < N_FLOAT_REGISTERS); i += 1)
+ WREG_SET (i, 0.0);
+}
+
+#define IMPORT_REGS() do \
+{ \
+ WREG_SET (SVM1_REG_STACK_POINTER, ((SCHEME_OBJECT) stack_pointer)); \
+ WREG_SET (SVM1_REG_FREE_POINTER, ((SCHEME_OBJECT) Free)); \
+ WREG_SET (SVM1_REG_VALUE, GET_VAL); \
+} while (0)
+
+#define EXPORT_REGS() do \
+{ \
+ stack_pointer \
+ = ((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_STACK_POINTER))); \
+ Free = ((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_FREE_POINTER))); \
+ SET_VAL (WREG_REF (SVM1_REG_VALUE)); \
+} while (0)
+
+long
+C_to_interface (void * address)
+{
+ IMPORT_REGS ();
+ PC = address;
+ while (1)
+ {
+ byte_t * new_pc = (execute_instruction ());
+ if (new_pc == 0)
+ break;
+ PC = new_pc;
+ }
+ EXPORT_REGS ();
+ return (svm1_result);
+}
+
+static jmp_buf k_execute_instruction;
+
+static byte_t *
+execute_instruction (void)
+{
+ if ((setjmp (k_execute_instruction)) != 0)
+ return (0);
+ return ((* (inst_defns[NEXT_BYTE])) ());
+}
+
+static insn_t *
+illegal_instruction (void)
+{
+ signal_illegal_instruction ();
+ return (0);
+}
+
+static void
+signal_illegal_instruction (void)
+{
+ svm1_result = ERR_COMPILED_CODE_ERROR;
+ longjmp (k_execute_instruction, 1);
+}
+
+#define TO_SIGNED(n) ((long) (n))
+#define FROM_SIGNED(n) ((word_t) (n))
+
+#define SIGNED_UNARY(op, a1) \
+ (FROM_SIGNED (op (TO_SIGNED (a1))))
+
+#define SIGNED_BINARY(op, a1, a2) \
+ (FROM_SIGNED ((TO_SIGNED (a1)) op (TO_SIGNED (a2))))
+
+#if 0
+/* The above definition isn't guaranteed to work in ANSI C, but in
+ practice it usually does. Here's an alternative that should always
+ work (in machines that use 2's complement). */
+#define TO_SIGNED(n) (to_signed (n))
+
+static long
+to_signed (word_t n)
+{
+ union { unsigned long n1; long n2; } us;
+ (us.n1) = n;
+ return (us.n2);
+}
+#endif
+\f
+/* Primitive decoders */
+
+#define DECODE_WORD_REGISTER(name) wreg_t name = (decode_wreg ())
+#define DECODE_FLOAT_REGISTER(name) freg_t name = (decode_freg ())
+#define DECODE_TYPE_WORD(name) tc_t name = (decode_type_word ())
+#define DECODE_UNSIGNED_8(name) word_t name = (decode_unsigned_8 ())
+#define DECODE_UNSIGNED_16(name) word_t name = (decode_unsigned_16 ())
+#define DECODE_UNSIGNED_32(name) word_t name = (decode_unsigned_32 ())
+#define DECODE_SIGNED_8(name) long name = (decode_signed_8 ())
+#define DECODE_SIGNED_16(name) long name = (decode_signed_16 ())
+#define DECODE_SIGNED_32(name) long name = (decode_signed_32 ())
+#define DECODE_FLOAT(name) double name = (decode_float ())
+
+static wreg_t
+decode_wreg (void)
+{
+ byte_t b = NEXT_BYTE;
+ if (!WORD_REGISTER_P (b))
+ signal_illegal_instruction ();
+ return (b);
+}
+
+static freg_t
+decode_freg (void)
+{
+ byte_t b = NEXT_BYTE;
+ if (!FLOAT_REGISTER_P (b))
+ signal_illegal_instruction ();
+ return (b);
+}
+
+static tc_t
+decode_type_word (void)
+{
+ byte_t b = NEXT_BYTE;
+ if (b >= N_TYPE_CODES)
+ signal_illegal_instruction ();
+ return (b);
+}
+
+static word_t
+decode_unsigned_8 (void)
+{
+ return (NEXT_BYTE);
+}
+
+static word_t
+decode_unsigned_16 (void)
+{
+ word_t b0 = NEXT_BYTE;
+ word_t b1 = NEXT_BYTE;
+ return ((b1 << 8) | b0);
+}
+
+static word_t
+decode_unsigned_32 (void)
+{
+ word_t b0 = NEXT_BYTE;
+ word_t b1 = NEXT_BYTE;
+ word_t b2 = NEXT_BYTE;
+ word_t b3 = NEXT_BYTE;
+ return ((b3 << 24) | (b2 << 16) | (b1 << 8) | b0);
+}
+
+static long
+decode_signed_8 (void)
+{
+ long b = NEXT_BYTE;
+ return ((b < 0x80) ? b : (b - 0x100));
+}
+
+static long
+decode_signed_16 (void)
+{
+ long n = (decode_unsigned_16 ());
+ return ((n < 0x8000) ? n : (n - 0x10000));
+}
+
+static long
+decode_signed_32 (void)
+{
+ word_t n = (decode_unsigned_32 ());
+ if (n < 0x80000000UL)
+ return ((long) n);
+#if (LONG_MAX > 0x7FFFFFFFUL)
+ return (((long) n) - 0x100000000L);
+#else
+ n -= 0x80000000UL;
+ {
+ long r = ((long) n);
+ r -= 0x40000000L;
+ r -= 0x40000000L;
+ return (r);
+ }
+#endif
+}
+
+static double
+decode_float (void)
+{
+ union { double f; byte_t b [(sizeof (double))]; } x;
+
+ if (little_endian_p)
+ {
+ unsigned int i = 0;
+ while (i < (sizeof (double)))
+ {
+ ((x.b) [i]) = NEXT_BYTE;
+ i += 1;
+ }
+ }
+ else
+ {
+ unsigned int i = (sizeof (double));
+ while (i > 0)
+ {
+ i -= 1;
+ ((x.b) [i]) = NEXT_BYTE;
+ }
+ }
+ return (x.f);
+}
+\f
+/* Instruction definitions */
+
+DEFINE_INST (store_b_wr_addr)
+{
+ DECODE_SVM1_INST_STORE_B_WR_ADDR (source, address);
+ (BYTE_REF (ADDRESS_VALUE (address))) = ((WREG_REF (source)) & 0xFF);
+ NEXT_PC;
+}
+
+DEFINE_INST (store_w_wr_addr)
+{
+ DECODE_SVM1_INST_STORE_W_WR_ADDR (source, address);
+ (WORD_REF (ADDRESS_VALUE (address))) = (WREG_REF (source));
+ NEXT_PC;
+}
+
+DEFINE_INST (store_f_fr_addr)
+{
+ DECODE_SVM1_INST_STORE_F_FR_ADDR (source, address);
+ (FLOAT_REF (ADDRESS_VALUE (address))) = (FREG_REF (source));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_b_wr_addr)
+{
+ DECODE_SVM1_INST_LOAD_B_WR_ADDR (target, address);
+ WREG_SET (target, (BYTE_REF (ADDRESS_VALUE (address))));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_w_wr_addr)
+{
+ DECODE_SVM1_INST_LOAD_W_WR_ADDR (target, address);
+ WREG_SET (target, (WORD_REF (ADDRESS_VALUE (address))));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_f_fr_addr)
+{
+ DECODE_SVM1_INST_LOAD_F_FR_ADDR (target, address);
+ FREG_SET (target, (FLOAT_REF (ADDRESS_VALUE (address))));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_address_addr)
+{
+ DECODE_SVM1_INST_LOAD_ADDRESS_ADDR (target, address);
+ WREG_SET (target, (ADDRESS_VALUE (address)));
+ NEXT_PC;
+}
+\f
+DEFINE_INST (load_immediate_wr_s8)
+{
+ DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_S8 (target, value);
+ WREG_SET (target, value);
+ NEXT_PC;
+}
+
+DEFINE_INST (load_immediate_wr_s16)
+{
+ DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_S16 (target, value);
+ WREG_SET (target, value);
+ NEXT_PC;
+}
+
+DEFINE_INST (load_immediate_wr_s32)
+{
+ DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_S32 (target, value);
+ WREG_SET (target, value);
+ NEXT_PC;
+}
+
+DEFINE_INST (load_immediate_wr_u8)
+{
+ DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_U8 (target, value);
+ WREG_SET (target, value);
+ NEXT_PC;
+}
+
+DEFINE_INST (load_immediate_wr_u16)
+{
+ DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_U16 (target, value);
+ WREG_SET (target, value);
+ NEXT_PC;
+}
+
+DEFINE_INST (load_immediate_wr_u32)
+{
+ DECODE_SVM1_INST_LOAD_IMMEDIATE_WR_U32 (target, value);
+ WREG_SET (target, value);
+ NEXT_PC;
+}
+
+DEFINE_INST (load_immediate_fr_flt)
+{
+ DECODE_SVM1_INST_LOAD_IMMEDIATE_FR_FLT (target, value);
+ FREG_SET (target, value);
+ NEXT_PC;
+}
+\f
+#define X_MAKE_OBJECT(t, d) \
+ (MAKE_OBJECT (((t) & TYPE_CODE_MASK), ((d) & DATUM_MASK)))
+
+#define X_MAKE_PTR(t, a) (X_MAKE_OBJECT (t, (ADDRESS_TO_DATUM (a))))
+
+#define X_OBJECT_ADDRESS(o) ((word_t) (OBJECT_ADDRESS (o)))
+
+DEFINE_INST (load_non_pointer_tc_u8)
+{
+ DECODE_SVM1_INST_LOAD_NON_POINTER_TC_U8 (target, type, datum);
+ WREG_SET (target, (X_MAKE_OBJECT (type, datum)));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_non_pointer_tc_u16)
+{
+ DECODE_SVM1_INST_LOAD_NON_POINTER_TC_U16 (target, type, datum);
+ WREG_SET (target, (X_MAKE_OBJECT (type, datum)));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_non_pointer_tc_u32)
+{
+ DECODE_SVM1_INST_LOAD_NON_POINTER_TC_U32 (target, type, datum);
+ WREG_SET (target, (X_MAKE_OBJECT (type, datum)));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_non_pointer_wr_u8)
+{
+ DECODE_SVM1_INST_LOAD_NON_POINTER_WR_U8 (target, type, datum);
+ WREG_SET (target, (X_MAKE_OBJECT ((WREG_REF (type)), datum)));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_non_pointer_wr_u16)
+{
+ DECODE_SVM1_INST_LOAD_NON_POINTER_WR_U16 (target, type, datum);
+ WREG_SET (target, (X_MAKE_OBJECT ((WREG_REF (type)), datum)));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_non_pointer_wr_u32)
+{
+ DECODE_SVM1_INST_LOAD_NON_POINTER_WR_U32 (target, type, datum);
+ WREG_SET (target, (X_MAKE_OBJECT ((WREG_REF (type)), datum)));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_non_pointer_tc_wr)
+{
+ DECODE_SVM1_INST_LOAD_NON_POINTER_TC_WR (target, type, datum);
+ WREG_SET (target, (X_MAKE_OBJECT (type, (WREG_REF (datum)))));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_non_pointer)
+{
+ DECODE_SVM1_INST_LOAD_NON_POINTER (target, type, datum);
+ WREG_SET (target, (X_MAKE_OBJECT ((WREG_REF (type)), (WREG_REF (datum)))));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_pointer_tc_wr)
+{
+ DECODE_SVM1_INST_LOAD_POINTER_TC_WR (target, type, address);
+ WREG_SET (target, (X_MAKE_PTR (type, (WREG_REF (address)))));
+ NEXT_PC;
+}
+
+DEFINE_INST (load_pointer)
+{
+ DECODE_SVM1_INST_LOAD_POINTER (target, type, address);
+ WREG_SET (target, (X_MAKE_PTR ((WREG_REF (type)), (WREG_REF (address)))));
+ NEXT_PC;
+}
+\f
+static void
+copy_block (word_t * to, word_t * from, word_t n_words)
+{
+ if (to > from)
+ {
+ word_t * p1 = (to + n_words);
+ word_t * p2 = (from + n_words);
+ while (p2 > from)
+ (*--p1) = (*--p2);
+ }
+ else if (to < from)
+ {
+ word_t * p2 = (from + n_words);
+ while (from < p2)
+ (*to++) = (*from++);
+ }
+}
+
+DEFINE_INST (copy_block_u8_w)
+{
+ DECODE_SVM1_INST_COPY_BLOCK_U8_W (r_to, r_from, n_words);
+ copy_block ((WORD_ADDR (WREG_REF (r_to))),
+ (WORD_ADDR (WREG_REF (r_from))),
+ n_words);
+ NEXT_PC;
+}
+
+DEFINE_INST (copy_block_wr_w)
+{
+ DECODE_SVM1_INST_COPY_BLOCK_WR_W (r_to, r_from, r_n_words);
+ copy_block ((WORD_ADDR (WREG_REF (r_to))),
+ (WORD_ADDR (WREG_REF (r_from))),
+ (WREG_REF (r_n_words)));
+ NEXT_PC;
+}
+
+DEFINE_INST (jump_pcr_s8)
+{
+ DECODE_SVM1_INST_JUMP_PCR_S8 (offset);
+ OFFSET_PC (offset);
+}
+
+DEFINE_INST (jump_pcr_s16)
+{
+ DECODE_SVM1_INST_JUMP_PCR_S16 (offset);
+ OFFSET_PC (offset);
+}
+
+DEFINE_INST (jump_pcr_s32)
+{
+ DECODE_SVM1_INST_JUMP_PCR_S32 (offset);
+ OFFSET_PC (offset);
+}
+
+DEFINE_INST (jump_indir_wr)
+{
+ DECODE_SVM1_INST_JUMP_INDIR_WR (address);
+ NEW_PC (BYTE_ADDR (WREG_REF (address)));
+}
+\f
+#define IJUMP(offset) \
+ NEW_PC (BYTE_ADDR (OBJECT_ADDRESS (* ((SCHEME_OBJECT *) (PC + (offset))))))
+
+DEFINE_INST (ijump_u8)
+{
+ DECODE_SVM1_INST_IJUMP_U8 (offset);
+ IJUMP (offset);
+}
+
+DEFINE_INST (ijump_u16)
+{
+ DECODE_SVM1_INST_IJUMP_U16 (offset);
+ IJUMP (offset);
+}
+
+DEFINE_INST (ijump_u32)
+{
+ DECODE_SVM1_INST_IJUMP_U32 (offset);
+ IJUMP (offset);
+}
+
+static void
+push_icall_entry (void * entry)
+{
+ stack_pointer = ((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_STACK_POINTER)));
+ STACK_PUSH (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, entry));
+ WREG_SET (SVM1_REG_STACK_POINTER, ((SCHEME_OBJECT) stack_pointer));
+}
+
+DEFINE_INST (icall_u8)
+{
+ DECODE_SVM1_INST_ICALL_U8 (offset);
+ push_icall_entry (PC - 2);
+ IJUMP (offset);
+}
+
+DEFINE_INST (icall_u16)
+{
+ DECODE_SVM1_INST_ICALL_U16 (offset);
+ push_icall_entry (PC - 3);
+ IJUMP (offset);
+}
+
+DEFINE_INST (icall_u32)
+{
+ DECODE_SVM1_INST_ICALL_U32 (offset);
+ push_icall_entry (PC - 5);
+ IJUMP (offset);
+}
+\f
+/* Conditional jumps */
+
+#define DEFINE_CJ_1(pl, pu, rl, ru, sl, su) \
+DEFINE_INST (cjump_##pl##_##rl##_##rl##_pcr_##sl) \
+{ \
+ DECODE_SVM1_INST_CJUMP_##pu##_##ru##_##ru##_PCR_##su \
+ (source1, source2, offset); \
+ CJ_PCR (CMP_##pu ((WREG_REF (source1)), (WREG_REF (source2)))); \
+}
+
+#define DEFINE_CJ_2(pl, pu, rl, ru, z, sl, su) \
+DEFINE_INST (cjump_##pl##_##rl##_pcr_##sl) \
+{ \
+ DECODE_SVM1_INST_CJUMP_##pu##_##ru##_PCR_##su (source, offset); \
+ CJ_PCR (CMP_##pu ((WREG_REF (source)), z)); \
+}
+
+#define CJ_PCR(p) COND_OFFSET_PC (p, offset)
+
+#define DEFINE_CJ_3(pl, pu, rl, ru, z, sl, su) \
+DEFINE_CJ_1 (pl, pu, rl, ru, sl, su) \
+DEFINE_CJ_2 (pl, pu, rl, ru, z, sl, su)
+
+#define DEFINE_CJ_WR(pl, pu) \
+DEFINE_CJ_3 (pl, pu, wr, WR, 0, s8, S8) \
+DEFINE_CJ_3 (pl, pu, wr, WR, 0, s16, S16) \
+DEFINE_CJ_3 (pl, pu, wr, WR, 0, s32, S32)
+
+#define DEFINE_CJ_WR_NZ(pl, pu) \
+DEFINE_CJ_1 (pl, pu, wr, WR, s8, S8) \
+DEFINE_CJ_1 (pl, pu, wr, WR, s16, S16) \
+DEFINE_CJ_1 (pl, pu, wr, WR, s32, S32)
+
+#define DEFINE_CJ_FR(pl, pu) \
+DEFINE_CJ_3 (pl, pu, fr, FR, 0.0, s8, S8) \
+DEFINE_CJ_3 (pl, pu, fr, FR, 0.0, s16, S16) \
+DEFINE_CJ_3 (pl, pu, fr, FR, 0.0, s32, S32)
+
+#define CMP_EQ(a, b) ((a) == (b))
+#define CMP_NEQ(a, b) ((a) != (b))
+#define CMP_LT(a, b) ((a) < (b))
+#define CMP_LE(a, b) ((a) <= (b))
+#define CMP_GT(a, b) ((a) > (b))
+#define CMP_GE(a, b) ((a) >= (b))
+#define CMP_SLT(a, b) ((TO_SIGNED (a)) < (TO_SIGNED (b)))
+#define CMP_SLE(a, b) ((TO_SIGNED (a)) <= (TO_SIGNED (b)))
+#define CMP_SGT(a, b) ((TO_SIGNED (a)) > (TO_SIGNED (b)))
+#define CMP_SGE(a, b) ((TO_SIGNED (a)) >= (TO_SIGNED (b)))
+#define CMP_CMP(a, b) (cmp_cmp ((a), (b)))
+#define CMP_NCMP(a, b) (!cmp_cmp ((a), (b)))
+
+static int
+cmp_cmp (double a, double b)
+{
+ return ((a < b) || (a > b) || (a == b));
+}
+
+DEFINE_CJ_WR (eq, EQ)
+DEFINE_CJ_WR (neq, NEQ)
+DEFINE_CJ_WR (slt, SLT)
+DEFINE_CJ_WR (sle, SLE)
+DEFINE_CJ_WR (sgt, SGT)
+DEFINE_CJ_WR (sge, SGE)
+
+DEFINE_CJ_WR_NZ (lt, LT)
+DEFINE_CJ_WR_NZ (le, LE)
+DEFINE_CJ_WR_NZ (gt, GT)
+DEFINE_CJ_WR_NZ (ge, GE)
+
+DEFINE_CJ_FR (eq, EQ)
+DEFINE_CJ_FR (neq, NEQ)
+DEFINE_CJ_FR (lt, LT)
+DEFINE_CJ_FR (le, LE)
+DEFINE_CJ_FR (gt, GT)
+DEFINE_CJ_FR (ge, GE)
+DEFINE_CJ_FR (cmp, CMP)
+DEFINE_CJ_FR (ncmp, NCMP)
+
+#define DEFINE_CJF_1(pl, pu, sl, su) \
+DEFINE_INST (cjump_##pl##_wr_pcr_##sl) \
+{ \
+ DECODE_SVM1_INST_CJUMP_##pu##_WR_PCR_##su (source, offset); \
+ CJ_PCR (CMP_##pu (WREG_REF (source))); \
+}
+
+#define DEFINE_CJF(pl, pu) \
+DEFINE_CJF_1 (pl, pu, s8, S8) \
+DEFINE_CJF_1 (pl, pu, s16, S16) \
+DEFINE_CJF_1 (pl, pu, s32, S32)
+
+#define CMP_FIX(a) (LONG_TO_FIXNUM_P (a))
+#define CMP_NFIX(a) (!CMP_FIX (a))
+#define CMP_IFIX(a) (((a) & SIGN_MASK) == (TC_FIXNUM * 2))
+#define CMP_NIFIX(a) (!CMP_IFIX (a))
+
+DEFINE_CJF (fix, FIX)
+DEFINE_CJF (nfix, NFIX)
+DEFINE_CJF (ifix, IFIX)
+DEFINE_CJF (nifix, NIFIX)
+\f
+DEFINE_INST (trap_trap_0)
+{
+ DECODE_SVM1_INST_TRAP_TRAP_0 (code);
+ return ((* (traps_0[code])) ());
+}
+
+static byte_t *
+illegal_trap_0 (void)
+{
+ signal_illegal_instruction ();
+ return (0);
+}
+
+DEFINE_INST (trap_trap_1_wr)
+{
+ DECODE_SVM1_INST_TRAP_TRAP_1_WR (code, r1);
+ return ((* (traps_1[code])) (r1));
+}
+
+static byte_t *
+illegal_trap_1 (wreg_t r1)
+{
+ signal_illegal_instruction ();
+ return (0);
+}
+
+DEFINE_INST (trap_trap_2_wr)
+{
+ DECODE_SVM1_INST_TRAP_TRAP_2_WR (code, r1, r2);
+ return ((* (traps_2[code])) (r1, r2));
+}
+
+static byte_t *
+illegal_trap_2 (wreg_t r1, wreg_t r2)
+{
+ signal_illegal_instruction ();
+ return (0);
+}
+
+DEFINE_INST (trap_trap_3_wr)
+{
+ DECODE_SVM1_INST_TRAP_TRAP_3_WR (code, r1, r2, r3);
+ return ((* (traps_3[code])) (r1, r2, r3));
+}
+
+static byte_t *
+illegal_trap_3 (wreg_t r1, wreg_t r2, wreg_t r3)
+{
+ signal_illegal_instruction ();
+ return (0);
+}
+
+#define TRAP_PREFIX(result) \
+ utility_result_t result; \
+ EXPORT_REGS ()
+
+#define TRAP_SUFFIX(result) \
+ if ((result).scheme_p) \
+ { \
+ IMPORT_REGS (); \
+ NEW_PC ((result).arg.new_pc); \
+ } \
+ else \
+ EXIT_VM ((result).arg.interpreter_code)
+\f
+#define DEFINE_TRAP_0(nl, util_name) \
+byte_t * \
+trap_##nl (void) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name ((&result), \
+ 0, \
+ 0, \
+ 0, \
+ 0); \
+ TRAP_SUFFIX (result); \
+}
+
+#define DEFINE_TRAP_1(nl, util_name) \
+byte_t * \
+trap_##nl (wreg_t source1) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name ((&result), \
+ ((long) (WREG_REF (source1))), \
+ 0, \
+ 0, \
+ 0); \
+ TRAP_SUFFIX (result); \
+}
+
+#define DEFINE_TRAP_2(nl, util_name) \
+byte_t * \
+trap_##nl (wreg_t source1, wreg_t source2) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name ((&result), \
+ ((long) (WREG_REF (source1))), \
+ ((long) (WREG_REF (source2))), \
+ 0, \
+ 0); \
+ TRAP_SUFFIX (result); \
+}
+
+#define DEFINE_TRAP_3(nl, util_name) \
+byte_t * \
+trap_##nl (wreg_t source1, wreg_t source2, wreg_t source3) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name ((&result), \
+ ((long) (WREG_REF (source1))), \
+ ((long) (WREG_REF (source2))), \
+ ((long) (WREG_REF (source3))), \
+ 0); \
+ TRAP_SUFFIX (result); \
+}
+\f
+#define DEFINE_TRAP_R0(nl, util_name) \
+byte_t * \
+trap_##nl (void) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name ((&result), \
+ ((long) (PC + CC_ENTRY_HEADER_SIZE)), \
+ 0, \
+ 0, \
+ 0); \
+ TRAP_SUFFIX (result); \
+}
+
+#define DEFINE_TRAP_R1(nl, util_name) \
+byte_t * \
+trap_##nl (wreg_t source1) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name ((&result), \
+ ((long) (PC + CC_ENTRY_HEADER_SIZE)), \
+ ((long) (WREG_REF (source1))), \
+ 0, \
+ 0); \
+ TRAP_SUFFIX (result); \
+}
+
+#define DEFINE_TRAP_R2(nl, util_name) \
+byte_t * \
+trap_##nl (wreg_t source1, wreg_t source2) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name ((&result), \
+ ((long) (PC + CC_ENTRY_HEADER_SIZE)), \
+ ((long) (WREG_REF (source1))), \
+ ((long) (WREG_REF (source2))), \
+ 0); \
+ TRAP_SUFFIX (result); \
+}
+
+#define DEFINE_TRAP_R3(nl, util_name) \
+byte_t * \
+trap_##nl (wreg_t source1, wreg_t source2, wreg_t source3) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name ((&result), \
+ ((long) (PC + CC_ENTRY_HEADER_SIZE)), \
+ ((long) (WREG_REF (source1))), \
+ ((long) (WREG_REF (source2))), \
+ ((long) (WREG_REF (source3)))); \
+ TRAP_SUFFIX (result); \
+}
+
+#define DEFINE_TRAMPOLINE(nl, util_name) \
+byte_t * \
+trap_##nl (void) \
+{ \
+ TRAP_PREFIX (result); \
+ comutil_##util_name \
+ ((&result), \
+ ((long) \
+ (trampoline_storage \
+ (cc_entry_address_to_block_address (PC - 2)))), \
+ 0, \
+ 0, \
+ 0); \
+ TRAP_SUFFIX (result); \
+}
+\f
+DEFINE_TRAP_0 (add, plus)
+DEFINE_TRAP_0 (decrement, decrement)
+DEFINE_TRAP_0 (divide, divide)
+DEFINE_TRAP_0 (equal_p, equal)
+DEFINE_TRAP_0 (greater_p, greater)
+DEFINE_TRAP_0 (increment, increment)
+DEFINE_TRAP_0 (less_p, less)
+DEFINE_TRAP_0 (modulo, modulo)
+DEFINE_TRAP_0 (multiply, multiply)
+DEFINE_TRAP_0 (negative_p, negative)
+DEFINE_TRAP_0 (positive_p, positive)
+DEFINE_TRAP_0 (quotient, quotient)
+DEFINE_TRAP_0 (remainder, remainder)
+DEFINE_TRAP_0 (subtract, minus)
+DEFINE_TRAP_0 (zero_p, zero)
+
+DEFINE_TRAP_1 (error, error)
+DEFINE_TRAP_1 (primitive_apply, primitive_apply)
+DEFINE_TRAP_1 (primitive_lexpr_apply, primitive_lexpr_apply)
+
+DEFINE_TRAP_R1 (lookup, lookup_trap)
+DEFINE_TRAP_R1 (safe_lookup, safe_lookup_trap)
+DEFINE_TRAP_R1 (unassigned_p, unassigned_p_trap)
+
+DEFINE_TRAP_2 (apply, apply)
+DEFINE_TRAP_2 (lexpr_apply, lexpr_apply)
+
+DEFINE_TRAP_R2 (assignment, assignment_trap)
+DEFINE_TRAP_R2 (primitive_error, primitive_error)
+
+DEFINE_TRAP_3 (cache_reference_apply, cache_lookup_apply)
+
+DEFINE_TRAP_R3 (link, link)
+
+DEFINE_TRAMPOLINE (operator_1_0, operator_1_0_trap)
+DEFINE_TRAMPOLINE (operator_2_0, operator_2_0_trap)
+DEFINE_TRAMPOLINE (operator_2_1, operator_2_1_trap)
+DEFINE_TRAMPOLINE (operator_3_0, operator_3_0_trap)
+DEFINE_TRAMPOLINE (operator_3_1, operator_3_1_trap)
+DEFINE_TRAMPOLINE (operator_3_2, operator_3_2_trap)
+DEFINE_TRAMPOLINE (operator_4_0, operator_4_0_trap)
+DEFINE_TRAMPOLINE (operator_4_1, operator_4_1_trap)
+DEFINE_TRAMPOLINE (operator_4_2, operator_4_2_trap)
+DEFINE_TRAMPOLINE (operator_4_3, operator_4_3_trap)
+DEFINE_TRAMPOLINE (operator_apply, operator_apply_trap)
+DEFINE_TRAMPOLINE (operator_lexpr, operator_lexpr_trap)
+DEFINE_TRAMPOLINE (operator_lookup, operator_lookup_trap)
+DEFINE_TRAMPOLINE (operator_primitive, operator_primitive_trap)
+DEFINE_TRAMPOLINE (reflect_to_interface, reflect_to_interface)
+DEFINE_TRAMPOLINE (return_to_interpreter, return_to_interpreter)
+\f
+#define DEFINE_INTERRUPT_TEST(name, a1, a2) \
+DEFINE_INST (interrupt_test_##name) \
+{ \
+ if ((((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_FREE_POINTER))) \
+ >= GET_MEMTOP) \
+ || (((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_STACK_POINTER))) \
+ >= GET_STACK_GUARD)) \
+ { \
+ utility_result_t result; \
+ \
+ EXPORT_REGS (); \
+ compiler_interrupt_common ((&result), (a1), (a2)); \
+ TRAP_SUFFIX (result); \
+ } \
+ NEXT_PC; \
+}
+
+DEFINE_INTERRUPT_TEST (procedure, (PC - 1), SHARP_F)
+DEFINE_INTERRUPT_TEST (closure, 0, SHARP_F)
+DEFINE_INTERRUPT_TEST (ic_procedure, (PC - 1), GET_ENV)
+DEFINE_INTERRUPT_TEST (continuation, (PC - 1), GET_VAL)
+
+DEFINE_INTERRUPT_TEST (dynamic_link,
+ (PC - 1),
+ (MAKE_CC_STACK_ENV (WREG_REF (SVM1_REG_DYNAMIC_LINK))))
+\f
+DEFINE_INST (flonum_header_u8)
+{
+ DECODE_SVM1_INST_FLONUM_HEADER_U8 (target, value);
+ WREG_SET (target,
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (FLONUM_SIZE * value))));
+ NEXT_PC;
+}
+
+DEFINE_INST (flonum_header_u16)
+{
+ DECODE_SVM1_INST_FLONUM_HEADER_U16 (target, value);
+ WREG_SET (target,
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (FLONUM_SIZE * value))));
+ NEXT_PC;
+}
+
+DEFINE_INST (flonum_header_u32)
+{
+ DECODE_SVM1_INST_FLONUM_HEADER_U32 (target, value);
+ WREG_SET (target,
+ (X_MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (FLONUM_SIZE * value))));
+ NEXT_PC;
+}
+
+DEFINE_INST (flonum_header)
+{
+ DECODE_SVM1_INST_FLONUM_HEADER (target, source);
+ WREG_SET (target,
+ (X_MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
+ (FLONUM_SIZE * (WREG_REF (source))))));
+ NEXT_PC;
+}
+
+DEFINE_INST (flonum_align)
+{
+ DECODE_SVM1_INST_FLONUM_ALIGN (target, source);
+ SCHEME_OBJECT * p = ((SCHEME_OBJECT *) (WREG_REF (source)));
+ ALIGN_FLOAT (p);
+ WREG_SET (target, ((word_t) p));
+ NEXT_PC;
+}
+\f
+#define UNARY_NOP(x) x
+#define SIGNED_NEGATE(x) (SIGNED_UNARY (-, (x)))
+#define WINCR(x) ((x) + 1)
+#define FINCR(x) ((x) + 1.0)
+#define WDECR(x) ((x) - 1)
+#define FDECR(x) ((x) - 1.0)
+#define WABS(x) (SIGNED_UNARY (labs, (x)))
+
+#define OP_ADD(x, y) ((x) + (y))
+#define OP_SUBTRACT(x, y) ((x) - (y))
+#define OP_MULTIPLY(x, y) ((x) * (y))
+#define OP_DIVIDE(x, y) ((x) / (y))
+#define OP_REMAINDER(x, y) ((x) % (y))
+#define OP_AND(x, y) ((x) & (y))
+#define OP_ANDC(x, y) ((x) &~ (y))
+#define OP_OR(x, y) ((x) | (y))
+#define OP_XOR(x, y) ((x) ^ (y))
+
+#define DEFINE_UNARY_WR(nl, nu, op) \
+DEFINE_INST (nl) \
+{ \
+ DECODE_SVM1_INST_##nu (target, source); \
+ WREG_SET (target, (op (WREG_REF (source)))); \
+ NEXT_PC; \
+}
+
+DEFINE_UNARY_WR (copy_wr, COPY_WR, UNARY_NOP)
+DEFINE_UNARY_WR (negate_wr, NEGATE_WR, SIGNED_NEGATE)
+DEFINE_UNARY_WR (increment_wr, INCREMENT_WR, WINCR)
+DEFINE_UNARY_WR (decrement_wr, DECREMENT_WR, WDECR)
+DEFINE_UNARY_WR (abs_wr, ABS_WR, WABS)
+DEFINE_UNARY_WR (not, NOT, ~)
+
+DEFINE_UNARY_WR (object_type, OBJECT_TYPE, OBJECT_TYPE)
+DEFINE_UNARY_WR (object_datum, OBJECT_DATUM, OBJECT_DATUM)
+DEFINE_UNARY_WR (object_address, OBJECT_ADDRESS, X_OBJECT_ADDRESS)
+DEFINE_UNARY_WR (fixnum_to_integer, FIXNUM_TO_INTEGER, FIXNUM_TO_LONG)
+DEFINE_UNARY_WR (integer_to_fixnum, INTEGER_TO_FIXNUM, LONG_TO_FIXNUM)
+DEFINE_UNARY_WR (flonum_length, FLONUM_LENGTH, FLOATING_VECTOR_LENGTH)
+
+#define DEFINE_UNARY_FR(nl, nu, op) \
+DEFINE_INST (nl) \
+{ \
+ DECODE_SVM1_INST_##nu (target, source); \
+ FREG_SET (target, (op (FREG_REF (source)))); \
+ NEXT_PC; \
+}
+
+DEFINE_UNARY_FR (copy_fr, COPY_FR, UNARY_NOP)
+DEFINE_UNARY_FR (negate_fr, NEGATE_FR, -)
+DEFINE_UNARY_FR (increment_fr, INCREMENT_FR, FINCR)
+DEFINE_UNARY_FR (decrement_fr, DECREMENT_FR, FDECR)
+DEFINE_UNARY_FR (abs_fr, ABS_FR, fabs)
+DEFINE_UNARY_FR (sqrt, SQRT, sqrt)
+DEFINE_UNARY_FR (round, ROUND, double_round)
+DEFINE_UNARY_FR (ceiling, CEILING, ceil)
+DEFINE_UNARY_FR (floor, FLOOR, floor)
+DEFINE_UNARY_FR (truncate, TRUNCATE, double_truncate)
+DEFINE_UNARY_FR (log, LOG, log)
+DEFINE_UNARY_FR (exp, EXP, exp)
+DEFINE_UNARY_FR (cos, COS, cos)
+DEFINE_UNARY_FR (sin, SIN, sin)
+DEFINE_UNARY_FR (tan, TAN, tan)
+DEFINE_UNARY_FR (acos, ACOS, acos)
+DEFINE_UNARY_FR (asin, ASIN, asin)
+DEFINE_UNARY_FR (atan, ATAN, atan)
+
+#define DEFINE_BINARY_WR(nl, nu, op) \
+DEFINE_INST (nl) \
+{ \
+ DECODE_SVM1_INST_##nu (target, source1, source2); \
+ WREG_SET (target, (op ((WREG_REF (source1)), (WREG_REF (source2))))); \
+ NEXT_PC; \
+}
+
+DEFINE_BINARY_WR (add_wr, ADD_WR, OP_ADD)
+DEFINE_BINARY_WR (subtract_wr, SUBTRACT_WR, OP_SUBTRACT)
+DEFINE_BINARY_WR (multiply_wr, MULTIPLY_WR, OP_MULTIPLY)
+DEFINE_BINARY_WR (quotient, QUOTIENT, OP_DIVIDE)
+DEFINE_BINARY_WR (remainder, REMAINDER, OP_REMAINDER)
+DEFINE_BINARY_WR (and, AND, OP_AND)
+DEFINE_BINARY_WR (andc, ANDC, OP_ANDC)
+DEFINE_BINARY_WR (or, OR, OP_OR)
+DEFINE_BINARY_WR (xor, XOR, OP_XOR)
+
+DEFINE_INST (lsh)
+{
+ DECODE_SVM1_INST_LSH (target, source1, source2);
+ long n = (TO_SIGNED (WREG_REF (source2)));
+ WREG_SET (target,
+ ((n < 0)
+ ? ((WREG_REF (source1)) >> (- n))
+ : ((WREG_REF (source1)) << n)));
+ NEXT_PC;
+}
+
+DEFINE_INST (max_unsigned)
+{
+ DECODE_SVM1_INST_MAX_UNSIGNED (target, source1, source2);
+ word_t n1 = (WREG_REF (source1));
+ word_t n2 = (WREG_REF (source2));
+ WREG_SET (target, ((n1 > n2) ? n1 : n2));
+ NEXT_PC;
+}
+
+DEFINE_INST (min_unsigned)
+{
+ DECODE_SVM1_INST_MIN_UNSIGNED (target, source1, source2);
+ word_t n1 = (WREG_REF (source1));
+ word_t n2 = (WREG_REF (source2));
+ WREG_SET (target, ((n1 < n2) ? n1 : n2));
+ NEXT_PC;
+}
+
+#define DEFINE_BINARY_FR(nl, nu, op) \
+DEFINE_INST (nl) \
+{ \
+ DECODE_SVM1_INST_##nu (target, source1, source2); \
+ FREG_SET (target, (op ((FREG_REF (source1)), (FREG_REF (source2))))); \
+ NEXT_PC; \
+}
+
+DEFINE_BINARY_FR (add_fr, ADD_FR, OP_ADD)
+DEFINE_BINARY_FR (subtract_fr, SUBTRACT_FR, OP_SUBTRACT)
+DEFINE_BINARY_FR (multiply_fr, MULTIPLY_FR, OP_MULTIPLY)
+DEFINE_BINARY_FR (divide, DIVIDE, OP_DIVIDE)
+DEFINE_BINARY_FR (atan2, ATAN2, atan2)
+\f
+/* Address decoders */
+
+static void
+decode_address (address_t * address)
+{
+ (* (address_decoders[NEXT_BYTE])) (address);
+}
+
+static void
+illegal_address (address_t * address)
+{
+ signal_illegal_instruction ();
+}
+
+static word_t
+offset_address_value (address_t * address)
+{
+ return ((WREG_REF (address->r1)) + (address->n1));
+}
+
+DEFINE_ADDRESS_DECODER (indir)
+{
+ DECODE_SVM1_ADDR_INDIR (base);
+ (address->r1) = base;
+ (address->n1) = 0;
+ (address->value) = offset_address_value;
+}
+
+#define MAKE_OFFSET_ADDRESS(base, offset, scale) \
+{ \
+ (address->r1) = (base); \
+ (address->n1) = ((offset) * (scale)); \
+ (address->value) = offset_address_value; \
+}
+
+DEFINE_ADDRESS_DECODER (offset_b)
+{
+ DECODE_SVM1_ADDR_OFFSET_B (base, offset);
+ MAKE_OFFSET_ADDRESS (base, offset, SBYTE);
+}
+
+DEFINE_ADDRESS_DECODER (offset_w)
+{
+ DECODE_SVM1_ADDR_OFFSET_W (base, offset);
+ MAKE_OFFSET_ADDRESS (base, offset, SWORD);
+}
+
+DEFINE_ADDRESS_DECODER (offset_f)
+{
+ DECODE_SVM1_ADDR_OFFSET_F (base, offset);
+ MAKE_OFFSET_ADDRESS (base, offset, SFLOAT);
+}
+
+static word_t
+indexed_address_value (address_t * address)
+{
+ return
+ ((WREG_REF (address->r1))
+ + (address->n1)
+ + ((WREG_REF (address->r2)) * (address->n2)));
+}
+
+#define MAKE_INDEXED_ADDRESS(base, offset, oscale, index, iscale) \
+{ \
+ (address->r1) = (base); \
+ (address->n1) = ((offset) * (oscale)); \
+ (address->r2) = (index); \
+ (address->n2) = (iscale); \
+ (address->value) = indexed_address_value; \
+}
+
+DEFINE_ADDRESS_DECODER (index_b_b)
+{
+ DECODE_SVM1_ADDR_INDEX_B_B (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SBYTE, index, SBYTE);
+}
+
+DEFINE_ADDRESS_DECODER (index_b_w)
+{
+ DECODE_SVM1_ADDR_INDEX_B_W (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SBYTE, index, SWORD);
+}
+
+DEFINE_ADDRESS_DECODER (index_b_f)
+{
+ DECODE_SVM1_ADDR_INDEX_B_F (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SBYTE, index, SFLOAT);
+}
+
+DEFINE_ADDRESS_DECODER (index_w_b)
+{
+ DECODE_SVM1_ADDR_INDEX_W_B (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SWORD, index, SBYTE);
+}
+
+DEFINE_ADDRESS_DECODER (index_w_w)
+{
+ DECODE_SVM1_ADDR_INDEX_W_W (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SWORD, index, SWORD);
+}
+
+DEFINE_ADDRESS_DECODER (index_w_f)
+{
+ DECODE_SVM1_ADDR_INDEX_W_F (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SWORD, index, SFLOAT);
+}
+
+DEFINE_ADDRESS_DECODER (index_f_b)
+{
+ DECODE_SVM1_ADDR_INDEX_F_B (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SFLOAT, index, SBYTE);
+}
+
+DEFINE_ADDRESS_DECODER (index_f_w)
+{
+ DECODE_SVM1_ADDR_INDEX_F_W (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SFLOAT, index, SWORD);
+}
+
+DEFINE_ADDRESS_DECODER (index_f_f)
+{
+ DECODE_SVM1_ADDR_INDEX_F_F (base, offset, index);
+ MAKE_INDEXED_ADDRESS (base, offset, SFLOAT, index, SFLOAT);
+}
+
+static word_t
+preinc_address_value (address_t * address)
+{
+ WREG_SET ((address->r1), ((WREG_REF (address->r1)) + (address->n2)));
+ return (WREG_REF (address->r1));
+}
+
+#define MAKE_PREINC_ADDRESS(base, scale) \
+{ \
+ (address->r1) = (base); \
+ (address->n2) = (scale); \
+ (address->value) = preinc_address_value; \
+}
+
+DEFINE_ADDRESS_DECODER (predec_b)
+{
+ DECODE_SVM1_ADDR_PREDEC_B (base);
+ MAKE_PREINC_ADDRESS (base, (- SBYTE));
+}
+
+DEFINE_ADDRESS_DECODER (predec_w)
+{
+ DECODE_SVM1_ADDR_PREDEC_W (base);
+ MAKE_PREINC_ADDRESS (base, (- SWORD));
+}
+
+DEFINE_ADDRESS_DECODER (predec_f)
+{
+ DECODE_SVM1_ADDR_PREDEC_F (base);
+ MAKE_PREINC_ADDRESS (base, (- SFLOAT));
+}
+
+DEFINE_ADDRESS_DECODER (preinc_b)
+{
+ DECODE_SVM1_ADDR_PREINC_B (base);
+ MAKE_PREINC_ADDRESS (base, SBYTE);
+}
+
+DEFINE_ADDRESS_DECODER (preinc_w)
+{
+ DECODE_SVM1_ADDR_PREINC_W (base);
+ MAKE_PREINC_ADDRESS (base, SWORD);
+}
+
+DEFINE_ADDRESS_DECODER (preinc_f)
+{
+ DECODE_SVM1_ADDR_PREINC_F (base);
+ MAKE_PREINC_ADDRESS (base, SFLOAT);
+}
+
+static word_t
+postinc_address_value (address_t * address)
+{
+ word_t value = (WREG_REF (address->r1));
+ WREG_SET ((address->r1), ((WREG_REF (address->r1)) + (address->n2)));
+ return (value);
+}
+
+#define MAKE_POSTINC_ADDRESS(base, scale) \
+{ \
+ (address->r1) = (base); \
+ (address->n2) = (scale); \
+ (address->value) = postinc_address_value; \
+}
+
+DEFINE_ADDRESS_DECODER (postdec_b)
+{
+ DECODE_SVM1_ADDR_POSTDEC_B (base);
+ MAKE_POSTINC_ADDRESS (base, (- SBYTE));
+}
+
+DEFINE_ADDRESS_DECODER (postdec_w)
+{
+ DECODE_SVM1_ADDR_POSTDEC_W (base);
+ MAKE_POSTINC_ADDRESS (base, (- SWORD));
+}
+
+DEFINE_ADDRESS_DECODER (postdec_f)
+{
+ DECODE_SVM1_ADDR_POSTDEC_F (base);
+ MAKE_POSTINC_ADDRESS (base, (- SFLOAT));
+}
+
+DEFINE_ADDRESS_DECODER (postinc_b)
+{
+ DECODE_SVM1_ADDR_POSTINC_B (base);
+ MAKE_POSTINC_ADDRESS (base, SBYTE);
+}
+
+DEFINE_ADDRESS_DECODER (postinc_w)
+{
+ DECODE_SVM1_ADDR_POSTINC_W (base);
+ MAKE_POSTINC_ADDRESS (base, SWORD);
+}
+
+DEFINE_ADDRESS_DECODER (postinc_f)
+{
+ DECODE_SVM1_ADDR_POSTINC_F (base);
+ MAKE_POSTINC_ADDRESS (base, SFLOAT);
+}
+
+static word_t
+pcr_value (address_t * address)
+{
+ return (((word_t) PC) + (address->n2));
+}
+
+#define MAKE_PCR_ADDRESS(offset) \
+{ \
+ (address->n2) = (offset); \
+ (address->value) = pcr_value; \
+}
+
+DEFINE_ADDRESS_DECODER (pcr_s8)
+{
+ DECODE_SVM1_ADDR_PCR_S8 (offset);
+ MAKE_PCR_ADDRESS (offset);
+}
+
+DEFINE_ADDRESS_DECODER (pcr_s16)
+{
+ DECODE_SVM1_ADDR_PCR_S16 (offset);
+ MAKE_PCR_ADDRESS (offset);
+}
+
+DEFINE_ADDRESS_DECODER (pcr_s32)
+{
+ DECODE_SVM1_ADDR_PCR_S32 (offset);
+ MAKE_PCR_ADDRESS (offset);
+}
+\f
+#define INITIALIZE_DECODER_TABLE(table, initial_value) do \
+{ \
+ unsigned int i; \
+ for (i = 0; (i < 256); i += 1) \
+ (table[i]) = initial_value; \
+} while (false)
+
+static void
+initialize_decoder_tables (void)
+{
+ INITIALIZE_DECODER_TABLE (address_decoders, illegal_address);
+#define BIND_ADDR(code, name) (address_decoders[code]) = decode_addr_##name
+ SVM1_ADDR_BINDINGS (BIND_ADDR);
+
+ INITIALIZE_DECODER_TABLE (inst_defns, illegal_instruction);
+#define BIND_INST(code, name) (inst_defns[code]) = insn_##name
+ SVM1_INST_BINDINGS (BIND_INST);
+
+ INITIALIZE_DECODER_TABLE (traps_0, illegal_trap_0);
+#define BIND_TRAP_0(code, name) (traps_0[code]) = trap_##name
+ SVM1_TRAP_0_BINDINGS (BIND_TRAP_0);
+
+ INITIALIZE_DECODER_TABLE (traps_1, illegal_trap_1);
+#define BIND_TRAP_1(code, name) (traps_1[code]) = trap_##name
+ SVM1_TRAP_1_BINDINGS (BIND_TRAP_1);
+
+ INITIALIZE_DECODER_TABLE (traps_2, illegal_trap_2);
+#define BIND_TRAP_2(code, name) (traps_2[code]) = trap_##name
+ SVM1_TRAP_2_BINDINGS (BIND_TRAP_2);
+
+ INITIALIZE_DECODER_TABLE (traps_3, illegal_trap_3);
+#define BIND_TRAP_3(code, name) (traps_3[code]) = trap_##name
+ SVM1_TRAP_3_BINDINGS (BIND_TRAP_3);
+}
/* -*-C-*-
-$Id: syntax.c,v 1.38 2007/04/01 17:33:07 riastradh Exp $
+$Id: syntax.c,v 1.39 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Primitives to support Edwin syntax tables, word and list parsing. */
/* NOTE: This program was created by translation from the syntax table
-code of GNU Emacs; it was translated from the original C to 68000
-assembly language (in 1986), and then translated back from 68000
-assembly language to C (in 1987). Users should be aware that the GNU
-GENERAL PUBLIC LICENSE may apply to this code. A copy of that license
-should have been included along with this file. */
+ code of GNU Emacs; it was translated from the original C to 68000
+ assembly language (in 1986), and then translated back from 68000
+ assembly language to C (in 1987). */
#include "scheme.h"
#include "prims.h"
/* Parser Initialization */
#define NORMAL_INITIALIZATION_COMMON(arity) \
- fast SCHEME_OBJECT syntax_table; \
- fast SCHEME_OBJECT group; \
- fast unsigned char * start; \
+ SCHEME_OBJECT syntax_table; \
+ SCHEME_OBJECT group; \
+ unsigned char * start; \
unsigned char * first_char, * end; \
long gap_length; \
PRIMITIVE_HEADER (arity); \
syntax_table = (ARG_REF (1)); \
CHECK_ARG (2, GROUP_P); \
group = (ARG_REF (2)); \
- first_char = (GROUP_TEXT_LOC (group, 0)); \
+ first_char = (GROUP_TEXT (group, 0)); \
start = (first_char + (arg_nonnegative_integer (3))); \
end = (first_char + (arg_nonnegative_integer (4))); \
gap_start = (first_char + (GROUP_GAP_START (group))); \
#define NORMAL_INITIALIZATION_FORWARD(arity) \
unsigned char * gap_start; \
- fast unsigned char * gap_end; \
+ unsigned char * gap_end; \
NORMAL_INITIALIZATION_COMMON (arity); \
if (start >= gap_start) \
start += gap_length; \
end += gap_length
#define NORMAL_INITIALIZATION_BACKWARD(arity) \
- fast unsigned char * gap_start; \
+ unsigned char * gap_start; \
unsigned char * gap_end; \
NORMAL_INITIALIZATION_COMMON (arity); \
if (start > gap_start) \
#define SCAN_LIST_INITIALIZATION(initialization) \
long depth, min_depth; \
- Boolean sexp_flag, ignore_comments, math_exit; \
+ bool sexp_flag, ignore_comments, math_exit; \
int c; \
initialization (7); \
depth = (arg_integer (5)); \
DEFINE_PRIMITIVE ("QUOTED-CHAR?", Prim_quoted_char_p, 4, 4, 0)
{
- Boolean quoted;
+ bool quoted;
NORMAL_INITIALIZATION_BACKWARD (4);
RIGHT_QUOTED_P (start, quoted);
DEFINE_PRIMITIVE ("SCAN-BACKWARD-PREFIX-CHARS", Prim_scan_backward_prefix_chars, 4, 4, 0)
{
- Boolean quoted;
+ bool quoted;
NORMAL_INITIALIZATION_BACKWARD (4);
while (true)
DEFINE_PRIMITIVE ("SCAN-FORWARD-PREFIX-CHARS", Prim_scan_forward_prefix_chars, 4, 4, 0)
{
- Boolean quoted;
+ bool quoted;
NORMAL_INITIALIZATION_FORWARD (4);
while (true)
\f
DEFINE_PRIMITIVE ("SCAN-LIST-BACKWARD", Prim_scan_list_backward, 7, 7, 0)
{
- Boolean quoted;
+ bool quoted;
SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_BACKWARD);
while (true)
DEFINE_PRIMITIVE ("SCAN-SEXPS-FORWARD", Prim_scan_sexps_forward, 7, 7, 0)
{
long target_depth;
- Boolean stop_before;
+ bool stop_before;
SCHEME_OBJECT state_argument;
long depth = 0;
long in_string = -1; /* -1 or delimiter character */
unsigned int in_comment = 0;
unsigned int comment_style = COMMENT_STYLE_A;
unsigned char * comment_start = 0;
- Boolean quoted = false;
+ bool quoted = false;
struct levelstruct level_start[LEVEL_ARRAY_LENGTH];
struct levelstruct *level;
struct levelstruct *level_end;
error_bad_range_arg (7);
quoted = ((VECTOR_REF (state_argument, SSF_STATE_QUOTED_P)) != SHARP_F);
-
+
if (in_comment != 0)
{
temp = (VECTOR_REF (state_argument, SSF_STATE_COMMENT_START));
done:
result = (allocate_marked_vector (TC_VECTOR, SSF_STATE_LENGTH, true));
- FAST_VECTOR_SET (result, SSF_STATE_DEPTH, (LONG_TO_FIXNUM (depth)));
- FAST_VECTOR_SET
+ VECTOR_SET (result, SSF_STATE_DEPTH, (LONG_TO_FIXNUM (depth)));
+ VECTOR_SET
(result, SSF_STATE_IN_STRING_P,
((in_string == -1)
? SHARP_F
: (LONG_TO_UNSIGNED_FIXNUM (in_string))));
- FAST_VECTOR_SET
+ VECTOR_SET
(result, SSF_STATE_COMMENT_STATE,
((in_comment == 0)
? SHARP_F
: (comment_style == COMMENT_STYLE_A)
? in_comment
: (in_comment + 4)))));
- FAST_VECTOR_SET (result, SSF_STATE_QUOTED_P, (BOOLEAN_TO_OBJECT (quoted)));
- FAST_VECTOR_SET
+ VECTOR_SET (result, SSF_STATE_QUOTED_P, (BOOLEAN_TO_OBJECT (quoted)));
+ VECTOR_SET
(result, SSF_STATE_START_OF_SEXP,
(((level -> last) == NULL)
? SHARP_F
: (LONG_TO_UNSIGNED_FIXNUM ((SCAN_TO_INDEX (level -> last)) - 1))));
- FAST_VECTOR_SET
+ VECTOR_SET
(result, SSF_STATE_LAST_SEXP,
(((level -> previous) == NULL)
? SHARP_F
: (LONG_TO_UNSIGNED_FIXNUM ((SCAN_TO_INDEX (level -> previous)) - 1))));
- FAST_VECTOR_SET
+ VECTOR_SET
(result, SSF_STATE_CONTAINING_SEXP,
(((level == level_start) || (((level - 1) -> last) == NULL))
? SHARP_F
: (LONG_TO_UNSIGNED_FIXNUM
((SCAN_TO_INDEX ((level - 1) -> last)) - 1))));
- FAST_VECTOR_SET
+ VECTOR_SET
(result, SSF_STATE_LOCATION,
(LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start))));
- FAST_VECTOR_SET
+ VECTOR_SET
(result, SSF_STATE_COMMENT_START,
((in_comment == 0)
? SHARP_F
/* -*-C-*-
-$Id: syntax.h,v 1.16 2007/01/05 21:19:25 cph Exp $
+$Id: syntax.h,v 1.17 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Definitions for Edwin syntax tables. */
/* NOTE: This program was created by translation from the syntax table
-code of GNU Emacs; it was translated from the original C to 68000
-assembly language (in 1986), and then translated back from 68000
-assembly language to C (in 1987). */
+ code of GNU Emacs; it was translated from the original C to 68000
+ assembly language (in 1986), and then translated back from 68000
+ assembly language to C (in 1987). */
\f
/* CODE is the syntax code for the character. */
#define SYNTAX_ENTRY_CODE(entry) ((enum syntaxcode) ((entry) & 0xF))
/* -*-C-*-
-$Id: syscall.h,v 1.20 2007/01/05 21:19:25 cph Exp $
+$Id: syscall.h,v 1.21 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "config.h"
\f
#ifdef __OS2__
-
-#define DEFINE_OS2_SYSCALLS
-#include "os2api.h"
-#undef DEFINE_OS2_SYSCALLS
-
-#else /* not __OS2__ */
-#ifdef __WIN32__
-
-#define DEFINE_WIN32_SYSCALLS
-#include "ntapi.h"
-#undef DEFINE_WIN32_SYSCALLS
-
-#else /* not __WIN32__ */
+# define DEFINE_OS2_SYSCALLS
+# include "os2api.h"
+# undef DEFINE_OS2_SYSCALLS
+#else
+# ifdef __WIN32__
+# define DEFINE_WIN32_SYSCALLS
+# include "ntapi.h"
+# undef DEFINE_WIN32_SYSCALLS
+# else
/* Unix case, inline for historical reasons. Must match "uxtop.c". */
syserr_too_many_open_files_in_system
};
-#endif /* not __WIN32__ */
+# endif /* not __WIN32__ */
#endif /* not __OS2__ */
-extern void EXFUN (error_in_system_call,
- (enum syserr_names, enum syscall_names));
-extern void EXFUN (error_system_call, (int, enum syscall_names name));
-extern enum syserr_names EXFUN (OS_error_code_to_syserr, (int));
+extern void error_in_system_call (enum syserr_names, enum syscall_names)
+ NORETURN;
+extern void error_system_call (int, enum syscall_names) NORETURN;
+extern enum syserr_names OS_error_code_to_syserr (int);
#endif /* SCM_SYSCALL_H */
/* -*-C-*-
-$Id: sysprim.c,v 9.54 2007/01/12 03:45:55 cph Exp $
+$Id: sysprim.c,v 9.55 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "ostty.h"
#include "ostop.h"
-extern long EXFUN (OS_set_trap_state, (long));
-extern double EXFUN (arg_flonum, (int));
+extern long OS_set_trap_state (long);
+extern double arg_flonum (int);
\f
/* Pretty random primitives */
PRIMITIVE_RETURN (UNSPECIFIC);
}
-DEFINE_PRIMITIVE ("EXIT-WITH-VALUE",
+DEFINE_PRIMITIVE ("EXIT-WITH-VALUE",
Prim_non_restartable_exit_with_value, 1, 1,
"Exit Scheme with no option to restart, returning integer argument\n\
as exit status.")
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
}
-DEFINE_PRIMITIVE ("HEAP-AVAILABLE?", Prim_heap_available_p, 1, 1,
+DEFINE_PRIMITIVE ("HEAP-AVAILABLE?", Prim_heap_available_p, 1, 1,
"(N-WORDS)\n\
Tests to see if there are at least N-WORDS words of heap storage available")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT ((Free + (arg_nonnegative_integer (1))) < MemTop));
+ (BOOLEAN_TO_OBJECT (HEAP_AVAILABLE_P (arg_ulong_integer (1))));
}
DEFINE_PRIMITIVE ("PRIMITIVE-GET-FREE", Prim_get_free, 1, 1,
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
- (MAKE_POINTER_OBJECT ((arg_index_integer (1, (MAX_TYPE_CODE + 1))), Free));
+ (MAKE_POINTER_OBJECT ((arg_ulong_index_integer (1, N_TYPE_CODES)), Free));
}
DEFINE_PRIMITIVE ("PRIMITIVE-INCREMENT-FREE", Prim_increment_free, 1, 1,
"(N-WORDS)\n\
-Advance the free pointer by N-WORDS words")
+Advance the free pointer by N-WORDS words.")
{
PRIMITIVE_HEADER (1);
- Free += (arg_nonnegative_integer (1));
+ Free += (arg_ulong_integer (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
#define CONVERT_ADDRESS(address) \
- (long_to_integer (ADDRESS_TO_DATUM (address)))
+ (ulong_to_integer (ADDRESS_TO_DATUM (address)))
DEFINE_PRIMITIVE ("GC-SPACE-STATUS", Prim_gc_space_status, 0, 0, 0)
{
- SCHEME_OBJECT * constant_low;
- SCHEME_OBJECT * constant_free;
- SCHEME_OBJECT * constant_high;
- SCHEME_OBJECT * heap_low;
- SCHEME_OBJECT * heap_free;
- SCHEME_OBJECT * heap_limit;
- SCHEME_OBJECT * heap_high;
-#ifndef USE_STACKLETS
- SCHEME_OBJECT * stack_low;
- SCHEME_OBJECT * stack_free;
- SCHEME_OBJECT * stack_limit;
- SCHEME_OBJECT * stack_high;
-#endif /* USE_STACKLETS */
- SCHEME_OBJECT result;
PRIMITIVE_HEADER (0);
-
- constant_low = Constant_Space;
- constant_free = Free_Constant;
- constant_high = Constant_Top;
- heap_low = Heap_Bottom;
- heap_free = Free;
- heap_limit = MemTop;
- heap_high = Heap_Top;
-#ifndef USE_STACKLETS
- stack_low = Stack_Bottom;
- stack_free = sp_register;
- stack_limit = Stack_Guard;
- stack_high = Stack_Top;
-#endif /* USE_STACKLETS */
-
- result = (make_vector (12, SHARP_F, true));
- VECTOR_SET (result, 0, (LONG_TO_UNSIGNED_FIXNUM (sizeof (SCHEME_OBJECT))));
- VECTOR_SET (result, 1, (CONVERT_ADDRESS (constant_low)));
- VECTOR_SET (result, 2, (CONVERT_ADDRESS (constant_free)));
- VECTOR_SET (result, 3, (CONVERT_ADDRESS (constant_high)));
- VECTOR_SET (result, 4, (CONVERT_ADDRESS (heap_low)));
- VECTOR_SET (result, 5, (CONVERT_ADDRESS (heap_free)));
- VECTOR_SET (result, 6, (CONVERT_ADDRESS (heap_limit)));
- VECTOR_SET (result, 7, (CONVERT_ADDRESS (heap_high)));
-#ifndef USE_STACKLETS
- VECTOR_SET (result, 8, (CONVERT_ADDRESS (stack_low)));
- VECTOR_SET (result, 9, (CONVERT_ADDRESS (stack_free)));
- VECTOR_SET (result, 10, (CONVERT_ADDRESS (stack_limit)));
- VECTOR_SET (result, 11, (CONVERT_ADDRESS (stack_high)));
-#endif /* USE_STACKLETS */
- PRIMITIVE_RETURN (result);
+ {
+ SCHEME_OBJECT v = (make_vector (12, SHARP_F, true));
+ VECTOR_SET (v, 0, (ULONG_TO_FIXNUM (sizeof (SCHEME_OBJECT))));
+ VECTOR_SET (v, 1, (CONVERT_ADDRESS (constant_start)));
+ VECTOR_SET (v, 2, (CONVERT_ADDRESS (constant_alloc_next)));
+ VECTOR_SET (v, 3, (CONVERT_ADDRESS (constant_end)));
+ VECTOR_SET (v, 4, (CONVERT_ADDRESS (heap_start)));
+ VECTOR_SET (v, 5, (CONVERT_ADDRESS (Free)));
+ VECTOR_SET (v, 6, (CONVERT_ADDRESS (heap_alloc_limit)));
+ VECTOR_SET (v, 7, (CONVERT_ADDRESS (heap_end)));
+ VECTOR_SET (v, 8, (CONVERT_ADDRESS (stack_start)));
+ VECTOR_SET (v, 9, (CONVERT_ADDRESS (stack_pointer)));
+ VECTOR_SET (v, 10, (CONVERT_ADDRESS (stack_guard)));
+ VECTOR_SET (v, 11, (CONVERT_ADDRESS (stack_end)));
+ PRIMITIVE_RETURN (v);
+ }
}
DEFINE_PRIMITIVE ("SCHEME-PROGRAM-NAME", Prim_scheme_program_name, 0, 0, 0)
/* -*-C-*-
-$Id: term.c,v 1.23 2007/04/01 17:33:07 riastradh Exp $
+$Id: term.c,v 1.24 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "osfile.h"
#include "edwin.h"
#include "option.h"
-#include "prims.h"
extern long death_blow;
-extern char * Term_Messages [];
-extern void EXFUN (get_band_parameters, (long * heap_size, long * const_size));
-extern void EXFUN (Reset_Memory, (void));
+extern void get_band_parameters (unsigned long *, unsigned long *);
#ifdef __WIN32__
# define USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
- extern void win32_deallocate_registers (void);
#endif
#ifdef __OS2__
# define USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
#endif
-static void EXFUN (edwin_auto_save, (void));
-static void EXFUN (delete_temp_files, (void));
+static void edwin_auto_save (void);
+static void delete_temp_files (void);
#define BYTES_TO_BLOCKS(n) (((n) + 1023) / 1024)
#define MIN_HEAP_DELTA 50
#endif
void
-DEFUN_VOID (init_exit_scheme)
+init_exit_scheme (void)
{
#ifdef INIT_EXIT_SCHEME
INIT_EXIT_SCHEME ();
}
\f
static void
-DEFUN (attempt_termination_backout, (code), int code)
+attempt_termination_backout (int code)
{
outf_flush_error(); /* NOT flush_fatal */
if ((WITHIN_CRITICAL_SECTION_P ())
|| (code == TERM_HALT)
- || (! (Valid_Fixed_Obj_Vector ())))
+ || (! (VECTOR_P (fixed_objects))))
return;
{
- SCHEME_OBJECT Term_Vector = (Get_Fixed_Obj_Slot (Termination_Proc_Vector));
+ SCHEME_OBJECT Term_Vector
+ = (VECTOR_REF (fixed_objects, Termination_Proc_Vector));
if ((! (VECTOR_P (Term_Vector)))
|| (((long) (VECTOR_LENGTH (Term_Vector))) <= code))
return;
Will_Push (CONTINUATION_SIZE
+ STACK_ENV_EXTRA_SLOTS
+ ((code == TERM_NO_ERROR_HANDLER) ? 5 : 4));
- Store_Return (RC_HALT);
- exp_register = (LONG_TO_UNSIGNED_FIXNUM (code));
- Save_Cont ();
+ SET_RC (RC_HALT);
+ SET_EXP (LONG_TO_UNSIGNED_FIXNUM (code));
+ SAVE_CONT ();
if (code == TERM_NO_ERROR_HANDLER)
STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (death_blow));
- STACK_PUSH (val_register); /* Arg 3 */
- STACK_PUSH (env_register); /* Arg 2 */
- STACK_PUSH (exp_register); /* Arg 1 */
+ PUSH_VAL (); /* Arg 3 */
+ PUSH_ENV (); /* Arg 2 */
+ PUSH_EXP (); /* Arg 1 */
STACK_PUSH (Handler); /* The handler function */
- STACK_PUSH (STACK_FRAME_HEADER
- + ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3));
+ PUSH_APPLY_FRAME_HEADER ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3);
Pushed ();
abort_to_interpreter (PRIM_NO_TRAP_APPLY);
}
}
\f
static void
-DEFUN (termination_prefix, (code), int code)
+termination_prefix (int code)
{
attempt_termination_backout (code);
OS_restore_external_state ();
{
if (!option_batch_mode)
{
- outf_console ("\n%s.\n", (Term_Messages [code]));
+ outf_console ("\n%s.\n", (term_messages[code]));
outf_flush_console ();
}
}
outf_fatal ("Reason for termination:");
#endif
outf_fatal ("\n");
- if ((code < 0) || (code > MAX_TERMINATION))
- outf_fatal ("Unknown termination code 0x%x", code);
- else
- outf_fatal ("%s", (Term_Messages [code]));
+ {
+ const char * msg = 0;
+ if ((code >= 0) && (code <= MAX_TERMINATION))
+ msg = (term_messages[code]);
+ if (msg == 0)
+ outf_fatal ("Unknown termination code %#x", code);
+ else
+ outf_fatal ("%s", msg);
+ }
if (WITHIN_CRITICAL_SECTION_P ())
outf_fatal (" within critical section \"%s\"",
(CRITICAL_SECTION_NAME ()));
}
}
+static void termination_suffix (int, int, bool) NORETURN;
+static void termination_suffix_trace (int) NORETURN;
+
static void
-DEFUN (termination_suffix, (code, value, abnormal_p),
- int code AND int value AND int abnormal_p)
+termination_suffix (int code, int value, bool abnormal_p)
{
#ifdef EXIT_HOOK
EXIT_HOOK (code, value, abnormal_p);
if (code != TERM_HALT)
#endif
outf_flush_fatal();
-#ifdef __WIN32__
- win32_deallocate_registers();
-#endif
- Reset_Memory ();
+ reset_memory ();
EXIT_SCHEME (value);
}
static void
-DEFUN (termination_suffix_trace, (code), int code)
+termination_suffix_trace (int code)
{
if (Trace_On_Error)
{
outf_error ("\n\n**** Stack trace ****\n\n");
- Back_Trace (error_output);
+ Back_Trace (ERROR_OUTPUT);
}
- termination_suffix (code, 1, 1);
+ termination_suffix (code, 1, true);
}
void
-DEFUN (Microcode_Termination, (code), int code)
+Microcode_Termination (int code)
{
termination_prefix (code);
termination_suffix_trace (code);
}
\f
void
-DEFUN (termination_normal, (value), CONST int value)
+termination_normal (const int value)
{
termination_prefix (TERM_HALT);
- termination_suffix (TERM_HALT, value, 0);
+ termination_suffix (TERM_HALT, value, false);
}
void
-DEFUN_VOID (termination_init_error)
+termination_init_error (void)
{
termination_prefix (TERM_EXIT);
- termination_suffix (TERM_EXIT, 1, 1);
+ termination_suffix (TERM_EXIT, 1, true);
}
void
-DEFUN_VOID (termination_end_of_computation)
+termination_end_of_computation (void)
{
termination_prefix (TERM_END_OF_COMPUTATION);
- Print_Expression (val_register, "Final result");
+ Print_Expression (GET_VAL, "Final result");
outf_console("\n");
- termination_suffix (TERM_END_OF_COMPUTATION, 0, 0);
+ termination_suffix (TERM_END_OF_COMPUTATION, 0, false);
}
void
-DEFUN_VOID (termination_trap)
+termination_trap (void)
{
/* This claims not to be abnormal so that the user will
not be asked a second time about dumping core. */
termination_prefix (TERM_TRAP);
- termination_suffix (TERM_TRAP, 1, 0);
+ termination_suffix (TERM_TRAP, 1, false);
}
\f
void
-DEFUN_VOID (termination_no_error_handler)
+termination_no_error_handler (void)
{
/* This does not print a back trace because the caller printed one. */
termination_prefix (TERM_NO_ERROR_HANDLER);
if (death_blow == ERR_FASL_FILE_TOO_BIG)
{
- long heap_size;
- long const_size;
- get_band_parameters (&heap_size, &const_size);
+ unsigned long heap_size;
+ unsigned long const_size;
+ get_band_parameters ((&heap_size), (&const_size));
outf_fatal ("Try again with values at least as large as\n");
- outf_fatal (" -heap %d (%d + %d)\n",
- (MIN_HEAP_DELTA + (BYTES_TO_BLOCKS (heap_size))),
- (BYTES_TO_BLOCKS (heap_size)),
- MIN_HEAP_DELTA);
- outf_fatal (" -constant %d\n", (BYTES_TO_BLOCKS (const_size)));
+ outf_fatal (" --heap %lu\n",
+ (MIN_HEAP_DELTA + (BYTES_TO_BLOCKS (heap_size))));
+ outf_fatal (" --constant %lu\n", (BYTES_TO_BLOCKS (const_size)));
}
- termination_suffix (TERM_NO_ERROR_HANDLER, 1, 1);
+ termination_suffix (TERM_NO_ERROR_HANDLER, 1, true);
}
void
-DEFUN_VOID (termination_gc_out_of_space)
+termination_gc_out_of_space (void)
{
termination_prefix (TERM_GC_OUT_OF_SPACE);
- outf_fatal ("You are out of space at the end of a Garbage Collection!\n");
- outf_fatal ("Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n",
- Free, MemTop, Heap_Top);
- outf_fatal ("Words required = %ld; Words available = %ld\n",
- (MemTop - Free), GC_Space_Needed);
+ outf_fatal ("You are out of space at the end of a garbage collection!\n");
+ outf_fatal
+ ("Free = %#lx; heap_alloc_limit = %#lx; heap_end = %#lx\n",
+ ((unsigned long) Free),
+ ((unsigned long) heap_alloc_limit),
+ ((unsigned long) heap_end));
+ outf_fatal ("# words needed = %lu; # words available = %lu\n",
+ gc_space_needed, HEAP_AVAILABLE);
termination_suffix_trace (TERM_GC_OUT_OF_SPACE);
}
void
-DEFUN_VOID (termination_eof)
+termination_eof (void)
{
Microcode_Termination (TERM_EOF);
}
void
-DEFUN (termination_signal, (signal_name), CONST char * signal_name)
+termination_signal (const char * signal_name)
{
if (signal_name != 0)
{
}
\f
static void
-DEFUN_VOID (edwin_auto_save)
+edwin_auto_save (void)
{
static SCHEME_OBJECT position;
static struct interpreter_state_s new_state;
position =
- ((Valid_Fixed_Obj_Vector ())
- ? (Get_Fixed_Obj_Slot (FIXOBJ_EDWIN_AUTO_SAVE))
+ ((VECTOR_P (fixed_objects))
+ ? (VECTOR_REF (fixed_objects, FIXOBJ_EDWIN_AUTO_SAVE))
: EMPTY_LIST);
while (PAIR_P (position))
{
&& ((GROUP_MODIFIED_P (PAIR_CAR (entry))) == SHARP_T))
{
SCHEME_OBJECT group = (PAIR_CAR (entry));
- char * namestring = ((char *) (STRING_LOC ((PAIR_CDR (entry)), 0)));
- SCHEME_OBJECT text = (GROUP_TEXT (group));
+ char * namestring = (STRING_POINTER (PAIR_CDR (entry)));
unsigned long length;
- unsigned char * start = (lookup_external_string (text, (&length)));
+ unsigned char * start = (GROUP_TEXT (group, (&length)));
unsigned char * end = (start + length);
unsigned char * gap_start = (start + (GROUP_GAP_START (group)));
unsigned char * gap_end = (start + (GROUP_GAP_END (group)));
}
static void
-DEFUN_VOID (delete_temp_files)
+delete_temp_files (void)
{
static SCHEME_OBJECT position;
static struct interpreter_state_s new_state;
position =
- ((Valid_Fixed_Obj_Vector ())
- ? (Get_Fixed_Obj_Slot (FIXOBJ_FILES_TO_DELETE))
+ ((VECTOR_P (fixed_objects))
+ ? (VECTOR_REF (fixed_objects, FIXOBJ_FILES_TO_DELETE))
: EMPTY_LIST);
while (PAIR_P (position))
{
{
bind_interpreter_state (&new_state);
if ((setjmp (interpreter_catch_env)) == 0)
- OS_file_remove ((char *) (STRING_LOC (entry, 0)));
+ OS_file_remove (STRING_POINTER (entry));
unbind_interpreter_state (&new_state);
}
}
/* Work-alike for termcap, plus extra features.
Copyright (C) 1985, 1986 Free Software Foundation, Inc.
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
+
NO WARRANTY
BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELY
#ifndef emacs
-#ifndef PTR
-# ifdef __STDC__
-# define PTR void *
-# else
-# define PTR char *
-# endif
-#endif
-
#ifndef NULL
# define NULL 0
#endif
exit (1);
}
-static PTR
+static void *
xmalloc (size)
int size;
{
- register PTR tem = malloc (size);
- if (tem == ((PTR) NULL))
+ void * tem = malloc (size);
+ if (tem == ((void *) NULL))
memory_out ();
return tem;
}
-static PTR
+static void *
xrealloc (ptr, size)
- PTR ptr;
+ void * ptr;
int size;
{
- register PTR tem = realloc (ptr, size);
- if (tem == ((PTR) NULL))
+ void * tem = realloc (ptr, size);
+ if (tem == ((void *) NULL))
memory_out ();
return tem;
}
an entry for a particular capability */
static char *
-find_capability (bp, cap)
- register char *bp, *cap;
+find_capability (char * bp, char * cap)
{
for (; *bp; bp++)
if (bp[0] == ':'
tgetnum (cap)
char *cap;
{
- register char *ptr = find_capability (term_entry, cap);
+ char *ptr = find_capability (term_entry, cap);
if (!ptr || ptr[-1] != '#')
return -1;
return atoi (ptr);
tgetflag (cap)
char *cap;
{
- register char *ptr = find_capability (term_entry, cap);
+ char *ptr = find_capability (term_entry, cap);
return 0 != ptr && ptr[-1] == ':';
}
char *cap;
char **area;
{
- register char *ptr = find_capability (term_entry, cap);
+ char *ptr = find_capability (term_entry, cap);
if (!ptr || (ptr[-1] != '=' && ptr[-1] != '~'))
return 0;
return tgetst1 (ptr, area);
char *ptr;
char **area;
{
- register char *p, *r;
- register int c;
- register int size;
+ char *p, *r;
+ int c;
+ int size;
char *ret;
- register int c1;
+ int c1;
if (!ptr)
return 0;
char PC;
tputs (string, nlines, outfun)
- register char *string;
+ char *string;
int nlines;
- register int (*outfun) ();
+ int (*outfun) ();
{
- register int padcount = 0;
+ int padcount = 0;
if (string == (char *) 0)
return;
tgetent (bp, name)
char *bp, *name;
{
- register char *tem;
- register int fd;
+ char *tem;
+ int fd;
struct buffer buf;
- register char *bp1;
+ char *bp1;
char *bp2;
char *term;
int malloc_size = 0;
- register int c;
+ int c;
char *tcenv; /* TERMCAP value, if it contais :tc=. */
char *indirect = 0; /* Terminal type in :tc= in TERMCAP value. */
int filep;
scan_file (string, fd, bufp)
char *string;
int fd;
- register struct buffer *bufp;
+ struct buffer *bufp;
{
- register char *tem;
- register char *end;
+ char *tem;
+ char *end;
bufp->ptr = bufp->beg;
bufp->full = 0;
by termcap entry LINE. */
static int
-name_match (line, name)
- char *line, *name;
+name_match (char *line, char * name)
{
- register char *tem;
+ char *tem;
if (!compare_contin (line, name))
return 1;
static int
compare_contin (str1, str2)
- register char *str1, *str2;
+ char *str1, *str2;
{
- register int c1, c2;
+ int c1, c2;
while (1)
{
c1 = *str1++;
static char *
gobble_line (fd, bufp, append_end)
int fd;
- register struct buffer *bufp;
+ struct buffer *bufp;
char *append_end;
{
- register char *end;
- register int nread;
- register char *buf = bufp->beg;
- register char *tem;
+ char *end;
+ int nread;
+ char *buf = bufp->beg;
+ char *tem;
if (append_end == 0)
append_end = bufp->ptr;
char *cap;
{
char *x = tgetstr (cap, 0);
- register char *y;
+ char *y;
printf ("%s: ", cap);
if (x)
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007 Massachusetts Institute of Technology
-$Id: terminfo.c,v 1.8 2007/01/05 21:19:25 cph Exp $
+$Id: terminfo.c,v 1.9 2007/04/22 16:31:23 cph Exp $
This file is part of GNU Emacs.
#include "config.h"
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# include <string.h>
-#endif
-
-extern char * EXFUN (tparm, (CONST char *, ...));
+extern char * tparm (const char *, ...);
/* Interface to curses/terminfo library.
Turns out that all of the terminfo-level routines look
format is different too. */
char *
-DEFUN (tparam, (string, outstring, len, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9),
- CONST char * string AND
- char * outstring AND
- int len AND
- int arg1 AND
- int arg2 AND
- int arg3 AND
- int arg4 AND
- int arg5 AND
- int arg6 AND
- int arg7 AND
- int arg8 AND
+tparam (const char * string,
+ char * outstring,
+ int len,
+ int arg1,
+ int arg2,
+ int arg3,
+ int arg4,
+ int arg5,
+ int arg6,
+ int arg7,
+ int arg8,
int arg9)
{
char * temp = (tparm (string, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9));
/* Merge parameters into a termcap entry string.
- Copyright (C) 1985-1992 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1987 Free Software Foundation, Inc.
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 Massachusetts Institute of Technology
NO WARRANTY
#define NO_ARG_ARRAY
#endif
-#include "ansidecl.h"
-
-extern char * EXFUN (tparam, (char *, char *, int, int, int, int, int));
-extern char * EXFUN (tgoto, (char *, int, int));
+extern char * tparam (char *, char *, int, int, int, int, int);
+extern char * tgoto (char *, int, int);
/* Assuming STRING is the value of a termcap string entry
containing `%' constructs to expand parameters,
The fourth and following args to tparam serve as the parameter values. */
-char * EXFUN (tparam1, (char *, char *, int, char *, char *, int *));
+char * tparam1 (char *, char *, int, char *, char *, int *);
/* VARARGS 2 */
char *
char *outstring;
int len;
char *up, *left;
- register int *argp;
+ int *argp;
{
- register int c;
- register char *p = string;
- register char *op = outstring;
+ int c;
+ char *p = string;
+ char *op = outstring;
char *outend;
int outlen = 0;
- register int tem;
+ int tem;
int *oargp = argp;
int doleft = 0;
int doup = 0;
/* If the buffer might be too short, make it bigger. */
if (op + 5 >= outend)
{
- register char *new;
+ char *new;
if (outlen == 0)
{
new = (char *) malloc (outlen = 40 + len);
/* -*-C-*-
-$Id: transact.c,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: transact.c,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <stdio.h>
#include "config.h"
#include "outf.h"
#include "dstack.h"
static void
-DEFUN (error, (procedure_name, message),
- CONST char * procedure_name AND
- CONST char * message)
+error (const char * procedure_name, const char * message)
{
outf_fatal ("%s: %s\n", procedure_name, message);
outf_flush_fatal ();
struct transaction
{
- PTR checkpoint;
+ void * checkpoint;
enum transaction_state state;
};
static struct transaction * current_transaction;
static void
-DEFUN (guarantee_current_transaction, (proc), CONST char * proc)
+guarantee_current_transaction (const char * proc)
{
if (current_transaction == 0)
error (proc, "no transaction");
}
void
-DEFUN_VOID (transaction_initialize)
+transaction_initialize (void)
{
current_transaction = 0;
}
void
-DEFUN_VOID (transaction_begin)
+transaction_begin (void)
{
- PTR checkpoint = dstack_position;
+ void * checkpoint = dstack_position;
struct transaction * transaction =
(dstack_alloc (sizeof (struct transaction)));
(transaction -> checkpoint) = checkpoint;
}
void
-DEFUN_VOID (transaction_abort)
+transaction_abort (void)
{
guarantee_current_transaction ("transaction_abort");
(current_transaction -> state) = aborting;
}
void
-DEFUN_VOID (transaction_commit)
+transaction_commit (void)
{
guarantee_current_transaction ("transaction_commit");
(current_transaction -> state) = committing;
struct action
{
enum transaction_action_type type;
- void EXFUN ((*procedure), (PTR environment));
- PTR environment;
+ void (*procedure) (void * environment);
+ void * environment;
};
static void
-DEFUN (execute_action, (action), PTR action)
+execute_action (void * action)
{
if ((((struct action *) action) -> type) !=
(((current_transaction -> state) == committing)
}
void
-DEFUN (transaction_record_action, (type, procedure, environment),
- enum transaction_action_type type AND
- void EXFUN ((*procedure), (PTR environment)) AND
- PTR environment)
+transaction_record_action (enum transaction_action_type type,
+ void (*procedure) (void * environment),
+ void * environment)
{
guarantee_current_transaction ("transaction_record_action");
{
/* -*-C-*-
-$Id: trap.h,v 9.53 2007/01/05 21:19:25 cph Exp $
+$Id: trap.h,v 9.54 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
#ifndef SCM_TRAP_H
-#define SCM_TRAP_H
+#define SCM_TRAP_H 1
\f
/* Kinds of traps:
#define TRAP_UNASSIGNED 0
#define TRAP_UNBOUND 2
#define TRAP_EXPENSIVE 6
-/* TRAP_MAX_IMMEDIATE is defined in const.h */
+/* TRAP_MAX_IMMEDIATE is defined in object.h */
/* The following are non-immediate traps: */
#define TRAP_COMPILER_CACHED 14
/* -*-C-*-
-$Id: tterm.c,v 1.20 2007/01/12 03:45:55 cph Exp $
+$Id: tterm.c,v 1.21 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# include <curses.h>
# include <term.h>
#else
- extern int EXFUN (tgetent, (char *, CONST char *));
- extern int EXFUN (tgetnum, (CONST char *));
- extern int EXFUN (tgetflag, (CONST char *));
- extern char * EXFUN (tgetstr, (CONST char *, char **));
- extern char * EXFUN (tgoto, (CONST char *, int, int));
- extern int EXFUN (tputs, (CONST char *, int, void (*) (int)));
+ extern int tgetent (char *, const char *);
+ extern int tgetnum (const char *);
+ extern int tgetflag (const char *);
+ extern char * tgetstr (const char *, char **);
+ extern char * tgoto (const char *, int, int);
+ extern int tputs (const char *, int, void (*) (int));
#endif
-extern char * EXFUN (tparam, (CONST char *, PTR, int, ...));
+extern char * tparam (const char *, void *, int, ...);
extern char * BC;
extern char * UP;
extern char PC;
static char * tputs_output_scan;
static int
-DEFUN (tputs_write_char, (c), int c)
+tputs_write_char (int c)
{
(*tputs_output_scan++) = c;
return (c);
PRIMITIVE_HEADER (1);
{
char * result = (tgetstr ((STRING_ARG (1)), (&tgetstr_pointer)));
- PRIMITIVE_RETURN
- ((result == 0) ? SHARP_F : (char_pointer_to_string (result)));
+ PRIMITIVE_RETURN ((result == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (result)));
}
}
BC = (((ARG_REF (4)) == SHARP_F) ? 0 : (STRING_ARG (4)));
UP = (((ARG_REF (5)) == SHARP_F) ? 0 : (STRING_ARG (5)));
PRIMITIVE_RETURN
- (char_pointer_to_string
- (tgoto ((STRING_ARG (1)),
- (arg_nonnegative_integer (2)),
- (arg_nonnegative_integer (3)))));
+ (char_pointer_to_string (tgoto ((STRING_ARG (1)),
+ (arg_nonnegative_integer (2)),
+ (arg_nonnegative_integer (3)))));
}
}
/* -*-C-*-
-$Id: types.h,v 9.42 2007/01/05 21:19:25 cph Exp $
+$Id: types.h,v 9.43 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-/* Type code definitions, numerical order */
+/* Type code definitions */
\f
-/* Name Value Previous Name */
-
#define TC_NULL 0x00
#define TC_LIST 0x01
#define TC_CHARACTER 0x02
#define TC_MANIFEST_CLOSURE 0x0D
#define TC_BIG_FIXNUM 0x0E
#define TC_PROCEDURE 0x0F
-#define TC_ENTITY 0x10 /* PRIMITIVE_EXTERNAL */
+#define TC_ENTITY 0x10
#define TC_DELAY 0x11
#define TC_ENVIRONMENT 0x12
#define TC_DELAYED 0x13
#define TC_INTERNED_SYMBOL 0x1D
#define TC_CHARACTER_STRING 0x1E
#define TC_ACCESS 0x1F
-#define TC_HUNK3_A 0x20 /* EXTENDED_FIXNUM */
+#define TC_HUNK3_A 0x20
#define TC_DEFINITION 0x21
#define TC_BROKEN_HEART 0x22
#define TC_ASSIGNMENT 0x23
#define TC_COMPILED_ENTRY 0x28
#define TC_LEXPR 0x29
#define TC_PCOMB3 0x2A
-#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B
+/* #define TC_UNUSED 0x2B */
#define TC_VARIABLE 0x2C
#define TC_THE_ENVIRONMENT 0x2D
-#define TC_FUTURE 0x2E
+/* #define TC_UNUSED 0x2E */
#define TC_VECTOR_1B 0x2F
#define TC_PCOMB0 0x30
#define TC_VECTOR_16B 0x31
-#define TC_REFERENCE_TRAP 0x32 /* UNASSIGNED */
+#define TC_REFERENCE_TRAP 0x32
#define TC_SEQUENCE_3 0x33
#define TC_CONDITIONAL 0x34
#define TC_DISJUNCTION 0x35
#define TC_WEAK_CONS 0x37
#define TC_QUAD 0x38
#define TC_LINKAGE_SECTION 0x39
-#define TC_RATNUM 0x3A /* COMPILER_LINK */
+#define TC_RATNUM 0x3A
#define TC_STACK_ENVIRONMENT 0x3B
#define TC_COMPLEX 0x3C
#define TC_COMPILED_CODE_BLOCK 0x3D
#define TC_RECORD 0x3E
+/* #define TC_UNUSED 0x3F */
-/* If you add a new type, don't forget to update gccode.h, gctype.c,
- and the type name table below. */
+/* If you add a new type, don't forget to update "gcloop.c"
+ and TYPE_NAME_TABLE below. */
-#define LAST_TYPE_CODE 0x3E
-#define MIN_TYPE_CODE_LENGTH 6
+#define MIN_TYPE_CODE_LENGTH 6
+#define TYPE_CODE_LIMIT (1 << MIN_TYPE_CODE_LENGTH)
+#define LAST_TYPE_CODE (TYPE_CODE_LIMIT - 1)
-#ifdef TYPE_CODE_LENGTH
-#if (TYPE_CODE_LENGTH < MIN_TYPE_CODE_LENGTH)
-#include ";; inconsistency between object.h and types.h: MIN_TYPE_CODE_LENGTH"
-#endif
+#if defined (TYPE_CODE_LENGTH) && (TYPE_CODE_LENGTH < MIN_TYPE_CODE_LENGTH)
+# include ";; inconsistency: TYPE_CODE_LENGTH < MIN_TYPE_CODE_LENGTH"
#endif
\f
#define TYPE_NAME_TABLE \
/* 0x28 */ "COMPILED-ENTRY", \
/* 0x29 */ "LEXPR", \
/* 0x2A */ "PCOMB3", \
- /* 0x2B */ "MANIFEST-SPECIAL-NM-VECTOR", \
+ /* 0x2B */ 0, \
/* 0x2C */ "VARIABLE", \
/* 0x2D */ "THE-ENVIRONMENT", \
- /* 0x2E */ "FUTURE", \
+ /* 0x2E */ 0, \
/* 0x2F */ "VECTOR-1B", \
/* 0x30 */ "PCOMB0", \
/* 0x31 */ "VECTOR-16B", \
/* 0x3B */ "STACK-ENVIRONMENT", \
/* 0x3C */ "COMPLEX", \
/* 0x3D */ "COMPILED-CODE-BLOCK", \
- /* 0x3E */ "RECORD" \
- }
-\f
-/* Flags and aliases */
-
-/* Type code 0x10 (used to be TC_PRIMITIVE_EXTERNAL) has been reused. */
-
-#define PRIMITIVE_EXTERNAL_REUSED
+ /* 0x3E */ "RECORD", \
+ /* 0x3F */ 0 \
+}
/* Aliases */
#define UNMARKED_HISTORY_TYPE TC_HUNK3_A
#define MARKED_HISTORY_TYPE TC_HUNK3_B
-
-#define case_TC_FIXNUMs case TC_FIXNUM
+++ /dev/null
-/* Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 1, or (at your option)
- any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with MIT/GNU Scheme; if not, write to the Free Software
- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
- 02110-1301, USA.
-
-In other words, you are welcome to use, share and improve this program.
-You are forbidden to forbid anyone else to use, share and improve
-what you give them. Help stamp out software-hoarding! */
-
-
-/*
- * unexec.c - Convert a running program into an a.out file.
- *
- * Author: Spencer W. Thomas
- * Computer Science Dept.
- * University of Utah
- * Date: Tue Mar 2 1982
- * Modified heavily since then.
- *
- * Synopsis:
- * unexec (new_name, a_name, data_start, bss_start, entry_address)
- * char *new_name, *a_name;
- * unsigned data_start, bss_start, entry_address;
- *
- * Takes a snapshot of the program and makes an a.out format file in the
- * file named by the string argument new_name.
- * If a_name is non-NULL, the symbol table will be taken from the given file.
- * On some machines, an existing a_name file is required.
- *
- * The boundaries within the a.out file may be adjusted with the data_start
- * and bss_start arguments. Either or both may be given as 0 for defaults.
- *
- * Data_start gives the boundary between the text segment and the data
- * segment of the program. The text segment can contain shared, read-only
- * program code and literal data, while the data segment is always unshared
- * and unprotected. Data_start gives the lowest unprotected address.
- * The value you specify may be rounded down to a suitable boundary
- * as required by the machine you are using.
- *
- * Specifying zero for data_start means the boundary between text and data
- * should not be the same as when the program was loaded.
- * If NO_REMAP is defined, the argument data_start is ignored and the
- * segment boundaries are never changed.
- *
- * Bss_start indicates how much of the data segment is to be saved in the
- * a.out file and restored when the program is executed. It gives the lowest
- * unsaved address, and is rounded up to a page boundary. The default when 0
- * is given assumes that the entire data segment is to be stored, including
- * the previous data and bss as well as any additional storage allocated with
- * break (2).
- *
- * The new file is set up to start at entry_address.
- *
- * If you make improvements I'd like to get them too.
- * harpo!utah-cs!thomas, thomas@Utah-20
- *
- */
-
-/* Modified to support SysVr3 shared libraries by James Van Artsdalen
- * of Dell Computer Corporation. james@bigtex.cactus.org.
- */
-
-/* There are several compilation parameters affecting unexec:
-
-* COFF
-
-Define this if your system uses COFF for executables.
-Otherwise we assume you use Berkeley format.
-
-* NO_REMAP
-
-Define this if you do not want to try to save Emacs's pure data areas
-as part of the text segment.
-
-Saving them as text is good because it allows users to share more.
-
-However, on machines that locate the text area far from the data area,
-the boundary cannot feasibly be moved. Such machines require
-NO_REMAP.
-
-Also, remapping can cause trouble with the built-in startup routine
-/lib/crt0.o, which defines `environ' as an initialized variable.
-Dumping `environ' as pure does not work! So, to use remapping,
-you must write a startup routine for your machine in Emacs's crt0.c.
-If NO_REMAP is defined, Emacs uses the system's crt0.o.
-
-* SECTION_ALIGNMENT
-
-Some machines that use COFF executables require that each section
-start on a certain boundary *in the COFF file*. Such machines should
-define SECTION_ALIGNMENT to a mask of the low-order bits that must be
-zero on such a boundary. This mask is used to control padding between
-segments in the COFF file.
-
-If SECTION_ALIGNMENT is not defined, the segments are written
-consecutively with no attempt at alignment. This is right for
-unmodified system V.
-
-* SEGMENT_MASK
-
-Some machines require that the beginnings and ends of segments
-*in core* be on certain boundaries. For most machines, a page
-boundary is sufficient. That is the default. When a larger
-boundary is needed, define SEGMENT_MASK to a mask of
-the bits that must be zero on such a boundary.
-
-* A_TEXT_OFFSET(HDR)
-
-Some machines count the a.out header as part of the size of the text
-segment (a_text); they may actually load the header into core as the
-first data in the text segment. Some have additional padding between
-the header and the real text of the program that is counted in a_text.
-
-For these machines, define A_TEXT_OFFSET(HDR) to examine the header
-structure HDR and return the number of bytes to add to `a_text'
-before writing it (above and beyond the number of bytes of actual
-program text). HDR's standard fields are already correct, except that
-this adjustment to the `a_text' field has not yet been made;
-thus, the amount of offset can depend on the data in the file.
-
-* A_TEXT_SEEK(HDR)
-
-If defined, this macro specifies the number of bytes to seek into the
-a.out file before starting to write the text segment.a
-
-* EXEC_MAGIC
-
-For machines using COFF, this macro, if defined, is a value stored
-into the magic number field of the output file.
-
-* ADJUST_EXEC_HEADER
-
-This macro can be used to generate statements to adjust or
-initialize nonstandard fields in the file header
-
-* ADDR_CORRECT(ADDR)
-
-Macro to correct an int which is the bit pattern of a pointer to a byte
-into an int which is the number of a byte.
-
-This macro has a default definition which is usually right.
-This default definition is a no-op on most machines (where a
-pointer looks like an int) but not on all machines.
-
-*/
-
-#ifndef emacs
-#define PERROR(arg) perror (arg); return -1
-#else
-#include "config.h"
-#define PERROR(file) report_error (file, new)
-#endif
-
-#ifndef CANNOT_DUMP /* all rest of file! */
-
-#ifndef CANNOT_UNEXEC /* most of rest of file */
-
-#include <a.out.h>
-/* Define getpagesize () if the system does not.
- Note that this may depend on symbols defined in a.out.h
- */
-#include "getpagesize.h"
-
-#ifndef makedev /* Try to detect types.h already loaded */
-#include <sys/types.h>
-#endif
-#include <stdio.h>
-#include <sys/stat.h>
-#include <errno.h>
-
-extern char *start_of_text (); /* Start of text */
-extern char *start_of_data (); /* Start of initialized data */
-
-#ifdef COFF
-#ifndef USG
-#ifndef STRIDE
-#ifndef UMAX
-#ifndef sun386
-/* I have a suspicion that these are turned off on all systems
- and can be deleted. Try it in version 19. */
-#include <filehdr.h>
-#include <aouthdr.h>
-#include <scnhdr.h>
-#include <syms.h>
-#endif /* not sun386 */
-#endif /* not UMAX */
-#endif /* Not STRIDE */
-#endif /* not USG */
-static long block_copy_start; /* Old executable start point */
-static struct filehdr f_hdr; /* File header */
-static struct aouthdr f_ohdr; /* Optional file header (a.out) */
-long bias; /* Bias to add for growth */
-long lnnoptr; /* Pointer to line-number info within file */
-#define SYMS_START block_copy_start
-
-static long text_scnptr;
-static long data_scnptr;
-
-#else /* not COFF */
-
-extern char *sbrk ();
-
-#define SYMS_START ((long) N_SYMOFF (ohdr))
-
-/* Some machines override the structure name for an a.out header. */
-#ifndef EXEC_HDR_TYPE
-#define EXEC_HDR_TYPE struct exec
-#endif
-
-#ifdef HPUX
-#ifdef HP9000S200_ID
-#define MY_ID HP9000S200_ID
-#else
-#include <model.h>
-#define MY_ID MYSYS
-#endif /* no HP9000S200_ID */
-static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC};
-static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC};
-#define N_TXTOFF(x) TEXT_OFFSET(x)
-#define N_SYMOFF(x) LESYM_OFFSET(x)
-static EXEC_HDR_TYPE hdr, ohdr;
-
-#else /* not HPUX */
-
-#if defined (USG) && !defined (IBMRTAIX) && !defined (IRIS)
-static struct bhdr hdr, ohdr;
-#define a_magic fmagic
-#define a_text tsize
-#define a_data dsize
-#define a_bss bsize
-#define a_syms ssize
-#define a_trsize rtsize
-#define a_drsize rdsize
-#define a_entry entry
-#define N_BADMAG(x) \
- (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\
- ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC)
-#define NEWMAGIC FMAGIC
-#else /* IRIS or IBMRTAIX or not USG */
-static EXEC_HDR_TYPE hdr, ohdr;
-#define NEWMAGIC ZMAGIC
-#endif /* IRIS or IBMRTAIX not USG */
-#endif /* not HPUX */
-
-static int unexec_text_start;
-static int unexec_data_start;
-
-#endif /* not COFF */
-
-static int pagemask;
-
-/* Correct an int which is the bit pattern of a pointer to a byte
- into an int which is the number of a byte.
- This is a no-op on ordinary machines, but not on all. */
-
-#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */
-#define ADDR_CORRECT(x) ((char *)(x) - (char*)0)
-#endif
-
-#ifdef emacs
-
-static
-report_error (file, fd)
- char *file;
- int fd;
-{
- if (fd)
- close (fd);
- error ("Failure operating on %s", file);
-}
-#endif /* emacs */
-
-#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1
-#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1
-#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1
-
-static
-report_error_1 (fd, msg, a1, a2)
- int fd;
- char *msg;
- int a1, a2;
-{
- close (fd);
-#ifdef emacs
- error (msg, a1, a2);
-#else
- fprintf (stderr, msg, a1, a2);
- fprintf (stderr, "\n");
-#endif
-}
-\f
-/* ****************************************************************
- * unexec
- *
- * driving logic.
- */
-unexec (new_name, a_name, data_start, bss_start, entry_address)
- char *new_name, *a_name;
- unsigned data_start, bss_start, entry_address;
-{
- int new, a_out = -1;
-
- if (a_name && (a_out = open (a_name, 0)) < 0)
- {
- PERROR (a_name);
- }
- if ((new = creat (new_name, 0666)) < 0)
- {
- PERROR (new_name);
- }
-
- if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0
- || copy_text_and_data (new, a_out) < 0
- || copy_sym (new, a_out, a_name, new_name) < 0
-#ifdef COFF
- || adjust_lnnoptrs (new, a_out, new_name) < 0
-#endif
- )
- {
- close (new);
- /* unlink (new_name); /* Failed, unlink new a.out */
- return -1;
- }
-
- close (new);
- if (a_out >= 0)
- close (a_out);
- mark_x (new_name);
- return 0;
-}
-
-/* ****************************************************************
- * make_hdr
- *
- * Make the header in the new a.out from the header in core.
- * Modify the text and data sizes.
- */
-static int
-make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name)
- int new, a_out;
- unsigned data_start, bss_start, entry_address;
- char *a_name;
- char *new_name;
-{
- int tem;
-#ifdef COFF
- auto struct scnhdr f_thdr; /* Text section header */
- auto struct scnhdr f_dhdr; /* Data section header */
- auto struct scnhdr f_bhdr; /* Bss section header */
- auto struct scnhdr scntemp; /* Temporary section header */
- register int scns;
-#endif /* COFF */
-#ifdef USG_SHARED_LIBRARIES
- extern unsigned int bss_end;
-#else
- unsigned int bss_end;
-#endif
-
- pagemask = getpagesize () - 1;
-
- /* Adjust text/data boundary. */
-#ifdef NO_REMAP
- data_start = (int) start_of_data ();
-#else /* not NO_REMAP */
- if (!data_start)
- data_start = (int) start_of_data ();
-#endif /* not NO_REMAP */
- data_start = ADDR_CORRECT (data_start);
-
-#ifdef SEGMENT_MASK
- data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */
-#else
- data_start = data_start & ~pagemask; /* (Down) to page boundary. */
-#endif
-
- bss_end = ADDR_CORRECT (sbrk (0)) + pagemask;
- bss_end &= ~ pagemask;
-
- /* Adjust data/bss boundary. */
- if (bss_start != 0)
- {
- bss_start = (ADDR_CORRECT (bss_start) + pagemask);
- /* (Up) to page bdry. */
- bss_start &= ~ pagemask;
- if (bss_start > bss_end)
- {
- ERROR1 ("unexec: Specified bss_start (%u) is past end of program",
- bss_start);
- }
- }
- else
- bss_start = bss_end;
-
- if (data_start > bss_start) /* Can't have negative data size. */
- {
- ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)",
- data_start, bss_start);
- }
-
-#ifdef COFF
- /* Salvage as much info from the existing file as possible */
- if (a_out >= 0)
- {
- if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
- {
- PERROR (a_name);
- }
- block_copy_start += sizeof (f_hdr);
- if (f_hdr.f_opthdr > 0)
- {
- if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
- {
- PERROR (a_name);
- }
- block_copy_start += sizeof (f_ohdr);
- }
- /* Loop through section headers, copying them in */
- for (scns = f_hdr.f_nscns; scns > 0; scns--) {
- if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
- {
- PERROR (a_name);
- }
- if (scntemp.s_scnptr > 0L)
- {
- if (block_copy_start < scntemp.s_scnptr + scntemp.s_size)
- block_copy_start = scntemp.s_scnptr + scntemp.s_size;
- }
- if (strcmp (scntemp.s_name, ".text") == 0)
- {
- f_thdr = scntemp;
- }
- else if (strcmp (scntemp.s_name, ".data") == 0)
- {
- f_dhdr = scntemp;
- }
- else if (strcmp (scntemp.s_name, ".bss") == 0)
- {
- f_bhdr = scntemp;
- }
- }
- }
- else
- {
- ERROR0 ("can't build a COFF file from scratch yet");
- }
-
- /* Now we alter the contents of all the f_*hdr variables
- to correspond to what we want to dump. */
-
-#ifdef USG_SHARED_LIBRARIES
-
- /* The amount of data we're adding to the file is distance from the
- * end of the original .data space to the current end of the .data
- * space.
- */
-
- bias = bss_end - (f_ohdr.data_start + f_dhdr.s_size);
-
-#endif
-
- f_hdr.f_flags |= (F_RELFLG | F_EXEC);
-#ifdef EXEC_MAGIC
- f_ohdr.magic = EXEC_MAGIC;
-#endif
-#ifndef NO_REMAP
- f_ohdr.text_start = (long) start_of_text ();
- f_ohdr.tsize = data_start - f_ohdr.text_start;
- f_ohdr.data_start = data_start;
-#endif /* NO_REMAP */
- f_ohdr.dsize = bss_start - f_ohdr.data_start;
- f_ohdr.bsize = bss_end - bss_start;
- f_thdr.s_size = f_ohdr.tsize;
- f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr);
- f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr));
- lnnoptr = f_thdr.s_lnnoptr;
-#ifdef SECTION_ALIGNMENT
- /* Some systems require special alignment
- of the sections in the file itself. */
- f_thdr.s_scnptr
- = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT;
-#endif /* SECTION_ALIGNMENT */
- text_scnptr = f_thdr.s_scnptr;
- f_dhdr.s_paddr = f_ohdr.data_start;
- f_dhdr.s_vaddr = f_ohdr.data_start;
- f_dhdr.s_size = f_ohdr.dsize;
- f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size;
-#ifdef SECTION_ALIGNMENT
- /* Some systems require special alignment
- of the sections in the file itself. */
- f_dhdr.s_scnptr
- = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT;
-#endif /* SECTION_ALIGNMENT */
-#ifdef DATA_SECTION_ALIGNMENT
- /* Some systems require special alignment
- of the data section only. */
- f_dhdr.s_scnptr
- = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT;
-#endif /* DATA_SECTION_ALIGNMENT */
- data_scnptr = f_dhdr.s_scnptr;
- f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize;
- f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize;
- f_bhdr.s_size = f_ohdr.bsize;
- f_bhdr.s_scnptr = 0L;
-#ifndef USG_SHARED_LIBRARIES
- bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start;
-#endif
-
- if (f_hdr.f_symptr > 0L)
- {
- f_hdr.f_symptr += bias;
- }
-
- if (f_thdr.s_lnnoptr > 0L)
- {
- f_thdr.s_lnnoptr += bias;
- }
-
-#ifdef ADJUST_EXEC_HEADER
- ADJUST_EXEC_HEADER
-#endif /* ADJUST_EXEC_HEADER */
-
- if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
- {
- PERROR (new_name);
- }
-
- if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
- {
- PERROR (new_name);
- }
-
-#ifndef USG_SHARED_LIBRARIES
-
- if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
- {
- PERROR (new_name);
- }
-
- if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
- {
- PERROR (new_name);
- }
-
- if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
- {
- PERROR (new_name);
- }
-
-#else /* USG_SHARED_LIBRARIES */
-
- /* The purpose of this code is to write out the new file's section
- * header table.
- *
- * Scan through the original file's sections. If the encountered
- * section is one we know (.text, .data or .bss), write out the
- * correct header. If it is a section we do not know (such as
- * .lib), adjust the address of where the section data is in the
- * file, and write out the header.
- *
- * If any section preceeds .text or .data in the file, this code
- * will not adjust the file pointer for that section correctly.
- */
-
- lseek (a_out, sizeof (f_hdr) + sizeof (f_ohdr), 0);
-
- for (scns = f_hdr.f_nscns; scns > 0; scns--)
- {
- if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
- PERROR (a_name);
-
- if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */
- {
- if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
- PERROR (new_name);
- }
- else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */
- {
- if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
- PERROR (new_name);
- }
- else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */
- {
- if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
- PERROR (new_name);
- }
- else
- {
- if (scntemp.s_scnptr)
- scntemp.s_scnptr += bias;
- if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
- PERROR (new_name);
- }
- }
-#endif /* USG_SHARED_LIBRARIES */
-
- return (0);
-
-#else /* if not COFF */
-
- /* Get symbol table info from header of a.out file if given one. */
- if (a_out >= 0)
- {
- if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr)
- {
- PERROR (a_name);
- }
-
- if (N_BADMAG (ohdr))
- {
- ERROR1 ("invalid magic number in %s", a_name);
- }
- hdr = ohdr;
- }
- else
- {
- bzero (hdr, sizeof hdr);
- }
-
- unexec_text_start = (long) start_of_text ();
- unexec_data_start = data_start;
-
- /* Machine-dependent fixup for header, or maybe for unexec_text_start */
-#ifdef ADJUST_EXEC_HEADER
- ADJUST_EXEC_HEADER;
-#endif /* ADJUST_EXEC_HEADER */
-
- hdr.a_trsize = 0;
- hdr.a_drsize = 0;
- if (entry_address != 0)
- hdr.a_entry = entry_address;
-
- hdr.a_bss = bss_end - bss_start;
- hdr.a_data = bss_start - data_start;
-#ifdef NO_REMAP
- hdr.a_text = ohdr.a_text;
-#else /* not NO_REMAP */
- hdr.a_text = data_start - unexec_text_start;
-
-#ifdef A_TEXT_OFFSET
- hdr.a_text += A_TEXT_OFFSET (ohdr);
-#endif
-
-#endif /* not NO_REMAP */
-
- if (write (new, &hdr, sizeof hdr) != sizeof hdr)
- {
- PERROR (new_name);
- }
-
-#ifdef A_TEXT_OFFSET
- hdr.a_text -= A_TEXT_OFFSET (ohdr);
-#endif
-
- return 0;
-
-#endif /* not COFF */
-}
-\f
-/* ****************************************************************
- * copy_text_and_data
- *
- * Copy the text and data segments from memory to the new a.out
- */
-static int
-copy_text_and_data (new, a_out)
- int new, a_out;
-{
- register char *end;
- register char *ptr;
-
-#ifdef COFF
-
-#ifdef USG_SHARED_LIBRARIES
-
- int scns;
- struct scnhdr scntemp; /* Temporary section header */
-
- /* The purpose of this code is to write out the new file's section
- * contents.
- *
- * Step through the section table. If we know the section (.text,
- * .data) do the appropriate thing. Otherwise, if the section has
- * no allocated space in the file (.bss), do nothing. Otherwise,
- * the section has space allocated in the file, and is not a section
- * we know. So just copy it.
- */
-
- lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0);
-
- for (scns = f_hdr.f_nscns; scns > 0; scns--)
- {
- if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
- PERROR ("temacs");
-
- if (!strcmp (scntemp.s_name, ".text"))
- {
- lseek (new, (long) text_scnptr, 0);
- ptr = (char *) f_ohdr.text_start;
- end = ptr + f_ohdr.tsize;
- write_segment (new, ptr, end);
- }
- else if (!strcmp (scntemp.s_name, ".data"))
- {
- lseek (new, (long) data_scnptr, 0);
- ptr = (char *) f_ohdr.data_start;
- end = ptr + f_ohdr.dsize;
- write_segment (new, ptr, end);
- }
- else if (!scntemp.s_scnptr)
- ; /* do nothing - no data for this section */
- else
- {
- char page[BUFSIZ];
- int size, n;
- long old_a_out_ptr = lseek (a_out, 0, 1);
-
- lseek (a_out, scntemp.s_scnptr, 0);
- for (size = scntemp.s_size; size > 0; size -= sizeof (page))
- {
- n = size > sizeof (page) ? sizeof (page) : size;
- if (read (a_out, page, n) != n || write (new, page, n) != n)
- PERROR ("xemacs");
- }
- lseek (a_out, old_a_out_ptr, 0);
- }
- }
-
-#else /* COFF, but not USG_SHARED_LIBRARIES */
-
- lseek (new, (long) text_scnptr, 0);
- ptr = (char *) f_ohdr.text_start;
- end = ptr + f_ohdr.tsize;
- write_segment (new, ptr, end);
-
- lseek (new, (long) data_scnptr, 0);
- ptr = (char *) f_ohdr.data_start;
- end = ptr + f_ohdr.dsize;
- write_segment (new, ptr, end);
-
-#endif /* USG_SHARED_LIBRARIES */
-
-#else /* if not COFF */
-
-/* Some machines count the header as part of the text segment.
- That is to say, the header appears in core
- just before the address that start_of_text () returns.
- For them, N_TXTOFF is the place where the header goes.
- We must adjust the seek to the place after the header.
- Note that at this point hdr.a_text does *not* count
- the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */
-
-#ifdef A_TEXT_SEEK
- lseek (new, (long) A_TEXT_SEEK (hdr), 0);
-#else
-#ifdef A_TEXT_OFFSET
- /* Note that on the Sequent machine A_TEXT_OFFSET != sizeof (hdr)
- and sizeof (hdr) is the correct amount to add here. */
- /* In version 19, eliminate this case and use A_TEXT_SEEK whenever
- N_TXTOFF is not right. */
- lseek (new, (long) N_TXTOFF (hdr) + sizeof (hdr), 0);
-#else
- lseek (new, (long) N_TXTOFF (hdr), 0);
-#endif /* no A_TEXT_OFFSET */
-#endif /* no A_TEXT_SEEK */
-
- ptr = (char *) unexec_text_start;
- end = ptr + hdr.a_text;
- write_segment (new, ptr, end);
-
- ptr = (char *) unexec_data_start;
- end = ptr + hdr.a_data;
-/* This lseek is certainly incorrect when A_TEXT_OFFSET
- and I believe it is a no-op otherwise.
- Let's see if its absence ever fails. */
-/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */
- write_segment (new, ptr, end);
-
-#endif /* not COFF */
-
- return 0;
-}
-
-write_segment (new, ptr, end)
- int new;
- register char *ptr, *end;
-{
- register int i, nwrite, ret;
- char buf[80];
- extern int errno;
- char zeros[128];
-
- bzero (zeros, sizeof zeros);
-
- for (i = 0; ptr < end;)
- {
- /* distance to next multiple of 128. */
- nwrite = (((int) ptr + 128) & -128) - (int) ptr;
- /* But not beyond specified end. */
- if (nwrite > end - ptr) nwrite = end - ptr;
- ret = write (new, ptr, nwrite);
- /* If write gets a page fault, it means we reached
- a gap between the old text segment and the old data segment.
- This gap has probably been remapped into part of the text segment.
- So write zeros for it. */
- if (ret == -1 && errno == EFAULT)
- write (new, zeros, nwrite);
- else if (nwrite != ret)
- {
- sprintf (buf,
- "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d",
- ptr, new, nwrite, ret, errno);
- PERROR (buf);
- }
- i += nwrite;
- ptr += nwrite;
- }
-}
-\f
-/* ****************************************************************
- * copy_sym
- *
- * Copy the relocation information and symbol table from the a.out to the new
- */
-static int
-copy_sym (new, a_out, a_name, new_name)
- int new, a_out;
- char *a_name, *new_name;
-{
- char page[1024];
- int n;
-
- if (a_out < 0)
- return 0;
-
-#ifdef COFF
- if (SYMS_START == 0L)
- return 0;
-#endif /* COFF */
-
-#ifdef COFF
- if (lnnoptr) /* if there is line number info */
- lseek (a_out, lnnoptr, 0); /* start copying from there */
- else
-#endif /* COFF */
- lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */
-
- while ((n = read (a_out, page, sizeof page)) > 0)
- {
- if (write (new, page, n) != n)
- {
- PERROR (new_name);
- }
- }
- if (n < 0)
- {
- PERROR (a_name);
- }
- return 0;
-}
-\f
-/* ****************************************************************
- * mark_x
- *
- * After succesfully building the new a.out, mark it executable
- */
-static
-mark_x (name)
- char *name;
-{
- struct stat sbuf;
- int um;
- int new = 0; /* for PERROR */
-
- um = umask (777);
- umask (um);
- if (stat (name, &sbuf) == -1)
- {
- PERROR (name);
- }
- sbuf.st_mode |= 0111 & ~um;
- if (chmod (name, sbuf.st_mode) == -1)
- PERROR (name);
-}
-\f
-/*
- * If the COFF file contains a symbol table and a line number section,
- * then any auxiliary entries that have values for x_lnnoptr must
- * be adjusted by the amount that the line number section has moved
- * in the file (bias computed in make_hdr). The #@$%&* designers of
- * the auxiliary entry structures used the absolute file offsets for
- * the line number entry rather than an offset from the start of the
- * line number section!
- *
- * When I figure out how to scan through the symbol table and pick out
- * the auxiliary entries that need adjustment, this routine will
- * be fixed. As it is now, all such entries are wrong and sdb
- * will complain. Fred Fish, UniSoft Systems Inc.
- */
-
-#ifdef COFF
-
-/* This function is probably very slow. Instead of reopening the new
- file for input and output it should copy from the old to the new
- using the two descriptors already open (WRITEDESC and READDESC).
- Instead of reading one small structure at a time it should use
- a reasonable size buffer. But I don't have time to work on such
- things, so I am installing it as submitted to me. -- RMS. */
-
-adjust_lnnoptrs (writedesc, readdesc, new_name)
- int writedesc;
- int readdesc;
- char *new_name;
-{
- register int nsyms;
- register int new;
-#ifdef amdahl_uts
- SYMENT symentry;
- AUXENT auxentry;
-#else
- struct syment symentry;
- union auxent auxentry;
-#endif
-
- if (!lnnoptr || !f_hdr.f_symptr)
- return 0;
-
- if ((new = open (new_name, 2)) < 0)
- {
- PERROR (new_name);
- return -1;
- }
-
- lseek (new, f_hdr.f_symptr, 0);
- for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++)
- {
- read (new, &symentry, SYMESZ);
- if (symentry.n_numaux)
- {
- read (new, &auxentry, AUXESZ);
- nsyms++;
- if (ISFCN (symentry.n_type)) {
- auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias;
- lseek (new, -AUXESZ, 1);
- write (new, &auxentry, AUXESZ);
- }
- }
- }
- close (new);
-}
-
-#endif /* COFF */
-
-#endif /* not CANNOT_UNEXEC */
-
-#endif /* not CANNOT_DUMP */
+++ /dev/null
-/* Unexec for HP 9000 Series 800 machines.
- Bob Desinger <hpsemc!bd@hplabs.hp.com>
-
- Note that the GNU project considers support for HP operation a
- peripheral activity which should not be allowed to divert effort
- from development of the GNU system. Changes in this code will be
- installed when users send them in, but aside from that we don't
- plan to think about it, or about whether other Emacs maintenance
- might break it.
-
-
- Unexec creates a copy of the old a.out file, and replaces the old data
- area with the current data area. When the new file is executed, the
- process will see the same data structures and data values that the
- original process had when unexec was called.
-
- Unlike other versions of unexec, this one copies symbol table and
- debug information to the new a.out file. Thus, the new a.out file
- may be debugged with symbolic debuggers.
-
- If you fix any bugs in this, I'd like to incorporate your fixes.
- Send them to uunet!hpda!hpsemc!jmorris or jmorris%hpsemc@hplabs.HP.COM.
-
- CAVEATS:
- This routine saves the current value of all static and external
- variables. This means that any data structure that needs to be
- initialized must be explicitly reset. Variables will not have their
- expected default values.
-
- Unfortunately, the HP-UX signal handler has internal initialization
- flags which are not explicitly reset. Thus, for signals to work in
- conjunction with this routine, the following code must executed when
- the new process starts up.
-
- void _sigreturn();
- ...
- sigsetreturn(_sigreturn);
-*/
-\f
-#include <stdio.h>
-#include <fcntl.h>
-#include <errno.h>
-
-#include <a.out.h>
-
-#define NBPG 2048
-#define roundup(x,n) ( ( (x)+(n-1) ) & ~(n-1) ) /* n is power of 2 */
-#define min(x,y) ( ((x)<(y))?(x):(y) )
-
-
-/* Create a new a.out file, same as old but with current data space */
-
-unexec(new_name, old_name, new_end_of_text, dummy1, dummy2)
- char new_name[]; /* name of the new a.out file to be created */
- char old_name[]; /* name of the old a.out file */
- char *new_end_of_text; /* ptr to new edata/etext; NOT USED YET */
- int dummy1, dummy2; /* not used by emacs */
-{
- int old, new;
- int old_size, new_size;
- struct header hdr;
- struct som_exec_auxhdr auxhdr;
-
- /* For the greatest flexibility, should create a temporary file in
- the same directory as the new file. When everything is complete,
- rename the temp file to the new name.
- This way, a program could update its own a.out file even while
- it is still executing. If problems occur, everything is still
- intact. NOT implemented. */
-
- /* Open the input and output a.out files */
- old = open(old_name, O_RDONLY);
- if (old < 0)
- { perror(old_name); exit(1); }
- new = open(new_name, O_CREAT|O_RDWR|O_TRUNC, 0777);
- if (new < 0)
- { perror(new_name); exit(1); }
-
- /* Read the old headers */
- read_header(old, &hdr, &auxhdr);
-
- /* Decide how large the new and old data areas are */
- old_size = auxhdr.exec_dsize;
- new_size = sbrk(0) - auxhdr.exec_dmem;
-
- /* Copy the old file to the new, up to the data space */
- lseek(old, 0, 0);
- copy_file(old, new, auxhdr.exec_dfile);
-
- /* Skip the old data segment and write a new one */
- lseek(old, old_size, 1);
- save_data_space(new, &hdr, &auxhdr, new_size);
-
- /* Copy the rest of the file */
- copy_rest(old, new);
-
- /* Update file pointers since we probably changed size of data area */
- update_file_ptrs(new, &hdr, &auxhdr, auxhdr.exec_dfile, new_size-old_size);
-
- /* Save the modified header */
- write_header(new, &hdr, &auxhdr);
-
- /* Close the binary file */
- close(old);
- close(new);
- exit(0);
-}
-
-/* Save current data space in the file, update header. */
-
-save_data_space(file, hdr, auxhdr, size)
- int file;
- struct header *hdr;
- struct som_exec_auxhdr *auxhdr;
- int size;
-{
- /* Write the entire data space out to the file */
- if (write(file, auxhdr->exec_dmem, size) != size)
- { perror("Can't save new data space"); exit(1); }
-
- /* Update the header to reflect the new data size */
- auxhdr->exec_dsize = size;
- auxhdr->exec_bsize = 0;
-}
-
-/* Update the values of file pointers when something is inserted. */
-
-update_file_ptrs(file, hdr, auxhdr, location, offset)
- int file;
- struct header *hdr;
- struct som_exec_auxhdr *auxhdr;
- unsigned int location;
- int offset;
-{
- struct subspace_dictionary_record subspace;
- int i;
-
- /* Increase the overall size of the module */
- hdr->som_length += offset;
-
- /* Update the various file pointers in the header */
-#define update(ptr) if (ptr > location) ptr = ptr + offset
- update(hdr->aux_header_location);
- update(hdr->space_strings_location);
- update(hdr->init_array_location);
- update(hdr->compiler_location);
- update(hdr->symbol_location);
- update(hdr->fixup_request_location);
- update(hdr->symbol_strings_location);
- update(hdr->unloadable_sp_location);
- update(auxhdr->exec_tfile);
- update(auxhdr->exec_dfile);
-
- /* Do for each subspace dictionary entry */
- lseek(file, hdr->subspace_location, 0);
- for (i = 0; i < hdr->subspace_total; i++)
- {
- if (read(file, &subspace, sizeof(subspace)) != sizeof(subspace))
- { perror("Can't read subspace record"); exit(1); }
-
- /* If subspace has a file location, update it */
- if (subspace.initialization_length > 0
- && subspace.file_loc_init_value > location)
- {
- subspace.file_loc_init_value += offset;
- lseek(file, -sizeof(subspace), 1);
- if (write(file, &subspace, sizeof(subspace)) != sizeof(subspace))
- { perror("Can't update subspace record"); exit(1); }
- }
- }
-
- /* Do for each initialization pointer record */
- /* (I don't think it applies to executable files, only relocatables) */
-#undef update
-}
-
-/* Read in the header records from an a.out file. */
-
-read_header(file, hdr, auxhdr)
- int file;
- struct header *hdr;
- struct som_exec_auxhdr *auxhdr;
-{
-
- /* Read the header in */
- lseek(file, 0, 0);
- if (read(file, hdr, sizeof(*hdr)) != sizeof(*hdr))
- { perror("Couldn't read header from a.out file"); exit(1); }
-
- if (hdr->a_magic != EXEC_MAGIC && hdr->a_magic != SHARE_MAGIC
- && hdr->a_magic != DEMAND_MAGIC)
- {
- fprintf(stderr, "a.out file doesn't have legal magic number\n");
- exit(1);
- }
-
- lseek(file, hdr->aux_header_location, 0);
- if (read(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr))
- {
- perror("Couldn't read auxiliary header from a.out file");
- exit(1);
- }
-}
-
-/* Write out the header records into an a.out file. */
-
-write_header(file, hdr, auxhdr)
- int file;
- struct header *hdr;
- struct som_exec_auxhdr *auxhdr;
-{
- /* Update the checksum */
- hdr->checksum = calculate_checksum(hdr);
-
- /* Write the header back into the a.out file */
- lseek(file, 0, 0);
- if (write(file, hdr, sizeof(*hdr)) != sizeof(*hdr))
- { perror("Couldn't write header to a.out file"); exit(1); }
- lseek(file, hdr->aux_header_location, 0);
- if (write(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr))
- { perror("Couldn't write auxiliary header to a.out file"); exit(1); }
-}
-
-/* Calculate the checksum of a SOM header record. */
-
-calculate_checksum(hdr)
- struct header *hdr;
-{
- int checksum, i, *ptr;
-
- checksum = 0; ptr = (int *) hdr;
-
- for (i=0; i<sizeof(*hdr)/sizeof(int)-1; i++)
- checksum ^= ptr[i];
-
- return(checksum);
-}
-
-/* Copy size bytes from the old file to the new one. */
-
-copy_file(old, new, size)
- int new, old;
- int size;
-{
- int len;
- int buffer[8196]; /* word aligned will be faster */
-
- for (; size > 0; size -= len)
- {
- len = min(size, sizeof(buffer));
- if (read(old, buffer, len) != len)
- { perror("Read failure on a.out file"); exit(1); }
- if (write(new, buffer, len) != len)
- { perror("Write failure in a.out file"); exit(1); }
- }
-}
-
-/* Copy the rest of the file, up to EOF. */
-
-copy_rest(old, new)
- int new, old;
-{
- int buffer[4096];
- int len;
-
- /* Copy bytes until end of file or error */
- while ( (len = read(old, buffer, sizeof(buffer))) > 0)
- if (write(new, buffer, len) != len) break;
-
- if (len != 0)
- { perror("Unable to copy the rest of the file"); exit(1); }
-}
-
-#ifdef DEBUG
-display_header(hdr, auxhdr)
- struct header *hdr;
- struct som_exec_auxhdr *auxhdr;
-{
- /* Display the header information (debug) */
- printf("\n\nFILE HEADER\n");
- printf("magic number %d \n", hdr->a_magic);
- printf("text loc %.8x size %d \n", auxhdr->exec_tmem, auxhdr->exec_tsize);
- printf("data loc %.8x size %d \n", auxhdr->exec_dmem, auxhdr->exec_dsize);
- printf("entry %x \n", auxhdr->exec_entry);
- printf("Bss segment size %u\n", auxhdr->exec_bsize);
- printf("\n");
- printf("data file loc %d size %d\n",
- auxhdr->exec_dfile, auxhdr->exec_dsize);
- printf("som_length %d\n", hdr->som_length);
- printf("unloadable sploc %d size %d\n",
- hdr->unloadable_sp_location, hdr->unloadable_sp_size);
-}
-#endif /* DEBUG */
/* -*-C-*-
-$Id: unstackify.c,v 11.4 2007/04/17 06:02:14 cph Exp $
+$Id: unstackify.c,v 11.5 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <string.h>
#include <stdlib.h>
+#include <stdbool.h>
+#include <string.h>
#define LIARC_IN_MICROCODE
#include "liarc.h"
#include "stackops.h"
-#ifndef DEBUG_STACKIFY
-
-#define DEBUG(stmt) do { } while (0)
-#define CHECK_SP_UNDERFLOW() do { } while (0)
-#define CHECK_SP_OVERFLOW() do { } while (0)
-#define CHECK_STR_OVERRUN() do { } while (0)
-\f
-#else /* DEBUG_STACKIFY */
-
-#define DEBUG(stmt) do { if (debug_flag) stmt } while (0)
-
-static char * opcode_names[] =
-{
- "stackify-opcode/illegal",
- "stackify-opcode/escape",
- "stackify-opcode/push-+fixnum",
- "stackify-opcode/push--fixnum",
- "stackify-opcode/push-+integer",
- "stackify-opcode/push--integer",
- "stackify-opcode/push-false",
- "stackify-opcode/push-true",
- "stackify-opcode/push-nil",
- "stackify-opcode/push-flonum",
- "stackify-opcode/push-cons-ratnum",
- "stackify-opcode/push-cons-recnum",
- "stackify-opcode/push-string",
- "stackify-opcode/push-symbol",
- "stackify-opcode/push-uninterned-symbol",
- "stackify-opcode/push-char",
- "stackify-opcode/push-bit-string",
- "stackify-opcode/push-empty-cons",
- "stackify-opcode/pop-and-set-car",
- "stackify-opcode/pop-and-set-cdr",
- "stackify-opcode/push-cons*",
- "stackify-opcode/push-empty-vector",
- "stackify-opcode/pop-and-vector-set",
- "stackify-opcode/push-vector",
- "stackify-opcode/push-empty-record",
- "stackify-opcode/pop-and-record-set",
- "stackify-opcode/push-record",
- "stackify-opcode/push-lookup",
- "stackify-opcode/store",
- "stackify-opcode/push-constant",
- "stackify-opcode/push-unassigned",
- "stackify-opcode/push-primitive",
- "stackify-opcode/push-primitive-lexpr",
- "stackify-opcode/push-nm-header",
- "stackify-opcode/push-label-entry",
- "stackify-opcode/push-linkage-header-operator",
- "stackify-opcode/push-linkage-header-reference",
- "stackify-opcode/push-linkage-header-assignment",
- "stackify-opcode/push-linkage-header-global",
- "stackify-opcode/push-linkage-header-closure",
- "stackify-opcode/push-ulong",
- "stackify-opcode/push-label-descriptor",
- "stackify-opcode/cc-block-to-entry",
- "stackify-opcode/retag-cc-block",
- "stackify-opcode/push-return-code",
- "unknown-055",
- "unknown-056",
- "unknown-057",
- "unknown-060",
- "unknown-061",
- "unknown-062",
- "unknown-063",
- "unknown-064",
- "unknown-065",
- "unknown-066",
- "unknown-067",
- "unknown-070",
- "unknown-071",
- "unknown-072",
- "unknown-073",
- "unknown-074",
- "unknown-075",
- "unknown-076",
- "unknown-077",
- "unknown-0100",
- "unknown-0101",
- "unknown-0102",
- "unknown-0103",
- "unknown-0104",
- "unknown-0105",
- "unknown-0106",
- "unknown-0107",
- "unknown-0110",
- "unknown-0111",
- "unknown-0112",
- "unknown-0113",
- "unknown-0114",
- "unknown-0115",
- "unknown-0116",
- "unknown-0117",
- "unknown-0120",
- "unknown-0121",
- "unknown-0122",
- "unknown-0123",
- "unknown-0124",
- "unknown-0125",
- "unknown-0126",
- "unknown-0127",
- "unknown-0130",
- "unknown-0131",
- "unknown-0132",
- "unknown-0133",
- "unknown-0134",
- "unknown-0135",
- "unknown-0136",
- "unknown-0137",
- "unknown-0140",
- "unknown-0141",
- "unknown-0142",
- "unknown-0143",
- "unknown-0144",
- "unknown-0145",
- "unknown-0146",
- "unknown-0147",
- "unknown-0150",
- "unknown-0151",
- "unknown-0152",
- "unknown-0153",
- "unknown-0154",
- "unknown-0155",
- "unknown-0156",
- "unknown-0157",
- "unknown-0160",
- "unknown-0161",
- "unknown-0162",
- "unknown-0163",
- "unknown-0164",
- "unknown-0165",
- "unknown-0166",
- "unknown-0167",
- "unknown-0170",
- "unknown-0171",
- "unknown-0172",
- "unknown-0173",
- "unknown-0174",
- "unknown-0175",
- "unknown-0176",
- "unknown-0177",
- "stackify-opcode/push-0",
- "stackify-opcode/push-1",
- "stackify-opcode/push-2",
- "stackify-opcode/push-3",
- "stackify-opcode/push-4",
- "stackify-opcode/push-5",
- "stackify-opcode/push-6",
- "stackify-opcode/push--1",
- "stackify-opcode/push-cons*-0",
- "stackify-opcode/push-cons*-1",
- "stackify-opcode/push-cons*-2",
- "stackify-opcode/push-cons*-3",
- "stackify-opcode/push-cons*-4",
- "stackify-opcode/push-cons*-5",
- "stackify-opcode/push-cons*-6",
- "stackify-opcode/push-cons*-7",
- "stackify-opcode/pop-and-vector-set-0",
- "stackify-opcode/pop-and-vector-set-1",
- "stackify-opcode/pop-and-vector-set-2",
- "stackify-opcode/pop-and-vector-set-3",
- "stackify-opcode/pop-and-vector-set-4",
- "stackify-opcode/pop-and-vector-set-5",
- "stackify-opcode/pop-and-vector-set-6",
- "stackify-opcode/pop-and-vector-set-7",
- "stackify-opcode/push-vector-1",
- "stackify-opcode/push-vector-2",
- "stackify-opcode/push-vector-3",
- "stackify-opcode/push-vector-4",
- "stackify-opcode/push-vector-5",
- "stackify-opcode/push-vector-6",
- "stackify-opcode/push-vector-7",
- "stackify-opcode/push-vector-8",
- "stackify-opcode/pop-and-record-set-0",
- "stackify-opcode/pop-and-record-set-1",
- "stackify-opcode/pop-and-record-set-2",
- "stackify-opcode/pop-and-record-set-3",
- "stackify-opcode/pop-and-record-set-4",
- "stackify-opcode/pop-and-record-set-5",
- "stackify-opcode/pop-and-record-set-6",
- "stackify-opcode/pop-and-record-set-7",
- "stackify-opcode/push-record-1",
- "stackify-opcode/push-record-2",
- "stackify-opcode/push-record-3",
- "stackify-opcode/push-record-4",
- "stackify-opcode/push-record-5",
- "stackify-opcode/push-record-6",
- "stackify-opcode/push-record-7",
- "stackify-opcode/push-record-8",
- "stackify-opcode/push-lookup-0",
- "stackify-opcode/push-lookup-1",
- "stackify-opcode/push-lookup-2",
- "stackify-opcode/push-lookup-3",
- "stackify-opcode/push-lookup-4",
- "stackify-opcode/push-lookup-5",
- "stackify-opcode/push-lookup-6",
- "stackify-opcode/push-lookup-7",
- "stackify-opcode/store-0",
- "stackify-opcode/store-1",
- "stackify-opcode/store-2",
- "stackify-opcode/store-3",
- "stackify-opcode/store-4",
- "stackify-opcode/store-5",
- "stackify-opcode/store-6",
- "stackify-opcode/store-7",
- "stackify-opcode/push-primitive-0",
- "stackify-opcode/push-primitive-1",
- "stackify-opcode/push-primitive-2",
- "stackify-opcode/push-primitive-3",
- "stackify-opcode/push-primitive-4",
- "stackify-opcode/push-primitive-5",
- "stackify-opcode/push-primitive-6",
- "stackify-opcode/push-primitive-7",
- "unknown-0310",
- "unknown-0311",
- "unknown-0312",
- "unknown-0313",
- "unknown-0314",
- "unknown-0315",
- "unknown-0316",
- "unknown-0317",
- "unknown-0320",
- "unknown-0321",
- "unknown-0322",
- "unknown-0323",
- "unknown-0324",
- "unknown-0325",
- "unknown-0326",
- "unknown-0327",
- "unknown-0330",
- "unknown-0331",
- "unknown-0332",
- "unknown-0333",
- "unknown-0334",
- "unknown-0335",
- "unknown-0336",
- "unknown-0337",
- "unknown-0340",
- "unknown-0341",
- "unknown-0342",
- "unknown-0343",
- "unknown-0344",
- "unknown-0345",
- "unknown-0346",
- "unknown-0347",
- "unknown-0350",
- "unknown-0351",
- "unknown-0352",
- "unknown-0353",
- "unknown-0354",
- "unknown-0355",
- "unknown-0356",
- "unknown-0357",
- "unknown-0360",
- "unknown-0361",
- "unknown-0362",
- "unknown-0363",
- "unknown-0364",
- "unknown-0365",
- "unknown-0366",
- "unknown-0367",
- "unknown-0370",
- "unknown-0371",
- "unknown-0372",
- "unknown-0373",
- "unknown-0374",
- "unknown-0375",
- "unknown-0376",
- "unknown-0377",
-};
-
-#define CHECK_SP_UNDERFLOW() do \
-{ \
- if (sp > regmap) \
- abort (); \
-} while (0)
-
-#define CHECK_SP_OVERFLOW() do \
-{ \
- if (sp < stack_bot) \
- abort (); \
-} while (0)
+typedef struct
+{
+ unsigned char * strptr;
+ entry_count_t dispatch_base;
+ SCHEME_OBJECT * sp;
+ SCHEME_OBJECT * regmap;
+} stackify_context_s, * stackify_context_t;
-#define CHECK_STR_OVERRUN() do \
-{ \
- if (strptr > strptr_end) \
- abort (); \
-} while (0)
+static entry_count_t dispatch_base;
-int debug_flag = 0;
+static unsigned char * prog_start;
+static unsigned char * prog_end;
+static unsigned char * pc;
-static unsigned char * pc_start;
-static SCHEME_OBJECT * stack_bot;
-static unsigned char * strptr_end;
-static unsigned char * strptr_start;
+static unsigned char * string_start;
+static unsigned char * string_end;
+static unsigned char * strptr;
-static unsigned print_everything_count = 0;
+static SCHEME_OBJECT * sp_lower;
+static SCHEME_OBJECT * sp_upper;
+static SCHEME_OBJECT * sp;
-#endif /* DEBUG_STACKIFY */
+static SCHEME_OBJECT * regmap;
+static SCHEME_OBJECT * regmap_end;
\f
-typedef struct stackify_context_S
-{
- unsigned char * strptr;
- entry_count_t dispatch_base;
- SCHEME_OBJECT * sp;
- SCHEME_OBJECT * regmap;
-} stackify_context_s, * stackify_context_t;
-
-static unsigned char * strptr;
-static entry_count_t dispatch_base;
-static SCHEME_OBJECT * sp, * regmap;
+#ifdef ENABLE_DEBUGGING_TOOLS
+
+#undef NDEBUG
+#include <assert.h>
+
+static const char * opcode_names [] =
+{
+ "stackify-opcode/illegal",
+ "stackify-opcode/escape",
+ "stackify-opcode/push-+fixnum",
+ "stackify-opcode/push--fixnum",
+ "stackify-opcode/push-+integer",
+ "stackify-opcode/push--integer",
+ "stackify-opcode/push-false",
+ "stackify-opcode/push-true",
+ "stackify-opcode/push-nil",
+ "stackify-opcode/push-flonum",
+ "stackify-opcode/push-cons-ratnum",
+ "stackify-opcode/push-cons-recnum",
+ "stackify-opcode/push-string",
+ "stackify-opcode/push-symbol",
+ "stackify-opcode/push-uninterned-symbol",
+ "stackify-opcode/push-char",
+ "stackify-opcode/push-bit-string",
+ "stackify-opcode/push-empty-cons",
+ "stackify-opcode/pop-and-set-car",
+ "stackify-opcode/pop-and-set-cdr",
+ "stackify-opcode/push-cons*",
+ "stackify-opcode/push-empty-vector",
+ "stackify-opcode/pop-and-vector-set",
+ "stackify-opcode/push-vector",
+ "stackify-opcode/push-empty-record",
+ "stackify-opcode/pop-and-record-set",
+ "stackify-opcode/push-record",
+ "stackify-opcode/push-lookup",
+ "stackify-opcode/store",
+ "stackify-opcode/push-constant",
+ "stackify-opcode/push-unassigned",
+ "stackify-opcode/push-primitive",
+ "stackify-opcode/push-primitive-lexpr",
+ "stackify-opcode/push-nm-header",
+ "stackify-opcode/push-label-entry",
+ "stackify-opcode/push-linkage-header-operator",
+ "stackify-opcode/push-linkage-header-reference",
+ "stackify-opcode/push-linkage-header-assignment",
+ "stackify-opcode/push-linkage-header-global",
+ "stackify-opcode/push-linkage-header-closure",
+ "stackify-opcode/push-ulong",
+ "stackify-opcode/push-label-descriptor",
+ "stackify-opcode/cc-block-to-entry",
+ "stackify-opcode/retag-cc-block",
+ "stackify-opcode/push-return-code",
+ "unknown-055",
+ "unknown-056",
+ "unknown-057",
+ "unknown-060",
+ "unknown-061",
+ "unknown-062",
+ "unknown-063",
+ "unknown-064",
+ "unknown-065",
+ "unknown-066",
+ "unknown-067",
+ "unknown-070",
+ "unknown-071",
+ "unknown-072",
+ "unknown-073",
+ "unknown-074",
+ "unknown-075",
+ "unknown-076",
+ "unknown-077",
+ "unknown-0100",
+ "unknown-0101",
+ "unknown-0102",
+ "unknown-0103",
+ "unknown-0104",
+ "unknown-0105",
+ "unknown-0106",
+ "unknown-0107",
+ "unknown-0110",
+ "unknown-0111",
+ "unknown-0112",
+ "unknown-0113",
+ "unknown-0114",
+ "unknown-0115",
+ "unknown-0116",
+ "unknown-0117",
+ "unknown-0120",
+ "unknown-0121",
+ "unknown-0122",
+ "unknown-0123",
+ "unknown-0124",
+ "unknown-0125",
+ "unknown-0126",
+ "unknown-0127",
+ "unknown-0130",
+ "unknown-0131",
+ "unknown-0132",
+ "unknown-0133",
+ "unknown-0134",
+ "unknown-0135",
+ "unknown-0136",
+ "unknown-0137",
+ "unknown-0140",
+ "unknown-0141",
+ "unknown-0142",
+ "unknown-0143",
+ "unknown-0144",
+ "unknown-0145",
+ "unknown-0146",
+ "unknown-0147",
+ "unknown-0150",
+ "unknown-0151",
+ "unknown-0152",
+ "unknown-0153",
+ "unknown-0154",
+ "unknown-0155",
+ "unknown-0156",
+ "unknown-0157",
+ "unknown-0160",
+ "unknown-0161",
+ "unknown-0162",
+ "unknown-0163",
+ "unknown-0164",
+ "unknown-0165",
+ "unknown-0166",
+ "unknown-0167",
+ "unknown-0170",
+ "unknown-0171",
+ "unknown-0172",
+ "unknown-0173",
+ "unknown-0174",
+ "unknown-0175",
+ "unknown-0176",
+ "unknown-0177",
+ "stackify-opcode/push-0",
+ "stackify-opcode/push-1",
+ "stackify-opcode/push-2",
+ "stackify-opcode/push-3",
+ "stackify-opcode/push-4",
+ "stackify-opcode/push-5",
+ "stackify-opcode/push-6",
+ "stackify-opcode/push--1",
+ "stackify-opcode/push-cons*-0",
+ "stackify-opcode/push-cons*-1",
+ "stackify-opcode/push-cons*-2",
+ "stackify-opcode/push-cons*-3",
+ "stackify-opcode/push-cons*-4",
+ "stackify-opcode/push-cons*-5",
+ "stackify-opcode/push-cons*-6",
+ "stackify-opcode/push-cons*-7",
+ "stackify-opcode/pop-and-vector-set-0",
+ "stackify-opcode/pop-and-vector-set-1",
+ "stackify-opcode/pop-and-vector-set-2",
+ "stackify-opcode/pop-and-vector-set-3",
+ "stackify-opcode/pop-and-vector-set-4",
+ "stackify-opcode/pop-and-vector-set-5",
+ "stackify-opcode/pop-and-vector-set-6",
+ "stackify-opcode/pop-and-vector-set-7",
+ "stackify-opcode/push-vector-1",
+ "stackify-opcode/push-vector-2",
+ "stackify-opcode/push-vector-3",
+ "stackify-opcode/push-vector-4",
+ "stackify-opcode/push-vector-5",
+ "stackify-opcode/push-vector-6",
+ "stackify-opcode/push-vector-7",
+ "stackify-opcode/push-vector-8",
+ "stackify-opcode/pop-and-record-set-0",
+ "stackify-opcode/pop-and-record-set-1",
+ "stackify-opcode/pop-and-record-set-2",
+ "stackify-opcode/pop-and-record-set-3",
+ "stackify-opcode/pop-and-record-set-4",
+ "stackify-opcode/pop-and-record-set-5",
+ "stackify-opcode/pop-and-record-set-6",
+ "stackify-opcode/pop-and-record-set-7",
+ "stackify-opcode/push-record-1",
+ "stackify-opcode/push-record-2",
+ "stackify-opcode/push-record-3",
+ "stackify-opcode/push-record-4",
+ "stackify-opcode/push-record-5",
+ "stackify-opcode/push-record-6",
+ "stackify-opcode/push-record-7",
+ "stackify-opcode/push-record-8",
+ "stackify-opcode/push-lookup-0",
+ "stackify-opcode/push-lookup-1",
+ "stackify-opcode/push-lookup-2",
+ "stackify-opcode/push-lookup-3",
+ "stackify-opcode/push-lookup-4",
+ "stackify-opcode/push-lookup-5",
+ "stackify-opcode/push-lookup-6",
+ "stackify-opcode/push-lookup-7",
+ "stackify-opcode/store-0",
+ "stackify-opcode/store-1",
+ "stackify-opcode/store-2",
+ "stackify-opcode/store-3",
+ "stackify-opcode/store-4",
+ "stackify-opcode/store-5",
+ "stackify-opcode/store-6",
+ "stackify-opcode/store-7",
+ "stackify-opcode/push-primitive-0",
+ "stackify-opcode/push-primitive-1",
+ "stackify-opcode/push-primitive-2",
+ "stackify-opcode/push-primitive-3",
+ "stackify-opcode/push-primitive-4",
+ "stackify-opcode/push-primitive-5",
+ "stackify-opcode/push-primitive-6",
+ "stackify-opcode/push-primitive-7",
+ "unknown-0310",
+ "unknown-0311",
+ "unknown-0312",
+ "unknown-0313",
+ "unknown-0314",
+ "unknown-0315",
+ "unknown-0316",
+ "unknown-0317",
+ "unknown-0320",
+ "unknown-0321",
+ "unknown-0322",
+ "unknown-0323",
+ "unknown-0324",
+ "unknown-0325",
+ "unknown-0326",
+ "unknown-0327",
+ "unknown-0330",
+ "unknown-0331",
+ "unknown-0332",
+ "unknown-0333",
+ "unknown-0334",
+ "unknown-0335",
+ "unknown-0336",
+ "unknown-0337",
+ "unknown-0340",
+ "unknown-0341",
+ "unknown-0342",
+ "unknown-0343",
+ "unknown-0344",
+ "unknown-0345",
+ "unknown-0346",
+ "unknown-0347",
+ "unknown-0350",
+ "unknown-0351",
+ "unknown-0352",
+ "unknown-0353",
+ "unknown-0354",
+ "unknown-0355",
+ "unknown-0356",
+ "unknown-0357",
+ "unknown-0360",
+ "unknown-0361",
+ "unknown-0362",
+ "unknown-0363",
+ "unknown-0364",
+ "unknown-0365",
+ "unknown-0366",
+ "unknown-0367",
+ "unknown-0370",
+ "unknown-0371",
+ "unknown-0372",
+ "unknown-0373",
+ "unknown-0374",
+ "unknown-0375",
+ "unknown-0376",
+ "unknown-0377",
+};
-#ifdef DEBUG_STACKIFY
+static bool debug_trace_p = 0;
static void
-print_everything (stackify_opcode_t op, unsigned char * pc)
+debug_trace (void)
{
- if (print_everything_count == 0)
- printf ("stack_bot = 0x%08x"
- "; stack_base = 0x%08x"
- "; strptr_end = 0x%08x\n",
- ((unsigned) stack_bot),
- ((unsigned) regmap),
- ((unsigned) strptr_end));
-
- printf ("(opcode %s stack-depth %d pc %d strtab-ptr %d)\n",
- opcode_names[op],
- (regmap - sp),
- (pc - pc_start),
- (strptr - strptr_start));
- return;
+ if (debug_trace_p)
+ {
+ if (pc == prog_start)
+ fprintf (stderr,
+ "sp_lower = 0x%08x;"
+ " sp_upper = 0x%08x;"
+ " string_end = 0x%08x\n",
+ ((unsigned int) sp_lower),
+ ((unsigned int) sp_upper),
+ ((unsigned int) string_end));
+ fprintf (stderr,
+ "(opcode %s stack-depth %d pc %d strtab-ptr %d)\n",
+ (opcode_names[*pc]),
+ (sp_upper - sp),
+ (pc - prog_start),
+ (strptr - string_start));
+ }
}
-#endif /* DEBUG_STACKIFY */
-
+#endif /* ENABLE_DEBUGGING_TOOLS */
+\f
static inline SCHEME_OBJECT
-DEFUN_VOID (unstackify_pop)
+unstackify_pop (void)
{
- SCHEME_OBJECT res = (* sp);
-
- sp += 1;
- CHECK_SP_UNDERFLOW ();
- return (res);
+ assert (sp < sp_upper);
+ return (*sp++);
}
static inline SCHEME_OBJECT
-DEFUN_VOID (unstackify_tos)
+unstackify_tos (void)
{
- return (* sp);
+ assert (sp < sp_upper);
+ return (*sp);
}
static inline void
-DEFUN (unstackify_push, (object), SCHEME_OBJECT object)
+unstackify_push (SCHEME_OBJECT object)
{
- sp -= 1;
- CHECK_SP_OVERFLOW ();
- (* sp) = object;
- return;
+ assert (sp > sp_lower);
+ (*--sp) = object;
}
-\f
+
/* Note: The encoded value is one greater than the actual value,
so that the encoding of a ulong never uses a null character.
- Thus we subtract one after decoding.
-*/
+ Thus we subtract one after decoding. */
static unsigned long
-DEFUN_VOID (unstackify_read_ulong)
-{
- unsigned shift = 0;
- unsigned long value = 0;
- unsigned char byte, * ptr = strptr;
-
- CHECK_STR_OVERRUN ();
-
- do
+unstackify_read_ulong (void)
+{
+ unsigned int shift = 0;
+ unsigned long value = 0;
+#ifdef ENABLE_DEBUGGING_TOOLS
+ unsigned long sentinel = 1;
+#endif
+ while (true)
{
- byte = (* ptr++);
- value = (value | ((byte & 0x7f) << shift));
- shift += 7;
- } while ((byte & 0x80) != 0);
-
- strptr = ptr;
- return (value - 1);
+ unsigned char byte = (*strptr++);
+ assert (strptr <= string_end);
+ value |= ((byte & 0x7f) << shift);
+ if ((byte & 0x80) == 0)
+ break;
+ assert ((sentinel <<= 7) != 0);
+ shift += 7;
+ }
+ return (value - 1);
}
-static unsigned char *
-DEFUN (unstackify_read_string, (plen), unsigned long * plen)
+static char *
+unstackify_read_string (unsigned long * plen)
{
- unsigned long len;
- unsigned char * res;
-
- len = (unstackify_read_ulong ());
- res = strptr;
- strptr = (res + len);
- (* plen) = len;
- return (res);
+ unsigned long len = (unstackify_read_ulong ());
+ char * res = ((char *) strptr);
+ assert ((strptr + len) <= string_end);
+ strptr += len;
+ (*plen) = len;
+ return (res);
}
/* This returns a newly allocated string */
static char *
-DEFUN_VOID (unstackify_read_C_string)
+unstackify_read_C_string (void)
{
- char * str;
- unsigned long len;
- unsigned char * temp;
-
- temp = (unstackify_read_string (& len));
- str = ((char *) (malloc (len + 1)));
- memcpy (str, temp, len);
- str[len] = '\0';
- return (str);
+ unsigned long len;
+ char * temp = (unstackify_read_string (&len));
+ char * str = (malloc (len + 1));
+ memcpy (str, temp, len);
+ (str[len]) = '\0';
+ return (str);
}
\f
static void
-DEFUN (unstackify_push_consS, (N), unsigned long N)
+unstackify_push_consS (unsigned long N)
{
- unsigned long i;
- SCHEME_OBJECT kar, kdr;
+ unsigned long i;
+ SCHEME_OBJECT kar;
+ SCHEME_OBJECT kdr = (unstackify_pop ());
- kdr = (unstackify_pop ());
- for (i = 0; (i <= N); i++)
+ for (i = 0; (i <= N); i += 1)
{
- kar = (unstackify_pop ());
- kdr = (CONS (kar, kdr));
+ kar = (unstackify_pop ());
+ kdr = (CONS (kar, kdr));
}
- unstackify_push (kdr);
+ unstackify_push (kdr);
}
static void
-DEFUN (unstackify_pop_and_set_cXr, (N), unsigned long N)
+unstackify_pop_and_set_cXr (unsigned long N)
{
- SCHEME_OBJECT cXr, pair;
-
- cXr = (unstackify_pop ());
- pair = (unstackify_tos ());
- FAST_MEMORY_SET (pair, N, cXr);
+ SCHEME_OBJECT cXr = (unstackify_pop ());
+ SCHEME_OBJECT pair = (unstackify_tos ());
+ MEMORY_SET (pair, N, cXr);
}
static void
-DEFUN (unstackify_push_empty_vector, (N), unsigned long N)
+unstackify_push_empty_vector (unsigned long N)
{
- SCHEME_OBJECT res;
-
- res = (ALLOCATE_VECTOR (N));
- unstackify_push (res);
+ SCHEME_OBJECT res = (ALLOCATE_VECTOR (N));
+ unstackify_push (res);
}
static void
-DEFUN (unstackify_pop_and_vector_set, (N), unsigned long N)
+unstackify_pop_and_vector_set (unsigned long N)
{
- SCHEME_OBJECT el, vec;
-
- el = (unstackify_pop ());
- vec = (unstackify_tos ());
- VECTOR_SET (vec, N, el);
+ SCHEME_OBJECT el = (unstackify_pop ());
+ SCHEME_OBJECT vec = (unstackify_tos ());
+ VECTOR_SET (vec, N, el);
}
static void
-DEFUN (unstackify_push_vector, (N), unsigned long N)
+unstackify_push_vector (unsigned long N)
{
- unsigned long i;
- SCHEME_OBJECT el, vec;
+ SCHEME_OBJECT vec = (ALLOCATE_VECTOR (N));
+ unsigned long i;
- vec = (ALLOCATE_VECTOR (N));
- for (i = 0; (i < N); i++)
- {
- el = (unstackify_pop ());
- VECTOR_SET (vec, i, el);
- }
+ for (i = 0; (i < N); i += 1)
+ VECTOR_SET (vec, i, (unstackify_pop ()));
- unstackify_push (vec);
+ unstackify_push (vec);
}
static void
-DEFUN (unstackify_push_empty_record, (N), unsigned long N)
+unstackify_push_empty_record (unsigned long N)
{
- SCHEME_OBJECT res;
-
- res = (ALLOCATE_RECORD (N));
- unstackify_push (res);
+ unstackify_push (ALLOCATE_RECORD (N));
}
static void
-DEFUN (unstackify_pop_and_record_set, (N), unsigned long N)
+unstackify_pop_and_record_set (unsigned long N)
{
- SCHEME_OBJECT el, rec;
-
- el = (unstackify_pop ());
- rec = (unstackify_tos ());
- RECORD_SET (rec, N, el);
+ SCHEME_OBJECT el = (unstackify_pop ());
+ SCHEME_OBJECT rec = (unstackify_tos ());
+ RECORD_SET (rec, N, el);
}
static void
-DEFUN (unstackify_push_record, (N), unsigned long N)
+unstackify_push_record (unsigned long N)
{
- unsigned long i;
- SCHEME_OBJECT el, rec;
+ SCHEME_OBJECT rec = (ALLOCATE_RECORD (N));
+ unsigned long i;
- rec = (ALLOCATE_RECORD (N));
- for (i = 0; (i < N); i++)
- {
- el = (unstackify_pop ());
- RECORD_SET (rec, i, el);
- }
+ for (i = 0; (i < N); i++)
+ RECORD_SET (rec, i, (unstackify_pop ()));
- unstackify_push (rec);
+ unstackify_push (rec);
}
static inline void
-DEFUN (unstackify_push_lookup, (N), unsigned long N)
+unstackify_push_lookup (unsigned long N)
{
- unstackify_push (regmap[N]);
+ assert ((regmap + N) < regmap_end);
+ unstackify_push (regmap[N]);
}
static inline void
-DEFUN (unstackify_store, (N), unsigned long N)
+unstackify_store (unsigned long N)
{
- regmap[N] = (unstackify_tos ());
+ assert ((regmap + N) < regmap_end);
+ (regmap[N]) = (unstackify_tos ());
}
static void
-DEFUN (unstackify_push_primitive, (N), long N)
+unstackify_push_primitive (long N)
{
- char * prim_name;
- SCHEME_OBJECT res;
-
- prim_name = (unstackify_read_C_string ());
- res = (MAKE_PRIMITIVE_PROCEDURE (prim_name, N));
- free (prim_name);
- unstackify_push (res);
+ const char * prim_name = (unstackify_read_C_string ());
+ SCHEME_OBJECT res = (MAKE_PRIMITIVE_PROCEDURE (prim_name, N));
+ free ((void *) prim_name);
+ unstackify_push (res);
}
\f
static inline void
-DEFUN (unstackify_undefined_opcode, (op), stackify_opcode_t op)
+unstackify_undefined_opcode (stackify_opcode_t op)
{
- outf_fatal ("unstackify/undefined_opcode invoked.\n");
+ outf_fatal ("unstackify/undefined_opcode invoked.\n");
}
static void
-DEFUN (stackify_push_ulong, (op), stackify_opcode_t op)
+stackify_push_ulong (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push ((SCHEME_OBJECT) N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push ((SCHEME_OBJECT) N);
}
static void
-DEFUN (stackify_push_Pfixnum, (op), stackify_opcode_t op)
+stackify_push_Pfixnum (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
- long val = ((long) (N));
-
- unstackify_push (LONG_TO_FIXNUM (val));
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push (ULONG_TO_FIXNUM (N));
}
static void
-DEFUN (stackify_push__fixnum, (op), stackify_opcode_t op)
+stackify_push__fixnum (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
- long val = (0 - ((long) N));
-
- unstackify_push (LONG_TO_FIXNUM (val));
+ long val = (0 - ((long) (unstackify_read_ulong ())));
+ unstackify_push (LONG_TO_FIXNUM (val));
}
static void
-DEFUN (stackify_push_Pinteger, (op), stackify_opcode_t op)
+stackify_push_Pinteger (stackify_opcode_t op)
{
- unsigned long len;
- SCHEME_OBJECT res;
- unsigned char * digits;
-
- digits = (unstackify_read_string (& len));
- res = (DIGIT_STRING_TO_INTEGER (false, len, digits));
-
- unstackify_push (res);
+ unsigned long len;
+ char * digits = (unstackify_read_string (&len));
+ unstackify_push (DIGIT_STRING_TO_INTEGER (false, len, digits));
}
static void
-DEFUN (stackify_push__integer, (op), stackify_opcode_t op)
+stackify_push__integer (stackify_opcode_t op)
{
- unsigned long len;
- SCHEME_OBJECT res;
- unsigned char * digits;
-
- digits = (unstackify_read_string (& len));
- res = (DIGIT_STRING_TO_INTEGER (true, len, digits));
-
- unstackify_push (res);
+ unsigned long len;
+ char * digits = (unstackify_read_string (&len));
+ unstackify_push (DIGIT_STRING_TO_INTEGER (true, len, digits));
}
static inline void
-DEFUN (stackify_push_false, (op), stackify_opcode_t op)
+stackify_push_false (stackify_opcode_t op)
{
- unstackify_push (SHARP_F);
+ unstackify_push (SHARP_F);
}
static inline void
-DEFUN (stackify_push_true, (op), stackify_opcode_t op)
+stackify_push_true (stackify_opcode_t op)
{
- unstackify_push (SHARP_T);
+ unstackify_push (SHARP_T);
}
static inline void
-DEFUN (stackify_push_nil, (op), stackify_opcode_t op)
+stackify_push_nil (stackify_opcode_t op)
{
- unstackify_push (EMPTY_LIST);
+ unstackify_push (EMPTY_LIST);
}
static void
-DEFUN (stackify_push_flonum, (op), stackify_opcode_t op)
+stackify_push_flonum (stackify_opcode_t op)
{
- double val;
- SCHEME_OBJECT res;
- char * str = (unstackify_read_C_string ());
-
- val = (strtod (((CONST char *) str), ((char **) NULL)));
- res = (DOUBLE_TO_FLONUM (val));
- free (str);
- unstackify_push (res);
+ char * str = (unstackify_read_C_string ());
+ double val = (strtod (str, 0));
+ free (str);
+ unstackify_push (DOUBLE_TO_FLONUM (val));
}
static void
-DEFUN (stackify_push_cons_ratnum, (op), stackify_opcode_t op)
+stackify_push_cons_ratnum (stackify_opcode_t op)
{
- SCHEME_OBJECT num, den, res;
-
- den = (unstackify_pop ());
- num = (unstackify_pop ());
- res = (MAKE_RATIO (num, den));
- unstackify_push (res);
+ SCHEME_OBJECT den = (unstackify_pop ());
+ SCHEME_OBJECT num = (unstackify_pop ());
+ unstackify_push (MAKE_RATIO (num, den));
}
static void
-DEFUN (stackify_push_cons_recnum, (op), stackify_opcode_t op)
+stackify_push_cons_recnum (stackify_opcode_t op)
{
- SCHEME_OBJECT real, imag, res;
-
- imag = (unstackify_pop ());
- real = (unstackify_pop ());
- res = (MAKE_COMPLEX (real, imag));
- unstackify_push (res);
+ SCHEME_OBJECT real = (unstackify_pop ());
+ SCHEME_OBJECT imag = (unstackify_pop ());
+ unstackify_push (MAKE_COMPLEX (real, imag));
}
static void
-DEFUN (stackify_push_string, (op), stackify_opcode_t op)
+stackify_push_string (stackify_opcode_t op)
{
- unsigned long len;
- SCHEME_OBJECT res;
- unsigned char * str;
-
- str = (unstackify_read_string (& len));
- res = (C_STRING_TO_SCHEME_STRING (len, ((CONST unsigned char *) str)));
- unstackify_push (res);
+ unsigned long len;
+ char * str = (unstackify_read_string (&len));
+ unstackify_push (C_STRING_TO_SCHEME_STRING (len, str));
}
static void
-DEFUN (stackify_push_symbol, (op), stackify_opcode_t op)
+stackify_push_symbol (stackify_opcode_t op)
{
- unsigned long len;
- SCHEME_OBJECT res;
- unsigned char * str;
-
- str = (unstackify_read_string (& len));
- res = (C_SYM_INTERN (len, str));
- unstackify_push (res);
+ unsigned long len;
+ char * str = (unstackify_read_string (&len));
+ unstackify_push (C_SYM_INTERN (len, str));
}
static void
-DEFUN (stackify_push_uninterned_symbol, (op), stackify_opcode_t op)
+stackify_push_uninterned_symbol (stackify_opcode_t op)
{
- unsigned long len;
- SCHEME_OBJECT res;
- unsigned char * str;
-
- str = (unstackify_read_string (& len));
- res = (C_TO_UNINTERNED_SYMBOL (len, str));
- unstackify_push (res);
+ unsigned long len;
+ char * str = (unstackify_read_string (&len));
+ unstackify_push (C_TO_UNINTERNED_SYMBOL (len, str));
}
static void
-DEFUN (stackify_push_char, (op), stackify_opcode_t op)
+stackify_push_char (stackify_opcode_t op)
{
- SCHEME_OBJECT res;
- unsigned long bits, code;
-
- bits = (unstackify_read_ulong ());
- code = (unstackify_read_ulong ());
- res = (MAKE_CHAR (bits, code));
- unstackify_push (res);
+ unsigned long bits = (unstackify_read_ulong ());
+ unsigned long code = (unstackify_read_ulong ());
+ unstackify_push (MAKE_CHAR (bits, code));
}
static void
-DEFUN (stackify_push_bit_string, (op), stackify_opcode_t op)
+stackify_push_bit_string (stackify_opcode_t op)
{
- SCHEME_OBJECT res;
- unsigned char * digits;
- unsigned long n_bits, len;
-
- n_bits = (unstackify_read_ulong ());
- digits = (unstackify_read_string (& len));
- res = (DIGIT_STRING_TO_BIT_STRING (n_bits, len, digits));
- unstackify_push (res);
+ unsigned long n_bits = (unstackify_read_ulong ());
+ unsigned long len;
+ char * digits = (unstackify_read_string (&len));
+ unstackify_push (DIGIT_STRING_TO_BIT_STRING (n_bits, len, digits));
}
static void
-DEFUN (stackify_push_empty_cons, (op), stackify_opcode_t op)
+stackify_push_empty_cons (stackify_opcode_t op)
{
- SCHEME_OBJECT res;
-
- res = (CONS (SHARP_F, SHARP_F));
- unstackify_push (res);
+ unstackify_push (CONS (SHARP_F, SHARP_F));
}
static inline void
-DEFUN (stackify_pop_and_set_car, (op), stackify_opcode_t op)
+stackify_pop_and_set_car (stackify_opcode_t op)
{
- unstackify_pop_and_set_cXr (CONS_CAR);
+ unstackify_pop_and_set_cXr (CONS_CAR);
}
static inline void
-DEFUN (stackify_pop_and_set_cdr, (op), stackify_opcode_t op)
+stackify_pop_and_set_cdr (stackify_opcode_t op)
{
- unstackify_pop_and_set_cXr (CONS_CDR);
+ unstackify_pop_and_set_cXr (CONS_CDR);
}
static void
-DEFUN (stackify_push_consS, (op), stackify_opcode_t op)
+stackify_push_consS (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push_consS (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push_consS (N);
}
static void
-DEFUN (stackify_push_empty_vector, (op), stackify_opcode_t op)
+stackify_push_empty_vector (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push_empty_vector (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push_empty_vector (N);
}
static void
-DEFUN (stackify_pop_and_vector_set, (op), stackify_opcode_t op)
+stackify_pop_and_vector_set (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_pop_and_vector_set (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_pop_and_vector_set (N);
}
static void
-DEFUN (stackify_push_vector, (op), stackify_opcode_t op)
+stackify_push_vector (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push_vector (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push_vector (N);
}
static void
-DEFUN (stackify_push_empty_record, (op), stackify_opcode_t op)
+stackify_push_empty_record (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push_empty_record (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push_empty_record (N);
}
static void
-DEFUN (stackify_pop_and_record_set, (op), stackify_opcode_t op)
+stackify_pop_and_record_set (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_pop_and_record_set (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_pop_and_record_set (N);
}
static void
-DEFUN (stackify_push_record, (op), stackify_opcode_t op)
+stackify_push_record (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push_record (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push_record (N);
}
static void
-DEFUN (stackify_push_lookup, (op), stackify_opcode_t op)
+stackify_push_lookup (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push_lookup (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push_lookup (N);
}
static void
-DEFUN (stackify_store, (op), stackify_opcode_t op)
+stackify_store (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_store (N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_store (N);
}
static void
-DEFUN (stackify_push_constant, (op), stackify_opcode_t op)
+stackify_push_constant (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push (MAKE_OBJECT (TC_CONSTANT, N));
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push (MAKE_OBJECT (TC_CONSTANT, N));
}
static inline void
-DEFUN (stackify_push_unassigned, (op), stackify_opcode_t op)
+stackify_push_unassigned (stackify_opcode_t op)
{
- unstackify_push (UNASSIGNED_OBJECT);
+ unstackify_push (UNASSIGNED_OBJECT);
}
static void
-DEFUN (stackify_push_primitive, (op), stackify_opcode_t op)
+stackify_push_primitive (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push_primitive ((long) N);
+ unsigned long N = (unstackify_read_ulong ());
+ unstackify_push_primitive ((long) N);
}
static inline void
-DEFUN (stackify_push_primitive_lexpr, (op), stackify_opcode_t op)
+stackify_push_primitive_lexpr (stackify_opcode_t op)
{
- unstackify_push_primitive (-1);
+ unstackify_push_primitive (-1);
}
static void
-DEFUN (stackify_push_N, (op), stackify_opcode_t op)
+stackify_push_N (stackify_opcode_t op)
{
- unsigned long N = (op - stackify_opcode_push_0);
-
- unstackify_push (LONG_TO_FIXNUM (N));
+ unstackify_push (ULONG_TO_FIXNUM (op - stackify_opcode_push_0));
}
static void
-DEFUN (stackify_push__1, (op), stackify_opcode_t op)
+stackify_push__1 (stackify_opcode_t op)
{
- unstackify_push (LONG_TO_FIXNUM (-1));
+ unstackify_push (LONG_TO_FIXNUM (-1));
}
static inline void
-DEFUN (stackify_push_consS_N, (op), stackify_opcode_t op)
+stackify_push_consS_N (stackify_opcode_t op)
{
- unsigned long N = (op - stackify_opcode_push_consS_0);
-
- unstackify_push_consS (N);
+ unstackify_push_consS (op - stackify_opcode_push_consS_0);
}
static inline void
-DEFUN (stackify_pop_and_vector_set_N, (op), stackify_opcode_t op)
+stackify_pop_and_vector_set_N (stackify_opcode_t op)
{
- unsigned long N = (op - stackify_opcode_pop_and_vector_set_0);
-
- unstackify_pop_and_vector_set (N);
+ unstackify_pop_and_vector_set (op - stackify_opcode_pop_and_vector_set_0);
}
static inline void
-DEFUN (stackify_push_vector_N, (op), stackify_opcode_t op)
+stackify_push_vector_N (stackify_opcode_t op)
{
- unsigned long N = (1 + (op - stackify_opcode_push_vector_1));
-
- unstackify_push_vector (N);
+ unstackify_push_vector (1 + (op - stackify_opcode_push_vector_1));
}
static inline void
-DEFUN (stackify_pop_and_record_set_N, (op), stackify_opcode_t op)
+stackify_pop_and_record_set_N (stackify_opcode_t op)
{
- unsigned long N = (op - stackify_opcode_pop_and_record_set_0);
-
- unstackify_pop_and_record_set (N);
+ unstackify_pop_and_record_set (op - stackify_opcode_pop_and_record_set_0);
}
static inline void
-DEFUN (stackify_push_record_N, (op), stackify_opcode_t op)
+stackify_push_record_N (stackify_opcode_t op)
{
- unsigned long N = (1 + (op - stackify_opcode_push_record_1));
-
- unstackify_push_record (N);
+ unstackify_push_record (1 + (op - stackify_opcode_push_record_1));
}
static inline void
-DEFUN (stackify_push_lookup_N, (op), stackify_opcode_t op)
+stackify_push_lookup_N (stackify_opcode_t op)
{
- unsigned long N = (op - stackify_opcode_push_lookup_0);
-
- unstackify_push_lookup (N);
+ unstackify_push_lookup (op - stackify_opcode_push_lookup_0);
}
static inline void
-DEFUN (stackify_store_N, (op), stackify_opcode_t op)
+stackify_store_N (stackify_opcode_t op)
{
- unsigned long N = (op - stackify_opcode_store_0);
-
- unstackify_store (N);
+ unstackify_store (op - stackify_opcode_store_0);
}
static inline void
-DEFUN (stackify_push_primitive_N, (op), stackify_opcode_t op)
+stackify_push_primitive_N (stackify_opcode_t op)
{
- unsigned long N = (op - stackify_opcode_push_primitive_0);
-
- unstackify_push_primitive (N);
+ unstackify_push_primitive (op - stackify_opcode_push_primitive_0);
}
\f
static void
-DEFUN (stackify_push_nm_header, (op), stackify_opcode_t op)
+stackify_push_nm_header (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, N));
+ unstackify_push
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (unstackify_read_ulong ())));
}
static void
-DEFUN (stackify_push_label_entry, (op), stackify_opcode_t op)
+stackify_push_label_entry (stackify_opcode_t op)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push ((SCHEME_OBJECT)
- (((unsigned long) dispatch_base) + N));
+ unstackify_push
+ ((SCHEME_OBJECT)
+ (((unsigned long) dispatch_base)
+ + (unstackify_read_ulong ())));
}
-union kludge_u
-{
- SCHEME_OBJECT obj;
- format_word arr[sizeof (SCHEME_OBJECT)/sizeof(format_word)];
-};
-
static void
-DEFUN (stackify_push_label_descriptor, (op), stackify_opcode_t op)
+stackify_push_label_descriptor (stackify_opcode_t op)
{
- unsigned long offset = (unstackify_read_ulong ());
- unsigned long code_word = (unstackify_read_ulong ());
- union kludge_u temp[2], * ptr;
-
- temp[0].obj = ((SCHEME_OBJECT) 0);
- temp[1].obj = ((SCHEME_OBJECT) 0);
- ptr = (& temp[1]);
- WRITE_LABEL_DESCRIPTOR (ptr, code_word, offset);
- unstackify_push (temp[0].obj);
+ unsigned long offset = (unstackify_read_ulong ());
+ unsigned long code_word = (unstackify_read_ulong ());
+ unstackify_push (MAKE_LABEL_DESCRIPTOR (code_word, offset));
}
static void
-DEFUN (stackify_retag_cc_block, (op), stackify_opcode_t op)
+stackify_retag_cc_block (stackify_opcode_t op)
{
- SCHEME_OBJECT vec = (unstackify_pop ());
-
- unstackify_push (OBJECT_NEW_TYPE (TC_COMPILED_CODE_BLOCK, vec));
+ unstackify_push
+ (OBJECT_NEW_TYPE (TC_COMPILED_CODE_BLOCK, (unstackify_pop ())));
}
static void
-DEFUN (stackify_cc_block_to_entry, (op), stackify_opcode_t op)
+stackify_cc_block_to_entry (stackify_opcode_t op)
{
- unsigned long offset = (unstackify_read_ulong ());
- SCHEME_OBJECT block = (unstackify_pop ());
-
- unstackify_push (CC_BLOCK_TO_ENTRY (block, offset));
+ unsigned long offset = (unstackify_read_ulong ());
+ SCHEME_OBJECT block = (unstackify_pop ());
+ unstackify_push (CC_BLOCK_TO_ENTRY (block, offset));
}
static void
-DEFUN (stackify_push_return_code, (op), stackify_opcode_t op)
+stackify_push_return_code (stackify_opcode_t op)
{
- unsigned long datum = (unstackify_read_ulong ());
-
- unstackify_push (MAKE_OBJECT (TC_RETURN_CODE, datum));
+ unstackify_push (MAKE_OBJECT (TC_RETURN_CODE, (unstackify_read_ulong ())));
}
\f
static void
-DEFUN (unstackify_push_linkage_header, (kind), unsigned long kind)
+unstackify_push_linkage_header (linkage_section_type_t type)
{
- unsigned long N = (unstackify_read_ulong ());
-
- unstackify_push (MAKE_LINKER_HEADER (kind, N));
+ unstackify_push (MAKE_LINKER_HEADER (type, (unstackify_read_ulong ())));
}
static void
-DEFUN (stackify_push_linkage_header_operator, (op), stackify_opcode_t op)
+stackify_push_linkage_header_operator (stackify_opcode_t op)
{
- unstackify_push_linkage_header (OPERATOR_LINKAGE_KIND);
+ unstackify_push_linkage_header (LINKAGE_SECTION_TYPE_OPERATOR);
}
static void
-DEFUN (stackify_push_linkage_header_reference, (op), stackify_opcode_t op)
+stackify_push_linkage_header_reference (stackify_opcode_t op)
{
- unstackify_push_linkage_header (REFERENCE_LINKAGE_KIND);
+ unstackify_push_linkage_header (LINKAGE_SECTION_TYPE_REFERENCE);
}
static void
-DEFUN (stackify_push_linkage_header_assignment, (op), stackify_opcode_t op)
+stackify_push_linkage_header_assignment (stackify_opcode_t op)
{
- unstackify_push_linkage_header (ASSIGNMENT_LINKAGE_KIND);
+ unstackify_push_linkage_header (LINKAGE_SECTION_TYPE_ASSIGNMENT);
}
static void
-DEFUN (stackify_push_linkage_header_global, (op), stackify_opcode_t op)
+stackify_push_linkage_header_global (stackify_opcode_t op)
{
- unstackify_push_linkage_header (GLOBAL_OPERATOR_LINKAGE_KIND);
+ unstackify_push_linkage_header (LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR);
}
static void
-DEFUN (stackify_push_linkage_header_closure, (op), stackify_opcode_t op)
+stackify_push_linkage_header_closure (stackify_opcode_t op)
{
- outf_fatal ("stackify_push_linkage_header_closure.\n");
+ outf_fatal ("stackify_push_linkage_header_closure.\n");
}
\f
static void
-DEFUN (unstackify_save_context, (context), stackify_context_t context)
+unstackify_save_context (stackify_context_t context)
{
- context->strptr = strptr;
- context->dispatch_base = dispatch_base;
- context->sp = sp;
- context->regmap = regmap;
- return;
+ (context->strptr) = strptr;
+ (context->dispatch_base) = dispatch_base;
+ (context->sp) = sp;
+ (context->regmap) = regmap;
}
static void
-DEFUN (unstackify_restore_context, (context), stackify_context_t context)
+unstackify_restore_context (stackify_context_t context)
{
- strptr = (context->strptr);
- dispatch_base = (context->dispatch_base);
- sp = (context->sp);
- regmap = (context->regmap);
- return;
+ strptr = (context->strptr);
+ dispatch_base = (context->dispatch_base);
+ sp = (context->sp);
+ regmap = (context->regmap);
}
SCHEME_OBJECT
-DEFUN (unstackify, (bytes, n_bytes, db),
- unsigned char * bytes
- AND unsigned long n_bytes
- AND entry_count_t db)
-{
- unsigned char op;
- SCHEME_OBJECT result;
- SCHEME_OBJECT * scratch;
- unsigned char * pc, * progstart, * progend;
- unsigned long stack_depth, regmap_size, proglen;
- stackify_context_s context;
+unstackify (unsigned char * bytes, size_t n_bytes, entry_count_t db)
+{
+ unsigned char op;
+ SCHEME_OBJECT result;
+ SCHEME_OBJECT * scratch;
+ unsigned long stack_length;
+ unsigned long regmap_length;
+ unsigned long prog_length;
+ stackify_context_s context;
- unstackify_save_context (& context);
+ unstackify_save_context (& context);
+
+ /* Read the header */
- /* Read the header */
+ string_start = bytes;
+ string_end = (bytes + n_bytes);
+ strptr = string_start;
- strptr = bytes;
- DEBUG (strptr_end = (bytes + 4357));
+ stack_length = (unstackify_read_ulong ());
+ regmap_length = (unstackify_read_ulong ());
+ prog_length = (unstackify_read_ulong ());
- stack_depth = (unstackify_read_ulong ());
- regmap_size = (unstackify_read_ulong ());
- proglen = (unstackify_read_ulong ());
+ /* Set up for execution */
- /* Set up for execution */
+ prog_start = strptr;
+ prog_end = (prog_start + prog_length);
+ pc = prog_start;
+
+ string_start = prog_end;
+ strptr = string_start;
- scratch = ((SCHEME_OBJECT *) (malloc ((stack_depth + regmap_size)
- * (sizeof (SCHEME_OBJECT)))));
+ scratch = (malloc ((stack_length + regmap_length) * SIZEOF_SCHEME_OBJECT));
+ if (scratch == 0)
+ return (SHARP_F);
- if (scratch == ((SCHEME_OBJECT *) NULL))
- return (SHARP_F);
+ sp_lower = scratch;
+ sp_upper = (sp_lower + stack_length);
+ sp = sp_upper;
- regmap = (scratch + stack_depth);
- sp = regmap;
- DEBUG (stack_bot = scratch);
+ regmap = sp_upper;
+ regmap_end = (regmap + regmap_length);
- progstart = strptr;
- progend = (progstart + proglen);
- strptr = progend;
- dispatch_base = db;
+ dispatch_base = db;
- DEBUG (pc_start = progstart);
- DEBUG (strptr_start = progend);
- DEBUG (print_everything_count = 0);
-\f
- /* Now, execute the program */
+ /* Now, execute the program */
- for (pc = progstart; (pc < progend); pc++)
+ while (pc < prog_end)
{
- op = ((stackify_opcode_t) (* pc));
- DEBUG (print_everything (op, pc));
- switch (op)
+#ifdef ENABLE_DEBUGGING_TOOLS
+ debug_trace ();
+#endif
+ op = ((stackify_opcode_t) (*pc++));
+ switch (op)
{
default:
case stackify_opcode_illegal:
case stackify_opcode_escape:
- unstackify_undefined_opcode (op);
- break;
+ unstackify_undefined_opcode (op);
+ break;
case stackify_opcode_push_Pfixnum:
- stackify_push_Pfixnum (op);
- break;
+ stackify_push_Pfixnum (op);
+ break;
case stackify_opcode_push__fixnum:
- stackify_push__fixnum (op);
- break;
+ stackify_push__fixnum (op);
+ break;
case stackify_opcode_push_Pinteger:
- stackify_push_Pinteger (op);
- break;
+ stackify_push_Pinteger (op);
+ break;
case stackify_opcode_push__integer:
- stackify_push__integer (op);
- break;
+ stackify_push__integer (op);
+ break;
case stackify_opcode_push_false:
- stackify_push_false (op);
- break;
+ stackify_push_false (op);
+ break;
case stackify_opcode_push_true:
- stackify_push_true (op);
- break;
+ stackify_push_true (op);
+ break;
case stackify_opcode_push_nil:
- stackify_push_nil (op);
- break;
+ stackify_push_nil (op);
+ break;
case stackify_opcode_push_flonum:
- stackify_push_flonum (op);
- break;
+ stackify_push_flonum (op);
+ break;
case stackify_opcode_push_cons_ratnum:
- stackify_push_cons_ratnum (op);
- break;
+ stackify_push_cons_ratnum (op);
+ break;
case stackify_opcode_push_cons_recnum:
- stackify_push_cons_recnum (op);
- break;
+ stackify_push_cons_recnum (op);
+ break;
case stackify_opcode_push_string:
- stackify_push_string (op);
- break;
+ stackify_push_string (op);
+ break;
case stackify_opcode_push_symbol:
- stackify_push_symbol (op);
- break;
+ stackify_push_symbol (op);
+ break;
case stackify_opcode_push_uninterned_symbol:
- stackify_push_uninterned_symbol (op);
- break;
-\f
+ stackify_push_uninterned_symbol (op);
+ break;
+
case stackify_opcode_push_char:
- stackify_push_char (op);
- break;
+ stackify_push_char (op);
+ break;
case stackify_opcode_push_bit_string:
- stackify_push_bit_string (op);
- break;
+ stackify_push_bit_string (op);
+ break;
case stackify_opcode_push_empty_cons:
- stackify_push_empty_cons (op);
- break;
+ stackify_push_empty_cons (op);
+ break;
case stackify_opcode_pop_and_set_car:
- stackify_pop_and_set_car (op);
- break;
+ stackify_pop_and_set_car (op);
+ break;
case stackify_opcode_pop_and_set_cdr:
- stackify_pop_and_set_cdr (op);
- break;
+ stackify_pop_and_set_cdr (op);
+ break;
case stackify_opcode_push_consS:
- stackify_push_consS (op);
- break;
+ stackify_push_consS (op);
+ break;
case stackify_opcode_push_empty_vector:
- stackify_push_empty_vector (op);
- break;
+ stackify_push_empty_vector (op);
+ break;
case stackify_opcode_pop_and_vector_set:
- stackify_pop_and_vector_set (op);
- break;
+ stackify_pop_and_vector_set (op);
+ break;
case stackify_opcode_push_vector:
- stackify_push_vector (op);
- break;
+ stackify_push_vector (op);
+ break;
case stackify_opcode_push_empty_record:
- stackify_push_empty_record (op);
- break;
+ stackify_push_empty_record (op);
+ break;
case stackify_opcode_pop_and_record_set:
- stackify_pop_and_record_set (op);
- break;
+ stackify_pop_and_record_set (op);
+ break;
case stackify_opcode_push_record:
- stackify_push_record (op);
- break;
+ stackify_push_record (op);
+ break;
case stackify_opcode_push_lookup:
- stackify_push_lookup (op);
- break;
+ stackify_push_lookup (op);
+ break;
case stackify_opcode_store:
- stackify_store (op);
- break;
+ stackify_store (op);
+ break;
case stackify_opcode_push_constant:
- stackify_push_constant (op);
- break;
+ stackify_push_constant (op);
+ break;
case stackify_opcode_push_unassigned:
- stackify_push_unassigned (op);
- break;
-\f
+ stackify_push_unassigned (op);
+ break;
+
case stackify_opcode_push_primitive:
- stackify_push_primitive (op);
- break;
+ stackify_push_primitive (op);
+ break;
case stackify_opcode_push_primitive_lexpr:
- stackify_push_primitive_lexpr (op);
- break;
+ stackify_push_primitive_lexpr (op);
+ break;
case stackify_opcode_push_0:
case stackify_opcode_push_1:
case stackify_opcode_push_4:
case stackify_opcode_push_5:
case stackify_opcode_push_6:
- stackify_push_N (op);
- break;
+ stackify_push_N (op);
+ break;
case stackify_opcode_push__1:
- stackify_push__1 (op);
- break;
+ stackify_push__1 (op);
+ break;
case stackify_opcode_push_consS_0:
case stackify_opcode_push_consS_1:
case stackify_opcode_push_consS_5:
case stackify_opcode_push_consS_6:
case stackify_opcode_push_consS_7:
- stackify_push_consS_N (op);
- break;
+ stackify_push_consS_N (op);
+ break;
case stackify_opcode_pop_and_vector_set_0:
case stackify_opcode_pop_and_vector_set_1:
case stackify_opcode_pop_and_vector_set_5:
case stackify_opcode_pop_and_vector_set_6:
case stackify_opcode_pop_and_vector_set_7:
- stackify_pop_and_vector_set_N (op);
- break;
+ stackify_pop_and_vector_set_N (op);
+ break;
case stackify_opcode_push_vector_1:
case stackify_opcode_push_vector_2:
case stackify_opcode_push_vector_6:
case stackify_opcode_push_vector_7:
case stackify_opcode_push_vector_8:
- stackify_push_vector_N (op);
- break;
-\f
+ stackify_push_vector_N (op);
+ break;
+
case stackify_opcode_pop_and_record_set_0:
case stackify_opcode_pop_and_record_set_1:
case stackify_opcode_pop_and_record_set_2:
case stackify_opcode_pop_and_record_set_5:
case stackify_opcode_pop_and_record_set_6:
case stackify_opcode_pop_and_record_set_7:
- stackify_pop_and_record_set_N (op);
- break;
+ stackify_pop_and_record_set_N (op);
+ break;
case stackify_opcode_push_record_1:
case stackify_opcode_push_record_2:
case stackify_opcode_push_record_6:
case stackify_opcode_push_record_7:
case stackify_opcode_push_record_8:
- stackify_push_record_N (op);
- break;
+ stackify_push_record_N (op);
+ break;
case stackify_opcode_push_lookup_0:
case stackify_opcode_push_lookup_1:
case stackify_opcode_push_lookup_5:
case stackify_opcode_push_lookup_6:
case stackify_opcode_push_lookup_7:
- stackify_push_lookup_N (op);
- break;
+ stackify_push_lookup_N (op);
+ break;
case stackify_opcode_store_0:
case stackify_opcode_store_1:
case stackify_opcode_store_5:
case stackify_opcode_store_6:
case stackify_opcode_store_7:
- stackify_store_N (op);
- break;
+ stackify_store_N (op);
+ break;
case stackify_opcode_push_primitive_0:
case stackify_opcode_push_primitive_1:
case stackify_opcode_push_primitive_5:
case stackify_opcode_push_primitive_6:
case stackify_opcode_push_primitive_7:
- stackify_push_primitive_N (op);
- break;
-\f
- /* Compiler support */
- /* Ordinary objects don't need the following */
+ stackify_push_primitive_N (op);
+ break;
+
+ /* Compiler support */
+ /* Ordinary objects don't need the following */
case stackify_opcode_push_nm_header:
- stackify_push_nm_header (op);
- break;
+ stackify_push_nm_header (op);
+ break;
case stackify_opcode_push_linkage_header_operator:
- stackify_push_linkage_header_operator (op);
- break;
+ stackify_push_linkage_header_operator (op);
+ break;
case stackify_opcode_push_linkage_header_reference:
- stackify_push_linkage_header_reference (op);
- break;
+ stackify_push_linkage_header_reference (op);
+ break;
case stackify_opcode_push_linkage_header_assignment:
- stackify_push_linkage_header_assignment (op);
- break;
+ stackify_push_linkage_header_assignment (op);
+ break;
case stackify_opcode_push_linkage_header_global:
- stackify_push_linkage_header_global (op);
- break;
+ stackify_push_linkage_header_global (op);
+ break;
case stackify_opcode_push_linkage_header_closure:
- stackify_push_linkage_header_closure (op);
- break;
+ stackify_push_linkage_header_closure (op);
+ break;
case stackify_opcode_push_ulong:
- stackify_push_ulong (op);
- break;
+ stackify_push_ulong (op);
+ break;
case stackify_opcode_push_label_entry:
- stackify_push_label_entry (op);
- break;
+ stackify_push_label_entry (op);
+ break;
case stackify_opcode_push_label_descriptor:
- stackify_push_label_descriptor (op);
- break;
+ stackify_push_label_descriptor (op);
+ break;
case stackify_opcode_retag_cc_block:
- stackify_retag_cc_block (op);
- break;
+ stackify_retag_cc_block (op);
+ break;
case stackify_opcode_cc_block_to_entry:
- stackify_cc_block_to_entry (op);
- break;
+ stackify_cc_block_to_entry (op);
+ break;
case stackify_opcode_push_return_code:
- stackify_push_return_code (op);
- break;
+ stackify_push_return_code (op);
+ break;
}
}
- /* Grab the result and return it */
-
- result = (unstackify_pop ());
-
- free (scratch);
-
- unstackify_restore_context (& context);
+ /* Grab the result and return it */
- return (result);
+ result = (unstackify_pop ());
+ free (scratch);
+ unstackify_restore_context (&context);
+ return (result);
}
/* -*-C-*-
-$Id: usrdef.h,v 9.48 2007/01/05 21:19:25 cph Exp $
+$Id: usrdef.h,v 9.49 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
-extern SCHEME_OBJECT EXFUN ((* (Static_Primitive_Procedure_Table[])), (void));
+extern SCHEME_OBJECT (* (Static_Primitive_Procedure_Table[])) (void);
extern int Static_Primitive_Arity_Table[];
extern int Static_Primitive_Count_Table[];
-extern CONST char * Static_Primitive_Name_Table[];
-extern CONST char * Static_Primitive_Documentation_Table[];
+extern const char * Static_Primitive_Name_Table[];
+extern const char * Static_Primitive_Documentation_Table[];
extern long MAX_STATIC_PRIMITIVE;
-extern void
- EXFUN (Microcode_Termination, (int)),
- EXFUN (signal_error_from_primitive, (long));
-
#endif /* SCM_USRDEF_H */
#| -*-Scheme-*-
-$Id: utabmd.scm,v 9.91 2007/01/05 21:19:25 cph Exp $
+$Id: utabmd.scm,v 9.92 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
THE-WORK-QUEUE ;19
FUTURE-READS-LOGGER ;1A
TOUCHED-FUTURES-VECTOR ;1B
- PRECIOUS-OBJECTS ;1C
+ #F #| PRECIOUS-OBJECTS |# ;1C
ERROR-PROCEDURE ;1D
#F #| UNSNAPPED-LINK |# ;1E
#F #| MICROCODE-UTILITIES-VECTOR |# ;1F
COMPILER-ERROR-PROCEDURE ;20
- LOST-OBJECT-BASE ;21
+ #F #| LOST-OBJECT-BASE |# ;21
STATE-SPACE-ROOT ;22
PRIMITIVE-PROFILING-TABLE ;23
GENERIC-TRAMPOLINE-ZERO? ;24
COMPILED-ENTRY ;28
LEXPR ;29
PRIMITIVE-COMBINATION-3 ;2A
- MANIFEST-SPECIAL-NM-VECTOR ;2B
+ #F ;2B
VARIABLE ;2C
THE-ENVIRONMENT ;2D
- FUTURE ;2E
+ #F ;2E
VECTOR-1B ;2F
PRIMITIVE-COMBINATION-0 ;30
VECTOR-16B ;31
BAD-RANGE-ARGUMENT-1 ;11
BAD-RANGE-ARGUMENT-2 ;12
MACRO-BINDING ;13
- #F ;14
+ FASDUMP-OBJECT-TOO-LARGE ;14
BAD-INTERRUPT-CODE ;15
#F ;16
FASL-FILE-TOO-BIG ;17
FASL-FILE-BAD-DATA ;18
- IMPURIFY-OBJECT-TOO-LARGE ;19
+ #F ;19
WRITE-INTO-PURE-SPACE ;1A
#F ;1B
#F ;1C
;;; This identification string is saved by the system.
-"$Id: utabmd.scm,v 9.91 2007/01/05 21:19:25 cph Exp $"
+"$Id: utabmd.scm,v 9.92 2007/04/22 16:31:23 cph Exp $"
\ No newline at end of file
/* -*-C-*-
-$Id: utils.c,v 9.89 2007/01/05 21:19:25 cph Exp $
+$Id: utils.c,v 9.90 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "prims.h"
#include "winder.h"
#include "history.h"
-#include "cmpint.h"
#include "syscall.h"
#ifdef __OS2__
-extern void OS2_handle_attention_interrupt (void);
+ extern void OS2_handle_attention_interrupt (void);
#endif
+
+SCHEME_OBJECT * history_register;
+unsigned long prev_restore_history_offset;
+
+static SCHEME_OBJECT copy_history (SCHEME_OBJECT);
\f
-/* Helper procedures for Setup_Interrupt, which follows. */
+/* Helper procedures for setup_interrupt, which follows. */
-static long
-DEFUN (compute_interrupt_number, (masked_interrupts),
- long masked_interrupts)
+static unsigned long
+compute_interrupt_number (unsigned long masked_interrupts)
{
- long interrupt_number = 0;
- long bit_mask = 1;
+ unsigned long interrupt_number = 0;
+ unsigned long bit_mask = 1;
while ((interrupt_number <= MAX_INTERRUPT_NUMBER)
&& ((masked_interrupts & bit_mask) == 0))
{
return (interrupt_number);
}
-/* This default is solely for compatibility with the previous behavior
- of the microcode. It is not a good default and should be
- overridden by the runtime system. */
-#define DEFAULT_INTERRUPT_HANDLER_MASK(interrupt_number) \
- ((1 << (interrupt_number)) - 1)
-
-static long
-DEFUN (compute_interrupt_handler_mask, (interrupt_masks, interrupt_number),
- SCHEME_OBJECT interrupt_masks AND
- long interrupt_number)
+static unsigned long
+compute_interrupt_handler_mask (SCHEME_OBJECT interrupt_masks,
+ unsigned long interrupt_number)
{
if ((VECTOR_P (interrupt_masks))
- && (interrupt_number <= ((long) (VECTOR_LENGTH (interrupt_masks)))))
+ && (interrupt_number <= (VECTOR_LENGTH (interrupt_masks))))
{
- SCHEME_OBJECT mask =
- (VECTOR_REF (interrupt_masks, interrupt_number));
- if ((INTEGER_P (mask)) && (integer_to_long_p (mask)))
+ SCHEME_OBJECT mask
+ = (VECTOR_REF (interrupt_masks, interrupt_number));
+ if ((INTEGER_P (mask)) && (integer_to_ulong_p (mask)))
/* Guarantee that the given interrupt is disabled. */
- return ((integer_to_long (mask)) &~ (1 << interrupt_number));
+ return ((integer_to_ulong (mask)) &~ (1UL << interrupt_number));
}
return
((interrupt_number <= MAX_INTERRUPT_NUMBER)
- ? (DEFAULT_INTERRUPT_HANDLER_MASK (interrupt_number))
- : (FETCH_INTERRUPT_MASK ()));
+ ? ((1UL << interrupt_number) - 1)
+ : GET_INT_MASK);
}
static void
-DEFUN (terminate_no_interrupt_handler, (masked_interrupts),
- long masked_interrupts)
+terminate_no_interrupt_handler (unsigned long masked_interrupts)
{
- outf_fatal("\nInterrupts = 0x%08lx, Mask = 0x%08lx, Masked = 0x%08lx\n",
- (FETCH_INTERRUPT_CODE ()),
- (FETCH_INTERRUPT_MASK ()),
- masked_interrupts);
+ outf_fatal ("\nInterrupts = %#08lx, Mask = %#08lx, Masked = %#08lx\n",
+ GET_INT_CODE,
+ GET_INT_MASK,
+ masked_interrupts);
Microcode_Termination (TERM_NO_INTERRUPT_HANDLER);
}
SCHEME_OBJECT
-DEFUN_VOID (initialize_interrupt_handler_vector)
+initialize_interrupt_handler_vector (void)
{
return (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false));
}
SCHEME_OBJECT
-DEFUN_VOID (initialize_interrupt_mask_vector)
+initialize_interrupt_mask_vector (void)
{
- SCHEME_OBJECT result =
- (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false));
- long interrupt_number;
-
- for (interrupt_number = 0;
- (interrupt_number <= MAX_INTERRUPT_NUMBER);
- interrupt_number += 1)
- VECTOR_SET
- (result, interrupt_number,
- (long_to_integer (DEFAULT_INTERRUPT_HANDLER_MASK (interrupt_number))));
- return (result);
+ SCHEME_OBJECT v = (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false));
+ unsigned long interrupt_number = 0;
+ while (interrupt_number <= MAX_INTERRUPT_NUMBER)
+ {
+ VECTOR_SET (v,
+ interrupt_number,
+ (ulong_to_integer ((1UL << interrupt_number) - 1)));
+ interrupt_number += 1;
+ }
+ return (v);
}
\f
-/* Setup_Interrupt is called from the Interrupt macro to do all of the
+/* setup_interrupt is called from the Interrupt macro to do all of the
setup for calling the user's interrupt routines. */
void
-DEFUN (Setup_Interrupt, (masked_interrupts), long masked_interrupts)
+setup_interrupt (unsigned long masked_interrupts)
{
SCHEME_OBJECT interrupt_handlers = SHARP_F;
SCHEME_OBJECT interrupt_masks = SHARP_F;
- long interrupt_number = (compute_interrupt_number (masked_interrupts));
- long interrupt_mask;
+ unsigned long interrupt_number
+ = (compute_interrupt_number (masked_interrupts));
+ unsigned long interrupt_mask;
SCHEME_OBJECT interrupt_handler;
#ifdef __OS2__
- if ((1 << interrupt_number) == INT_Global_1)
+ if ((1UL << interrupt_number) == INT_Global_1)
{
OS2_handle_attention_interrupt ();
abort_to_interpreter (PRIM_POP_RETURN);
}
-#endif /* __OS2__ */
- if (! (Valid_Fixed_Obj_Vector ()))
- {
- outf_fatal ("\nInvalid fixed-objects vector.");
- terminate_no_interrupt_handler (masked_interrupts);
- }
- interrupt_handlers = (Get_Fixed_Obj_Slot (System_Interrupt_Vector));
- interrupt_masks = (Get_Fixed_Obj_Slot (FIXOBJ_INTERRUPT_MASK_VECTOR));
- if (! (VECTOR_P (interrupt_handlers)))
+#endif
+ if (!VECTOR_P (fixed_objects))
{
- outf_fatal ("\nInvalid handlers vector (0x%lx).", interrupt_handlers);
+ outf_fatal ("\nInvalid fixed-objects vector");
terminate_no_interrupt_handler (masked_interrupts);
}
- if (interrupt_number >= ((long) (VECTOR_LENGTH (interrupt_handlers))))
+ interrupt_handlers = (VECTOR_REF (fixed_objects, SYSTEM_INTERRUPT_VECTOR));
+ interrupt_masks = (VECTOR_REF (fixed_objects, FIXOBJ_INTERRUPT_MASK_VECTOR));
+ if (! ((VECTOR_P (interrupt_handlers))
+ && (interrupt_number < (VECTOR_LENGTH (interrupt_handlers)))))
{
- outf_fatal("\nInterrupt out of range: %ld (vector length = %ld).",
- interrupt_number,
- (VECTOR_LENGTH (interrupt_handlers)));
+ outf_fatal ("\nUnable to get interrupt handler.");
terminate_no_interrupt_handler (masked_interrupts);
}
- interrupt_mask =
- (compute_interrupt_handler_mask (interrupt_masks, interrupt_number));
- Global_Interrupt_Hook ();
+ interrupt_mask
+ = (compute_interrupt_handler_mask (interrupt_masks, interrupt_number));
interrupt_handler = (VECTOR_REF (interrupt_handlers, interrupt_number));
-#if 0
- /* This label may be used in Global_Interrupt_Hook: */
- passed_checks:
-#endif
- Stop_History ();
+ stop_history ();
preserve_interrupt_mask ();
Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
user supplied interrupt routine. It will be given two arguments:
the UNmasked interrupt requests, and the currently enabled
interrupts. */
- STACK_PUSH (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
- STACK_PUSH (LONG_TO_FIXNUM (FETCH_INTERRUPT_CODE ()));
+ STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_MASK));
+ STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_CODE));
STACK_PUSH (interrupt_handler);
- STACK_PUSH (STACK_FRAME_HEADER + 2);
+ PUSH_APPLY_FRAME_HEADER (2);
Pushed ();
/* Turn off interrupts: */
SET_INTERRUPT_MASK (interrupt_mask);
/* Error processing utilities */
void
-DEFUN (err_print, (error_code, where), long error_code AND outf_channel where)
+err_print (long error_code, outf_channel where)
{
- extern char * Error_Names [];
-
- if (error_code > MAX_ERROR)
- outf (where, "Unknown error code 0x%lx.\n", error_code);
+ const char * message
+ = ((error_code <= MAX_ERROR)
+ ? (Error_Names[error_code])
+ : 0);
+ if (message == 0)
+ outf (where, "Unknown error code %#lx.\n", error_code);
else
- outf (where, "Error code 0x%lx (%s).\n",
- error_code,
- (Error_Names [error_code]));
- return;
+ outf (where, "Error code %#lx (%s).\n", error_code, message);
}
-extern long death_blow;
long death_blow;
-void
-DEFUN (error_death, (code, message), long code AND char * message)
+static void
+error_death (long code, char * message)
{
death_blow = code;
outf_fatal ("\nMicrocode Error: %s.\n", message);
- err_print (code, fatal_output);
+ err_print (code, FATAL_OUTPUT);
outf_error ("\n**** Stack Trace ****\n\n");
- Back_Trace (error_output);
+ Back_Trace (ERROR_OUTPUT);
termination_no_error_handler ();
/*NOTREACHED*/
}
void
-DEFUN_VOID (Stack_Death)
+Stack_Death (void)
{
outf_fatal("\nWill_Push vs. Pushed inconsistency.\n");
Microcode_Termination (TERM_BAD_STACK);
}
\f
void
-DEFUN_VOID (preserve_interrupt_mask)
+preserve_interrupt_mask (void)
{
Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_RESTORE_INT_MASK);
- exp_register = (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
- Save_Cont ();
+ SET_RC (RC_RESTORE_INT_MASK);
+ SET_EXP (ULONG_TO_FIXNUM (GET_INT_MASK));
+ SAVE_CONT ();
Pushed ();
- return;
}
-/* back_out_of_primitive sets the registers up so that the backout
- mechanism in interpret.c will cause the primitive to be
- restarted if the error/interrupt is proceeded. */
+/* canonicalize_primitive_context should be used by "unsafe"
+ primitives to guarantee that their execution context is the
+ expected one, ie. they are called from the interpreter. If they
+ are called from compiled code, they should abort to the interpreter
+ and reenter. */
void
-DEFUN_VOID (back_out_of_primitive_internal)
+canonicalize_primitive_context (void)
{
- long nargs;
- SCHEME_OBJECT primitive;
+ SCHEME_OBJECT primitive = GET_PRIMITIVE;
+ unsigned long n_args;
- /* Setup a continuation to return to compiled code if the primitive is
- restarted and completes successfully. */
+ assert (PRIMITIVE_P (primitive));
+ n_args = (PRIMITIVE_N_ARGUMENTS (primitive));
- primitive = (Registers[REGBLOCK_PRIMITIVE]);
- if (! (PRIMITIVE_P (primitive)))
+#ifdef CC_SUPPORT_P
+ if (CC_ENTRY_P (STACK_REF (n_args)))
{
- outf_fatal(
- "\nback_out_of_primitive backing out when not in primitive!\n");
- Microcode_Termination (TERM_BAD_BACK_OUT);
+ /* The primitive has been invoked from compiled code. */
+ STACK_PUSH (primitive);
+ PUSH_APPLY_FRAME_HEADER (n_args);
+ guarantee_interp_return ();
+ SET_PRIMITIVE (SHARP_F);
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
}
- nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
- if (COMPILED_CODE_ADDRESS_P (STACK_REF (nargs)))
- compiler_apply_procedure (nargs);
- STACK_PUSH (primitive);
- STACK_PUSH (STACK_FRAME_HEADER + nargs);
- env_register = THE_NULL_ENV;
- val_register = SHARP_F;
- Store_Return (RC_INTERNAL_APPLY);
- exp_register = SHARP_F;
- (Registers[REGBLOCK_PRIMITIVE]) = SHARP_F;
- return;
+#endif
}
-void
-DEFUN_VOID (back_out_of_primitive)
-{
- back_out_of_primitive_internal ();
- Save_Cont ();
- return;
-}
-\f
-/* canonicalize_primitive_context should be used by "unsafe" primitives
- to guarantee that their execution context is the expected one, ie.
- they are called from the interpreter.
- If they are called from compiled code, they should abort to the
- interpreter and reenter.
- Note: This is called only from the macro PRIMITIVE_CANONICALIZE_CONTEXT,
- so that the work can be divided between them if it is an issue. */
+/* back_out_of_primitive sets the registers up so that the backout
+ mechanism in "interp.c" will cause the primitive to be
+ restarted if the error/interrupt is proceeded. */
void
-DEFUN_VOID (canonicalize_primitive_context)
+back_out_of_primitive (void)
{
- long nargs;
- SCHEME_OBJECT primitive;
-
- primitive = (Registers[REGBLOCK_PRIMITIVE]);
- if (! (PRIMITIVE_P (primitive)))
- {
- outf_fatal
- ("\ncanonicalize_primitive_context invoked when not in primitive!\n");
- Microcode_Termination (TERM_BAD_BACK_OUT);
- }
- nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
- if (! (COMPILED_CODE_ADDRESS_P (STACK_REF (nargs))))
- return;
- /* The primitive has been invoked from compiled code. */
- PRIMITIVE_ABORT (PRIM_REENTER);
- /*NOTREACHED*/
+ SCHEME_OBJECT primitive = GET_PRIMITIVE;
+ assert (PRIMITIVE_P (primitive));
+ STACK_PUSH (primitive);
+ PUSH_APPLY_FRAME_HEADER (PRIMITIVE_N_ARGUMENTS (primitive));
+ guarantee_interp_return ();
+ SET_PRIMITIVE (SHARP_F);
+ SET_EXP (SHARP_F);
+ SET_RC (RC_INTERNAL_APPLY);
+ SAVE_CONT ();
+ SET_ENV (THE_NULL_ENV);
+ SET_VAL (SHARP_F);
}
\f
/* Useful error procedures */
invoked from compiled code. */
void
-DEFUN (signal_error_from_primitive, (error_code), long error_code)
+signal_error_from_primitive (long error_code)
{
PRIMITIVE_ABORT (error_code);
/*NOTREACHED*/
}
void
-DEFUN_VOID (signal_interrupt_from_primitive)
+signal_interrupt_from_primitive (void)
{
PRIMITIVE_ABORT (PRIM_INTERRUPT);
/*NOTREACHED*/
}
void
-DEFUN (error_wrong_type_arg, (n), int n)
+error_wrong_type_arg (int n)
{
- fast long error_code;
+ long error_code;
switch (n)
{
}
void
-DEFUN (error_bad_range_arg, (n), int n)
+error_bad_range_arg (int n)
{
- fast long error_code;
+ long error_code;
switch (n)
{
}
\f
void
-DEFUN_VOID (error_external_return)
+error_external_return (void)
{
signal_error_from_primitive (ERR_EXTERNAL_RETURN);
}
static SCHEME_OBJECT error_argument;
void
-DEFUN (error_with_argument, (argument), SCHEME_OBJECT argument)
+error_with_argument (SCHEME_OBJECT argument)
{
error_argument = argument;
signal_error_from_primitive (ERR_WITH_ARGUMENT);
}
void
-DEFUN (error_in_system_call, (err, name),
- enum syserr_names err AND enum syscall_names name)
+error_in_system_call (enum syserr_names err, enum syscall_names name)
{
/* System call errors have some additional information.
Encode this as a vector in place of the error code. */
}
void
-DEFUN (error_system_call, (code, name),
- int code AND enum syscall_names name)
+error_system_call (int code, enum syscall_names name)
{
error_in_system_call ((OS_error_code_to_syserr (code)), name);
/*NOTREACHED*/
}
long
-DEFUN (arg_integer, (arg_number), int arg_number)
+arg_integer (int arg_number)
{
- fast SCHEME_OBJECT object = (ARG_REF (arg_number));
+ SCHEME_OBJECT object = (ARG_REF (arg_number));
if (! (INTEGER_P (object)))
error_wrong_type_arg (arg_number);
if (! (integer_to_long_p (object)))
}
long
-DEFUN (arg_nonnegative_integer, (arg_number), int arg_number)
+arg_nonnegative_integer (int arg_number)
{
- fast long result = (arg_integer (arg_number));
+ long result = (arg_integer (arg_number));
if (result < 0)
error_bad_range_arg (arg_number);
return (result);
}
long
-DEFUN (arg_index_integer, (arg_number, upper_limit),
- int arg_number AND long upper_limit)
+arg_index_integer (int arg_number, long upper_limit)
{
- fast long result = (arg_integer (arg_number));
+ long result = (arg_integer (arg_number));
if ((result < 0) || (result >= upper_limit))
error_bad_range_arg (arg_number);
return (result);
}
long
-DEFUN (arg_integer_in_range,
- (arg_number, lower_limit, upper_limit),
- int arg_number AND long lower_limit AND long upper_limit)
+arg_integer_in_range (int arg_number, long lower_limit, long upper_limit)
{
- fast long result = (arg_integer (arg_number));
+ long result = (arg_integer (arg_number));
if ((result < lower_limit) || (result >= upper_limit))
error_bad_range_arg (arg_number);
return (result);
}
unsigned long
-DEFUN (arg_ulong_integer, (arg_number), int arg_number)
+arg_ulong_integer (int arg_number)
{
- fast SCHEME_OBJECT object = (ARG_REF (arg_number));
+ SCHEME_OBJECT object = (ARG_REF (arg_number));
if (! (INTEGER_P (object)))
error_wrong_type_arg (arg_number);
if (! (integer_to_ulong_p (object)))
}
unsigned long
-DEFUN (arg_ulong_index_integer, (arg_number, upper_limit),
- int arg_number AND unsigned long upper_limit)
+arg_ulong_index_integer (int arg_number, unsigned long upper_limit)
{
- fast unsigned long result = (arg_ulong_integer (arg_number));
+ unsigned long result = (arg_ulong_integer (arg_number));
if (result >= upper_limit)
error_bad_range_arg (arg_number);
return (result);
}
+
+unsigned long
+arg_ulong_integer_in_range (int arg_number,
+ unsigned long lower_limit,
+ unsigned long upper_limit)
+{
+ unsigned long result = (arg_ulong_integer (arg_number));
+ if (! ((result >= lower_limit) && (result < upper_limit)))
+ error_bad_range_arg (arg_number);
+ return (result);
+}
\f
-Boolean
-DEFUN (real_number_to_double_p, (x), fast SCHEME_OBJECT x)
+bool
+real_number_to_double_p (SCHEME_OBJECT x)
{
return ((! (BIGNUM_P (x))) || (BIGNUM_TO_DOUBLE_P (x)));
}
double
-DEFUN (real_number_to_double, (x), fast SCHEME_OBJECT x)
+real_number_to_double (SCHEME_OBJECT x)
{
return
((FIXNUM_P (x))
}
double
-DEFUN (arg_real_number, (arg_number), int arg_number)
+arg_real_number (int arg_number)
{
- fast SCHEME_OBJECT number = (ARG_REF (arg_number));
+ SCHEME_OBJECT number = (ARG_REF (arg_number));
if (! (REAL_P (number)))
error_wrong_type_arg (arg_number);
if (! (real_number_to_double_p (number)))
}
double
-DEFUN (arg_real_in_range, (arg_number, lower_limit, upper_limit),
- int arg_number AND double lower_limit AND double upper_limit)
+arg_real_in_range (int arg_number, double lower_limit, double upper_limit)
{
- fast double result = (arg_real_number (arg_number));
+ double result = (arg_real_number (arg_number));
if ((result < lower_limit) || (result > upper_limit))
error_bad_range_arg (arg_number);
return (result);
}
\f
-Boolean
-DEFUN (interpreter_applicable_p, (object), fast SCHEME_OBJECT object)
+bool
+interpreter_applicable_p (SCHEME_OBJECT object)
{
tail_recurse:
switch (OBJECT_TYPE (object))
object = (MEMORY_REF (object, ENTITY_OPERATOR));
goto tail_recurse;
}
+#ifdef CC_SUPPORT_P
case TC_COMPILED_ENTRY:
{
- long results [3];
- compiled_entry_type (object, results);
- return ((results [0]) == 0);
+ cc_entry_type_t cet;
+ return
+ ((read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (object))))
+ ? false
+ : ((cet.marker) == CET_PROCEDURE));
}
+#endif
default:
return (false);
}
}
\f
- /******************/
- /* ERROR HANDLING */
- /******************/
-
-/* It is assumed that any caller of the error code has already
- * restored its state to a situation which will make it
- * restartable if the error handler returns normally. As a
- * result, the only work to be done on an error is to verify
- * that there is an error handler, save the current continuation and
- * create a new one if entered from Pop_Return rather than Eval,
- * turn off interrupts, and call it with two arguments: Error-Code
- * and Interrupt-Enables.
- */
+/* Error handling
+
+ It is assumed that any caller of the error code has already
+ restored its state to a situation which will make it restartable if
+ the error handler returns normally. As a result, the only work to
+ be done on an error is to verify that there is an error handler,
+ save the current continuation and create a new one if entered from
+ Pop_Return rather than Eval, turn off interrupts, and call it with
+ two arguments: the error code and interrupt enables. */
void
-DEFUN (Do_Micro_Error, (Err, From_Pop_Return),
- long Err AND Boolean From_Pop_Return)
+Do_Micro_Error (long error_code, bool from_pop_return_p)
{
- SCHEME_OBJECT Error_Vector = SHARP_F;
- SCHEME_OBJECT Handler;
-
- if (Consistency_Check)
- {
- err_print(Err, error_output);
- Print_Expression(exp_register, "Expression was");
- outf_error ("\nEnvironment 0x%lx (#%lo).\n",
- ((long) exp_register), ((long) env_register));
- Print_Return("Return code");
- outf_error ("\n");
- }
+ SCHEME_OBJECT handler = SHARP_F;
- Error_Exit_Hook();
+#ifdef ENABLE_DEBUGGING_TOOLS
+ err_print (error_code, ERROR_OUTPUT);
+ if ((GET_RC == RC_INTERNAL_APPLY)
+ || (GET_RC == RC_INTERNAL_APPLY_VAL))
+ {
+ SCHEME_OBJECT * sp = (STACK_LOC (CONTINUATION_SIZE));
+ Print_Expression ((sp[STACK_ENV_FUNCTION]), "Procedure was");
+ outf_error ("\n");
+ outf_error ("# of arguments: %lu\n",
+ (APPLY_FRAME_HEADER_N_ARGS (sp[STACK_ENV_HEADER])));
+ }
+ else
+ {
+ Print_Expression (GET_EXP, "Expression was");
+ outf_error ("\n");
+ Print_Expression (GET_ENV, "Environment was");
+ outf_error ("\n");
+ }
+ Print_Return ("Return code");
+ outf_error ("\n");
+#endif
if (Trace_On_Error)
- {
- outf_error ("\n\n**** Stack Trace ****\n\n");
- Back_Trace (error_output);
- }
+ {
+ outf_error ("\n\n**** Stack Trace ****\n\n");
+ Back_Trace (ERROR_OUTPUT);
+ }
#ifdef ENABLE_DEBUGGING_TOOLS
{
- int *From = &(local_circle[0]), *To = &(debug_circle[0]), i;
-
- for (i = 0; i < local_nslots; i++)
- *To++ = *From++;
- debug_nslots = local_nslots;
- debug_slotno = local_slotno;
+ unsigned int * from = local_circle;
+ unsigned int * end = (from + local_nslots);
+ unsigned int * to = debug_circle;
+ while (from < end)
+ (*to++) = (*from++);
}
+ debug_nslots = local_nslots;
+ debug_slotno = local_slotno;
#endif
-/* Do_Micro_Error continues on the next page. */
-\f
-/* Do_Micro_Error, continued */
-
- /* This can NOT be folded into the Will_Push below since we cannot
- afford to have the Will_Push put down its own continuation.
- There is guaranteed to be enough space for this one
- continuation; in fact, the Will_Push here is really unneeded!
- */
-
- if (From_Pop_Return)
- {
- Will_Push (CONTINUATION_SIZE);
- Save_Cont ();
- Pushed ();
- }
-
- Will_Push (CONTINUATION_SIZE + (From_Pop_Return ? 0 : 1));
- if (From_Pop_Return)
- exp_register = val_register;
+ Will_Push (CONTINUATION_SIZE + (from_pop_return_p ? 0 : 1));
+ if (from_pop_return_p)
+ SET_EXP (GET_VAL);
else
- STACK_PUSH (env_register);
- Store_Return ((From_Pop_Return) ?
- RC_POP_RETURN_ERROR :
- RC_EVAL_ERROR);
- Save_Cont ();
- Pushed ();
-
-/* Do_Micro_Error continues on the next page. */
-\f
-/* Do_Micro_Error, continued */
-
- if ((!Valid_Fixed_Obj_Vector()) ||
- (OBJECT_TYPE ((Error_Vector =
- Get_Fixed_Obj_Slot(System_Error_Vector))) !=
- TC_VECTOR))
- {
- error_death (Err,
- (((Valid_Fixed_Obj_Vector())
- && (Error_Vector == SHARP_F))
- ? "No error handlers"
- : "No error handlers: Bad handlers vector"));
- /*NOTREACHED*/
- }
+ PUSH_ENV ();
+ SET_RC (from_pop_return_p ? RC_POP_RETURN_ERROR : RC_EVAL_ERROR);
+ SAVE_CONT ();
+ Pushed ();
- if ((Err < 0) || (Err >= ((long) (VECTOR_LENGTH (Error_Vector)))))
{
- if (VECTOR_LENGTH (Error_Vector) == 0)
- error_death (Err, "No error handlers: Empty handlers vector");
- /*NOTREACHED*/
- Handler = (VECTOR_REF (Error_Vector, ERR_BAD_ERROR_CODE));
+ SCHEME_OBJECT error_vector = SHARP_F;
+ if (VECTOR_P (fixed_objects))
+ error_vector = (VECTOR_REF (fixed_objects, SYSTEM_ERROR_VECTOR));
+ if (!VECTOR_P (error_vector))
+ error_death (error_code, "No error handlers");
+ if ((error_code >= 0) && (error_code < (VECTOR_LENGTH (error_vector))))
+ handler = (VECTOR_REF (error_vector, error_code));
+ else if (ERR_BAD_ERROR_CODE < (VECTOR_LENGTH (error_vector)))
+ handler = (VECTOR_REF (error_vector, ERR_BAD_ERROR_CODE));
+ else
+ error_death (error_code, "No error handlers");
}
- else
- Handler = (VECTOR_REF (Error_Vector, Err));
/* Return from error handler will re-enable interrupts & restore history */
- Stop_History();
+ stop_history ();
preserve_interrupt_mask ();
- Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
- /* Arg 2: Int. mask */
- STACK_PUSH (LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
- /* Arg 1: Err. No */
- if ((Err == ERR_WITH_ARGUMENT) || (Err == ERR_IN_SYSTEM_CALL))
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
+ /* Arg 2: interrupt mask */
+ STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_MASK));
+ /* Arg 1: error code */
+ if ((error_code == ERR_WITH_ARGUMENT) || (error_code == ERR_IN_SYSTEM_CALL))
STACK_PUSH (error_argument);
- else if ((Err >= SMALLEST_FIXNUM) && (Err <= BIGGEST_FIXNUM))
- STACK_PUSH (LONG_TO_FIXNUM (Err));
else
- STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (ERR_BAD_ERROR_CODE));
- /* Procedure: Handler */
- STACK_PUSH (Handler);
- STACK_PUSH (STACK_FRAME_HEADER + 2);
- Pushed();
+ STACK_PUSH (long_to_integer (error_code));
+ STACK_PUSH (handler);
+ PUSH_APPLY_FRAME_HEADER (2);
+ Pushed ();
/* Disable all interrupts */
- SET_INTERRUPT_MASK(0);
- return;
+ SET_INTERRUPT_MASK (0);
}
\f
-/* HISTORY manipulation */
+/* History */
-SCHEME_OBJECT *
-DEFUN_VOID (Make_Dummy_History)
+void
+reset_history (void)
{
- SCHEME_OBJECT *History_Rib = Free;
- SCHEME_OBJECT *Result;
+ prev_restore_history_offset = 0;
+ history_register
+ = (((VECTOR_P (fixed_objects))
+ && ((READ_DUMMY_HISTORY ()) != SHARP_F))
+ ? (OBJECT_ADDRESS (READ_DUMMY_HISTORY ()))
+ : (make_dummy_history ()));
+}
- Free[RIB_EXP] = SHARP_F;
- Free[RIB_ENV] = SHARP_F;
- Free[RIB_NEXT_REDUCTION] =
- MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History_Rib);
- Free += 3;
- Result = Free;
- Free[HIST_RIB] = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History_Rib);
- Free[HIST_NEXT_SUBPROBLEM] =
- MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Result);
- Free[HIST_PREV_SUBPROBLEM] =
- MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Result);
+SCHEME_OBJECT *
+make_dummy_history (void)
+{
+ SCHEME_OBJECT * rib = Free;
+ (Free[RIB_EXP]) = SHARP_F;
+ (Free[RIB_ENV]) = SHARP_F;
+ (Free[RIB_NEXT_REDUCTION])
+ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, rib));
Free += 3;
- return (Result);
+ {
+ SCHEME_OBJECT * history = Free;
+ (Free[HIST_RIB])
+ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, rib));
+ (Free[HIST_NEXT_SUBPROBLEM])
+ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history));
+ (Free[HIST_PREV_SUBPROBLEM])
+ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history));
+ Free += 3;
+ return (history);
+ }
+}
+
+/* save_history places a restore history frame on the stack. Such a
+ frame consists of a normal continuation frame plus a pointer to the
+ stacklet on which the last restore history is located and the
+ offset within that stacklet. If the last restore history is in
+ this stacklet then the history pointer is #F to signify this. If
+ there is no previous restore history then the history pointer is #F
+ and the offset is 0. */
+
+void
+save_history (unsigned long rc)
+{
+ Will_Push (HISTORY_SIZE);
+ STACK_PUSH (SHARP_F); /* Prev_Restore_History_Stacklet */
+ STACK_PUSH (ULONG_TO_FIXNUM (prev_restore_history_offset));
+ SET_EXP (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
+ SET_RC (rc);
+ SAVE_CONT ();
+ Pushed ();
+ history_register = (OBJECT_ADDRESS (READ_DUMMY_HISTORY ()));
}
+/* restore_history pops a history object off the stack and makes a
+ copy of it the current history collection object. This is called
+ only from the RC_RESTORE_HISTORY case in "interp.c". */
+
+bool
+restore_history (SCHEME_OBJECT hist_obj)
+{
+ SCHEME_OBJECT new_hist = (copy_history (hist_obj));
+ if (new_hist == SHARP_F)
+ return (false);
+ history_register = (OBJECT_ADDRESS (new_hist));
+ return (true);
+}
+\f
/* The entire trick to history is right here: it is either copied or
- reused when restored. Initially, Stop_History marks the stack so
+ reused when restored. Initially, stop_history marks the stack so
that the history will merely be popped and reused. On a catch,
however, the return code is changed to force the history to be
copied instead. Thus, histories saved as part of a control point
- are not side-effected in the history collection process.
-*/
+ are not side-effected in the history collection process. */
void
-DEFUN_VOID (Stop_History)
+stop_history (void)
{
- SCHEME_OBJECT Saved_Expression;
- long Saved_Return_Code;
-
- Saved_Expression = exp_register;
- Saved_Return_Code = ret_register;
- Will_Push(HISTORY_SIZE);
- Save_History(RC_RESTORE_DONT_COPY_HISTORY);
- Pushed();
- Prev_Restore_History_Stacklet = NULL;
- Prev_Restore_History_Offset = ((Get_End_Of_Stacklet() - sp_register) +
- CONTINUATION_RETURN_CODE);
- exp_register = Saved_Expression;
- Store_Return(Saved_Return_Code);
- return;
+ SCHEME_OBJECT exp = GET_EXP;
+ SCHEME_OBJECT ret = GET_RET;
+ SAVE_HISTORY (RC_RESTORE_DONT_COPY_HISTORY);
+ prev_restore_history_offset = (STACK_N_PUSHED + CONTINUATION_RETURN_CODE);
+ SET_RET (ret);
+ SET_EXP (exp);
}
-\f
-/* This returns a history object,
- or SHARP_F if it needs to GC,
- or SHARP_T if it is not a valid history object.
- */
-SCHEME_OBJECT
-DEFUN (copy_history, (hist_obj), SCHEME_OBJECT hist_obj)
+void
+new_subproblem (SCHEME_OBJECT expression, SCHEME_OBJECT environment)
{
- long space_left, vert_type, rib_type;
- SCHEME_OBJECT *fast_free;
- SCHEME_OBJECT new_hunk, *last_hunk, *hist_ptr, *orig_hist, temp;
- SCHEME_OBJECT *orig_rib, *source_rib, *rib_slot;
+ history_register = (OBJECT_ADDRESS (history_register[HIST_NEXT_SUBPROBLEM]));
+ HISTORY_MARK (history_register[HIST_MARK]);
+ {
+ SCHEME_OBJECT * rib = (OBJECT_ADDRESS (history_register[HIST_RIB]));
+ HISTORY_MARK (rib[RIB_MARK]);
+ (rib[RIB_ENV]) = environment;
+ (rib[RIB_EXP]) = expression;
+ }
+}
- if (!(HUNK3_P (hist_obj)))
- return (SHARP_T);
+void
+reuse_subproblem (SCHEME_OBJECT expression, SCHEME_OBJECT environment)
+{
+ SCHEME_OBJECT * rib = (OBJECT_ADDRESS (history_register[HIST_RIB]));
+ HISTORY_MARK (rib[RIB_MARK]);
+ (rib[RIB_ENV]) = environment;
+ (rib[RIB_EXP]) = expression;
+}
- space_left = ((Space_Before_GC ()) - 3);
- fast_free = Free;
+void
+new_reduction (SCHEME_OBJECT expression, SCHEME_OBJECT environment)
+{
+ SCHEME_OBJECT * rib
+ = (OBJECT_ADDRESS
+ (MEMORY_REF ((history_register[HIST_RIB]), RIB_NEXT_REDUCTION)));
+ (history_register[HIST_RIB])
+ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, rib));
+ (rib[RIB_ENV]) = (environment);
+ (rib[RIB_EXP]) = (expression);
+ HISTORY_UNMARK (rib[RIB_MARK]);
+}
- vert_type = (OBJECT_TYPE (hist_obj));
- orig_hist = (OBJECT_ADDRESS (hist_obj));
- hist_ptr = orig_hist;
- last_hunk = (Heap_Top - 3);
+void
+end_subproblem (void)
+{
+ HISTORY_UNMARK (history_register[HIST_MARK]);
+ history_register = (OBJECT_ADDRESS (history_register[HIST_PREV_SUBPROBLEM]));
+}
- do
- {
- /* Allocate and link the vertebra. */
+void
+compiler_new_subproblem (void)
+{
+ new_subproblem (SHARP_F, (MAKE_RETURN_CODE (RC_POP_FROM_COMPILED_CODE)));
+}
- space_left -= 3;
- if (space_left < 0)
- return (SHARP_F);
+void
+compiler_new_reduction (void)
+{
+ new_reduction (SHARP_F, (MAKE_RETURN_CODE (RC_POP_FROM_COMPILED_CODE)));
+}
+\f
+/* Returns SHARP_F if insufficient space available. */
- new_hunk = (MAKE_POINTER_OBJECT (vert_type, fast_free));
- last_hunk[HIST_NEXT_SUBPROBLEM] = new_hunk;
+static SCHEME_OBJECT
+copy_history (SCHEME_OBJECT hist_obj)
+{
+ unsigned long space_left, vert_type, rib_type;
+ SCHEME_OBJECT new_hunk, * last_hunk, * hist_ptr, * orig_hist, temp;
+ SCHEME_OBJECT * orig_rib, * source_rib, * rib_slot;
- fast_free[HIST_PREV_SUBPROBLEM] =
- (MAKE_POINTER_OBJECT ((OBJECT_TYPE (hist_ptr[HIST_PREV_SUBPROBLEM])),
- last_hunk));
- last_hunk = fast_free;
- fast_free += 3;
+ assert (HUNK3_P (hist_obj));
- /* Copy the rib. */
+ space_left = (SPACE_BEFORE_GC ());
+ if (space_left < 3)
+ return (SHARP_F);
+ space_left -= 3;
- temp = hist_ptr[HIST_RIB];
- rib_type = (OBJECT_TYPE (temp));
- orig_rib = (OBJECT_ADDRESS (temp));
- rib_slot = (last_hunk + HIST_RIB);
-
- source_rib = orig_rib;
+ vert_type = (OBJECT_TYPE (hist_obj));
+ orig_hist = (OBJECT_ADDRESS (hist_obj));
+ hist_ptr = orig_hist;
+ last_hunk = (heap_end - 3);
- do
+ do
{
- space_left -= 3;
- if (space_left < 0)
+ /* Allocate and link the vertebra. */
+ if (space_left < 3)
return (SHARP_F);
+ space_left -= 3;
- *rib_slot = (MAKE_POINTER_OBJECT (rib_type, fast_free));
- fast_free[RIB_EXP] = source_rib[RIB_EXP];
- fast_free[RIB_ENV] = source_rib[RIB_ENV];
- rib_slot = (fast_free + RIB_NEXT_REDUCTION);
- fast_free += 3;
-\f
- temp = source_rib[RIB_NEXT_REDUCTION];
- rib_type = (OBJECT_TYPE (temp));
- source_rib = (OBJECT_ADDRESS (temp));
- } while (source_rib != orig_rib);
-
- *rib_slot = (OBJECT_NEW_TYPE (rib_type, last_hunk[HIST_RIB]));
-
- temp = hist_ptr[HIST_NEXT_SUBPROBLEM];
- vert_type = (OBJECT_TYPE (temp));
- hist_ptr = (OBJECT_ADDRESS (temp));
- } while (hist_ptr != orig_hist);
-
- Free = fast_free;
- new_hunk = Heap_Top[HIST_NEXT_SUBPROBLEM - 3];
- last_hunk[HIST_NEXT_SUBPROBLEM] = (OBJECT_NEW_TYPE (vert_type, new_hunk));
- FAST_MEMORY_SET (new_hunk, HIST_PREV_SUBPROBLEM,
- (MAKE_POINTER_OBJECT
- ((OBJECT_TYPE (hist_ptr[HIST_PREV_SUBPROBLEM])),
- last_hunk)));
- return (new_hunk);
-}
-
-/* Restore_History pops a history object off the stack and
- makes a COPY of it the current history collection object.
- This is called only from the RC_RESTORE_HISTORY case in
- interpret.c .
- */
+ new_hunk = (MAKE_POINTER_OBJECT (vert_type, Free));
+ (last_hunk[HIST_NEXT_SUBPROBLEM]) = new_hunk;
-Boolean
-DEFUN (Restore_History, (hist_obj), SCHEME_OBJECT hist_obj)
-{
- SCHEME_OBJECT new_hist;
+ (Free[HIST_PREV_SUBPROBLEM])
+ = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (hist_ptr[HIST_PREV_SUBPROBLEM])),
+ last_hunk));
+ last_hunk = Free;
+ Free += 3;
- new_hist = (copy_history (hist_obj));
- if (new_hist == SHARP_F)
- return (false);
- else if (new_hist == SHARP_T)
- {
- outf_fatal ("\nBad history to restore.\n");
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- return (0);
- }
- else
- {
- history_register = (OBJECT_ADDRESS (new_hist));
- return (1);
- }
+ /* Copy the rib. */
+ temp = (hist_ptr[HIST_RIB]);
+ rib_type = (OBJECT_TYPE (temp));
+ orig_rib = (OBJECT_ADDRESS (temp));
+ rib_slot = (last_hunk + HIST_RIB);
+
+ source_rib = orig_rib;
+
+ do
+ {
+ if (space_left < 3)
+ return (SHARP_F);
+ space_left -= 3;
+
+ (*rib_slot) = (MAKE_POINTER_OBJECT (rib_type, Free));
+ (Free[RIB_EXP]) = (source_rib[RIB_EXP]);
+ (Free[RIB_ENV]) = (source_rib[RIB_ENV]);
+ rib_slot = (Free + RIB_NEXT_REDUCTION);
+ Free += 3;
+ temp = (source_rib[RIB_NEXT_REDUCTION]);
+ rib_type = (OBJECT_TYPE (temp));
+ source_rib = (OBJECT_ADDRESS (temp));
+ }
+ while (source_rib != orig_rib);
+
+ (*rib_slot) = (OBJECT_NEW_TYPE (rib_type, (last_hunk[HIST_RIB])));
+
+ temp = (hist_ptr[HIST_NEXT_SUBPROBLEM]);
+ vert_type = (OBJECT_TYPE (temp));
+ hist_ptr = (OBJECT_ADDRESS (temp));
+ }
+ while (hist_ptr != orig_hist);
+
+ new_hunk = (heap_end [HIST_NEXT_SUBPROBLEM - 3]);
+ (last_hunk[HIST_NEXT_SUBPROBLEM]) = (OBJECT_NEW_TYPE (vert_type, new_hunk));
+ MEMORY_SET (new_hunk, HIST_PREV_SUBPROBLEM,
+ (MAKE_POINTER_OBJECT
+ ((OBJECT_TYPE (hist_ptr[HIST_PREV_SUBPROBLEM])),
+ last_hunk)));
+ return (new_hunk);
}
\f
/* If a "debugging" version of the interpreter is made, then this
procedure is called to actually invoke a primitive. When a
"production" version is made, all of the consistency checks are
- omitted and a macro from "default.h" is used to directly code the
+ omitted and a macro from "interp.h" is used to directly code the
call to the primitive function. */
#ifdef ENABLE_DEBUGGING_TOOLS
-SCHEME_OBJECT
-DEFUN (primitive_apply_internal, (primitive), SCHEME_OBJECT primitive)
+void
+primitive_apply_internal (SCHEME_OBJECT primitive)
{
- SCHEME_OBJECT result;
if (Primitive_Debug)
Print_Primitive (primitive);
+#if 0
{
- SCHEME_OBJECT * saved_stack = sp_register;
- PRIMITIVE_APPLY_INTERNAL (result, primitive);
- if (saved_stack != sp_register)
+ SCHEME_OBJECT * saved_stack = stack_pointer;
+ PRIMITIVE_APPLY_INTERNAL (primitive);
+ /* Some primitives violate this condition, for example,
+ WITH-INTERRUPT-MASK. */
+ if (saved_stack != stack_pointer)
{
- int arity = (PRIMITIVE_N_ARGUMENTS (primitive));
+ unsigned long arity = (PRIMITIVE_N_ARGUMENTS (primitive));
Print_Expression (primitive, "Stack bad after ");
- outf_fatal ("\nStack was 0x%lx, now 0x%lx, #args=%ld.\n",
- ((long) saved_stack), ((long) sp_register), ((long) arity));
+ outf_fatal ("\nStack was %#lx, now %#lx, #args=%lu.\n",
+ ((unsigned long) saved_stack),
+ ((unsigned long) stack_pointer),
+ arity);
Microcode_Termination (TERM_EXIT);
}
}
+#else
+ PRIMITIVE_APPLY_INTERNAL (primitive);
+#endif
if (Primitive_Debug)
{
- Print_Expression (result, "Primitive Result");
+ Print_Expression (GET_VAL, "Primitive Result");
outf_error("\n");
outf_flush_error();
}
- return (result);
}
#endif /* ENABLE_DEBUGGING_TOOLS */
#ifdef ENABLE_PRIMITIVE_PROFILING
/* The profiling mechanism is enabled by storing a vector in the fixed
- objects vector. The vector should be initialized to contain all zeros
- */
-
-void
-DEFUN (record_primitive_entry, (primitive), SCHEME_OBJECT primitive)
-{
- SCHEME_OBJECT table;
-
- if ((Fixed_Objects != SHARP_F) &&
- ((table = Get_Fixed_Obj_Slot (Primitive_Profiling_Table)) != SHARP_F))
- {
- long index = (1 + (OBJECT_DATUM (primitive)));
- MEMORY_SET
- (table,
- index,
- (long_to_integer (1 + (integer_to_long (MEMORY_REF (table, index))))));
- }
- return;
-}
-
-#endif /* ENABLE_PRIMITIVE_PROFILING */
-\f
-#ifdef USE_STACKLETS
- /******************/
- /* STACKLETS */
- /******************/
+ objects vector. The vector should be initialized to contain all
+ zeros. */
void
-DEFUN (Allocate_New_Stacklet, (N), long N)
+record_primitive_entry (SCHEME_OBJECT primitive)
{
- SCHEME_OBJECT Old_Expression, *Old_Stacklet, Old_Return;
- Old_Stacklet = Current_Stacklet;
- Terminate_Old_Stacklet();
- if ((Free_Stacklets == NULL) ||
- ((N + STACKLET_SLACK) >
- (OBJECT_DATUM (Free_Stacklets[STACKLET_LENGTH]))))
- {
- long size;
-
- /*
- Room is set aside for the header bytes of a stacklet plus
- the two words required for the RC_JOIN_STACKLETS frame.
- */
-
- size = New_Stacklet_Size(N);
- if (GC_Check(size))
+ if (VECTOR_P (fixed_objects))
{
- Request_GC(size);
- if ((Free + size) >= Heap_Top)
- Microcode_Termination(TERM_STACK_OVERFLOW);
+ SCHEME_OBJECT table
+ = (VECTOR_REF (fixed_objects, Primitive_Profiling_Table));
+ if (VECTOR_P (table))
+ {
+ unsigned long index = (OBJECT_DATUM (primitive));
+ VECTOR_SET (table,
+ index,
+ (ulong_to_integer
+ (1 + (integer_to_ulong (VECTOR_REF (table, index))))));
+ }
}
- Free[STACKLET_LENGTH] = MAKE_OBJECT (TC_MANIFEST_VECTOR, (size - 1));
- SET_STACK_GUARD (& (Free[STACKLET_HEADER_SIZE]));
- Free += size;
- sp_register = Free;
- }
- else
- {
- /* Grab first one on the free list */
-
- SCHEME_OBJECT *New_Stacklet;
-
- New_Stacklet = Free_Stacklets;
- Free_Stacklets =
- ((SCHEME_OBJECT *) Free_Stacklets[STACKLET_FREE_LIST_LINK]);
- sp_register =
- &New_Stacklet[1 + (OBJECT_DATUM (New_Stacklet[STACKLET_LENGTH]))];
- SET_STACK_GUARD (& (New_Stacklet[STACKLET_HEADER_SIZE]));
- }
- Old_Expression = exp_register;
- Old_Return = ret_register;
- exp_register = (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Old_Stacklet));
- Store_Return(RC_JOIN_STACKLETS);
- /*
- Will_Push omitted because size calculation includes enough room.
- */
- Save_Cont();
- exp_register = Old_Expression;
- Store_Return(Old_Return);
- return;
}
-#endif /* USE_STACKLETS */
+#endif /* ENABLE_PRIMITIVE_PROFILING */
\f
/* Dynamic Winder support code */
SCHEME_OBJECT
-DEFUN (Find_State_Space, (State_Point), SCHEME_OBJECT State_Point)
+Find_State_Space (SCHEME_OBJECT State_Point)
{
long How_Far =
(UNSIGNED_FIXNUM_TO_LONG
- (FAST_MEMORY_REF (State_Point, STATE_POINT_DISTANCE_TO_ROOT)));
+ (MEMORY_REF (State_Point, STATE_POINT_DISTANCE_TO_ROOT)));
long i;
- fast SCHEME_OBJECT Point = State_Point;
+ SCHEME_OBJECT Point = State_Point;
for (i=0; i <= How_Far; i++)
{
#ifdef ENABLE_DEBUGGING_TOOLS
if (Point == SHARP_F)
{
- outf_fatal(
- "\nState_Point 0x%lx wrong: count was %ld, #F at %ld\n",
+ outf_fatal("\nState_Point %#lx wrong: count was %ld, #F at %ld\n",
((long) State_Point), ((long) How_Far), ((long) i));
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
#endif /* ENABLE_DEBUGGING_TOOLS */
- Point = FAST_MEMORY_REF (Point, STATE_POINT_NEARER_POINT);
+ Point = MEMORY_REF (Point, STATE_POINT_NEARER_POINT);
}
return (Point);
}
-/* ASSUMPTION: State points, which are created only by the interpreter,
- never contain FUTUREs except possibly as the thunks (which are handled
- by the apply code).
+/* Assumptions:
- Furthermore:
(1) On a single processor, things should work with multiple state
- spaces. The microcode variable Current_State_Point tracks
+ spaces. The microcode variable current_state_point tracks
the location in the "boot" space (i.e. the one whose space is
#F) and the state spaces themselves (roots of the space
trees) track the other spaces.
itself. As such, it is using the pun that PRIMITIVE_ABORT is just a
(non-local) return to the interpreter. This should be cleaned up.
NOTE: Any primitive that invokes this procedure must do a
- PRIMITIVE_CANONICALIZE_CONTEXT() first!
-*/
-\f
+ canonicalize_primitive_context() first! */
+
void
-DEFUN (Translate_To_Point, (Target), SCHEME_OBJECT Target)
+Translate_To_Point (SCHEME_OBJECT Target)
{
SCHEME_OBJECT State_Space, Current_Location, *Path;
- fast SCHEME_OBJECT Path_Point, *Path_Ptr;
+ SCHEME_OBJECT Path_Point, *Path_Ptr;
long Distance, Merge_Depth, From_Depth, i;
State_Space = Find_State_Space(Target);
Path = Free;
- guarantee_state_point();
Distance =
(UNSIGNED_FIXNUM_TO_LONG
- (FAST_MEMORY_REF (Target, STATE_POINT_DISTANCE_TO_ROOT)));
+ (MEMORY_REF (Target, STATE_POINT_DISTANCE_TO_ROOT)));
if (State_Space == SHARP_F)
- Current_Location = Current_State_Point;
+ Current_Location = current_state_point;
else
Current_Location = MEMORY_REF (State_Space, STATE_SPACE_NEAREST_POINT);
i++)
{
*Path_Ptr-- = Path_Point;
- Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
+ Path_Point = MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
}
From_Depth =
(UNSIGNED_FIXNUM_TO_LONG
- (FAST_MEMORY_REF (Current_Location, STATE_POINT_DISTANCE_TO_ROOT)));
-\f
+ (MEMORY_REF (Current_Location, STATE_POINT_DISTANCE_TO_ROOT)));
+
for (Path_Point = Current_Location, Merge_Depth = From_Depth;
Merge_Depth > Distance;
Merge_Depth--)
- Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
+ Path_Point = MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
for (Path_Ptr = (&(Path[Merge_Depth]));
Merge_Depth >= 0;
{
if (*Path_Ptr == Path_Point)
break;
- Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
+ Path_Point = MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
}
#ifdef ENABLE_DEBUGGING_TOOLS
if (Merge_Depth < 0)
{
- outf_fatal("\nMerge_Depth went negative: %d\n", Merge_Depth);
+ outf_fatal ("\nMerge_Depth went negative: %ld\n", Merge_Depth);
Microcode_Termination (TERM_EXIT);
}
#endif /* ENABLE_DEBUGGING_TOOLS */
STACK_PUSH (Target);
STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM((From_Depth - Merge_Depth)));
STACK_PUSH (Current_Location);
- exp_register = State_Space;
- Store_Return(RC_MOVE_TO_ADJACENT_POINT);
- Save_Cont();
+ SET_EXP (State_Space);
+ SET_RC(RC_MOVE_TO_ADJACENT_POINT);
+ SAVE_CONT();
Pushed();
- {
- long mask;
-
- /* Disable lower than GC level */
- mask = (FETCH_INTERRUPT_MASK() & ((INT_GC << 1) - 1));
- SET_INTERRUPT_MASK(mask);
- }
+ /* Disable lower than GC level */
+ SET_INTERRUPT_MASK (GET_INT_MASK & ((INT_GC << 1) - 1));
PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
#ifdef __WIN32__
#include <windows.h>
-#include "cmpintmd.h"
SCHEME_OBJECT
-DEFUN_VOID (Compiler_Get_Fixed_Objects)
+Compiler_Get_Fixed_Objects (void)
{
- if (Valid_Fixed_Obj_Vector())
- return (Get_Fixed_Obj_Slot(Me_Myself));
- else
- return (SHARP_F);
+ return ((VECTOR_P (fixed_objects)) ? fixed_objects : SHARP_F);
}
-extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void));
-extern SCHEME_OBJECT EXFUN
- (C_call_scheme, (SCHEME_OBJECT, long, SCHEME_OBJECT *));
+extern SCHEME_OBJECT Re_Enter_Interpreter (void);
+extern SCHEME_OBJECT C_call_scheme
+ (SCHEME_OBJECT, long, SCHEME_OBJECT *);
SCHEME_OBJECT
-DEFUN (C_call_scheme, (proc, nargs, argvec),
- SCHEME_OBJECT proc
- AND long nargs
- AND SCHEME_OBJECT * argvec)
+C_call_scheme (SCHEME_OBJECT proc,
+ long n_args,
+ SCHEME_OBJECT * argvec)
{
SCHEME_OBJECT primitive, prim_lexpr, * sp, result;
SCHEME_OBJECT * callers_last_return_code;
-#if (COMPILER_PROCESSOR_TYPE == COMPILER_IA32_TYPE)
+#ifdef CC_IS_NATIVE
extern void * C_Frame_Pointer;
extern void * C_Stack_Pointer;
void * cfp = C_Frame_Pointer;
__try
#endif
#endif
- {
- primitive = (Registers[REGBLOCK_PRIMITIVE]);
- prim_lexpr = (Registers[REGBLOCK_LEXPR_ACTUALS]);
+ {
+ primitive = GET_PRIMITIVE;
+ prim_lexpr = GET_LEXPR_ACTUALS;
callers_last_return_code = last_return_code;
if (! (PRIMITIVE_P (primitive)))
abort_to_interpreter (ERR_CANNOT_RECURSE);
/*NOTREACHED*/
- sp = sp_register;
+ sp = stack_pointer;
- Will_Push ((2 * CONTINUATION_SIZE) + (nargs + STACK_ENV_EXTRA_SLOTS + 1));
+ Will_Push ((2 * CONTINUATION_SIZE) + (n_args + STACK_ENV_EXTRA_SLOTS + 1));
{
long i;
- Store_Return (RC_END_OF_COMPUTATION);
- exp_register = primitive;
- Save_Cont ();
+ SET_RC (RC_END_OF_COMPUTATION);
+ SET_EXP (primitive);
+ SAVE_CONT ();
- for (i = nargs; --i >= 0; )
+ for (i = n_args; --i >= 0; )
STACK_PUSH (argvec[i]);
STACK_PUSH (proc);
- STACK_PUSH (STACK_FRAME_HEADER + nargs);
+ PUSH_APPLY_FRAME_HEADER (n_args);
- Store_Return (RC_INTERNAL_APPLY);
- exp_register = SHARP_F;
- Save_Cont ();
+ SET_RC (RC_INTERNAL_APPLY);
+ SET_EXP (SHARP_F);
+ SAVE_CONT ();
}
Pushed ();
result = (Re_Enter_Interpreter ());
- if (sp_register != sp)
+ if (stack_pointer != sp)
signal_error_from_primitive (ERR_STACK_HAS_SLIPPED);
/*NOTREACHED*/
last_return_code = callers_last_return_code;
- Registers[REGBLOCK_LEXPR_ACTUALS] = prim_lexpr;
- Registers[REGBLOCK_PRIMITIVE] = primitive;
+ SET_LEXPR_ACTUALS (prim_lexpr);
+ SET_PRIMITIVE (primitive);
}
-#if (COMPILER_PROCESSOR_TYPE == COMPILER_IA32_TYPE)
+#ifdef CC_IS_NATIVE
#ifdef CL386
- __finally
+ __finally
#endif
{
C_Frame_Pointer = cfp;
return result;
}
-#endif /* not __OS2__ */
+#endif /* __WIN32__ */
+\f
+void
+set_ptr_register (unsigned int index, SCHEME_OBJECT * p)
+{
+ (Registers[index]) = ((SCHEME_OBJECT) p);
+}
+
+void
+set_ulong_register (unsigned int index, unsigned long value)
+{
+ (Registers[index]) = ((SCHEME_OBJECT) value);
+}
/* -*-C-*-
-$Id: ux.c,v 1.31 2007/01/22 07:47:39 riastradh Exp $
+$Id: ux.c,v 1.32 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#endif
\f
void
-DEFUN (UX_prim_check_errno, (name), enum syscall_names name)
+UX_prim_check_errno (enum syscall_names name)
{
if (errno != EINTR)
error_system_call (errno, name);
#ifdef HAVE_TERMIOS_H
int
-DEFUN (UX_terminal_get_state, (fd, s), int fd AND Ttty_state * s)
+UX_terminal_get_state (int fd, Ttty_state * s)
{
return
((((tcgetattr (fd, (& (s -> tio)))) < 0)
}
int
-DEFUN (UX_terminal_set_state, (fd, s), int fd AND Ttty_state * s)
+UX_terminal_set_state (int fd, Ttty_state * s)
{
return
((((tcsetattr (fd, TCSANOW, (& (s -> tio)))) < 0)
#ifdef HAVE_TERMIO_H
int
-DEFUN (UX_terminal_get_state, (fd, s), int fd AND Ttty_state * s)
+UX_terminal_get_state (int fd, Ttty_state * s)
{
return
((((UX_ioctl (fd, TCGETA, (& (s -> tio)))) < 0)
}
int
-DEFUN (UX_terminal_set_state, (fd, s), int fd AND Ttty_state * s)
+UX_terminal_set_state (int fd, Ttty_state * s)
{
return
((((UX_ioctl (fd, TCSETA, (& (s -> tio)))) < 0)
}
int
-DEFUN (UX_tcdrain, (fd), int fd)
+UX_tcdrain (int fd)
{
return (UX_ioctl (fd, TCSBRK, 1));
}
int
-DEFUN (UX_tcflush, (fd, queue_selector), int fd AND int queue_selector)
+UX_tcflush (int fd, int queue_selector)
{
return (UX_ioctl (fd, TCFLSH, queue_selector));
}
#ifdef HAVE_SGTTY_H
int
-DEFUN (UX_terminal_get_state, (fd, s), int fd AND Ttty_state * s)
+UX_terminal_get_state (int fd, Ttty_state * s)
{
return
((((UX_ioctl (fd, TIOCGETP, (& (s -> sg)))) < 0)
}
int
-DEFUN (UX_terminal_set_state, (fd, s), int fd AND Ttty_state * s)
+UX_terminal_set_state (int fd, Ttty_state * s)
{
return
((((UX_ioctl (fd, TIOCSETN, (& (s -> sg)))) < 0)
}
int
-DEFUN (UX_tcdrain, (fd), int fd)
+UX_tcdrain (int fd)
{
/* BSD provides no such feature -- pretend it worked. */
return (0);
}
int
-DEFUN (UX_tcflush, (fd, queue_selector), int fd AND int queue_selector)
+UX_tcflush (int fd, int queue_selector)
{
/* Losing BSD always flushes input and output together. */
int zero = 0;
\f
#ifdef SLAVE_PTY_P
int
-DEFUN (UX_setup_slave_pty, (fd), int fd)
+UX_setup_slave_pty (int fd)
{
return
(((ioctl (fd, I_PUSH, "ptem")) == 0)
\f
#ifdef EMULATE_GETPGRP
pid_t
-DEFUN_VOID (UX_getpgrp)
+UX_getpgrp (void)
{
return (getpgrp (getpid ()));
}
#ifdef EMULATE_SETSID
pid_t
-DEFUN_VOID (UX_setsid)
+UX_setsid (void)
{
#ifdef TIOCNOTTY
int fd = (UX_open ("/dev/tty", O_RDWR, 0));
#ifdef EMULATE_SETPGID
int
-DEFUN (UX_setpgid, (pid, pgid), pid_t pid AND pid_t pgid)
+UX_setpgid (pid_t pid, pid_t pgid)
{
errno = ENOSYS;
return (-1);
#ifdef EMULATE_CTERMID
char *
-DEFUN (UX_ctermid, (s), char * s)
+UX_ctermid (char * s)
{
static char result [] = "/dev/tty";
if (s == 0)
#ifdef EMULATE_KILL
int
-DEFUN (UX_kill, (pid, sig), pid_t pid AND int sig)
+UX_kill (pid_t pid, int sig)
{
return ((pid >= 0) ? (kill (pid, sig)) : (killpg ((-pid), sig)));
}
#ifdef EMULATE_TCGETPGRP
pid_t
-DEFUN (UX_tcgetpgrp, (fd), int fd)
+UX_tcgetpgrp (int fd)
{
#ifdef TIOCGPGRP
pid_t pgrp_id;
#ifdef EMULATE_TCSETPGRP
int
-DEFUN (UX_tcsetpgrp, (fd, pgrp_id),
- int fd AND
- pid_t pgrp_id)
+UX_tcsetpgrp (int fd, pid_t pgrp_id)
{
#ifdef TIOCSPGRP
return (UX_ioctl (fd, TIOCSPGRP, (&pgrp_id)));
\f
#ifdef EMULATE_GETCWD
char *
-DEFUN (UX_getcwd, (buffer, length),
- char * buffer AND
- size_t length)
+UX_getcwd (char * buffer, size_t length)
{
char internal_buffer [MAXPATHLEN + 2];
char * collection_buffer;
\f
#ifdef EMULATE_WAITPID
int
-DEFUN (UX_waitpid, (pid, stat_loc, options),
- pid_t pid AND
- int * stat_loc AND
- int options)
+UX_waitpid (pid_t pid, int * stat_loc, int options)
{
if (pid == (-1))
return (wait3 (stat_loc, options, 0));
#ifdef EMULATE_DUP2
int
-DEFUN (UX_dup2, (fd, fd2), int fd AND int fd2)
+UX_dup2 (int fd, int fd2)
{
if (fd != fd2)
UX_close (fd2);
#ifdef EMULATE_RENAME
int
-DEFUN (UX_rename, (from_name, to_name),
- CONST char * from_name AND
- CONST char * to_name)
+UX_rename (const char * from_name, const char * to_name)
{
int result;
if ((result = (UX_access (from_name, 0))) < 0)
#ifdef EMULATE_MKDIR
int
-DEFUN (UX_mkdir, (name, mode),
- CONST char * name AND
- mode_t mode)
+UX_mkdir (const char * name, mode_t mode)
{
return (UX_mknod (name, ((mode & MODE_DIR) | S_IFDIR), ((dev_t) 0)));
}
#ifdef _POSIX_VERSION
cc_t
-DEFUN (UX_PC_VDISABLE, (fildes), int fildes)
+UX_PC_VDISABLE (int fildes)
{
#ifdef _POSIX_VDISABLE
return ((cc_t) _POSIX_VDISABLE);
static clock_t memoized_clk_tck = 0;
clock_t
-DEFUN_VOID (UX_SC_CLK_TCK)
+UX_SC_CLK_TCK (void)
{
if (memoized_clk_tck == 0)
memoized_clk_tck = ((clock_t) (sysconf (_SC_CLK_TCK)));
#ifndef HAVE_SIGACTION
int
-DEFUN (UX_sigemptyset, (set), sigset_t * set)
+UX_sigemptyset (sigset_t * set)
{
(*set) = 0;
return (0);
}
int
-DEFUN (UX_sigfillset, (set), sigset_t * set)
+UX_sigfillset (sigset_t * set)
{
(*set) = (-1);
return (0);
}
int
-DEFUN (UX_sigaddset, (set, signo), sigset_t * set AND int signo)
+UX_sigaddset (sigset_t * set, int signo)
{
if (signo <= 0)
return (-1);
}
int
-DEFUN (UX_sigdelset, (set, signo), sigset_t * set AND int signo)
+UX_sigdelset (sigset_t * set, int signo)
{
if (signo <= 0)
return (-1);
}
int
-DEFUN (UX_sigismember, (set, signo), CONST sigset_t * set AND int signo)
+UX_sigismember (const sigset_t * set, int signo)
{
if (signo <= 0)
return (-1);
#endif
int
-DEFUN (UX_sigaction, (signo, act, oact),
- int signo AND
- CONST struct sigaction * act AND
- struct sigaction * oact)
+UX_sigaction (int signo, const struct sigaction * act, struct sigaction * oact)
{
struct sigvec svec;
struct sigvec sovec;
}
int
-DEFUN (UX_sigprocmask, (how, set, oset),
- int how AND
- CONST sigset_t * set AND
- sigset_t * oset)
+UX_sigprocmask (int how, const sigset_t * set, sigset_t * oset)
{
long omask;
if (set == 0)
}
int
-DEFUN (UX_sigsuspend, (set), CONST sigset_t * set)
+UX_sigsuspend (const sigset_t * set)
{
return (sigpause (*set));
}
\f
#ifdef EMULATE_SYSCONF
long
-DEFUN (sysconf, (parameter), int parameter)
+sysconf (int parameter)
{
switch (parameter)
{
#ifdef EMULATE_FPATHCONF
long
-DEFUN (fpathconf, (filedes, parameter), int filedes AND int parameter)
+fpathconf (int filedes, int parameter)
{
switch (parameter)
{
}
#endif /* EMULATE_FPATHCONF */
\f
-/* This is called during initialization, when the error system is not
- set up.
-*/
-
void *
-DEFUN (OS_malloc_init, (size), unsigned int size)
+OS_malloc_init (size_t size)
{
- void * result = (UX_malloc (size));
- return (result);
+ return (UX_malloc (size));
}
void *
-DEFUN (OS_malloc, (size), unsigned int size)
+OS_malloc (size_t size)
{
void * result = (UX_malloc (size));
if (result == 0)
}
void *
-DEFUN (OS_realloc, (ptr, size), void * ptr AND unsigned int size)
+OS_realloc (void * ptr, size_t size)
{
void * result = (UX_realloc (ptr, size));
if (result == 0)
}
void
-DEFUN (OS_free, (ptr), void * ptr)
+OS_free (void * ptr)
{
UX_free (ptr);
}
#ifdef HAVE_SYSCONF
unsigned long
-DEFUN_VOID (UX_getpagesize)
+UX_getpagesize (void)
{
static int vp = 0;
static long v;
/* -*-C-*-
-$Id: ux.h,v 1.82 2007/01/05 21:19:25 cph Exp $
+$Id: ux.h,v 1.83 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#endif
#if defined(__netbsd__) || defined(__NetBSD__)
-# define SYSTEM_VARIANT "NETBSD"
+# define SYSTEM_VARIANT "NetBSD"
#endif
#ifdef _NEXTOS
#include <grp.h>
#include <pwd.h>
#include <signal.h>
-#include <stdio.h>
#include <sys/param.h>
#include <sys/stat.h>
#include <sys/times.h>
extern char ** environ;
#endif
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# include <string.h>
-#else
-# ifndef HAVE_STRCHR
-# define strchr index
-# define strrchr rindex
-# endif
- extern char * strchr ();
- extern char * strrchr ();
-# ifndef HAVE_MEMCPY
-# define memcpy(d, s, n) bcopy ((s), (d), (n))
-# define memmove(d, s, n) bcopy ((s), (d), (n))
-# endif
-#endif
-
#ifdef HAVE_SYS_FILE_H
# include <sys/file.h>
#endif
#ifdef HAVE_SYS_IOCTL_H
# include <sys/ioctl.h>
#else
- extern int EXFUN (ioctl, (int, unsigned long, ...));
+ extern int ioctl (int, unsigned long, ...);
#endif
#ifdef HAVE_FCNTL_H
# include <fcntl.h>
#else
- extern int EXFUN (open, (CONST char *, int, ...));
-#endif
-
-#ifdef HAVE_LIMITS_H
-# include <limits.h>
+ extern int open (const char *, int, ...);
#endif
#ifdef HAVE_SYS_WAIT_H
# ifndef WSTOPSIG
# define WSTOPSIG(_X) (((_X) & 0xFF00) >> 8)
# endif
- extern pid_t EXFUN (wait, (int *));
+ extern pid_t wait (int *);
# ifdef HAVE_WAITPID
- extern pid_t EXFUN (waitpid, (pid_t, int *, int));
+ extern pid_t waitpid (pid_t, int *, int);
# endif
# ifdef HAVE_WAIT3
- extern pid_t EXFUN (wait3, (int *, int, struct rusage *));
+ extern pid_t wait3 (int *, int, struct rusage *);
# endif
#endif
time_t actime;
time_t modtime;
};
- extern int EXFUN (utime, (CONST char *, struct utimbuf *));
+ extern int utime (const char *, struct utimbuf *);
#endif
#ifdef HAVE_TERMIOS_H
#ifdef _POSIX_REALTIME_SIGNALS
typedef void (*Tsignal_handler) (int, siginfo_t *, void *);
#else
- typedef RETSIGTYPE EXFUN ((*Tsignal_handler), (int));
+ typedef RETSIGTYPE (*Tsignal_handler) (int);
#endif
#ifdef VOID_SIGNAL_HANDLERS
# define MAXPATHLEN 1024
#endif
-#ifdef HAVE_STDC
+#ifdef HAVE_C_BACKSLASH_A
# define ALERT_CHAR '\a'
# define ALERT_STRING "\a"
#else
\f
#ifdef HAVE_GETLOGIN
# ifndef HAVE_UNISTD_H
- extern char * EXFUN (getlogin, (void));
+ extern char * getlogin (void);
# endif
#endif
#ifndef STDC_HEADERS
# ifndef HAVE_MALLOC_H
- extern PTR EXFUN (malloc, (size_t));
- extern PTR EXFUN (realloc, (PTR, size_t));
+ extern void * malloc (size_t);
+ extern void * realloc (void *, size_t);
# endif
- extern char * EXFUN (getenv, (CONST char *));
+ extern char * getenv (const char *);
#endif
#define UX_abort abort
# define UX_dup2 dup2
#else
# ifdef HAVE_FCNTL
- extern int EXFUN (UX_dup2, (int, int));
+ extern int UX_dup2 (int, int);
# define EMULATE_DUP2
# define HAVE_DUP2
# endif
#ifdef HAVE_GETCWD
# define UX_getcwd getcwd
#else
- extern char * EXFUN (UX_getcwd, (char *, size_t));
+ extern char * UX_getcwd (char *, size_t);
# define EMULATE_GETCWD
# define HAVE_GETCWD
#endif
#ifdef HAVE_MKDIR
# define UX_mkdir mkdir
#else
- extern int EXFUN (UX_mkdir, (CONST char *, mode_t));
+ extern int UX_mkdir (const char *, mode_t);
# define EMULATE_MKDIR
# define HAVE_MKDIR
#endif
#ifdef HAVE_RENAME
# define UX_rename rename
#else
- extern int EXFUN (UX_rename, (CONST char *, CONST char *));
+ extern int UX_rename (const char *, const char *);
# define EMULATE_RENAME
# define HAVE_RENAME
#endif
# define UX_waitpid waitpid
#else
# ifdef HAVE_WAIT3
- extern int EXFUN (UX_waitpid, (pid_t, int *, int));
+ extern int UX_waitpid (pid_t, int *, int);
# define EMULATE_WAITPID
# define HAVE_WAITPID
# endif
#ifdef HAVE_CTERMID
# define UX_ctermid ctermid
#else
- extern char * EXFUN (UX_ctermid, (char * s));
+ extern char * UX_ctermid (char * s);
# define EMULATE_CTERMID
#endif
#ifdef HAVE_KILL
# define UX_kill kill
#else
- extern int EXFUN (UX_kill, (pid_t pid, int sig));
+ extern int UX_kill (pid_t pid, int sig);
# define EMULATE_KILL
#endif
#ifdef HAVE_GETPAGESIZE
# define UX_getpagesize getpagesize
#else
- extern unsigned long EXFUN (UX_getpagesize, (void));
+ extern unsigned long UX_getpagesize (void);
# define EMULATE_GETPAGESIZE
#endif
\f
+/* poll is somewhat busted on Mac OSX 10.4 (Tiger), so use select. */
#ifdef __APPLE__
-/* poll is somewhat busted on Mac OSX 10.4 (Tiger). Force the use of select */
-
-#undef HAVE_POLL
+# undef HAVE_POLL
#endif
#ifdef HAVE_POLL
/* Must push various STREAMS modules onto the slave side of a PTY
when it is opened. */
# define SLAVE_PTY_P(filename) ((strncmp ((filename), "/dev/pts/", 9)) == 0)
- extern int EXFUN (UX_setup_slave_pty, (int));
+ extern int UX_setup_slave_pty (int);
# define SETUP_SLAVE_PTY UX_setup_slave_pty
#endif
#else /* not HAVE_TERMIOS_H */
-extern int EXFUN (UX_tcdrain, (int));
-extern int EXFUN (UX_tcflush, (int, int));
+extern int UX_tcdrain (int);
+extern int UX_tcflush (int, int);
/* These values chosen to match the ioctl TCFLSH argument for termio. */
#define TCIFLUSH 0
#define TCOFLUSH 1
#endif /* not HAVE_TERMIO_H */
#endif /* not HAVE_TERMIOS_H */
-extern int EXFUN (UX_terminal_get_state, (int, Ttty_state *));
-extern int EXFUN (UX_terminal_set_state, (int, Ttty_state *));
+extern int UX_terminal_get_state (int, Ttty_state *);
+extern int UX_terminal_set_state (int, Ttty_state *);
#ifdef _POSIX_VERSION
# define UX_getpgrp getpgrp
# ifdef GETPGRP_VOID
# define UX_getpgrp getpgrp
# else
- extern pid_t EXFUN (UX_getpgrp, (void));
+ extern pid_t UX_getpgrp (void);
# define EMULATE_GETPGRP
# endif
# ifdef SETPGRP_VOID
# define UX_setsid setpgrp
# else
- extern pid_t EXFUN (UX_setsid, (void));
+ extern pid_t UX_setsid (void);
# define EMULATE_SETSID
# endif
# ifdef HAVE_SETPGRP2
# endif
# endif
# endif
- extern pid_t EXFUN (UX_tcgetpgrp, (int));
+ extern pid_t UX_tcgetpgrp (int);
# define EMULATE_TCGETPGRP
- extern int EXFUN (UX_tcsetpgrp, (int, pid_t));
+ extern int UX_tcsetpgrp (int, pid_t);
# define EMULATE_TCSETPGRP
#endif
#else /* not HAVE_SIGACTION */
typedef long sigset_t;
-extern int EXFUN (UX_sigemptyset, (sigset_t *));
-extern int EXFUN (UX_sigfillset, (sigset_t *));
-extern int EXFUN (UX_sigaddset, (sigset_t *, int));
-extern int EXFUN (UX_sigdelset, (sigset_t *, int));
-extern int EXFUN (UX_sigismember, (CONST sigset_t *, int));
+extern int UX_sigemptyset (sigset_t *);
+extern int UX_sigfillset (sigset_t *);
+extern int UX_sigaddset (sigset_t *, int);
+extern int UX_sigdelset (sigset_t *, int);
+extern int UX_sigismember (const sigset_t *, int);
#ifdef HAVE_SIGVEC
# define UX_sigvec sigvec
int sa_flags;
};
-extern int EXFUN
- (UX_sigaction, (int, CONST struct sigaction *, struct sigaction *));
-extern int EXFUN (UX_sigprocmask, (int, CONST sigset_t *, sigset_t *));
-extern int EXFUN (UX_sigsuspend, (CONST sigset_t *));
+extern int UX_sigaction (int, const struct sigaction *, struct sigaction *);
+extern int UX_sigprocmask (int, const sigset_t *, sigset_t *);
+extern int UX_sigsuspend (const sigset_t *);
#define SIG_BLOCK 0
#define SIG_UNBLOCK 1
#define SIG_SETMASK 2
#ifdef _POSIX_VERSION
# ifndef HAVE_FPATHCONF
- extern long EXFUN (fpathconf, (int, int));
+ extern long fpathconf (int, int);
# define EMULATE_FPATHCONF
# endif
# ifndef HAVE_SYSCONF
- extern long EXFUN (sysconf, (int));
+ extern long sysconf (int);
# define EMULATE_SYSCONF
# endif
- extern cc_t EXFUN (UX_PC_VDISABLE, (int fildes));
- extern clock_t EXFUN (UX_SC_CLK_TCK, (void));
+ extern cc_t UX_PC_VDISABLE (int fildes);
+ extern clock_t UX_SC_CLK_TCK (void);
# define UX_SC_OPEN_MAX() ((size_t) (sysconf (_SC_OPEN_MAX)))
# define UX_SC_CHILD_MAX() ((size_t) (sysconf (_SC_CHILD_MAX)))
#endif /* not _POSIX_VERSION */
\f
-extern void EXFUN (UX_prim_check_errno, (enum syscall_names name));
+extern void UX_prim_check_errno (enum syscall_names name);
#define STD_VOID_SYSTEM_CALL(name, expression) \
{ \
/* -*-C-*-
-$Id: uxctty.c,v 1.18 2007/01/05 21:19:25 cph Exp $
+$Id: uxctty.c,v 1.19 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
static struct terminal_state_recording inside_stdin_state;
static struct terminal_state_recording inside_stdout_state;
-static void EXFUN (ctty_update_interrupt_chars, (void));
+static void ctty_update_interrupt_chars (void);
\f
static int
-DEFUN (get_terminal_state, (fd, s), int fd AND Ttty_state * s)
+get_terminal_state (int fd, Ttty_state * s)
{
while (1)
{
}
static int
-DEFUN (set_terminal_state, (fd, s), int fd AND Ttty_state * s)
+set_terminal_state (int fd, Ttty_state * s)
{
while (1)
{
static int
-DEFUN (get_flags, (fd, flags), int fd AND int * flags)
+get_flags (int fd, int * flags)
{
#ifdef FCNTL_NONBLOCK
while (1)
}
static int
-DEFUN (set_flags, (fd, flags), int fd AND int * flags)
+set_flags (int fd, int * flags)
{
#ifdef FCNTL_NONBLOCK
while (1)
}
\f
static void
-DEFUN (save_external_state, (s), struct terminal_state_recording * s)
+save_external_state (struct terminal_state_recording * s)
{
(s -> recorded_p) =
(scheme_in_foreground
}
static void
-DEFUN (restore_external_state, (s), struct terminal_state_recording * s)
+restore_external_state (struct terminal_state_recording * s)
{
if (s -> recorded_p)
{
}
void
-DEFUN (save_internal_state, (s, es),
- struct terminal_state_recording * s AND
+save_internal_state (struct terminal_state_recording * s,
struct terminal_state_recording * es)
{
/* Don't do anything unless we have a recording of the external
}
static void
-DEFUN (restore_internal_state, (s, es),
- struct terminal_state_recording * s AND
+restore_internal_state (struct terminal_state_recording * s,
struct terminal_state_recording * es)
{
/* When we recorded the internal state, we had a recording of the
}
\f
void
-DEFUN_VOID (UX_ctty_save_external_state)
+UX_ctty_save_external_state (void)
{
if (permit_ctty_control && (ctty_fildes >= 0))
{
}
void
-DEFUN_VOID (UX_ctty_restore_external_state)
+UX_ctty_restore_external_state (void)
{
restore_external_state (&outside_ctty_state);
restore_external_state (&outside_stdin_state);
}
void
-DEFUN_VOID (UX_ctty_save_internal_state)
+UX_ctty_save_internal_state (void)
{
save_internal_state ((&inside_ctty_state), (&outside_ctty_state));
save_internal_state ((&inside_stdin_state), (&outside_stdin_state));
}
void
-DEFUN_VOID (UX_ctty_restore_internal_state)
+UX_ctty_restore_internal_state (void)
{
int do_update =
((inside_ctty_state . recorded_p)
}
int
-DEFUN_VOID (OS_ctty_interrupt_control)
+OS_ctty_interrupt_control (void)
{
return (outside_ctty_state . recorded_p);
}
int
-DEFUN (UX_terminal_control_ok, (fd), int fd)
+UX_terminal_control_ok (int fd)
{
return
((fd == STDIN_FILENO)
#define KEYBOARD_ALL_INTERRUPTS 0x7
cc_t
-DEFUN_VOID (OS_ctty_quit_char)
+OS_ctty_quit_char (void)
{
return (current_interrupt_chars . quit);
}
cc_t
-DEFUN_VOID (OS_ctty_int_char)
+OS_ctty_int_char (void)
{
return (current_interrupt_chars . intrpt);
}
cc_t
-DEFUN_VOID (OS_ctty_tstp_char)
+OS_ctty_tstp_char (void)
{
return (current_interrupt_chars . tstp);
}
cc_t
-DEFUN_VOID (OS_ctty_disabled_char)
+OS_ctty_disabled_char (void)
{
return ((ctty_fildes >= 0) ? (UX_PC_VDISABLE (ctty_fildes)) : '\377');
}
int
-DEFUN_VOID (OS_ctty_fd)
+OS_ctty_fd (void)
{
return (ctty_fildes);
}
/* not currently used */
static void
-DEFUN (ctty_get_interrupt_chars, (ic), Tinterrupt_chars * ic)
+ctty_get_interrupt_chars (Tinterrupt_chars * ic)
{
Ttty_state s;
if ((get_terminal_state (ctty_fildes, (&s))) == 0)
#endif /* 0 */
\f
static void
-DEFUN (ctty_set_interrupt_chars, (ic), Tinterrupt_chars * ic)
+ctty_set_interrupt_chars (Tinterrupt_chars * ic)
{
Ttty_state s;
if ((get_terminal_state (ctty_fildes, (&s))) == 0)
}
\f
static void
-DEFUN_VOID (ctty_update_interrupt_chars)
+ctty_update_interrupt_chars (void)
{
if (outside_ctty_state . recorded_p)
{
}
\f
void
-DEFUN (OS_ctty_get_interrupt_enables, (mask), Tinterrupt_enables * mask)
+OS_ctty_get_interrupt_enables (Tinterrupt_enables * mask)
{
(*mask) = current_interrupt_enables;
}
void
-DEFUN (OS_ctty_set_interrupt_enables, (mask), Tinterrupt_enables * mask)
+OS_ctty_set_interrupt_enables (Tinterrupt_enables * mask)
{
current_interrupt_enables = (*mask);
ctty_update_interrupt_chars ();
#if 0
void
-DEFUN (OS_ctty_set_interrupt_chars, (quit_char, int_char, tstp_char),
- cc_t quit_char AND
- cc_t int_char AND
+OS_ctty_set_interrupt_chars (cc_t quit_char,
+ cc_t int_char,
cc_t tstp_char)
{
(current_interrupt_chars . quit) = quit_char;
#endif
unsigned int
-DEFUN_VOID (OS_ctty_num_int_chars)
+OS_ctty_num_int_chars (void)
{
return (3);
}
cc_t *
-DEFUN_VOID (OS_ctty_get_int_chars)
+OS_ctty_get_int_chars (void)
{
static cc_t int_chars [3];
}
void
-DEFUN (OS_ctty_set_int_chars, (int_chars), cc_t * int_chars)
+OS_ctty_set_int_chars (cc_t * int_chars)
{
current_interrupt_chars.quit = int_chars[0];
current_interrupt_chars.intrpt = int_chars[1];
return;
}
\f
-extern enum interrupt_handler EXFUN (OS_signal_quit_handler, (void));
-extern enum interrupt_handler EXFUN (OS_signal_int_handler, (void));
-extern enum interrupt_handler EXFUN (OS_signal_tstp_handler, (void));
-extern void EXFUN
- (OS_signal_set_interrupt_handlers,
- (enum interrupt_handler quit_handler,
+extern enum interrupt_handler OS_signal_quit_handler (void);
+extern enum interrupt_handler OS_signal_int_handler (void);
+extern enum interrupt_handler OS_signal_tstp_handler (void);
+extern void OS_signal_set_interrupt_handlers
+ (enum interrupt_handler quit_handler,
enum interrupt_handler int_handler,
- enum interrupt_handler tstp_handler));
+ enum interrupt_handler tstp_handler);
cc_t *
-DEFUN_VOID (OS_ctty_get_int_char_handlers)
+OS_ctty_get_int_char_handlers (void)
{
static cc_t int_handlers [3];
}
void
-DEFUN (OS_ctty_set_int_char_handlers, (int_handlers), cc_t * int_handlers)
+OS_ctty_set_int_char_handlers (cc_t * int_handlers)
{
OS_signal_set_interrupt_handlers
(((enum interrupt_handler) (int_handlers [0])),
}
void
-DEFUN (UX_initialize_ctty, (interactive), int interactive)
+UX_initialize_ctty (int interactive)
{
{
- char * tty = (UX_ctermid (0));
+ char buffer [L_ctermid];
+ char * tty = (UX_ctermid (buffer));
ctty_fildes =
(((tty == 0) || ((tty[0]) == 0))
? (-1)
/* -*-C-*-
-$Id: uxenv.c,v 1.25 2007/01/05 21:19:25 cph Exp $
+$Id: uxenv.c,v 1.26 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
+#include "scheme.h"
+#include "prims.h"
#include "ux.h"
#include "osenv.h"
-#include "config.h" /* For TRUE/FALSE & true/false */
\f
time_t
-DEFUN_VOID (OS_encoded_time)
+OS_encoded_time (void)
{
time_t t;
STD_UINT_SYSTEM_CALL (syscall_time, t, (UX_time (0)));
}
void
-DEFUN (OS_decode_time, (t, buffer), time_t t AND struct time_structure * buffer)
+OS_decode_time (time_t t, struct time_structure * buffer)
{
struct tm * ts;
STD_PTR_SYSTEM_CALL (syscall_localtime, ts, (UX_localtime (&t)));
}
void
-DEFUN (OS_decode_utc, (t, buffer), time_t t AND struct time_structure * buffer)
+OS_decode_utc (time_t t, struct time_structure * buffer)
{
struct tm * ts;
STD_PTR_SYSTEM_CALL (syscall_gmtime, ts, (UX_gmtime (&t)));
}
time_t
-DEFUN (OS_encode_time, (buffer), struct time_structure * buffer)
+OS_encode_time (struct time_structure * buffer)
{
#ifdef HAVE_MKTIME
time_t t = 0;
}
static void
-DEFUN_VOID (initialize_timezone)
+initialize_timezone (void)
{
#ifdef __CYGWIN__
tzset ();
-#endif
+#endif
}
\f
#ifdef HAVE_TIMES
#endif
static void
-DEFUN_VOID (initialize_process_clock)
+initialize_process_clock (void)
{
struct tms buffer;
UX_times (&buffer);
}
double
-DEFUN_VOID (OS_process_clock)
+OS_process_clock (void)
{
double ct = ((double) (UX_SC_CLK_TCK ()));
struct tms buffer;
#else /* not HAVE_TIMES */
static void
-DEFUN_VOID (initialize_process_clock)
+initialize_process_clock (void)
{
}
double
-DEFUN_VOID (OS_process_clock)
+OS_process_clock (void)
{
/* This must not signal an error in normal use. */
return (0.0);
static struct timeval initial_rtc;
static void
-DEFUN_VOID (initialize_real_time_clock)
+initialize_real_time_clock (void)
{
struct timezone tz;
UX_gettimeofday ((&initial_rtc), (&tz));
}
double
-DEFUN_VOID (OS_real_time_clock)
+OS_real_time_clock (void)
{
struct timeval rtc;
struct timezone tz;
static clock_t initial_rtc;
static void
-DEFUN_VOID (initialize_real_time_clock)
+initialize_real_time_clock (void)
{
struct tms buffer;
initial_rtc = (UX_times (&buffer));
}
double
-DEFUN_VOID (OS_real_time_clock)
+OS_real_time_clock (void)
{
double ct = ((double) (UX_SC_CLK_TCK ()));
struct tms buffer;
static time_t initial_rtc;
static void
-DEFUN_VOID (initialize_real_time_clock)
+initialize_real_time_clock (void)
{
initial_rtc = (time (0));
}
double
-DEFUN_VOID (OS_real_time_clock)
+OS_real_time_clock (void)
{
time_t t;
STD_UINT_SYSTEM_CALL (syscall_time, t, (UX_time (0)));
#ifdef HAVE_SETITIMER
static void
-DEFUN (set_timer, (which, first, interval),
- int which AND
- clock_t first AND
+set_timer (int which,
+ clock_t first,
clock_t interval)
{
struct itimerval value;
}
void
-DEFUN (OS_process_timer_set, (first, interval),
- clock_t first AND
+OS_process_timer_set (clock_t first,
clock_t interval)
{
set_timer (ITIMER_VIRTUAL, first, interval);
}
void
-DEFUN_VOID (OS_process_timer_clear)
+OS_process_timer_clear (void)
{
set_timer (ITIMER_VIRTUAL, 0, 0);
}
void
-DEFUN (OS_profile_timer_set, (first, interval),
- clock_t first AND
+OS_profile_timer_set (clock_t first,
clock_t interval)
{
set_timer (ITIMER_PROF, first, interval);
}
void
-DEFUN_VOID (OS_profile_timer_clear)
+OS_profile_timer_clear (void)
{
set_timer (ITIMER_PROF, 0, 0);
}
void
-DEFUN (OS_real_timer_set, (first, interval),
- clock_t first AND
+OS_real_timer_set (clock_t first,
clock_t interval)
{
set_timer (ITIMER_REAL, first, interval);
}
void
-DEFUN_VOID (OS_real_timer_clear)
+OS_real_timer_clear (void)
{
set_timer (ITIMER_REAL, 0, 0);
}
static unsigned int alarm_interval;
void
-DEFUN_VOID (reschedule_alarm)
+reschedule_alarm (void)
{
UX_alarm (alarm_interval);
}
void
-DEFUN (OS_process_timer_set, (first, interval),
- clock_t first AND
+OS_process_timer_set (clock_t first,
clock_t interval)
{
error_unimplemented_primitive ();
}
void
-DEFUN_VOID (OS_process_timer_clear)
+OS_process_timer_clear (void)
{
return;
}
void
-DEFUN (OS_profile_timer_set, (first, interval),
- clock_t first AND
+OS_profile_timer_set (clock_t first,
clock_t interval)
{
error_unimplemented_primitive ();
}
void
-DEFUN_VOID (OS_profile_timer_clear)
+OS_profile_timer_clear (void)
{
return;
}
void
-DEFUN (OS_real_timer_set, (first, interval),
- clock_t first AND
+OS_real_timer_set (clock_t first,
clock_t interval)
{
alarm_interval = ((interval + 999) / 1000);
}
void
-DEFUN_VOID (OS_real_timer_clear)
+OS_real_timer_clear (void)
{
alarm_interval = 0;
UX_alarm (0);
#endif /* HAVE_SETITIMER */
void
-DEFUN_VOID (UX_initialize_environment)
+UX_initialize_environment (void)
{
initialize_timezone ();
initialize_process_clock ();
static size_t current_dir_path_size = 0;
static char * current_dir_path = 0;
-CONST char *
-DEFUN_VOID (OS_working_dir_pathname)
+const char *
+OS_working_dir_pathname (void)
{
if (current_dir_path) {
return (current_dir_path);
}
void
-DEFUN (OS_set_working_dir_pathname, (name), CONST char * name)
+OS_set_working_dir_pathname (const char * name)
{
size_t name_size = strlen (name);
STD_VOID_SYSTEM_CALL (syscall_chdir, (UX_chdir (name)));
if (name_size < current_dir_path_size) {
strcpy(current_dir_path, name);
return;
- }
+ }
current_dir_path_size *= 2;
{
char * new_current_dir_path =
}
}
-CONST char *
-DEFUN_VOID (OS_current_user_name)
+const char *
+OS_current_user_name (void)
{
{
- CONST char * result = (UX_getlogin ());
+ const char * result = (UX_getlogin ());
if ((result != 0) && (*result != '\0'))
return (result);
}
return (0);
}
-CONST char *
-DEFUN_VOID (OS_current_user_home_directory)
+const char *
+OS_current_user_home_directory (void)
{
{
char * user_name = (UX_getlogin ());
/* -*-C-*-
-$Id: uxfile.c,v 1.15 2007/01/05 21:19:25 cph Exp $
+$Id: uxfile.c,v 1.16 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
+#include "scheme.h"
+#include "prims.h"
#include "ux.h"
#include "osfile.h"
#include "uxio.h"
-extern void EXFUN (terminal_open, (Tchannel channel));
+extern void terminal_open (Tchannel channel);
\f
static enum channel_type
-DEFUN (fd_channel_type, (fd), int fd)
+fd_channel_type (int fd)
{
struct stat stat_buf;
if ((UX_fstat (fd, (&stat_buf))) < 0)
}
Tchannel
-DEFUN (OS_open_fd, (fd), int fd)
+OS_open_fd (int fd)
{
enum channel_type type = (fd_channel_type (fd));
Tchannel channel;
}
static Tchannel
-DEFUN (open_file, (filename, oflag), CONST char * filename AND int oflag)
+open_file (const char * filename, int oflag)
{
int fd;
STD_UINT_SYSTEM_CALL
#define DEFUN_OPEN_FILE(name, oflag) \
Tchannel \
-DEFUN (name, (filename), CONST char * filename) \
+name (const char * filename) \
{ \
return (open_file (filename, oflag)); \
}
#else
Tchannel
-DEFUN (OS_open_append_file, (filename), CONST char * filename)
+OS_open_append_file (const char * filename)
{
error_unimplemented_primitive ();
return (0);
#endif
\f
static Tchannel
-DEFUN (make_load_channel, (fd), int fd)
+make_load_channel (int fd)
{
enum channel_type type = (fd_channel_type (fd));
if ((type == channel_type_terminal)
}
Tchannel
-DEFUN (OS_open_load_file, (filename), CONST char * filename)
+OS_open_load_file (const char * filename)
{
while (1)
{
}
Tchannel
-DEFUN (OS_open_dump_file, (filename), CONST char * filename)
+OS_open_dump_file (const char * filename)
{
while (1)
{
}
off_t
-DEFUN (OS_file_length, (channel), Tchannel channel)
+OS_file_length (Tchannel channel)
{
struct stat stat_buf;
STD_VOID_SYSTEM_CALL
}
off_t
-DEFUN (OS_file_position, (channel), Tchannel channel)
+OS_file_position (Tchannel channel)
{
off_t result;
STD_UINT_SYSTEM_CALL
}
void
-DEFUN (OS_file_set_position, (channel, position),
- Tchannel channel AND
- off_t position)
+OS_file_set_position (Tchannel channel, off_t position)
{
off_t result;
STD_UINT_SYSTEM_CALL
}
void
-DEFUN (OS_file_truncate, (channel, length),
- Tchannel channel AND
- off_t length)
+OS_file_truncate (Tchannel channel, off_t length)
{
STD_VOID_SYSTEM_CALL
(syscall_ftruncate,
/* -*-C-*-
-$Id: uxfs.c,v 1.29 2007/01/05 21:19:25 cph Exp $
+$Id: uxfs.c,v 1.30 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#endif
\f
int
-DEFUN (UX_read_file_status, (filename, s),
- CONST char * filename AND
- struct stat * s)
+UX_read_file_status (const char * filename, struct stat * s)
{
while ((UX_lstat (filename, s)) < 0)
{
}
int
-DEFUN (UX_read_file_status_indirect, (filename, s),
- CONST char * filename AND
- struct stat * s)
+UX_read_file_status_indirect (const char * filename, struct stat * s)
{
while ((UX_stat (filename, s)) < 0)
{
}
enum file_existence
-DEFUN (OS_file_existence_test, (name), CONST char * name)
+OS_file_existence_test (const char * name)
{
struct stat s;
if (!UX_read_file_status (name, (&s)))
}
enum file_existence
-DEFUN (OS_file_existence_test_direct, (name), CONST char * name)
+OS_file_existence_test_direct (const char * name)
{
struct stat s;
if (!UX_read_file_status (name, (&s)))
}
enum file_type
-DEFUN (OS_file_type_direct, (name), CONST char * name)
-COMPUTE_FILE_TYPE (UX_read_file_status, name)
+OS_file_type_direct (const char * name)
+ COMPUTE_FILE_TYPE (UX_read_file_status, name)
enum file_type
-DEFUN (OS_file_type_indirect, (name), CONST char * name)
-COMPUTE_FILE_TYPE (UX_read_file_status_indirect, name)
+OS_file_type_indirect (const char * name)
+ COMPUTE_FILE_TYPE (UX_read_file_status_indirect, name)
\f
-CONST char *
-DEFUN (UX_file_system_type, (name), CONST char * name)
+const char *
+UX_file_system_type (const char * name)
{
#ifdef HAVE_STATFS
struct statfs s;
}
\f
int
-DEFUN (OS_file_directory_p, (name), CONST char * name)
+OS_file_directory_p (const char * name)
{
struct stat s;
return
&& (((s . st_mode) & S_IFMT) == S_IFDIR));
}
-CONST char *
-DEFUN (OS_file_soft_link_p, (name), CONST char * name)
+const char *
+OS_file_soft_link_p (const char * name)
{
#ifdef HAVE_SYMLINK
struct stat s;
error_system_call (ENOMEM, syscall_realloc);
}
(buffer[scr]) = '\0';
- return ((CONST char *) buffer);
+ return ((const char *) buffer);
}
#else
return (0);
}
int
-DEFUN (OS_file_access, (name, mode), CONST char * name AND unsigned int mode)
+OS_file_access (const char * name, unsigned int mode)
{
return ((UX_access (name, mode)) == 0);
}
void
-DEFUN (OS_file_remove, (name), CONST char * name)
+OS_file_remove (const char * name)
{
STD_VOID_SYSTEM_CALL (syscall_unlink, (UX_unlink (name)));
}
void
-DEFUN (OS_file_remove_link, (name), CONST char * name)
+OS_file_remove_link (const char * name)
{
struct stat s;
if ((UX_read_file_status (name, (&s)))
}
\f
void
-DEFUN (OS_file_link_hard, (from_name, to_name),
- CONST char * from_name AND
- CONST char * to_name)
+OS_file_link_hard (const char * from_name, const char * to_name)
{
STD_VOID_SYSTEM_CALL (syscall_link, (UX_link (from_name, to_name)));
}
void
-DEFUN (OS_file_link_soft, (from_name, to_name),
- CONST char * from_name AND
- CONST char * to_name)
+OS_file_link_soft (const char * from_name, const char * to_name)
{
#ifdef HAVE_SYMLINK
STD_VOID_SYSTEM_CALL (syscall_symlink, (UX_symlink (from_name, to_name)));
}
void
-DEFUN (OS_file_rename, (from_name, to_name),
- CONST char * from_name AND
- CONST char * to_name)
+OS_file_rename (const char * from_name, const char * to_name)
{
STD_VOID_SYSTEM_CALL (syscall_rename, (UX_rename (from_name, to_name)));
}
#endif
void
-DEFUN (OS_file_copy, (from_name, to_name),
- CONST char * from_name AND
- CONST char * to_name)
+OS_file_copy (const char * from_name, const char * to_name)
{
Tchannel src, dst;
off_t src_len, len;
}
void
-DEFUN (OS_directory_make, (name), CONST char * name)
+OS_directory_make (const char * name)
{
STD_VOID_SYSTEM_CALL (syscall_mkdir, (UX_mkdir (name, MODE_DIR)));
}
void
-DEFUN (OS_directory_delete, (name), CONST char * name)
+OS_directory_delete (const char * name)
{
STD_VOID_SYSTEM_CALL (syscall_rmdir, (UX_rmdir (name)));
}
\f
-static void EXFUN (protect_fd, (int fd));
+static void protect_fd (int fd);
int
-DEFUN (OS_file_touch, (filename), CONST char * filename)
+OS_file_touch (const char * filename)
{
int fd;
transaction_begin ();
}
static void
-DEFUN (protect_fd_close, (ap), PTR ap)
+protect_fd_close (void * ap)
{
UX_close (* ((int *) ap));
}
static void
-DEFUN (protect_fd, (fd), int fd)
+protect_fd (int fd)
{
int * p = (dstack_alloc (sizeof (int)));
(*p) = fd;
static unsigned int n_directory_pointers;
void
-DEFUN_VOID (UX_initialize_directory_reader)
+UX_initialize_directory_reader (void)
{
directory_pointers = 0;
n_directory_pointers = 0;
}
static unsigned int
-DEFUN (allocate_directory_pointer, (pointer), DIR * pointer)
+allocate_directory_pointer (DIR * pointer)
{
if (n_directory_pointers == 0)
{
unsigned int n_pointers = (2 * n_directory_pointers);
DIR ** pointers =
((DIR **)
- (UX_realloc (((PTR) directory_pointers),
+ (UX_realloc (((void *) directory_pointers),
((sizeof (DIR *)) * n_pointers))));
if (pointers == 0)
error_system_call (ENOMEM, syscall_realloc);
#define DEALLOCATE_DIRECTORY(index) ((directory_pointers[(index)]) = 0)
int
-DEFUN (OS_directory_valid_p, (index), long index)
+OS_directory_valid_p (unsigned int index)
{
return
- ((0 <= index)
- && (index < n_directory_pointers)
+ ((index < n_directory_pointers)
&& ((REFERENCE_DIRECTORY (index)) != 0));
}
\f
unsigned int
-DEFUN (OS_directory_open, (name), CONST char * name)
+OS_directory_open (const char * name)
{
- /* Cast `name' to non-const because hp-ux 7.0 declaration incorrect. */
- DIR * pointer = (opendir ((char *) name));
+ DIR * pointer = (opendir (name));
if (pointer == 0)
error_system_call (errno, syscall_opendir);
return (allocate_directory_pointer (pointer));
}
-CONST char *
-DEFUN (OS_directory_read, (index), unsigned int index)
+const char *
+OS_directory_read (unsigned int index)
{
struct dirent * entry = (readdir (REFERENCE_DIRECTORY (index)));
return ((entry == 0) ? 0 : (entry -> d_name));
}
-CONST char *
-DEFUN (OS_directory_read_matching, (index, prefix),
- unsigned int index AND
- CONST char * prefix)
+const char *
+OS_directory_read_matching (unsigned int index, const char * prefix)
{
DIR * pointer = (REFERENCE_DIRECTORY (index));
unsigned int n = (strlen (prefix));
}
void
-DEFUN (OS_directory_close, (index), unsigned int index)
+OS_directory_close (unsigned int index)
{
closedir (REFERENCE_DIRECTORY (index));
DEALLOCATE_DIRECTORY (index);
/* -*-C-*-
-$Id: uxio.c,v 1.56 2007/01/05 21:19:25 cph Exp $
+$Id: uxio.c,v 1.57 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
+#include "scheme.h"
+#include "prims.h"
#include "ux.h"
#include "uxio.h"
#include "uxselect.h"
#endif
static void
-DEFUN_VOID (UX_channel_close_all)
+UX_channel_close_all (void)
{
Tchannel channel;
for (channel = 0; (channel < OS_channel_table_size); channel += 1)
OS_channel_close_noerror (channel);
}
-extern void EXFUN (add_reload_cleanup, (void (*) (void)));
-
void
-DEFUN_VOID (UX_initialize_channels)
+UX_initialize_channels (void)
{
OS_channel_table_size = (UX_SC_OPEN_MAX ());
channel_table =
}
void
-DEFUN_VOID (UX_reset_channels)
+UX_reset_channels (void)
{
UX_free (channel_table);
channel_table = 0;
}
Tchannel
-DEFUN_VOID (channel_allocate)
+channel_allocate (void)
{
Tchannel channel = 0;
while (1)
}
\f
int
-DEFUN (UX_channel_descriptor, (channel), Tchannel channel)
+UX_channel_descriptor (Tchannel channel)
{
return (CHANNEL_DESCRIPTOR (channel));
}
int
-DEFUN (OS_channel_open_p, (channel), Tchannel channel)
+OS_channel_open_p (Tchannel channel)
{
return (CHANNEL_OPEN_P (channel));
}
void
-DEFUN (OS_channel_close, (channel), Tchannel channel)
+OS_channel_close (Tchannel channel)
{
if (! (CHANNEL_INTERNAL (channel)))
{
}
void
-DEFUN (OS_channel_close_noerror, (channel), Tchannel channel)
+OS_channel_close_noerror (Tchannel channel)
{
if (! (CHANNEL_INTERNAL (channel)))
{
}
static void
-DEFUN (channel_close_on_abort_1, (cp), PTR cp)
+channel_close_on_abort_1 (void * cp)
{
OS_channel_close (* ((Tchannel *) cp));
}
void
-DEFUN (OS_channel_close_on_abort, (channel), Tchannel channel)
+OS_channel_close_on_abort (Tchannel channel)
{
Tchannel * cp = (dstack_alloc (sizeof (Tchannel)));
(*cp) = (channel);
}
\f
enum channel_type
-DEFUN (OS_channel_type, (channel), Tchannel channel)
+OS_channel_type (Tchannel channel)
{
return (CHANNEL_TYPE (channel));
}
long
-DEFUN (OS_channel_read, (channel, buffer, nbytes),
- Tchannel channel AND
- PTR buffer AND
- size_t nbytes)
+OS_channel_read (Tchannel channel, void * buffer, size_t nbytes)
{
if (nbytes == 0)
return (0);
}
long
-DEFUN (OS_channel_write, (channel, buffer, nbytes),
- Tchannel channel AND
- CONST PTR buffer AND
- size_t nbytes)
+OS_channel_write (Tchannel channel, const void * buffer, size_t nbytes)
{
if (nbytes == 0)
return (0);
}
\f
size_t
-DEFUN (OS_channel_read_load_file, (channel, buffer, nbytes),
- Tchannel channel AND PTR buffer AND size_t nbytes)
+OS_channel_read_load_file (Tchannel channel, void * buffer, size_t nbytes)
{
int scr = (UX_read ((CHANNEL_DESCRIPTOR (channel)), buffer, nbytes));
return ((scr < 0) ? 0 : scr);
}
size_t
-DEFUN (OS_channel_write_dump_file, (channel, buffer, nbytes),
- Tchannel channel AND CONST PTR buffer AND size_t nbytes)
+OS_channel_write_dump_file (Tchannel channel,
+ const void * buffer,
+ size_t nbytes)
{
int scr = (UX_write ((CHANNEL_DESCRIPTOR (channel)), buffer, nbytes));
return ((scr < 0) ? 0 : scr);
}
void
-DEFUN (OS_channel_write_string, (channel, string),
- Tchannel channel AND
- CONST char * string)
+OS_channel_write_string (Tchannel channel, const char * string)
{
unsigned long length = (strlen (string));
if ((OS_channel_write (channel, string, length)) != length)
}
void
-DEFUN (OS_make_pipe, (readerp, writerp),
- Tchannel * readerp AND
- Tchannel * writerp)
+OS_make_pipe (Tchannel * readerp, Tchannel * writerp)
{
int pv [2];
transaction_begin ();
#ifdef FCNTL_NONBLOCK
static int
-DEFUN (get_flags, (fd), int fd)
+get_flags (int fd)
{
int scr;
STD_UINT_SYSTEM_CALL (syscall_fcntl_GETFL, scr, (UX_fcntl (fd, F_GETFL, 0)));
}
static void
-DEFUN (set_flags, (fd, flags), int fd AND int flags)
+set_flags (int fd, int flags)
{
STD_VOID_SYSTEM_CALL (syscall_fcntl_SETFL, (UX_fcntl (fd, F_SETFL, flags)));
}
int
-DEFUN (OS_channel_nonblocking_p, (channel), Tchannel channel)
+OS_channel_nonblocking_p (Tchannel channel)
{
return (CHANNEL_NONBLOCKING (channel));
}
void
-DEFUN (OS_channel_nonblocking, (channel), Tchannel channel)
+OS_channel_nonblocking (Tchannel channel)
{
int fd = (CHANNEL_DESCRIPTOR (channel));
int flags = (get_flags (fd));
}
void
-DEFUN (OS_channel_blocking, (channel), Tchannel channel)
+OS_channel_blocking (Tchannel channel)
{
int fd = (CHANNEL_DESCRIPTOR (channel));
int flags = (get_flags (fd));
#else /* not FCNTL_NONBLOCK */
int
-DEFUN (OS_channel_nonblocking_p, (channel), Tchannel channel)
+OS_channel_nonblocking_p (Tchannel channel)
{
return (-1);
}
void
-DEFUN (OS_channel_nonblocking, (channel), Tchannel channel)
+OS_channel_nonblocking (Tchannel channel)
{
error_unimplemented_primitive ();
}
void
-DEFUN (OS_channel_blocking, (channel), Tchannel channel)
+OS_channel_blocking (Tchannel channel)
{
}
\f
#ifdef HAVE_POLL
-CONST int OS_have_select_p = 1;
+const int OS_have_select_p = 1;
struct select_registry_s
{
| ((((revents) & POLLHUP) != 0) ? SELECT_MODE_HUP : 0))
select_registry_t
-DEFUN_VOID (OS_allocate_select_registry)
+OS_allocate_select_registry (void)
{
struct select_registry_s * r
= (UX_malloc (sizeof (struct select_registry_s)));
}
void
-DEFUN (OS_deallocate_select_registry, (registry), select_registry_t registry)
+OS_deallocate_select_registry (select_registry_t registry)
{
struct select_registry_s * r = registry;
UX_free (SR_ENTRIES (r));
}
void
-DEFUN (OS_add_to_select_registry, (registry, fd, mode),
- select_registry_t registry AND
- int fd AND
- unsigned int mode)
+OS_add_to_select_registry (select_registry_t registry,
+ int fd,
+ unsigned int mode)
{
struct select_registry_s * r = registry;
unsigned int i = 0;
}
void
-DEFUN (OS_remove_from_select_registry, (registry, fd, mode),
- select_registry_t registry AND
- int fd AND
- unsigned int mode)
+OS_remove_from_select_registry (select_registry_t registry,
+ int fd,
+ unsigned int mode)
{
struct select_registry_s * r = registry;
unsigned int i = 0;
}
unsigned int
-DEFUN (OS_select_registry_length, (registry),
- select_registry_t registry)
+OS_select_registry_length (select_registry_t registry)
{
struct select_registry_s * r = registry;
return (SR_N_FDS (r));
}
void
-DEFUN (OS_select_registry_result, (registry, index),
- select_registry_t registry AND
- unsigned int index AND
- int * fd_r AND
- unsigned int * mode_r)
+OS_select_registry_result (select_registry_t registry,
+ unsigned int index,
+ int * fd_r,
+ unsigned int * mode_r)
{
struct select_registry_s * r = registry;
(*fd_r) = ((SR_ENTRY (r, index)) -> fd);
}
int
-DEFUN (OS_test_select_registry, (registry, blockp),
- select_registry_t registry AND
- int blockp)
+OS_test_select_registry (select_registry_t registry, int blockp)
{
struct select_registry_s * r = registry;
while (1)
}
int
-DEFUN (OS_test_select_descriptor, (fd, blockp, mode),
- int fd AND
- int blockp AND
- unsigned int mode)
+OS_test_select_descriptor (int fd, int blockp, unsigned int mode)
{
struct pollfd pfds [1];
((pfds [0]) . fd) = fd;
#else /* not HAVE_POLL */
\f
#ifdef HAVE_SELECT
-CONST int OS_have_select_p = 1;
+const int OS_have_select_p = 1;
#else
-CONST int OS_have_select_p = 0;
+const int OS_have_select_p = 0;
#endif
struct select_registry_s
| ((FD_ISSET ((fd), (SR_RWRITERS (r)))) ? SELECT_MODE_WRITE : 0))
select_registry_t
-DEFUN_VOID (OS_allocate_select_registry)
+OS_allocate_select_registry (void)
{
struct select_registry_s * r
= (UX_malloc (sizeof (struct select_registry_s)));
}
void
-DEFUN (OS_deallocate_select_registry, (registry), select_registry_t registry)
+OS_deallocate_select_registry (select_registry_t registry)
{
struct select_registry_s * r = registry;
UX_free (r);
}
void
-DEFUN (OS_add_to_select_registry, (registry, fd, mode),
- select_registry_t registry AND
- int fd AND
- unsigned int mode)
+OS_add_to_select_registry (select_registry_t registry,
+ int fd,
+ unsigned int mode)
{
struct select_registry_s * r = registry;
int was_set = (SR_FD_ISSET (fd, r));
}
void
-DEFUN (OS_remove_from_select_registry, (registry, fd, mode),
- select_registry_t registry AND
- int fd AND
- unsigned int mode)
+OS_remove_from_select_registry (select_registry_t registry,
+ int fd,
+ unsigned int mode)
{
struct select_registry_s * r = registry;
int was_set = (SR_FD_ISSET (fd, r));
}
unsigned int
-DEFUN (OS_select_registry_length, (registry),
- select_registry_t registry)
+OS_select_registry_length (select_registry_t registry)
{
struct select_registry_s * r = registry;
return (SR_N_FDS (r));
}
void
-DEFUN (OS_select_registry_result, (registry, index, fd_r, mode_r),
- select_registry_t registry AND
- unsigned int index AND
- int * fd_r AND
- unsigned int * mode_r)
+OS_select_registry_result (select_registry_t registry,
+ unsigned int index,
+ int * fd_r,
+ unsigned int * mode_r)
{
struct select_registry_s * r = registry;
unsigned int i = 0;
}
int
-DEFUN (OS_test_select_registry, (registry, blockp),
- select_registry_t registry AND
- int blockp)
+OS_test_select_registry (select_registry_t registry, int blockp)
{
#ifdef HAVE_SELECT
struct select_registry_s * r = registry;
}
int
-DEFUN (OS_test_select_descriptor, (fd, blockp, mode),
- int fd AND
- int blockp AND
- unsigned int mode)
+OS_test_select_descriptor (int fd, int blockp, unsigned int mode)
{
#ifdef HAVE_SELECT
while (1)
FD_ZERO (&writeable);
if ((mode & SELECT_MODE_WRITE) != 0)
FD_SET (fd, (&writeable));
-
+
INTERRUPTABLE_EXTENT
(nfds,
((OS_process_any_status_change ())
/* poll(2) */
unsigned int
-DEFUN_VOID (UX_select_registry_size)
+UX_select_registry_size (void)
{
return ((sizeof (struct pollfd)) * OS_channel_table_size);
}
unsigned int
-DEFUN_VOID (UX_select_registry_lub)
+UX_select_registry_lub (void)
{
return (OS_channel_table_size);
}
void
-DEFUN (UX_select_registry_clear_all, (fds), PTR fds)
+UX_select_registry_clear_all (void * fds)
{
struct pollfd * scan = fds;
struct pollfd * end = (scan + OS_channel_table_size);
}
void
-DEFUN (UX_select_registry_set, (fds, fd), PTR fds AND unsigned int fd)
+UX_select_registry_set (void * fds, unsigned int fd)
{
struct pollfd * scan = fds;
struct pollfd * end = (scan + OS_channel_table_size);
}
void
-DEFUN (UX_select_registry_clear, (fds, fd), PTR fds AND unsigned int fd)
+UX_select_registry_clear (void * fds, unsigned int fd)
{
struct pollfd * scan = fds;
struct pollfd * end = (scan + OS_channel_table_size);
}
int
-DEFUN (UX_select_registry_is_set, (fds, fd), PTR fds AND unsigned int fd)
+UX_select_registry_is_set (void * fds, unsigned int fd)
{
struct pollfd * scan = fds;
struct pollfd * end = (scan + OS_channel_table_size);
}
enum select_input
-DEFUN (UX_select_registry_test, (input_fds, blockp, output_fds, output_nfds),
- PTR input_fds AND
- int blockp AND
- unsigned int * output_fds AND
- unsigned int * output_nfds)
+UX_select_registry_test (void * input_fds,
+ int blockp,
+ unsigned int * output_fds,
+ unsigned int * output_nfds)
{
struct pollfd * pfds = input_fds;
unsigned int n_pfds = (count_select_registry_entries (pfds));
}
enum select_input
-DEFUN (UX_select_descriptor, (fd, blockp),
- unsigned int fd AND
- int blockp)
+UX_select_descriptor (unsigned int fd, int blockp)
{
struct pollfd pfds [1];
int nfds;
return (select_input_process_status);
if (pending_interrupts_p ())
return (select_input_interrupt);
- }
+ }
}
enum select_input
-DEFUN (UX_select_input, (fd, blockp), int fd AND int blockp)
+UX_select_input (int fd, int blockp)
{
return (UX_select_descriptor (fd, blockp));
}
/* select(2) */
unsigned int
-DEFUN_VOID (UX_select_registry_size)
+UX_select_registry_size (void)
{
return (sizeof (SELECT_TYPE));
}
unsigned int
-DEFUN_VOID (UX_select_registry_lub)
+UX_select_registry_lub (void)
{
return (FD_SETSIZE);
}
void
-DEFUN (UX_select_registry_clear_all, (fds), PTR fds)
+UX_select_registry_clear_all (void * fds)
{
FD_ZERO ((SELECT_TYPE *) fds);
}
void
-DEFUN (UX_select_registry_set, (fds, fd), PTR fds AND unsigned int fd)
+UX_select_registry_set (void * fds, unsigned int fd)
{
FD_SET (fd, ((SELECT_TYPE *) fds));
}
void
-DEFUN (UX_select_registry_clear, (fds, fd), PTR fds AND unsigned int fd)
+UX_select_registry_clear (void * fds, unsigned int fd)
{
FD_CLR (fd, ((SELECT_TYPE *) fds));
}
int
-DEFUN (UX_select_registry_is_set, (fds, fd), PTR fds AND unsigned int fd)
+UX_select_registry_is_set (void * fds, unsigned int fd)
{
return (FD_ISSET (fd, ((SELECT_TYPE *) fds)));
}
enum select_input
-DEFUN (UX_select_registry_test, (input_fds, blockp, output_fds, output_nfds),
- PTR input_fds AND
- int blockp AND
- unsigned int * output_fds AND
- unsigned int * output_nfds)
+UX_select_registry_test (void * input_fds,
+ int blockp,
+ unsigned int * output_fds,
+ unsigned int * output_nfds)
{
#ifdef HAVE_SELECT
while (1)
{
SELECT_TYPE readable;
int nfds;
-
+
readable = (* ((SELECT_TYPE *) input_fds));
INTERRUPTABLE_EXTENT
(nfds,
}
enum select_input
-DEFUN (UX_select_descriptor, (fd, blockp),
- unsigned int fd AND
- int blockp)
+UX_select_descriptor (unsigned int fd, int blockp)
{
#ifdef HAVE_SELECT
SELECT_TYPE readable;
}
enum select_input
-DEFUN (UX_select_input, (fd, blockp), int fd AND int blockp)
+UX_select_input (int fd, int blockp)
{
SELECT_TYPE readable;
unsigned int fds [FD_SETSIZE];
/* -*-C-*-
-$Id: uxio.h,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: uxio.h,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
}
extern struct channel * channel_table;
-extern Tchannel EXFUN (channel_allocate, (void));
+extern Tchannel channel_allocate (void);
#endif /* SCM_UXIO_H */
/* -*-C-*-
-$Id: uxproc.c,v 1.34 2007/01/05 21:19:25 cph Exp $
+$Id: uxproc.c,v 1.35 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
+#include "scheme.h"
#include "ux.h"
#include "uxproc.h"
#include "uxio.h"
#include "error: can't hack subprocess I/O without dup2() or equivalent"
#endif
-extern void EXFUN ((*subprocess_death_hook), (pid_t pid, int * status));
-extern void EXFUN ((*stop_signal_hook), (int signo));
-extern void EXFUN (stop_signal_default, (int signo));
-extern int EXFUN (OS_ctty_fd, (void));
-extern void EXFUN (UX_initialize_child_signals, (void));
+extern void (*subprocess_death_hook) (pid_t pid, int * status);
+extern void (*stop_signal_hook) (int signo);
+extern void stop_signal_default (int signo);
+extern int OS_ctty_fd (void);
+extern void UX_initialize_child_signals (void);
-static void EXFUN (subprocess_death, (pid_t pid, int * status));
-static void EXFUN (stop_signal_handler, (int signo));
-static void EXFUN (give_terminal_to, (Tprocess process));
-static void EXFUN (get_terminal_back, (void));
-static void EXFUN (process_wait, (Tprocess process));
-static int EXFUN (child_setup_tty, (int fd));
+static void subprocess_death (pid_t pid, int * status);
+static void stop_signal_handler (int signo);
+static void give_terminal_to (Tprocess process);
+static void get_terminal_back (void);
+static void process_wait (Tprocess process);
+static int child_setup_tty (int fd);
size_t OS_process_table_size;
struct process * process_table;
#ifdef HAVE_POSIX_SIGNALS
static void
-DEFUN (restore_signal_mask, (environment), PTR environment)
+restore_signal_mask (void * environment)
{
UX_sigprocmask (SIG_SETMASK, ((sigset_t *) environment), 0);
}
static void
-DEFUN_VOID (block_sigchld)
+block_sigchld (void)
{
sigset_t * outside = (dstack_alloc (sizeof (sigset_t)));
sigset_t sigchld;
}
static void
-DEFUN_VOID (block_jc_signals)
+block_jc_signals (void)
{
sigset_t * outside = (dstack_alloc (sizeof (sigset_t)));
sigset_t jc_signals;
static sigset_t grabbed_signal_mask;
static void
-DEFUN_VOID (grab_signal_mask)
+grab_signal_mask (void)
{
UX_sigprocmask (SIG_BLOCK, 0, (&grabbed_signal_mask));
}
#ifdef HAVE_SIGHOLD
static void
-DEFUN (release_sigchld, (environment), PTR environment)
+release_sigchld (void * environment)
{
UX_sigrelse (SIGCHLD);
}
static void
-DEFUN_VOID (block_sigchld)
+block_sigchld (void)
{
UX_sighold (SIGCHLD);
transaction_record_action (tat_always, release_sigchld, 0);
#endif /* not HAVE_POSIX_SIGNALS */
\f
void
-DEFUN_VOID (UX_initialize_processes)
+UX_initialize_processes (void)
{
OS_process_table_size = (UX_SC_CHILD_MAX ());
process_table =
}
void
-DEFUN_VOID (UX_reset_processes)
+UX_reset_processes (void)
{
UX_free (process_table);
process_table = 0;
}
static void
-DEFUN (process_allocate_abort, (environment), PTR environment)
+process_allocate_abort (void * environment)
{
Tprocess process = (* ((Tprocess *) environment));
switch (PROCESS_RAW_STATUS (process))
}
static Tprocess
-DEFUN_VOID (process_allocate)
+process_allocate (void)
{
Tprocess process;
for (process = 0; (process < OS_process_table_size); process += 1)
}
void
-DEFUN (OS_process_deallocate, (process), Tprocess process)
+OS_process_deallocate (Tprocess process)
{
(PROCESS_ID (process)) = 0;
(PROCESS_RAW_STATUS (process)) = process_status_free;
}
\f
Tprocess
-DEFUN (OS_make_subprocess,
- (filename, argv, envp, working_directory,
- ctty_type, ctty_name,
- channel_in_type, channel_in,
- channel_out_type, channel_out,
- channel_err_type, channel_err),
- CONST char * filename AND
- CONST char ** argv AND
- CONST char ** VOLATILE envp AND
- CONST char * working_directory AND
- enum process_ctty_type ctty_type AND
- char * ctty_name AND
- enum process_channel_type channel_in_type AND
- Tchannel channel_in AND
- enum process_channel_type channel_out_type AND
- Tchannel channel_out AND
- enum process_channel_type channel_err_type AND
- Tchannel channel_err)
+OS_make_subprocess (const char * filename,
+ const char ** argv,
+ const char ** volatile envp,
+ const char * working_directory,
+ enum process_ctty_type ctty_type,
+ char * ctty_name,
+ enum process_channel_type channel_in_type,
+ Tchannel channel_in,
+ enum process_channel_type channel_out_type,
+ Tchannel channel_out,
+ enum process_channel_type channel_err_type,
+ Tchannel channel_err)
{
pid_t child_pid;
- Tprocess child;
- VOLATILE enum process_jc_status child_jc_status = process_jc_status_no_ctty;
+ volatile Tprocess child;
+ volatile enum process_jc_status child_jc_status = process_jc_status_no_ctty;
if (envp == 0)
- envp = ((CONST char **) environ);
+ envp = ((const char **) environ);
switch (ctty_type)
{
case process_ctty_type_none:
UX_initialize_child_signals ();
/* Start the process. */
- execve (filename, ((char * CONST *) argv), ((char * CONST *) envp));
+ execve (filename, ((char * const *) argv), ((char * const *) envp));
kill_child:
_exit (1);
}
#define DEFUN_PROCESS_ACCESSOR(name, result_type, accessor) \
result_type \
-DEFUN (name, (process), Tprocess process) \
+name (Tprocess process) \
{ \
return (accessor (process)); \
}
(OS_process_jc_status, enum process_jc_status, PROCESS_JC_STATUS)
\f
int
-DEFUN (OS_process_valid_p, (process), Tprocess process)
+OS_process_valid_p (Tprocess process)
{
switch (PROCESS_RAW_STATUS (process))
{
}
int
-DEFUN (OS_process_continuable_p, (process), Tprocess process)
+OS_process_continuable_p (Tprocess process)
{
switch (PROCESS_RAW_STATUS (process))
{
}
int
-DEFUN (OS_process_foregroundable_p, (process), Tprocess process)
+OS_process_foregroundable_p (Tprocess process)
{
switch (PROCESS_JC_STATUS (process))
{
}
int
-DEFUN (OS_process_status_sync, (process), Tprocess process)
+OS_process_status_sync (Tprocess process)
{
transaction_begin ();
block_sigchld ();
}
int
-DEFUN_VOID (OS_process_status_sync_all)
+OS_process_status_sync_all (void)
{
transaction_begin ();
block_sigchld ();
}
int
-DEFUN_VOID (OS_process_any_status_change)
+OS_process_any_status_change (void)
{
return (process_tick != sync_tick);
}
\f
void
-DEFUN (OS_process_send_signal, (process, sig), Tprocess process AND int sig)
+OS_process_send_signal (Tprocess process, int sig)
{
STD_VOID_SYSTEM_CALL
- (syscall_kill,
+ (syscall_kill,
(UX_kill ((((PROCESS_JC_STATUS (process)) == process_jc_status_jc)
? (- (PROCESS_ID (process)))
: (PROCESS_ID (process))),
}
void
-DEFUN (OS_process_kill, (process), Tprocess process)
+OS_process_kill (Tprocess process)
{
OS_process_send_signal (process, SIGKILL);
}
void
-DEFUN (OS_process_stop, (process), Tprocess process)
+OS_process_stop (Tprocess process)
{
OS_process_send_signal (process, SIGTSTP);
}
void
-DEFUN (OS_process_interrupt, (process), Tprocess process)
+OS_process_interrupt (Tprocess process)
{
OS_process_send_signal (process, SIGINT);
}
void
-DEFUN (OS_process_quit, (process), Tprocess process)
+OS_process_quit (Tprocess process)
{
OS_process_send_signal (process, SIGQUIT);
}
void
-DEFUN (OS_process_hangup, (process), Tprocess process)
+OS_process_hangup (Tprocess process)
{
OS_process_send_signal (process, SIGHUP);
}
void
-DEFUN (OS_process_continue_background, (process), Tprocess process)
+OS_process_continue_background (Tprocess process)
{
transaction_begin ();
block_sigchld ();
}
void
-DEFUN (OS_process_continue_foreground, (process), Tprocess process)
+OS_process_continue_foreground (Tprocess process)
{
transaction_begin ();
grab_signal_mask ();
if ((PROCESS_RAW_STATUS (process)) == process_status_stopped)
{
NEW_RAW_STATUS (process, process_status_running, 0);
- OS_process_send_signal (process, SIGCONT);
+ OS_process_send_signal (process, SIGCONT);
}
process_wait (process);
transaction_commit ();
}
\f
void
-DEFUN (OS_process_wait, (process), Tprocess process)
+OS_process_wait (Tprocess process)
{
transaction_begin ();
grab_signal_mask ();
}
static void
-DEFUN (get_terminal_back_1, (environment), PTR environment)
+get_terminal_back_1 (void * environment)
{
get_terminal_back ();
}
static void
-DEFUN (give_terminal_to, (process), Tprocess process)
+give_terminal_to (Tprocess process)
{
if (((PROCESS_JC_STATUS (process)) == process_jc_status_jc)
&& (SCHEME_IN_FOREGROUND ()))
}
static void
-DEFUN_VOID (get_terminal_back)
+get_terminal_back (void)
{
if (foreground_child_process != NO_PROCESS)
{
}
static void
-DEFUN (process_wait, (process), Tprocess process)
+process_wait (Tprocess process)
{
#ifdef HAVE_POSIX_SIGNALS
while (((PROCESS_RAW_STATUS (process)) == process_status_running)
}
\f
static Tprocess
-DEFUN (find_process, (pid), pid_t pid)
+find_process (pid_t pid)
{
Tprocess process;
for (process = 0; (process < OS_process_table_size); process += 1)
}
static void
-DEFUN (subprocess_death, (pid, status), pid_t pid AND int * status)
+subprocess_death (pid_t pid, int * status)
{
Tprocess process = (find_process (pid));
if (process != NO_PROCESS)
}
static void
-DEFUN (stop_signal_handler, (signo), int signo)
+stop_signal_handler (int signo)
{
/* If Scheme gets a stop signal while waiting on a foreground
subprocess, it must grab the terminal back from the subprocess
#endif
static int
-DEFUN (child_setup_tty, (fd), int fd)
+child_setup_tty (int fd)
{
cc_t disabled_char = (UX_PC_VDISABLE (fd));
struct termios s;
#ifdef HAVE_TERMIO_H
static int
-DEFUN (child_setup_tty, (fd), int fd)
+child_setup_tty (int fd)
{
cc_t disabled_char = (UX_PC_VDISABLE (fd));
struct termio s;
#ifdef HAVE_SGTTY_H
static int
-DEFUN (child_setup_tty, (fd), int fd)
+child_setup_tty (int fd)
{
struct sgttyb s;
if ((ioctl (fd, TIOCGETP, (&s))) < 0)
/* -*-C-*-
-$Id: uxselect.h,v 1.10 2007/01/05 21:19:25 cph Exp $
+$Id: uxselect.h,v 1.11 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
select_input_interrupt
};
-extern enum select_input EXFUN (UX_select_input, (int fd, int blockp));
-extern unsigned int EXFUN (UX_select_registry_size, (void));
-extern unsigned int EXFUN (UX_select_registry_lub, (void));
-extern void EXFUN (UX_select_registry_clear_all, (PTR fds));
-extern void EXFUN (UX_select_registry_set, (PTR fds, unsigned int fd));
-extern void EXFUN (UX_select_registry_clear, (PTR fds, unsigned int fd));
-extern int EXFUN (UX_select_registry_is_set, (PTR fds, unsigned int fd));
-extern enum select_input EXFUN
- (UX_select_registry_test,
- (PTR input_fds, int blockp,
- unsigned int * output_fds, unsigned int * output_nfds));
-extern enum select_input EXFUN
- (UX_select_descriptor, (unsigned int fd, int blockp));
+extern enum select_input UX_select_input (int fd, int blockp);
+extern unsigned int UX_select_registry_size (void);
+extern unsigned int UX_select_registry_lub (void);
+extern void UX_select_registry_clear_all (void * fds);
+extern void UX_select_registry_set (void * fds, unsigned int fd);
+extern void UX_select_registry_clear (void * fds, unsigned int fd);
+extern int UX_select_registry_is_set (void * fds, unsigned int fd);
+extern enum select_input UX_select_registry_test
+ (void * input_fds, int blockp,
+ unsigned int * output_fds, unsigned int * output_nfds);
+extern enum select_input UX_select_descriptor
+ (unsigned int fd, int blockp);
#endif /* SCM_UXSELECT_H */
/* -*-C-*-
-$Id: uxsig.c,v 1.48 2007/01/05 21:19:25 cph Exp $
+$Id: uxsig.c,v 1.49 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include "config.h"
+#include "scheme.h"
+#include "option.h"
#include "ux.h"
#include "ossig.h"
#include "osctty.h"
#include "uxutil.h"
#include "critsec.h"
-extern cc_t EXFUN (OS_ctty_quit_char, (void));
-extern cc_t EXFUN (OS_ctty_int_char, (void));
-extern cc_t EXFUN (OS_ctty_tstp_char, (void));
-extern cc_t EXFUN (OS_ctty_disabled_char, (void));
-extern void EXFUN (tty_set_next_interrupt_char, (cc_t c));
-extern void EXFUN (UX_reinitialize_tty, (void));
+extern cc_t OS_ctty_quit_char (void);
+extern cc_t OS_ctty_int_char (void);
+extern cc_t OS_ctty_tstp_char (void);
+extern cc_t OS_ctty_disabled_char (void);
+extern void tty_set_next_interrupt_char (cc_t c);
+extern void UX_reinitialize_tty (void);
\f
/* Signal Manipulation */
# endif
#endif
+#ifndef __APPLE__
+# define HAVE_SIGFPE
+#endif
+
static Tsignal_handler
-DEFUN (current_handler, (signo), int signo)
+current_handler (int signo)
{
struct sigaction act;
UX_sigaction (signo, 0, (&act));
return (SIGACT_HANDLER (&act));
}
-/* Work-around for 64-bit environment bug on Mac OSX */
-
-#if defined(__APPLE__) && defined(__LP64__)
-#define SA_SIGINFO_EXTRA SA_64REGSET
-#endif
-
-#ifndef SA_SIGINFO_EXTRA
-#define SA_SIGINFO_EXTRA 0
-#endif
-
void
-DEFUN (INSTALL_HANDLER, (signo, handler),
- int signo AND
- Tsignal_handler handler)
+INSTALL_HANDLER (int signo, Tsignal_handler handler)
{
struct sigaction act;
if ((handler == ((Tsignal_handler) SIG_IGN))
|| (handler == ((Tsignal_handler) SIG_DFL)))
{
- (act . sa_handler) = ((PTR) handler);
+ (act . sa_handler) = ((void *) handler);
(act . sa_flags) = 0;
}
else
{
(SIGACT_HANDLER (&act)) = handler;
- (act . sa_flags) = (SA_SIGINFO | SA_SIGINFO_EXTRA);
+ (act . sa_flags) = SA_SIGINFO;
+ /* Work-around for 64-bit environment bug on Mac OSX */
+#if defined(__APPLE__) && defined(__LP64__)
+ (act . sa_flags) |= SA_64REGSET;
+#endif
}
UX_sigemptyset (& (act . sa_mask));
UX_sigaddset ((& (act . sa_mask)), signo);
#ifdef HAVE_SIGHOLD
static Tsignal_handler
-DEFUN (current_handler, (signo), int signo)
+current_handler (int signo)
{
Tsignal_handler result = (UX_sigset (signo, SIG_HOLD));
if (result != SIG_HOLD)
#else /* not HAVE_SIGHOLD */
static Tsignal_handler
-DEFUN (current_handler, (signo), int signo)
+current_handler (int signo)
{
Tsignal_handler result = (UX_signal (signo, SIG_IGN));
if (result != SIG_IGN)
#ifdef NEED_HANDLER_TRANSACTION
void
-DEFUN (ta_abort_handler, (ap), PTR ap)
+ta_abort_handler (void * ap)
{
ABORT_HANDLER ((((struct handler_record *) ap) -> signo),
(((struct handler_record *) ap) -> handler));
#ifdef HAVE_POSIX_SIGNALS
static void
-DEFUN (restore_signal_mask, (environment), PTR environment)
+restore_signal_mask (void * environment)
{
UX_sigprocmask (SIG_SETMASK, ((sigset_t *) environment), 0);
}
static void
-DEFUN (save_signal_mask, (environment), PTR environment)
+save_signal_mask (void * environment)
{
UX_sigprocmask (SIG_SETMASK, 0, ((sigset_t *) environment));
}
void
-DEFUN_VOID (preserve_signal_mask)
+preserve_signal_mask (void)
{
dstack_alloc_and_protect
((sizeof (sigset_t)), save_signal_mask, restore_signal_mask);
static sigset_t blocked_signals;
void
-DEFUN_VOID (block_signals)
+block_signals (void)
{
sigset_t all_signals;
UX_sigfillset (&all_signals);
}
void
-DEFUN_VOID (unblock_signals)
+unblock_signals (void)
{
UX_sigprocmask (SIG_SETMASK, (&blocked_signals), 0);
}
#else /* not HAVE_POSIX_SIGNALS */
void
-DEFUN_VOID (preserve_signal_mask)
+preserve_signal_mask (void)
{
}
void
-DEFUN_VOID (block_signals)
+block_signals (void)
{
}
void
-DEFUN_VOID (unblock_signals)
+unblock_signals (void)
{
}
#endif /* not HAVE_POSIX_SIGNALS */
void
-DEFUN (deactivate_handler, (signo), int signo)
+deactivate_handler (int signo)
{
INSTALL_HANDLER (signo, ((Tsignal_handler) SIG_IGN));
}
void
-DEFUN (activate_handler, (signo, handler),
- int signo AND
- Tsignal_handler handler)
+activate_handler (int signo, Tsignal_handler handler)
{
INSTALL_HANDLER (signo, handler);
}
int * signal_history_pointer;
static void
-DEFUN_VOID (initialize_signal_debugging)
+initialize_signal_debugging (void)
{
int * scan = (&signal_history[0]);
int * end = (scan + (sizeof (signal_history)));
}
static void
-DEFUN (record_signal_delivery, (signo), int signo)
+record_signal_delivery (int signo)
{
block_signals ();
(*signal_history_pointer++) = signo;
struct signal_descriptor
{
int signo;
- CONST char * name;
+ const char * name;
enum dfl_action action;
int flags;
};
static unsigned int signal_descriptors_limit;
static void
-DEFUN (defsignal, (signo, name, action, flags),
- int signo AND
- CONST char * name AND
- enum dfl_action action AND
- int flags)
+defsignal (int signo, const char * name, enum dfl_action action, int flags)
{
if (signo == 0)
return;
}
static struct signal_descriptor *
-DEFUN (find_signal_descriptor, (signo), int signo)
+find_signal_descriptor (int signo)
{
struct signal_descriptor * scan = signal_descriptors;
struct signal_descriptor * end = (scan + signal_descriptors_length);
return (0);
}
-CONST char *
-DEFUN (find_signal_name, (signo), int signo)
+const char *
+find_signal_name (int signo)
{
static char buffer [32];
struct signal_descriptor * descriptor = (find_signal_descriptor (signo));
if (descriptor != 0)
return (descriptor -> name);
sprintf (buffer, "unknown signal %d", signo);
- return ((CONST char *) buffer);
+ return ((const char *) buffer);
}
\f
#if (SIGABRT == SIGIOT)
#endif
static void
-DEFUN_VOID (initialize_signal_descriptors)
+initialize_signal_descriptors (void)
{
signal_descriptors_length = 0;
signal_descriptors_limit = 32;
defsignal (SIGTRAP, "SIGTRAP", dfl_terminate, CORE_DUMP);
defsignal (SIGIOT, "SIGIOT", dfl_terminate, CORE_DUMP);
defsignal (SIGEMT, "SIGEMT", dfl_terminate, CORE_DUMP);
-#ifndef __APPLE__
+#ifdef HAVE_SIGFPE
defsignal (SIGFPE, "SIGFPE", dfl_terminate, CORE_DUMP);
-#endif /* __APPLE__ */
+#endif
defsignal (SIGKILL, "SIGKILL", dfl_terminate, (NOIGNORE | NOBLOCK | NOCATCH));
defsignal (SIGBUS, "SIGBUS", dfl_terminate, CORE_DUMP);
defsignal (SIGSEGV, "SIGSEGV", dfl_terminate, CORE_DUMP);
#define CONTROL_X_INTERRUPT_CHAR 'X'
static void
-DEFUN (echo_keyboard_interrupt, (c, dc), cc_t c AND cc_t dc)
+echo_keyboard_interrupt (cc_t c, cc_t dc)
{
if (c == (OS_ctty_disabled_char ()))
c = dc;
tty_set_next_interrupt_char (CONTROL_B_INTERRUPT_CHAR);
})
-static void EXFUN (interactive_interrupt_handler, (SIGCONTEXT_T * scp));
+static void interactive_interrupt_handler (SIGCONTEXT_T * scp);
static
DEFUN_STD_HANDLER (sighnd_interactive,
(interactive_interrupt_handler (scp)))
void
-DEFUN (stop_signal_default, (signo), int signo)
+stop_signal_default (int signo)
{
#ifdef HAVE_POSIX_SIGNALS
if ((isatty (STDIN_FILENO))
#endif /* HAVE_POSIX_SIGNALS */
}
-void EXFUN ((*stop_signal_hook), (int signo));
+void (*stop_signal_hook) (int signo);
#ifdef HAVE_POSIX_SIGNALS
# define IF_POSIX_SIGNALS(code) do code while (0)
}))
void
-DEFUN_VOID (OS_restartable_exit)
+OS_restartable_exit (void)
{
stop_signal_default (SIGTSTP);
}
#else /* not HAVE_SETITIMER */
-extern void EXFUN (reschedule_alarm, (void));
+extern void reschedule_alarm (void);
static
DEFUN_STD_HANDLER (sighnd_timer,
? (find_signal_name (signo))
: 0)))
\f
-#ifdef HAS_COMPILER_SUPPORT
-# include "cmpintmd.h"
-# if (COMPILER_PROCESSOR_TYPE == COMPILER_IA32_TYPE)
-
-extern void EXFUN (i386_interface_initialize, (void));
-#define FPE_RESET_TRAPS i386_interface_initialize
-
-# endif
-#endif
-
#ifndef FPE_RESET_TRAPS
# define FPE_RESET_TRAPS()
#endif
+#ifdef HAVE_SIGFPE
static
DEFUN_STD_HANDLER (sighnd_fpe,
{
FPE_RESET_TRAPS ();
trap_handler ("floating-point exception", signo, info, scp);
})
+#endif
static
DEFUN_STD_HANDLER (sighnd_hardware_trap,
case we just hope that child terminations don't happen too close to
one another to cause problems. */
-void EXFUN ((*subprocess_death_hook), (pid_t pid, int * status));
+void (*subprocess_death_hook) (pid_t pid, int * status);
#ifdef HAVE_WAITPID
-#define WAITPID(status) (UX_waitpid ((-1), (status), (WNOHANG | WUNTRACED)))
-#define BREAK
+# define WAITPID(status) (UX_waitpid ((-1), (status), (WNOHANG | WUNTRACED)))
+# define BREAK
#else
-#define WAITPID(status) (UX_wait (status))
-#define BREAK break
+# define WAITPID(status) (UX_wait (status))
+# define BREAK break
#endif
static
/* Signal Bindings */
static void
-DEFUN (bind_handler, (signo, handler),
- int signo AND
- Tsignal_handler handler)
+bind_handler (int signo, Tsignal_handler handler)
{
Tsignal_handler old_handler
= ((signo == 0)
? ((Tsignal_handler) SIG_DFL)
: (current_handler (signo)));
- if ((signo != 0)
+ if ((signo != 0)
&& ((old_handler == ((Tsignal_handler) SIG_DFL))
|| ((old_handler == ((Tsignal_handler) SIG_IGN))
&& (signo == SIGCHLD)))
}
static void
-DEFUN_VOID (unblock_all_signals)
+unblock_all_signals (void)
{
/* Force the signal mask to be empty. */
#ifdef HAVE_POSIX_SIGNALS
}
void
-DEFUN_VOID (UX_initialize_signals)
+UX_initialize_signals (void)
{
stop_signal_hook = 0;
subprocess_death_hook = 0;
initialize_signal_descriptors ();
initialize_signal_debugging ();
bind_handler (SIGINT, sighnd_control_g);
-#ifndef __APPLE__
+#ifdef HAVE_SIGFPE
bind_handler (SIGFPE, sighnd_fpe);
-#endif /* __APPLE__ */
+#endif
bind_handler (SIGALRM, sighnd_timer);
bind_handler (SIGVTALRM, sighnd_timer);
bind_handler (SIGUSR1, sighnd_save_then_terminate);
/* Initialize the signals in a child subprocess. */
void
-DEFUN_VOID (UX_initialize_child_signals)
+UX_initialize_child_signals (void)
{
unblock_all_signals ();
/* SIGPIPE was ignored above; we must set it back to the default
taken.
*/
cc_t
-DEFUN (OS_tty_map_interrupt_char, (int_char), cc_t int_char)
+OS_tty_map_interrupt_char (cc_t int_char)
{
return int_char;
}
-static void EXFUN (print_interactive_help, (void));
-static void EXFUN (print_interrupt_chars, (void));
-static void EXFUN (examine_memory, (void));
-static void EXFUN (reset_query, (SIGCONTEXT_T * scp));
-static void EXFUN (interactive_back_trace, (void));
+static void print_interactive_help (void);
+static void print_interrupt_chars (void);
+static void examine_memory (void);
+static void reset_query (SIGCONTEXT_T * scp);
+static void interactive_back_trace (void);
#define INTERACTIVE_NEWLINE() \
{ \
}
static void
-DEFUN (interactive_interrupt_handler, (scp), SIGCONTEXT_T * scp)
+interactive_interrupt_handler (SIGCONTEXT_T * scp)
{
if (!option_emacs_subprocess)
{
}
\f
static enum interrupt_handler
-DEFUN (encode_interrupt_handler, (handler), Tsignal_handler handler)
+encode_interrupt_handler (Tsignal_handler handler)
{
return
((handler == ((Tsignal_handler) sighnd_control_g))
}
static Tsignal_handler
-DEFUN (decode_interrupt_handler, (encoding), enum interrupt_handler encoding)
+decode_interrupt_handler (enum interrupt_handler encoding)
{
return
((encoding == interrupt_handler_control_g)
}
enum interrupt_handler
-DEFUN_VOID (OS_signal_quit_handler)
+OS_signal_quit_handler (void)
{
return (encode_interrupt_handler (current_handler (SIGQUIT)));
}
enum interrupt_handler
-DEFUN_VOID (OS_signal_int_handler)
+OS_signal_int_handler (void)
{
return (encode_interrupt_handler (current_handler (SIGINT)));
}
enum interrupt_handler
-DEFUN_VOID (OS_signal_tstp_handler)
+OS_signal_tstp_handler (void)
{
return
((UX_SC_JOB_CONTROL ())
}
void
-DEFUN (OS_signal_set_interrupt_handlers,
- (quit_handler, int_handler, tstp_handler),
- enum interrupt_handler quit_handler AND
- enum interrupt_handler int_handler AND
- enum interrupt_handler tstp_handler)
+OS_signal_set_interrupt_handlers (enum interrupt_handler quit_handler,
+ enum interrupt_handler int_handler,
+ enum interrupt_handler tstp_handler)
{
{
Tsignal_handler handler = (decode_interrupt_handler (quit_handler));
}
\f
static void
-DEFUN (describe_sighnd, (signo, c), int signo AND unsigned char c)
+describe_sighnd (int signo, unsigned char c)
{
switch (encode_interrupt_handler (current_handler (signo)))
{
}
\f
static void
-DEFUN_VOID (print_interrupt_chars)
+print_interrupt_chars (void)
{
{
unsigned char quit_char = (OS_ctty_quit_char ());
}
static void
-DEFUN_VOID (print_interactive_help)
+print_interactive_help (void)
{
fputs ("\n\n", stdout);
fputs ("^B: Enter a breakpoint loop.\n", stdout);
}
\f
static void
-DEFUN (invoke_soft_reset, (name), char * name)
+invoke_soft_reset (const char * name)
{
soft_reset ();
/*NOTREACHED*/
}
static void
-DEFUN (reset_query, (scp), SIGCONTEXT_T * scp)
+reset_query (SIGCONTEXT_T * scp)
{
putc ('\n', stdout);
fflush (stdout);
if (WITHIN_CRITICAL_SECTION_P ())
{
- static CONST char * reset_choices [] =
+ static const char * reset_choices [] =
{
"D = delay reset until the end of the critical section",
"N = attempt reset now",
#define USERIO_READ_LINE_INPUT_FAILED 2
static int
-DEFUN (userio_read_line, (line, size), char * line AND int size)
+userio_read_line (char * line, int size)
{
int result = USERIO_READ_LINE_TOO_LONG;
transaction_begin ();
}
static void
-DEFUN_VOID (examine_memory)
+examine_memory (void)
{
char input_string [256];
fputs ("Enter location to examine (0x prefix for hex): ", stdout);
}
\f
void
-DEFUN (eta_fclose, (stream), PTR stream)
+eta_fclose (void * stream)
{
(void) (fclose ((FILE *) stream));
return;
}
static void
-DEFUN_VOID (interactive_back_trace)
+interactive_back_trace (void)
{
char input_string [256];
fputs ("Enter the stack trace filename (default: terminal): ", stdout);
}
INTERACTIVE_NEWLINE ();
if ((strlen (&input_string[0])) == 0)
- debug_back_trace (console_output);
+ debug_back_trace (CONSOLE_OUTPUT);
else
{
transaction_begin ();
}
transaction_record_action (tat_always,
eta_fclose,
- ((PTR) to_dump));
+ ((void *) to_dump));
outf_console ("Writing the stack trace to file \"%s\" -- ",
&input_string[0]);
outf_flush_console ();
The magic constant of 276 was found by poking with adb. */
static void
-DEFUN (sun3_save_regs, (regs), int * regs)
+sun3_save_regs (int * regs)
{
asm ("\n\
movel a6@(8),a0\n\
#ifdef vax
static int
-DEFUN_VOID (vax_get_r0)
+vax_get_r0 (void)
{
/* This is a kludge. It relies on r0 being the return value register. */
asm ("ret");
}
static int *
-DEFUN (vax_save_start, (regs, r0), int * regs AND int r0)
+vax_save_start (int * regs, int r0)
{
asm ("movl fp,-(sp)");
asm ("movl 4(ap),fp");
}
static void
-DEFUN (vax_save_finish, (fp, pscp, scp),
- int * fp AND
- struct sigcontext * pscp AND
- struct full_sigcontext * scp)
+vax_save_finish (int * fp,
+ struct sigcontext * pscp,
+ struct full_sigcontext * scp)
{
(scp -> fs_original) = pscp;
#ifndef _ULTRIX
this file. */
Tsignal_handler
-DEFUN (signal, (signo, handler),
- int signo AND
- Tsignal_handler handler)
+signal (int signo, Tsignal_handler handler)
{
struct sigaction act;
struct sigaction oact;
called because that guarantees that the flags are correct. */
void
-DEFUN_VOID (sony_block_sigchld)
+sony_block_sigchld (void)
{
sighold (SIGCHLD);
}
void
-DEFUN_VOID (sony_unblock_sigchld)
+sony_unblock_sigchld (void)
{
INSTALL_HANDLER (SIGCHLD, sighnd_dead_subprocess);
sigrelse (SIGCHLD);
/* -*-C-*-
-$Id: uxsig.h,v 1.12 2007/01/05 21:19:25 cph Exp $
+$Id: uxsig.h,v 1.13 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define DEFUN_STD_HANDLER(name, statement) \
Tsignal_handler_result \
-DEFUN (name, (signo, info, pscp), \
- int signo AND \
- SIGINFO_T info AND \
- SIGCONTEXT_ARG_T * pscp) \
+name (int signo, \
+ SIGINFO_T info, \
+ SIGCONTEXT_ARG_T * pscp) \
{ \
int STD_HANDLER_abortp; \
DECLARE_SIGCONTEXT (scp, pscp); \
#define DEFUN_STD_HANDLER(name, statement) \
Tsignal_handler_result \
-DEFUN (name, (signo, info, pscp), \
- int signo AND \
- SIGINFO_T info AND \
- SIGCONTEXT_ARG_T * pscp) \
+name (int signo, \
+ SIGINFO_T info, \
+ SIGCONTEXT_ARG_T * pscp) \
{ \
int STD_HANDLER_abortp; \
DECLARE_SIGCONTEXT (scp, pscp); \
SIGNAL_HANDLER_RETURN (); \
}
-extern void EXFUN (ta_abort_handler, (PTR));
+extern void ta_abort_handler (void *);
#endif /* NEED_HANDLER_TRANSACTION */
/* -*-C-*-
-$Id: uxsock.c,v 1.35 2007/01/12 03:45:55 cph Exp $
+$Id: uxsock.c,v 1.36 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "uxsock.h"
#include "uxio.h"
#include "prims.h"
-#include "limits.h"
static void do_connect (int, struct sockaddr *, socklen_t);
\f
Tchannel
-DEFUN (OS_open_tcp_stream_socket, (host, port),
- PTR host AND
- unsigned int port)
+OS_open_tcp_stream_socket (void * host, unsigned int port)
{
int s;
Tchannel channel;
}
void
-DEFUN (OS_shutdown_socket, (channel, stype),
- Tchannel channel AND
- unsigned long stype)
+OS_shutdown_socket (Tchannel channel, unsigned long stype)
{
STD_VOID_SYSTEM_CALL
(syscall_shutdown,
}
int
-DEFUN (OS_get_service_by_name, (service_name, protocol_name),
- CONST char * service_name AND
- CONST char * protocol_name)
+OS_get_service_by_name (const char * service_name, const char * protocol_name)
{
struct servent * entry = (UX_getservbyname (service_name, protocol_name));
return ((entry == 0) ? (-1) : (entry -> s_port));
}
unsigned long
-DEFUN (OS_get_service_by_number, (port_number),
- CONST unsigned long port_number)
+OS_get_service_by_number (const unsigned long port_number)
{
return ((unsigned long) (htons ((unsigned short) port_number)));
}
unsigned int
-DEFUN_VOID (OS_host_address_length)
+OS_host_address_length (void)
{
return (sizeof (struct in_addr));
}
char **
-DEFUN (OS_get_host_by_name, (host_name), CONST char * host_name)
+OS_get_host_by_name (const char * host_name)
{
struct hostent * entry = (UX_gethostbyname (host_name));
if (entry == 0)
#define HOSTNAMESIZE 1024
-CONST char *
-DEFUN_VOID (OS_get_host_name)
+const char *
+OS_get_host_name (void)
{
char host_name [HOSTNAMESIZE];
STD_VOID_SYSTEM_CALL
}
}
-CONST char *
-DEFUN (OS_canonical_host_name, (host_name), CONST char * host_name)
+const char *
+OS_canonical_host_name (const char * host_name)
{
struct hostent * entry = (gethostbyname (host_name));
if (entry == 0)
}
}
-CONST char *
-DEFUN (OS_get_host_by_address, (host_addr), CONST char * host_addr)
+const char *
+OS_get_host_by_address (const char * host_addr)
{
struct hostent * entry
= (gethostbyaddr (host_addr, (OS_host_address_length ()), AF_INET));
}
void
-DEFUN (OS_host_address_any, (addr), PTR addr)
+OS_host_address_any (void * addr)
{
(((struct in_addr *) addr) -> s_addr) = (htonl (INADDR_ANY));
}
void
-DEFUN (OS_host_address_loopback, (addr), PTR addr)
+OS_host_address_loopback (void * addr)
{
(((struct in_addr *) addr) -> s_addr) = (htonl (INADDR_LOOPBACK));
}
#ifdef HAVE_UNIX_SOCKETS
Tchannel
-DEFUN (OS_open_unix_stream_socket, (filename), CONST char * filename)
+OS_open_unix_stream_socket (const char * filename)
{
int s;
Tchannel channel;
#endif /* HAVE_UNIX_SOCKETS */
\f
Tchannel
-DEFUN_VOID (OS_create_tcp_server_socket)
+OS_create_tcp_server_socket (void)
{
int s;
STD_UINT_SYSTEM_CALL
}
void
-DEFUN (OS_bind_tcp_server_socket, (channel, host, port),
- Tchannel channel AND
- PTR host AND
- unsigned int port)
+OS_bind_tcp_server_socket (Tchannel channel, void * host, unsigned int port)
{
struct sockaddr_in address;
int one = 1;
#endif
void
-DEFUN (OS_listen_tcp_server_socket, (channel), Tchannel channel)
+OS_listen_tcp_server_socket (Tchannel channel)
{
STD_VOID_SYSTEM_CALL
(syscall_listen,
}
Tchannel
-DEFUN (OS_server_connection_accept, (channel, peer_host, peer_port),
- Tchannel channel AND
- PTR peer_host AND
- unsigned int * peer_port)
+OS_server_connection_accept (Tchannel channel,
+ void * peer_host,
+ unsigned int * peer_port)
{
static struct sockaddr_in address;
socklen_t address_length = (sizeof (struct sockaddr_in));
/* -*-C-*-
-$Id: uxsock.h,v 1.15 2007/01/05 21:19:25 cph Exp $
+$Id: uxsock.h,v 1.16 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "osio.h"
-extern Tchannel EXFUN (OS_open_tcp_stream_socket, (PTR, unsigned int));
-extern void EXFUN (OS_shutdown_socket, (Tchannel, unsigned long));
-extern int EXFUN (OS_get_service_by_name, (CONST char *, CONST char *));
-extern unsigned long EXFUN (OS_get_service_by_number, (CONST unsigned long));
-extern unsigned int EXFUN (OS_host_address_length, (void));
-extern char ** EXFUN (OS_get_host_by_name, (CONST char *));
-extern CONST char * EXFUN (OS_get_host_name, (void));
-extern CONST char * EXFUN (OS_canonical_host_name, (CONST char *));
-extern CONST char * EXFUN (OS_get_host_by_address, (CONST char *));
-extern void EXFUN (OS_host_address_any, (PTR));
-extern void EXFUN (OS_host_address_loopback, (PTR));
+extern Tchannel OS_open_tcp_stream_socket (void *, unsigned int);
+extern void OS_shutdown_socket (Tchannel, unsigned long);
+extern int OS_get_service_by_name (const char *, const char *);
+extern unsigned long OS_get_service_by_number (const unsigned long);
+extern unsigned int OS_host_address_length (void);
+extern char ** OS_get_host_by_name (const char *);
+extern const char * OS_get_host_name (void);
+extern const char * OS_canonical_host_name (const char *);
+extern const char * OS_get_host_by_address (const char *);
+extern void OS_host_address_any (void *);
+extern void OS_host_address_loopback (void *);
#ifdef HAVE_UNIX_SOCKETS
-extern Tchannel EXFUN (OS_open_unix_stream_socket, (CONST char *));
+ extern Tchannel OS_open_unix_stream_socket (const char *);
#endif
-extern Tchannel EXFUN (OS_create_tcp_server_socket, (void));
-extern void EXFUN (OS_bind_tcp_server_socket, (Tchannel, PTR, unsigned int));
-extern void EXFUN (OS_listen_tcp_server_socket, (Tchannel));
-extern Tchannel EXFUN
- (OS_server_connection_accept, (Tchannel, PTR, unsigned int *));
+extern Tchannel OS_create_tcp_server_socket (void);
+extern void OS_bind_tcp_server_socket (Tchannel, void *, unsigned int);
+extern void OS_listen_tcp_server_socket (Tchannel);
+extern Tchannel OS_server_connection_accept (Tchannel, void *, unsigned int *);
#endif /* SCM_UXSOCK_H */
/* -*-C-*-
-$Id: uxterm.c,v 1.33 2007/01/05 21:19:25 cph Exp $
+$Id: uxterm.c,v 1.34 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "ospty.h"
#include "prims.h"
-extern long EXFUN (arg_nonnegative_integer, (int));
-extern long EXFUN (arg_index_integer, (int, long));
+extern int UX_terminal_control_ok (int fd);
#if defined(HAVE_TERMIOS_H) || defined(HAVE_TERMIO_H)
# ifndef ISTRIP
#define TERMINAL_ORIGINAL_STATE(channel) ((terminal_table[(channel)]) . state)
void
-DEFUN_VOID (UX_initialize_terminals)
+UX_initialize_terminals (void)
{
terminal_table =
(UX_malloc (OS_channel_table_size * (sizeof (struct terminal_state))));
}
void
-DEFUN_VOID (UX_reset_terminals)
+UX_reset_terminals (void)
{
UX_free (terminal_table);
terminal_table = 0;
/* This is called from the file-opening code. */
void
-DEFUN (terminal_open, (channel), Tchannel channel)
+terminal_open (Tchannel channel)
{
(TERMINAL_BUFFER (channel)) = (-1);
get_terminal_state (channel, (& (TERMINAL_ORIGINAL_STATE (channel))));
}
void
-DEFUN (get_terminal_state, (channel, s), Tchannel channel AND Ttty_state * s)
+get_terminal_state (Tchannel channel, Ttty_state * s)
{
STD_VOID_SYSTEM_CALL
(syscall_terminal_get_state,
}
void
-DEFUN (set_terminal_state, (channel, s), Tchannel channel AND Ttty_state * s)
+set_terminal_state (Tchannel channel, Ttty_state * s)
{
- extern int EXFUN (UX_terminal_control_ok, (int fd));
if (UX_terminal_control_ok (CHANNEL_DESCRIPTOR (channel)))
STD_VOID_SYSTEM_CALL
(syscall_terminal_set_state,
}
\f
unsigned int
-DEFUN (terminal_state_get_ospeed, (s), Ttty_state * s)
+terminal_state_get_ospeed (Ttty_state * s)
{
#ifdef HAVE_TERMIOS_H
return (cfgetospeed (TIO (s)));
}
unsigned int
-DEFUN (terminal_state_get_ispeed, (s), Ttty_state * s)
+terminal_state_get_ispeed (Ttty_state * s)
{
#ifdef HAVE_TERMIOS_H
return (cfgetispeed (TIO (s)));
}
void
-DEFUN (terminal_state_set_ospeed, (s, b),
- Ttty_state * s AND
- unsigned int b)
+terminal_state_set_ospeed (Ttty_state * s, unsigned int b)
{
#ifdef HAVE_TERMIOS_H
cfsetospeed ((TIO (s)), b);
}
void
-DEFUN (terminal_state_set_ispeed, (s, b),
- Ttty_state * s AND
- unsigned int b)
+terminal_state_set_ispeed (Ttty_state * s, unsigned int b)
{
#ifdef HAVE_TERMIOS_H
cfsetispeed ((TIO (s)), b);
}
int
-DEFUN (terminal_state_cooked_output_p, (s), Ttty_state * s)
+terminal_state_cooked_output_p (Ttty_state * s)
{
#if defined(HAVE_TERMIOS_H) || defined(HAVE_TERMIO_H)
return ((((TIO (s)) -> c_oflag) & OPOST) != 0);
}
void
-DEFUN (terminal_state_raw_output, (s), Ttty_state * s)
+terminal_state_raw_output (Ttty_state * s)
{
#if defined(HAVE_TERMIOS_H) || defined(HAVE_TERMIO_H)
((TIO (s)) -> c_oflag) &=~ OPOST;
}
void
-DEFUN (terminal_state_cooked_output, (s, channel),
- Ttty_state * s AND Tchannel channel)
+terminal_state_cooked_output (Ttty_state * s, Tchannel channel)
{
Ttty_state * os = (& (TERMINAL_ORIGINAL_STATE (channel)));
#if defined(HAVE_TERMIOS_H) || defined(HAVE_TERMIO_H)
}
\f
int
-DEFUN (terminal_state_buffered_p, (s), Ttty_state * s)
+terminal_state_buffered_p (Ttty_state * s)
{
#if defined(HAVE_TERMIOS_H) || defined(HAVE_TERMIO_H)
return ((((TIO (s)) -> c_lflag) & ICANON) != 0);
}
void
-DEFUN (terminal_state_nonbuffered, (s, fd, polling),
- Ttty_state * s AND
- int fd AND
- int polling)
+terminal_state_nonbuffered (Ttty_state * s, int fd, int polling)
{
#if defined(HAVE_TERMIOS_H) || defined(HAVE_TERMIO_H)
}
void
-DEFUN (terminal_state_raw, (s, fd), Ttty_state * s AND int fd)
+terminal_state_raw (Ttty_state * s, int fd)
{
terminal_state_nonbuffered (s, fd, 0);
}
void
-DEFUN (terminal_state_buffered, (s, channel),
- Ttty_state * s AND
- Tchannel channel)
+terminal_state_buffered (Ttty_state * s, Tchannel channel)
{
Ttty_state * os = (& (TERMINAL_ORIGINAL_STATE (channel)));
}
\f
unsigned int
-DEFUN (OS_terminal_get_ispeed, (channel), Tchannel channel)
+OS_terminal_get_ispeed (Tchannel channel)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
unsigned int
-DEFUN (OS_terminal_get_ospeed, (channel), Tchannel channel)
+OS_terminal_get_ospeed (Tchannel channel)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
void
-DEFUN (OS_terminal_set_ispeed, (channel, baud),
- Tchannel channel AND
- unsigned int baud)
+OS_terminal_set_ispeed (Tchannel channel, unsigned int baud)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
void
-DEFUN (OS_terminal_set_ospeed, (channel, baud),
- Tchannel channel AND
- unsigned int baud)
+OS_terminal_set_ospeed (Tchannel channel, unsigned int baud)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
unsigned int
-DEFUN (arg_baud_index, (argument), unsigned int argument)
+arg_baud_index (unsigned int argument)
{
- unsigned long index = (arg_nonnegative_integer (argument));
+ unsigned long index = (arg_ulong_integer (argument));
switch (index)
{
case B0:
}
unsigned int
-DEFUN (OS_baud_index_to_rate, (index), unsigned int index)
+OS_baud_index_to_rate (unsigned int index)
{
switch (index)
{
}
int
-DEFUN (OS_baud_rate_to_index, (rate), unsigned int rate)
+OS_baud_rate_to_index (unsigned int rate)
{
switch (rate)
{
}
unsigned int
-DEFUN_VOID (OS_terminal_state_size)
+OS_terminal_state_size (void)
{
return (sizeof (Ttty_state));
}
void
-DEFUN (OS_terminal_get_state, (channel, statep),
- Tchannel channel AND
- PTR statep)
+OS_terminal_get_state (Tchannel channel, void * statep)
{
get_terminal_state (channel, statep);
}
void
-DEFUN (OS_terminal_set_state, (channel, statep),
- Tchannel channel AND
- PTR statep)
+OS_terminal_set_state (Tchannel channel, void * statep)
{
set_terminal_state (channel, statep);
}
\f
int
-DEFUN (OS_terminal_cooked_output_p, (channel), Tchannel channel)
+OS_terminal_cooked_output_p (Tchannel channel)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
void
-DEFUN (OS_terminal_raw_output, (channel), Tchannel channel)
+OS_terminal_raw_output (Tchannel channel)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
void
-DEFUN (OS_terminal_cooked_output, (channel), Tchannel channel)
+OS_terminal_cooked_output (Tchannel channel)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
int
-DEFUN (OS_terminal_buffered_p, (channel), Tchannel channel)
+OS_terminal_buffered_p (Tchannel channel)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
void
-DEFUN (OS_terminal_buffered, (channel), Tchannel channel)
+OS_terminal_buffered (Tchannel channel)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
void
-DEFUN (OS_terminal_nonbuffered, (channel), Tchannel channel)
+OS_terminal_nonbuffered (Tchannel channel)
{
Ttty_state s;
get_terminal_state (channel, (&s));
}
void
-DEFUN (OS_terminal_flush_input, (channel), Tchannel channel)
+OS_terminal_flush_input (Tchannel channel)
{
STD_VOID_SYSTEM_CALL
(syscall_tcflush, (UX_tcflush ((CHANNEL_DESCRIPTOR (channel)), TCIFLUSH)));
}
void
-DEFUN (OS_terminal_flush_output, (channel), Tchannel channel)
+OS_terminal_flush_output (Tchannel channel)
{
STD_VOID_SYSTEM_CALL
(syscall_tcflush, (UX_tcflush ((CHANNEL_DESCRIPTOR (channel)), TCOFLUSH)));
}
void
-DEFUN (OS_terminal_drain_output, (channel), Tchannel channel)
+OS_terminal_drain_output (Tchannel channel)
{
STD_VOID_SYSTEM_CALL
(syscall_tcdrain, (UX_tcdrain (CHANNEL_DESCRIPTOR (channel))));
}
int
-DEFUN_VOID (OS_job_control_p)
+OS_job_control_p (void)
{
return (UX_SC_JOB_CONTROL ());
}
\f
int
-DEFUN_VOID (OS_have_ptys_p)
+OS_have_ptys_p (void)
{
#ifdef HAVE_GRANTPT
return (1);
#endif
}
-static CONST char *
-DEFUN (open_pty_master_bsd, (master_fd, master_fname),
- Tchannel * master_fd AND
- CONST char ** master_fname)
+static const char *
+open_pty_master_bsd (Tchannel * master_fd, const char ** master_fname)
{
static char master_name [24];
static char slave_name [24];
and return the file name of the pty.
Signal error if none available. */
-CONST char *
-DEFUN (OS_open_pty_master, (master_fd, master_fname),
- Tchannel * master_fd AND
- CONST char ** master_fname)
+const char *
+OS_open_pty_master (Tchannel * master_fd, const char ** master_fname)
{
#ifdef HAVE_GRANTPT
while (1)
}
void
-DEFUN (OS_pty_master_send_signal, (channel, sig), Tchannel channel AND int sig)
+OS_pty_master_send_signal (Tchannel channel, int sig)
{
#ifdef TIOCSIGSEND
STD_VOID_SYSTEM_CALL
}
void
-DEFUN (OS_pty_master_kill, (channel), Tchannel channel)
+OS_pty_master_kill (Tchannel channel)
{
OS_pty_master_send_signal (channel, SIGKILL);
}
void
-DEFUN (OS_pty_master_stop, (channel), Tchannel channel)
+OS_pty_master_stop (Tchannel channel)
{
OS_pty_master_send_signal (channel, SIGTSTP);
}
void
-DEFUN (OS_pty_master_continue, (channel), Tchannel channel)
+OS_pty_master_continue (Tchannel channel)
{
OS_pty_master_send_signal (channel, SIGCONT);
}
void
-DEFUN (OS_pty_master_interrupt, (channel), Tchannel channel)
+OS_pty_master_interrupt (Tchannel channel)
{
OS_pty_master_send_signal (channel, SIGINT);
}
void
-DEFUN (OS_pty_master_quit, (channel), Tchannel channel)
+OS_pty_master_quit (Tchannel channel)
{
OS_pty_master_send_signal (channel, SIGQUIT);
}
void
-DEFUN (OS_pty_master_hangup, (channel), Tchannel channel)
+OS_pty_master_hangup (Tchannel channel)
{
OS_pty_master_send_signal (channel, SIGHUP);
}
/* -*-C-*-
-$Id: uxterm.h,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: uxterm.h,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "osterm.h"
-extern int EXFUN (terminal_state_buffered_p, (Ttty_state * s));
-extern void EXFUN
- (terminal_state_buffered, (Ttty_state * s, Tchannel channel));
-extern void EXFUN
- (terminal_state_nonbuffered, (Ttty_state * s, int fd, int polling));
-extern void EXFUN (terminal_state_raw, (Ttty_state * s, int fd));
-extern void EXFUN (get_terminal_state, (Tchannel channel, Ttty_state * s));
-extern void EXFUN (set_terminal_state, (Tchannel channel, Ttty_state * s));
+extern int terminal_state_buffered_p (Ttty_state * s);
+extern void terminal_state_buffered (Ttty_state * s, Tchannel channel);
+extern void terminal_state_nonbuffered (Ttty_state * s, int fd, int polling);
+extern void terminal_state_raw (Ttty_state * s, int fd);
+extern void get_terminal_state (Tchannel channel, Ttty_state * s);
+extern void set_terminal_state (Tchannel channel, Ttty_state * s);
#endif /* SCM_UXTERM_H */
/* -*-C-*-
-$Id: uxtop.c,v 1.35 2007/04/03 03:58:58 cph Exp $
+$Id: uxtop.c,v 1.36 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "errors.h"
#include "option.h"
#include "config.h"
-#include "default.h"
+#include "object.h"
#include "extern.h"
-extern void EXFUN (UX_initialize_channels, (void));
-extern void EXFUN (UX_initialize_ctty, (int interactive));
-extern void EXFUN (UX_initialize_directory_reader, (void));
-extern void EXFUN (UX_initialize_environment, (void));
-extern void EXFUN (UX_initialize_processes, (void));
-extern void EXFUN (UX_initialize_signals, (void));
-extern void EXFUN (UX_initialize_terminals, (void));
-extern void EXFUN (UX_initialize_trap_recovery, (void));
-extern void EXFUN (UX_initialize_tty, (void));
-extern void EXFUN (UX_initialize_userio, (void));
-
-extern void EXFUN (UX_reset_channels, (void));
-extern void EXFUN (UX_reset_processes, (void));
-extern void EXFUN (UX_reset_terminals, (void));
-extern void EXFUN (execute_reload_cleanups, (void));
-
-extern cc_t EXFUN (OS_ctty_quit_char, (void));
-extern void EXFUN (UX_ctty_save_external_state, (void));
-extern void EXFUN (UX_ctty_save_internal_state, (void));
-extern void EXFUN (UX_ctty_restore_internal_state, (void));
-extern void EXFUN (UX_ctty_restore_external_state, (void));
-
-/* reset_interruptable_extent */
-
-extern CONST char * OS_Name;
-extern CONST char * OS_Variant;
+extern void UX_initialize_channels (void);
+extern void UX_initialize_ctty (int interactive);
+extern void UX_initialize_directory_reader (void);
+extern void UX_initialize_environment (void);
+extern void UX_initialize_processes (void);
+extern void UX_initialize_signals (void);
+extern void UX_initialize_terminals (void);
+extern void UX_initialize_trap_recovery (void);
+extern void UX_initialize_tty (void);
+extern void UX_initialize_userio (void);
+
+extern void UX_reset_channels (void);
+extern void UX_reset_processes (void);
+extern void UX_reset_terminals (void);
+
+extern cc_t OS_ctty_quit_char (void);
+extern void UX_ctty_save_external_state (void);
+extern void UX_ctty_save_internal_state (void);
+extern void UX_ctty_restore_internal_state (void);
+extern void UX_ctty_restore_external_state (void);
\f
static int interactive;
int
-DEFUN_VOID (OS_under_emacs_p)
+OS_under_emacs_p (void)
{
return (option_emacs_subprocess);
}
void
-DEFUN_VOID (OS_initialize)
+OS_initialize (void)
{
initialize_interruptable_extent ();
{
}
void
-DEFUN_VOID (OS_announcement)
+OS_announcement (void)
{
if ((!option_emacs_subprocess) && (OS_ctty_interrupt_control ()))
fprintf
}
void
-DEFUN_VOID (OS_reset)
+OS_reset (void)
{
/*
There should really be a reset for each initialize above,
}
\f
void
-DEFUN (OS_quit, (code, abnormal_p), int code AND int abnormal_p)
+OS_quit (int code, int abnormal_p)
{
fflush (stdout);
if (abnormal_p
}
void
-DEFUN_VOID (UX_dump_core)
+UX_dump_core (void)
{
OS_restore_external_state ();
/* Unmask this too? */
}
void
-DEFUN_VOID (OS_save_external_state)
+OS_save_external_state (void)
{
UX_ctty_save_external_state ();
}
void
-DEFUN_VOID (OS_save_internal_state)
+OS_save_internal_state (void)
{
UX_ctty_save_internal_state ();
}
void
-DEFUN_VOID (OS_restore_internal_state)
+OS_restore_internal_state (void)
{
UX_ctty_restore_internal_state ();
}
void
-DEFUN_VOID (OS_restore_external_state)
+OS_restore_external_state (void)
{
UX_ctty_restore_external_state ();
}
\f
enum syserr_names
-DEFUN (OS_error_code_to_syserr, (code), int code)
+OS_error_code_to_syserr (int code)
{
switch (code)
{
case E2BIG: return (syserr_arg_list_too_long);
case EACCES: return (syserr_permission_denied);
- case EAGAIN: return (syserr_resource_temporarily_unavailable);
#ifdef EADDRINUSE
case EADDRINUSE: return (syserr_address_in_use);
#endif
+ case EAGAIN: return (syserr_resource_temporarily_unavailable);
case EBADF: return (syserr_bad_file_descriptor);
case EBUSY: return (syserr_resource_busy);
case ECHILD: return (syserr_no_child_processes);
}
\f
static int
-DEFUN (syserr_to_error_code, (syserr), enum syserr_names syserr)
+syserr_to_error_code (enum syserr_names syserr)
{
switch (syserr)
{
#ifdef HAVE_STRERROR
-CONST char *
-DEFUN (OS_error_code_to_message, (syserr), unsigned int syserr)
+const char *
+OS_error_code_to_message (unsigned int syserr)
{
return
((syserr == 0)
extern int sys_nerr;
#endif
-CONST char *
-DEFUN (OS_error_code_to_message, (syserr), unsigned int syserr)
+const char *
+OS_error_code_to_message (unsigned int syserr)
{
int code = (syserr_to_error_code ((enum syserr_names) syserr));
return (((code > 0) && (code <= sys_nerr)) ? (sys_errlist [code]) : 0);
#endif /* not HAVE_STRERROR */
\f
-static char * syscall_names_table [] =
+static const char * syscall_names_table [] =
{
"accept",
"bind",
};
void
-OS_syscall_names (unsigned int * length, char *** names)
+OS_syscall_names (unsigned long * length, const char *** names)
{
(*length) = ((sizeof (syscall_names_table)) / (sizeof (char *)));
(*names) = syscall_names_table;
}
\f
-static char * syserr_names_table [] =
+static const char * syserr_names_table [] =
{
"unknown",
"address-in-use",
};
void
-OS_syserr_names (unsigned int * length, char *** names)
+OS_syserr_names (unsigned long * length, const char *** names)
{
(*length) = ((sizeof (syserr_names_table)) / (sizeof (char *)));
(*names) = syserr_names_table;
/* -*-C-*-
-$Id: uxtop.h,v 1.7 2007/01/05 21:19:25 cph Exp $
+$Id: uxtop.h,v 1.8 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "ostop.h"
-extern void EXFUN (UX_dump_core, (void));
+extern void UX_dump_core (void);
#endif /* SCM_UXTOP_H */
/* -*-C-*-
-$Id: uxtrap.c,v 1.45 2007/01/12 03:45:55 cph Exp $
+$Id: uxtrap.c,v 1.46 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
#include "scheme.h"
+#include "history.h"
#include "ux.h"
#include "uxtrap.h"
#include "uxutil.h"
#include "option.h"
#include "ostop.h"
+#include "gccode.h"
-#ifdef HAS_COMPILER_SUPPORT
-# include "gccode.h"
-# if defined(HAVE_SIGCONTEXT) && !defined(USE_STACKLETS)
-# define ENABLE_TRAP_RECOVERY 1
-# endif
- /* FIXME: Support ppc, ppc64, x86_64, and ia64 */
-# if defined(__ppc__) || defined(__ppc64__) || defined(__x86_64__) || defined(__ia64__)
-# undef ENABLE_TRAP_RECOVERY
-# endif
+#ifdef HAVE_SIGCONTEXT
+# define ENABLE_TRAP_RECOVERY 1
+#endif
+
+/* FIXME: Support these architectures. */
+#ifdef __ppc__
+# undef ENABLE_TRAP_RECOVERY
+#endif
+#ifdef __ppc64__
+# undef ENABLE_TRAP_RECOVERY
+#endif
+#ifdef __x86_64__
+# undef ENABLE_TRAP_RECOVERY
+#endif
+#ifdef __ia64__
+# undef ENABLE_TRAP_RECOVERY
#endif
-extern CONST char * EXFUN (find_signal_name, (int signo));
-extern void EXFUN (UX_dump_core, (void));
-extern PTR initial_C_stack_pointer;
-extern int EXFUN (pc_to_utility_index, (unsigned long));
-extern int EXFUN (pc_to_builtin_index, (unsigned long));
-extern SCHEME_OBJECT * EXFUN (find_constant_space_block, (SCHEME_OBJECT *));
+extern const char * find_signal_name (int);
+extern void UX_dump_core (void);
+extern void * initial_C_stack_pointer;
\f
struct ux_sig_code_desc
{
int signo;
unsigned long code_mask;
unsigned long code_value;
- char * name;
+ const char * name;
};
static struct ux_sig_code_desc ux_signal_codes [64];
static SIGINFO_T saved_info;
static SIGCONTEXT_T * saved_scp;
-static void EXFUN
- (continue_from_trap, (int, SIGINFO_T, SIGCONTEXT_T *));
+static void continue_from_trap
+ (int, SIGINFO_T, SIGCONTEXT_T *);
-static SCHEME_OBJECT * EXFUN (find_heap_address, (unsigned long));
-static SCHEME_OBJECT * EXFUN (find_constant_address, (unsigned long));
-
-#ifdef ENABLE_TRAP_RECOVERY
-static SCHEME_OBJECT * EXFUN
- (find_block_address_in_area, (SCHEME_OBJECT *, SCHEME_OBJECT *));
+#ifdef CC_SUPPORT_P
+ static SCHEME_OBJECT * find_heap_address (unsigned long);
+ static SCHEME_OBJECT * find_constant_address (unsigned long);
+# ifdef ENABLE_TRAP_RECOVERY
+ static SCHEME_OBJECT * find_block_address (unsigned long, SCHEME_OBJECT *);
+ static SCHEME_OBJECT * find_block_address_in_area
+ (SCHEME_OBJECT *, SCHEME_OBJECT *);
+# endif
#endif
-static void EXFUN
- (setup_trap_frame, (int,
- SIGINFO_T,
- SIGCONTEXT_T *,
- struct trap_recovery_info *,
- SCHEME_OBJECT *));
+static void setup_trap_frame
+ (int,
+ SIGINFO_T,
+ SIGCONTEXT_T *,
+ struct trap_recovery_info *,
+ SCHEME_OBJECT *);
-static void EXFUN (initialize_ux_signal_codes, (void));
+static void initialize_ux_signal_codes (void);
+static SCHEME_OBJECT find_signal_code_name (int, SIGINFO_T, SIGCONTEXT_T *);
-static SCHEME_OBJECT EXFUN
- (find_signal_code_name, (int, SIGINFO_T, SIGCONTEXT_T *));
+static enum pc_location classify_pc
+ (unsigned long, SCHEME_OBJECT **, unsigned int *);
-static enum pc_location EXFUN
- (classify_pc, (unsigned long, SCHEME_OBJECT **, unsigned int *));
-
-static void EXFUN (trap_normal_termination, (void));
-static void EXFUN (trap_immediate_termination, (void));
-static void EXFUN (trap_dump_core, (void));
-static void EXFUN (trap_recover, (void));
+static void trap_normal_termination (void);
+static void trap_immediate_termination (void);
+static void trap_dump_core (void);
+static void trap_recover (void);
\f
void
-DEFUN_VOID (UX_initialize_trap_recovery)
+UX_initialize_trap_recovery (void)
{
trap_state = trap_state_recover;
user_trap_state = trap_state_recover;
}
enum trap_state
-DEFUN (OS_set_trap_state, (state), enum trap_state state)
+OS_set_trap_state (enum trap_state state)
{
enum trap_state old_trap_state = user_trap_state;
user_trap_state = state;
}
void
-DEFUN (hard_reset, (scp), SIGCONTEXT_T * scp)
+hard_reset (SIGCONTEXT_T * scp)
{
/* 0 is an invalid signal, it means a user requested reset. */
continue_from_trap (0, 0, scp);
}
void
-DEFUN_VOID (soft_reset)
+soft_reset (void)
{
/* Called synchronously. */
struct trap_recovery_info trinfo;
- SCHEME_OBJECT * new_stack_pointer =
- (((sp_register <= Stack_Top) && (sp_register > Stack_Guard))
- ? sp_register
- : 0);
- if ((Registers[REGBLOCK_PRIMITIVE]) != SHARP_F)
+ SCHEME_OBJECT * new_stack_pointer
+ = ((SP_OK_P (stack_pointer)) ? stack_pointer : 0);
+ if (GET_PRIMITIVE != SHARP_F)
{
(trinfo . state) = STATE_PRIMITIVE;
- (trinfo . pc_info_1) = (Registers[REGBLOCK_PRIMITIVE]);
- (trinfo . pc_info_2) =
- (LONG_TO_UNSIGNED_FIXNUM (Registers[REGBLOCK_LEXPR_ACTUALS]));
+ (trinfo . pc_info_1) = GET_PRIMITIVE;
+ (trinfo . pc_info_2) = (ULONG_TO_FIXNUM (GET_LEXPR_ACTUALS));
(trinfo . extra_trap_info) = SHARP_F;
}
else
(trinfo . pc_info_2) = SHARP_F;
(trinfo . extra_trap_info) = SHARP_F;
}
- if ((Free >= Heap_Top) || (Free < Heap_Bottom))
- /* Let's hope this works. */
- Free = MemTop;
+ if (!ADDRESS_IN_HEAP_P (Free))
+ Free = heap_alloc_limit; /* Let's hope this works. */
setup_trap_frame (0, 0, 0, (&trinfo), new_stack_pointer);
}
+#ifdef CC_SUPPORT_P
SCHEME_OBJECT
-DEFUN (find_ccblock, (pc), unsigned long pc)
+find_ccblock (unsigned long pc)
{
SCHEME_OBJECT * block_addr;
unsigned int index;
block_addr = 0;
classify_pc (pc, (&block_addr), (&index));
- return
- ((block_addr != 0)
- ? (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
- : SHARP_F);
+ return ((block_addr != 0) ? (MAKE_CC_BLOCK (block_addr)) : SHARP_F);
}
+#endif
\f
void
-DEFUN (trap_handler, (message, signo, info, scp),
- CONST char * message AND
- int signo AND
- SIGINFO_T info AND
- SIGCONTEXT_T * scp)
+trap_handler (const char * message,
+ int signo,
+ SIGINFO_T info,
+ SIGCONTEXT_T * scp)
{
int code = ((SIGINFO_VALID_P (info)) ? (SIGINFO_CODE (info)) : 0);
- Boolean stack_overflowed_p = (STACK_OVERFLOWED_P ());
+ bool stack_overflowed_p = (STACK_OVERFLOWED_P ());
enum trap_state old_trap_state = trap_state;
if (old_trap_state == trap_state_exitting_hard)
while (1)
{
- static CONST char * trap_query_choices[] =
+ static const char * trap_query_choices[] =
{
"D = dump core",
"I = terminate immediately",
}
}
\f
-#define PC_ALIGNED_P(pc) ((((unsigned long) (pc)) & PC_ALIGNMENT_MASK) == 0)
-
#ifdef ENABLE_TRAP_RECOVERY
/* Heuristic recovery from Unix signals (traps).
} while (0)
static void
-DEFUN (continue_from_trap, (signo, info, scp),
- int signo AND
- SIGINFO_T info AND
- SIGCONTEXT_T * scp)
+continue_from_trap (int signo, SIGINFO_T info, SIGCONTEXT_T * scp)
{
unsigned long pc = (SIGCONTEXT_PC (scp));
- SCHEME_OBJECT primitive = (Registers[REGBLOCK_PRIMITIVE]);
+ SCHEME_OBJECT primitive = GET_PRIMITIVE;
SCHEME_OBJECT * block_addr;
unsigned int index;
SCHEME_OBJECT * new_sp = 0;
switch (classify_pc (pc, (&block_addr), (&index)))
{
case pcl_primitive:
- new_sp = sp_register;
+ new_sp = stack_pointer;
SET_RECOVERY_INFO
- (STATE_PRIMITIVE,
- primitive,
- (LONG_TO_UNSIGNED_FIXNUM (Registers[REGBLOCK_LEXPR_ACTUALS])));
+ (STATE_PRIMITIVE, primitive, (ULONG_TO_FIXNUM (GET_LEXPR_ACTUALS)));
break;
case pcl_heap:
case pcl_constant:
+#ifdef CC_SUPPORT_P
new_sp = ((SCHEME_OBJECT *) (SIGCONTEXT_SCHSP (scp)));
Free = ((SCHEME_OBJECT *) (SIGCONTEXT_RFREE (scp)));
SET_RECOVERY_INFO
(STATE_COMPILED_CODE,
- (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr)),
+ (MAKE_CC_BLOCK (block_addr)),
(LONG_TO_UNSIGNED_FIXNUM (pc - ((unsigned long) block_addr))));
break;
+#endif
case pcl_utility:
- new_sp = sp_register;
- SET_RECOVERY_INFO
- (STATE_UTILITY,
- (ULONG_TO_FIXNUM (index)),
- UNSPECIFIC);
+#ifdef CC_SUPPORT_P
+ new_sp = stack_pointer;
+ SET_RECOVERY_INFO (STATE_UTILITY, (ULONG_TO_FIXNUM (index)), UNSPECIFIC);
break;
+#endif
case pcl_builtin:
+#ifdef CC_SUPPORT_P
new_sp = ((SCHEME_OBJECT *) (SIGCONTEXT_SCHSP (scp)));
Free = ((SCHEME_OBJECT *) (SIGCONTEXT_RFREE (scp)));
- SET_RECOVERY_INFO
- (STATE_BUILTIN,
- (ULONG_TO_FIXNUM (index)),
- UNSPECIFIC);
+ SET_RECOVERY_INFO (STATE_BUILTIN, (ULONG_TO_FIXNUM (index)), UNSPECIFIC);
break;
+#endif
case pcl_unknown:
new_sp = 0;
}
/* Sanity-check the new SP. */
- if (! ((Stack_Bottom <= new_sp)
- && (new_sp < Stack_Top)
- && (ALIGNED_P (new_sp))))
+ if (! ((ADDRESS_IN_STACK_P (new_sp)) && (ALIGNED_P (new_sp))))
new_sp = 0;
/* Sanity-check Free. */
if ((new_sp != 0)
- && (Heap_Bottom <= Free)
- && (Free < Heap_Top)
+ && (ADDRESS_IN_HEAP_P (Free))
&& (ALIGNED_P (Free)))
{
- if (Free < MemTop)
+ if (FREE_OK_P (Free))
{
Free += FREE_PARANOIA_MARGIN;
- if (Free > MemTop)
- Free = MemTop;
+ if (!FREE_OK_P (Free))
+ Free = heap_alloc_limit;
}
}
else
- Free = MemTop;
+ Free = heap_alloc_limit;
/* Encode the registers. */
(recovery_info . extra_trap_info) =
If the pointer is in the heap, it can actually do twice as
much work, but it is expected to pay off on the average. */
+#ifdef CC_SUPPORT_P
+
#define MINIMUM_SCAN_RANGE 2048
static SCHEME_OBJECT *
-DEFUN (find_heap_address, (pc), unsigned long pc)
+find_heap_address (unsigned long pc)
+{
+ return (find_block_address (pc, heap_start));
+}
+
+static SCHEME_OBJECT *
+find_constant_address (unsigned long pc)
+{
+ return (find_block_address (pc, constant_start));
+}
+
+static SCHEME_OBJECT *
+find_block_address (unsigned long pc, SCHEME_OBJECT * area_start)
{
SCHEME_OBJECT * pcp = ((SCHEME_OBJECT *) (pc &~ SCHEME_ALIGNMENT_MASK));
- unsigned long maximum_distance = (pcp - Heap_Bottom);
+ unsigned long maximum_distance = (pcp - area_start);
unsigned long distance = maximum_distance;
while ((distance / 2) > MINIMUM_SCAN_RANGE)
}
}
-static SCHEME_OBJECT *
-DEFUN (find_constant_address, (pc), unsigned long pc)
-{
- SCHEME_OBJECT * pcp = ((SCHEME_OBJECT *) (pc &~ SCHEME_ALIGNMENT_MASK));
- SCHEME_OBJECT * constant_block = (find_constant_space_block (pcp));
- return
- ((constant_block != 0)
- ? (find_block_address_in_area (pcp, constant_block))
- : 0);
-}
-
/* Find the compiled code block in area that contains `pc_value',
by scanning sequentially the complete area.
For the time being, skip over manifest closures and linkage sections. */
static SCHEME_OBJECT *
-DEFUN (find_block_address_in_area, (pcp, area_start),
- SCHEME_OBJECT * pcp AND
- SCHEME_OBJECT * area_start)
+find_block_address_in_area (SCHEME_OBJECT * pcp, SCHEME_OBJECT * area_start)
{
SCHEME_OBJECT * first_valid = area_start;
SCHEME_OBJECT * area = area_start;
{
case TC_LINKAGE_SECTION:
{
- switch (READ_LINKAGE_KIND (object))
+ unsigned long count = (linkage_section_count (object));
+ area += 1;
+ switch (linkage_section_type (object))
{
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- case OPERATOR_LINKAGE_KIND:
- {
- unsigned long count = (READ_OPERATOR_LINKAGE_COUNT (object));
- area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
- }
+ case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
+ case LINKAGE_SECTION_TYPE_OPERATOR:
+ area += (count * UUO_LINK_SIZE);
break;
default:
- area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
+ area += count;
break;
}
}
break;
case TC_MANIFEST_CLOSURE:
- {
- area += 1;
- {
- unsigned long count = (MANIFEST_CLOSURE_COUNT (area));
- area = (MANIFEST_CLOSURE_END (area, count));
- }
- }
+ area = (compiled_closure_objects (area + 1));
break;
case TC_MANIFEST_NM_VECTOR:
&& (((OBJECT_TYPE (*block)) == TC_MANIFEST_VECTOR)
|| ((OBJECT_TYPE (*block)) == FIXNUM_MARKER))
&& ((OBJECT_DATUM (*block)) >= (count + 1))
- && (PLAUSIBLE_CC_BLOCK_P (block)))
+ && (plausible_cc_block_p (block)))
? block
: 0);
}
}
return (0);
}
+#endif /* CC_SUPPORT_P */
\f
#else /* not ENABLE_TRAP_RECOVERY */
};
static void
-DEFUN (continue_from_trap, (signo, info, scp),
- int signo AND
- SIGINFO_T info AND
- SIGCONTEXT_T * scp)
+continue_from_trap (int signo, SIGINFO_T info, SIGCONTEXT_T * scp)
{
- if (Free < MemTop)
- Free = MemTop;
+ if (Free < heap_alloc_limit)
+ Free = heap_alloc_limit;
setup_trap_frame (signo, info, scp, (&dummy_recovery_info), 0);
}
+#ifdef CC_SUPPORT_P
+
static SCHEME_OBJECT *
-DEFUN (find_heap_address, (pc), unsigned long pc)
+find_heap_address (unsigned long pc)
{
return (0);
}
static SCHEME_OBJECT *
-DEFUN (find_constant_address, (pc), unsigned long pc)
+find_constant_address (unsigned long pc)
{
return (0);
}
+#endif /* CC_SUPPORT_P */
#endif /* not ENABLE_TRAP_RECOVERY */
\f
static void
-DEFUN (setup_trap_frame, (signo, info, scp, trinfo, new_stack_pointer),
- int signo AND
- SIGINFO_T info AND
- SIGCONTEXT_T * scp AND
- struct trap_recovery_info * trinfo AND
- SCHEME_OBJECT * new_stack_pointer)
+setup_trap_frame (int signo,
+ SIGINFO_T info,
+ SIGCONTEXT_T * scp,
+ struct trap_recovery_info * trinfo,
+ SCHEME_OBJECT * new_stack_pointer)
{
- unsigned long saved_mask = (FETCH_INTERRUPT_MASK ());
+ unsigned long saved_mask = GET_INT_MASK;
SCHEME_OBJECT handler;
SCHEME_OBJECT signal_name;
SET_INTERRUPT_MASK (0); /* To prevent GC for now. */
- handler = SHARP_F;
- if (Valid_Fixed_Obj_Vector ())
- handler = (Get_Fixed_Obj_Slot (Trap_Handler));
- if (handler == SHARP_F)
+ handler
+ = ((VECTOR_P (fixed_objects))
+ ? (VECTOR_REF (fixed_objects, TRAP_HANDLER))
+ : SHARP_F);
+ if (!INTERPRETER_APPLICABLE_P (handler))
{
fprintf (stderr, "There is no trap handler for recovery!\n");
fflush (stderr);
? (char_pointer_to_string (find_signal_name (signo)))
: SHARP_F);
- if (Free > MemTop)
- Request_GC (0);
+ if (!FREE_OK_P (Free))
+ REQUEST_GC (0);
if (new_stack_pointer != 0)
- sp_register = new_stack_pointer;
+ stack_pointer = new_stack_pointer;
else
{
INITIALIZE_STACK ();
Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_END_OF_COMPUTATION);
- exp_register = SHARP_F;
- Save_Cont ();
+ SET_RC (RC_END_OF_COMPUTATION);
+ SET_EXP (SHARP_F);
+ SAVE_CONT ();
Pushed ();
}
STACK_PUSH (BOOLEAN_TO_OBJECT (new_stack_pointer != 0));
STACK_PUSH (find_signal_code_name (signo, info, scp));
STACK_PUSH (signal_name);
- Store_Return (RC_HARDWARE_TRAP);
- exp_register = (long_to_integer (signo));
- Save_Cont ();
+ SET_RC (RC_HARDWARE_TRAP);
+ SET_EXP (long_to_integer (signo));
+ SAVE_CONT ();
Pushed ();
if ((new_stack_pointer != 0)
/* This may want to do it in other cases, but this may be enough. */
&& ((trinfo -> state) == STATE_COMPILED_CODE))
- Stop_History ();
- history_register = (Make_Dummy_History ());
+ stop_history ();
+ history_register = (make_dummy_history ());
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (signal_name);
STACK_PUSH (handler);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
+ PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
SET_INTERRUPT_MASK (saved_mask);
}
\f
static void
-DEFUN_VOID (initialize_ux_signal_codes)
+initialize_ux_signal_codes (void)
{
unsigned int i = 0;
INITIALIZE_UX_SIGNAL_CODES ();
}
static SCHEME_OBJECT
-DEFUN (find_signal_code_name, (signo, info, scp),
- int signo AND
- SIGINFO_T info AND
- SIGCONTEXT_T * scp)
+find_signal_code_name (int signo, SIGINFO_T info, SIGCONTEXT_T * scp)
{
unsigned long code = 0;
- char * name = 0;
+ const char * name = 0;
if (SIGINFO_VALID_P (info))
{
code = (SIGINFO_CODE (info));
}
return
(cons ((ulong_to_integer (code)),
- ((name == 0) ? SHARP_F : (char_pointer_to_string (name)))));
+ ((name == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (name)))));
}
\f
static enum pc_location
-DEFUN (classify_pc, (pc, r_block_addr, r_index),
- unsigned long pc AND
- SCHEME_OBJECT ** r_block_addr AND
- unsigned int * r_index)
+classify_pc (unsigned long pc,
+ SCHEME_OBJECT ** r_block_addr,
+ unsigned int * r_index)
{
+#ifdef CC_SUPPORT_P
if (PC_ALIGNED_P (pc))
{
- if (ADDRESS_HEAP_P ((SCHEME_OBJECT *) pc))
+ if (HEAP_ADDRESS_P ((SCHEME_OBJECT *) pc))
{
SCHEME_OBJECT * block_addr = (find_heap_address (pc));
- if (block_addr != 0)
- {
- if (r_block_addr != 0)
- (*r_block_addr) = block_addr;
- return (pcl_heap);
- }
+ if (block_addr == 0)
+ return (pcl_unknown);
+ if (r_block_addr != 0)
+ (*r_block_addr) = block_addr;
+ return (pcl_heap);
}
- else if (ADDRESS_CONSTANT_P ((SCHEME_OBJECT *) pc))
+ if (ADDRESS_IN_CONSTANT_P ((SCHEME_OBJECT *) pc))
{
SCHEME_OBJECT * block_addr = (find_constant_address (pc));
- if (block_addr != 0)
- {
- if (r_block_addr != 0)
- (*r_block_addr) = block_addr;
- return (pcl_constant);
- }
+ if (block_addr == 0)
+ return (pcl_unknown);
+ if (r_block_addr != 0)
+ (*r_block_addr) = block_addr;
+ return (pcl_constant);
}
- else if (ADDRESS_UCODE_P (pc))
+ if (ADDRESS_UCODE_P (pc))
{
int index = (pc_to_builtin_index (pc));
if (index >= 0)
(*r_index) = index;
return (pcl_utility);
}
- if ((OBJECT_TYPE (Registers[REGBLOCK_PRIMITIVE])) == TC_PRIMITIVE)
+ if ((OBJECT_TYPE (GET_PRIMITIVE)) == TC_PRIMITIVE)
return (pcl_primitive);
}
}
+#else
+ if ((ADDRESS_UCODE_P (pc))
+ && ((OBJECT_TYPE (GET_PRIMITIVE)) == TC_PRIMITIVE))
+ return (pcl_primitive);
+#endif
return (pcl_unknown);
}
\f
static void
-DEFUN_VOID (trap_normal_termination)
+trap_normal_termination (void)
{
trap_state = trap_state_exitting_soft;
termination_trap ();
}
static void
-DEFUN_VOID (trap_immediate_termination)
+trap_immediate_termination (void)
{
trap_state = trap_state_exitting_hard;
OS_restore_external_state ();
}
static void
-DEFUN_VOID (trap_dump_core)
+trap_dump_core (void)
{
if (! (option_disable_core_dump))
UX_dump_core ();
}
static void
-DEFUN_VOID (trap_recover)
+trap_recover (void)
{
if (WITHIN_CRITICAL_SECTION_P ())
{
/* -*-C-*-
-$Id: uxtrap.h,v 1.38 2007/02/23 23:45:28 riastradh Exp $
+$Id: uxtrap.h,v 1.39 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define DECLARE_SIGCONTEXT(scp, arg) \
SIGCONTEXT_T scp [1]; \
- static void EXFUN (sun3_save_regs, (int *)); \
+ static void sun3_save_regs, (int *); \
sun3_save_regs (& ((((scp) [0]) . fs_regs) [0])); \
(((scp) [0]) . fs_original) = (arg)
/* r0 has to be kludged. */
#define DECLARE_SIGCONTEXT(partial, full) \
SIGCONTEXT_T scp [1]; \
- static int EXFUN (vax_get_r0, (void)); \
- static int * EXFUN (vax_save_start, (int *, int)); \
- static void EXFUN \
- (vax_save_finish, (int *, \
+ static int vax_get_r0 (void); \
+ static int * vax_save_start (int *, int); \
+ static void vax_save_finish \
+ (int *, \
struct sigcontext *, \
- struct full_sigcontext *)); \
+ struct full_sigcontext *); \
vax_save_finish ((vax_save_start ((& ((((full) [0]) . fs_regs) [0])), \
(vax_get_r0 ()))), \
(partial), \
#endif /* not _POSIX_REALTIME_SIGNALS */
#endif /* __linux__ */
-
+
#ifdef __FreeBSD__
-
-#include <ucontext.h>
-
+# include <ucontext.h>
#endif
#ifdef _MACH_UNIX
#endif
#ifndef SIGCONTEXT_RFREE
-# define SIGCONTEXT_RFREE ((unsigned long) MemTop)
+# define SIGCONTEXT_RFREE ((unsigned long) heap_alloc_limit)
#endif
#ifndef SIGCONTEXT_SCHSP
# define INITIALIZE_UX_SIGNAL_CODES()
#endif
-/* PCs must be aligned according to this. */
-
-#define PC_ALIGNMENT_MASK ((1 << PC_ZERO_BITS) - 1)
-
-#ifndef HAS_COMPILER_SUPPORT
-# define PLAUSIBLE_CC_BLOCK_P(block) 0
-#endif
-
#ifdef _AIX
extern int _etext;
#endif
trap_state_exitting_hard
};
-extern void EXFUN (UX_initialize_trap_recovery, (void));
-extern enum trap_state EXFUN (OS_set_trap_state, (enum trap_state state));
-extern void EXFUN (hard_reset, (SIGCONTEXT_T * scp));
-extern void EXFUN (soft_reset, (void));
-extern void EXFUN
- (trap_handler, (CONST char *, int, SIGINFO_T, SIGCONTEXT_T *));
-extern SCHEME_OBJECT find_ccblock (unsigned long);
+extern void UX_initialize_trap_recovery (void);
+extern enum trap_state OS_set_trap_state (enum trap_state state);
+extern void hard_reset (SIGCONTEXT_T * scp);
+extern void soft_reset (void);
+extern void trap_handler
+ (const char *, int, SIGINFO_T, SIGCONTEXT_T *);
+#ifdef CC_SUPPORT_P
+ extern SCHEME_OBJECT find_ccblock (unsigned long);
+#endif
#define STATE_UNKNOWN (LONG_TO_UNSIGNED_FIXNUM (0))
#define STATE_PRIMITIVE (LONG_TO_UNSIGNED_FIXNUM (1))
/* -*-C-*-
-$Id: uxtty.c,v 1.15 2007/01/05 21:19:25 cph Exp $
+$Id: uxtty.c,v 1.16 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
+#include "scheme.h"
+#include "option.h"
#include "ux.h"
#include "ostty.h"
#include "osenv.h"
#include "uxio.h"
#include "uxterm.h"
+
+extern Tchannel OS_open_fd (int fd);
+extern int tgetent (void *, const char *);
+extern int tgetnum (const char *);
+extern const char * tgetstr (const char *, char **);
+extern void tputs (const char *, int, void (*) (char));
\f
/* Standard Input and Output */
static Tchannel output_channel;
static int tty_x_size;
static int tty_y_size;
-static CONST char * tty_command_beep;
-static CONST char * tty_command_clear;
+static const char * tty_command_beep;
+static const char * tty_command_clear;
Tchannel
-DEFUN_VOID (OS_tty_input_channel)
+OS_tty_input_channel (void)
{
return (input_channel);
}
Tchannel
-DEFUN_VOID (OS_tty_output_channel)
+OS_tty_output_channel (void)
{
return (output_channel);
}
unsigned int
-DEFUN_VOID (OS_tty_x_size)
+OS_tty_x_size (void)
{
return (tty_x_size);
}
unsigned int
-DEFUN_VOID (OS_tty_y_size)
+OS_tty_y_size (void)
{
return (tty_y_size);
}
-CONST char *
-DEFUN_VOID (OS_tty_command_beep)
+const char *
+OS_tty_command_beep (void)
{
return (tty_command_beep);
}
-CONST char *
-DEFUN_VOID (OS_tty_command_clear)
+const char *
+OS_tty_command_clear (void)
{
return (tty_command_clear);
}
static char * tputs_output_scan;
static void
-DEFUN (tputs_write_char, (c), char c)
+tputs_write_char (char c)
{
(*tputs_output_scan++) = c;
}
void
-DEFUN_VOID (UX_reinitialize_tty)
+UX_reinitialize_tty (void)
{
- extern int EXFUN (atoi, (CONST char *));
-
tty_x_size = (-1);
tty_y_size = (-1);
tty_command_beep = ALERT_STRING;
#endif /* TIOCGWINSZ */
if ((tty_x_size <= 0) || (tty_y_size <= 0))
{
- CONST char * columns = (UX_getenv ("COLUMNS"));
- CONST char * lines = (UX_getenv ("LINES"));
+ const char * columns = (UX_getenv ("COLUMNS"));
+ const char * lines = (UX_getenv ("LINES"));
if ((columns != 0) && (lines != 0))
{
int x = (atoi (columns));
}
tputs_output_scan = tputs_output;
{
- extern int EXFUN (tgetent, (PTR, CONST char *));
- extern int EXFUN (tgetnum, (CONST char *));
- extern CONST char * EXFUN (tgetstr, (CONST char *, char **));
static char tgetstr_buffer [TERMCAP_BUFFER_SIZE];
char termcap_buffer [TERMCAP_BUFFER_SIZE];
char * tbp = tgetstr_buffer;
- CONST char * term;
+ const char * term;
if ((isatty (STDOUT_FILENO))
&& (!option_emacs_subprocess)
&& ((term = (getenv ("TERM"))) != 0)
tty_command_clear = "\f";
else
{
- extern void EXFUN (tputs, (CONST char *, int, void (*) (char)));
char * command = tputs_output_scan;
tputs (tty_command_clear, tty_y_size, tputs_write_char);
(*tputs_output_scan++) = '\0';
}
void
-DEFUN_VOID (UX_initialize_tty)
+UX_initialize_tty (void)
{
- extern Tchannel EXFUN (OS_open_fd, (int fd));
input_channel = (OS_open_fd (STDIN_FILENO));
(CHANNEL_INTERNAL (input_channel)) = 1;
output_channel = (OS_open_fd (STDOUT_FILENO));
/* -*-C-*-
-$Id: uxutil.c,v 1.11 2007/01/05 21:19:25 cph Exp $
+$Id: uxutil.c,v 1.12 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
+#include "scheme.h"
#include "ux.h"
#include "uxutil.h"
#include <ctype.h>
-extern void EXFUN (terminal_state_raw, (Ttty_state *, int));
+extern void terminal_state_raw (Ttty_state *, int);
\f
-static CONST char *
-DEFUN (char_description_brief, (c), unsigned char c)
+static const char *
+char_description_brief (unsigned char c)
{
static char buffer [5];
switch (c)
}
}
-CONST char *
-DEFUN (char_description, (c, long_p), unsigned char c AND int long_p)
+const char *
+char_description (unsigned char c, int long_p)
{
static char buffer [64];
- CONST char * description = (char_description_brief (c));
+ const char * description = (char_description_brief (c));
if (long_p)
{
int meta = (c >= 0200);
static Ttty_state original_tty_state;
void
-DEFUN_VOID (UX_initialize_userio)
+UX_initialize_userio (void)
{
UX_terminal_get_state (STDIN_FILENO, (&original_tty_state));
}
static void
-DEFUN (restore_input_state, (ap), PTR ap)
+restore_input_state (void * ap)
{
UX_terminal_set_state (STDIN_FILENO, ap);
}
static Ttty_state *
-DEFUN_VOID (save_input_state)
+save_input_state (void)
{
Ttty_state * s = (dstack_alloc (sizeof (Ttty_state)));
UX_terminal_get_state (STDIN_FILENO, s);
}
void
-DEFUN_VOID (userio_buffered_input)
+userio_buffered_input (void)
{
save_input_state ();
UX_terminal_set_state (STDIN_FILENO, (&original_tty_state));
}
char
-DEFUN_VOID (userio_read_char)
+userio_read_char (void)
{
char c;
while (1)
}
char
-DEFUN_VOID (userio_read_char_raw)
+userio_read_char_raw (void)
{
transaction_begin ();
{
}
\f
char
-DEFUN (userio_choose_option, (herald, prompt, choices),
- CONST char * herald AND
- CONST char * prompt AND
- CONST char ** choices)
+userio_choose_option (const char * herald,
+ const char * prompt,
+ const char ** choices)
{
while (1)
{
fputs (herald, stdout);
putc ('\n', stdout);
{
- CONST char ** scan = choices;
+ const char ** scan = choices;
while (1)
{
- CONST char * choice = (*scan++);
+ const char * choice = (*scan++);
if (choice == 0)
break;
fprintf (stdout, " %s\n", choice);
if (islower (command))
command = (toupper (command));
{
- CONST char ** scan = choices;
+ const char ** scan = choices;
while (1)
{
- CONST char * choice = (*scan++);
+ const char * choice = (*scan++);
if (choice == 0)
break;
{
}
int
-DEFUN (userio_confirm, (prompt), CONST char * prompt)
+userio_confirm (const char * prompt)
{
while (1)
{
/* -*-C-*-
-$Id: uxutil.h,v 1.7 2007/01/05 21:19:25 cph Exp $
+$Id: uxutil.h,v 1.8 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "os.h"
-extern CONST char * EXFUN (char_description, (unsigned char c, int long_p));
-extern void EXFUN (userio_buffered_input, (void));
-extern char EXFUN (userio_read_char, (void));
-extern char EXFUN (userio_read_char_raw, (void));
-extern char EXFUN
- (userio_choose_option,
- (CONST char * herald, CONST char * prompt, CONST char ** choices));
-extern int EXFUN (userio_confirm, (CONST char * prompt));
+extern const char * char_description (unsigned char c, int long_p);
+extern void userio_buffered_input (void);
+extern char userio_read_char (void);
+extern char userio_read_char_raw (void);
+extern char userio_choose_option
+ (const char * herald, const char * prompt, const char ** choices);
+extern int userio_confirm (const char * prompt);
#endif /* SCM_UXUTIL_H */
+++ /dev/null
-/* -*-C-*-
-
-$Id: uxyp.c,v 1.7 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Interfacte to the Yellow Pages server */
-
-#include "scheme.h"
-#include "prims.h"
-#include <stdio.h>
-#include <malloc.h>
-#include <ntl.h>
-#include <rpc/rpc.h>
-#include "uxyp.h"
-\f
-#define YP_HOST "polar.lcs.mit.edu"
-
-/*
- * Please do not edit this procedure.
- * It was generated using rpcgen.
- */
-
-/* Default timeout can be changed using clnt_control() */
-static struct timeval TIMEOUT = { 25, 0 };
-
-char **
-do_yp_frame_1(argp, clnt)
- char **argp;
- CLIENT *clnt;
-{
- static char *res;
-
- bzero((char *)&res, sizeof(res));
- if (clnt_call(clnt, do_yp_frame, xdr_wrapstring, argp, xdr_wrapstring, &res, TIMEOUT) != RPC_SUCCESS) {
- return (NULL);
- }
- return (&res);
-}
-
-static int yp_debug = 0;
-CLIENT *cl = NULL;
-
-DEFINE_PRIMITIVE ("YELLOW-PAGES-LOOKUP", Prim_yellow_pages_lookup, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- {
- fast SCHEME_OBJECT string = (ARG_REF (1));
- unsigned char *c_string = STRING_LOC(string,0);
- unsigned char **result;
-
- /*
- * Do remote call
- */
- if(cl == NULL){
- cl = clnt_create(YP_HOST,yp_server,yp_server_version,"tcp");
- if(cl == NULL){
- clnt_pcreateerror(YP_HOST);
- return(NULL);
- }
- }
- result = (unsigned char **) do_yp_frame_1(&c_string,cl);
- PRIMITIVE_RETURN (char_pointer_to_string(*result));
- }
-}
+++ /dev/null
-/*
- * Please do not edit this file.
- * It was generated using rpcgen.
- */
-
-#include <rpc/types.h>
-
-
-#define yp_server ((u_long)0x20001003)
-#define yp_server_version ((u_long)1)
-#define do_yp_frame ((u_long)301)
-extern char **do_yp_frame_1();
-
/* -*-C-*-
-$Id: vector.c,v 9.44 2007/01/05 21:19:25 cph Exp $
+$Id: vector.c,v 9.45 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(arg_index_integer (argument_number, (VECTOR_LENGTH (vector))))
#define ARG_GC_VECTOR(argument_number) \
- ((GC_VECTOR_P (ARG_REF (argument_number))) \
+ ((GC_TYPE_VECTOR (ARG_REF (argument_number))) \
? (ARG_REF (argument_number)) \
: ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
SCHEME_OBJECT
-DEFUN (allocate_non_marked_vector, (type_code, length, gc_check_p),
- int type_code AND fast long length AND Boolean gc_check_p)
+allocate_vector (unsigned int type,
+ unsigned int manifest_type,
+ unsigned long length,
+ SCHEME_OBJECT ** fp)
{
- fast SCHEME_OBJECT result;
+ SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (type, (*fp)));
+ (*(*fp)++) = (MAKE_OBJECT (manifest_type, length));
+ (*fp) += length;
+ return (result);
+}
+SCHEME_OBJECT
+allocate_non_marked_vector (unsigned int type,
+ unsigned long length,
+ bool gc_check_p)
+{
if (gc_check_p)
- Primitive_GC_If_Needed (length + 1);
- result = (MAKE_POINTER_OBJECT (type_code, Free));
- (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length));
- Free += length;
- return (result);
+ Primitive_GC_If_Needed (1 + length);
+ return (allocate_vector (type, TC_MANIFEST_NM_VECTOR, length, (&Free)));
}
SCHEME_OBJECT
-DEFUN (allocate_marked_vector, (type_code, length, gc_check_p),
- int type_code AND fast long length AND Boolean gc_check_p)
+allocate_marked_vector (unsigned int type,
+ unsigned long length,
+ bool gc_check_p)
{
if (gc_check_p)
- Primitive_GC_If_Needed (length + 1);
- {
- fast SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (type_code, Free));
- (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
- Free += length;
- return (result);
- }
+ Primitive_GC_If_Needed (1 + length);
+ return (allocate_vector (type, TC_MANIFEST_VECTOR, length, (&Free)));
}
SCHEME_OBJECT
-DEFUN (make_vector, (length, contents, gc_check_p),
- fast long length AND fast SCHEME_OBJECT contents AND Boolean gc_check_p)
+make_vector (unsigned long length, SCHEME_OBJECT contents, bool gc_check_p)
{
if (gc_check_p)
Primitive_GC_If_Needed (length + 1);
{
- fast SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_VECTOR, Free));
+ SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_VECTOR, Free));
(*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
while ((length--) > 0)
(*Free++) = contents;
PRIMITIVE_HEADER (LEXPR);
{
SCHEME_OBJECT result =
- (allocate_marked_vector (TC_VECTOR, (LEXPR_N_ARGUMENTS ()), true));
- fast SCHEME_OBJECT * argument_scan = (ARG_LOC (1));
- fast SCHEME_OBJECT * argument_limit =
- (ARG_LOC ((LEXPR_N_ARGUMENTS ()) + 1));
- fast SCHEME_OBJECT * result_scan = (VECTOR_LOC (result, 0));
+ (allocate_marked_vector (TC_VECTOR, GET_LEXPR_ACTUALS, true));
+ SCHEME_OBJECT * argument_scan = (ARG_LOC (1));
+ SCHEME_OBJECT * argument_limit = (ARG_LOC (GET_LEXPR_ACTUALS + 1));
+ SCHEME_OBJECT * result_scan = (VECTOR_LOC (result, 0));
while (argument_scan != argument_limit)
(*result_scan++) = (STACK_LOCATIVE_POP (argument_scan));
PRIMITIVE_RETURN (result);
{
PRIMITIVE_HEADER (LEXPR);
{
- long nargs = (LEXPR_N_ARGUMENTS ());
+ unsigned long nargs = GET_LEXPR_ACTUALS;
if (nargs < 1)
signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
{
SCHEME_OBJECT result = (allocate_marked_vector (TC_RECORD, nargs, true));
- fast SCHEME_OBJECT * argument_scan = (ARG_LOC (1));
- fast SCHEME_OBJECT * argument_limit = (ARG_LOC (nargs + 1));
- fast SCHEME_OBJECT * result_scan = (VECTOR_LOC (result, 0));
+ SCHEME_OBJECT * argument_scan = (ARG_LOC (1));
+ SCHEME_OBJECT * argument_limit = (ARG_LOC (nargs + 1));
+ SCHEME_OBJECT * result_scan = (VECTOR_LOC (result, 0));
while (argument_scan != argument_limit)
(*result_scan++) = (STACK_LOCATIVE_POP (argument_scan));
PRIMITIVE_RETURN (result);
DEFINE_PRIMITIVE ("VECTOR?", Prim_vector_p, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
+ SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ object = (ARG_REF (1));
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (VECTOR_P (object)));
}
DEFINE_PRIMITIVE ("%RECORD?", Prim_record_p, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
+ SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ object = (ARG_REF (1));
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (RECORD_P (object)));
}
DEFINE_PRIMITIVE ("SYSTEM-VECTOR?", Prim_sys_vector, 1, 1, 0)
{
- fast SCHEME_OBJECT object;
+ SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_VECTOR_P (object)));
+ object = (ARG_REF (1));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_TYPE_VECTOR (object)));
}
\f
#define VECTOR_LENGTH_PRIMITIVE(arg_type) \
{ \
- fast SCHEME_OBJECT vector; \
PRIMITIVE_HEADER (1); \
- TOUCH_IN_PRIMITIVE ((arg_type (1)), vector); \
- PRIMITIVE_RETURN (long_to_integer (VECTOR_LENGTH (vector))); \
+ PRIMITIVE_RETURN (long_to_integer (VECTOR_LENGTH (arg_type (1)))); \
}
DEFINE_PRIMITIVE ("VECTOR-LENGTH", Prim_vector_length, 1, 1, 0)
#define VECTOR_REF_PRIMITIVE(arg_type) \
{ \
- fast SCHEME_OBJECT vector; \
+ SCHEME_OBJECT vector; \
PRIMITIVE_HEADER (2); \
- TOUCH_IN_PRIMITIVE ((arg_type (1)), vector); \
+ vector = (arg_type (1)); \
PRIMITIVE_RETURN \
(VECTOR_REF (vector, (ARG_VECTOR_INDEX (2, vector)))); \
}
#define VECTOR_SET_PRIMITIVE(arg_type) \
{ \
- fast SCHEME_OBJECT vector; \
+ SCHEME_OBJECT vector; \
PRIMITIVE_HEADER (3); \
- TOUCH_IN_PRIMITIVE ((arg_type (1)), vector); \
+ vector = (arg_type (1)); \
{ \
- fast SCHEME_OBJECT new_value = (ARG_REF (3)); \
- SIDE_EFFECT_IMPURIFY (vector, new_value); \
+ SCHEME_OBJECT new_value = (ARG_REF (3)); \
VECTOR_SET (vector, (ARG_VECTOR_INDEX (2, vector)), new_value); \
} \
PRIMITIVE_RETURN (UNSPECIFIC); \
\f
#define SUBVECTOR_TO_LIST_PRIMITIVE(arg_type) \
{ \
- fast SCHEME_OBJECT vector; \
- fast long start; \
- fast long end; \
+ SCHEME_OBJECT vector; \
+ long start; \
+ long end; \
PRIMITIVE_HEADER (3); \
- TOUCH_IN_PRIMITIVE ((arg_type (1)), vector); \
+ vector = (arg_type (1)); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
if (end > ((long) (VECTOR_LENGTH (vector)))) \
}
static SCHEME_OBJECT
-DEFUN (subvector_to_list, (vector, start, end),
- SCHEME_OBJECT vector AND long start AND long end)
+subvector_to_list (SCHEME_OBJECT vector, long start, long end)
{
SCHEME_OBJECT result;
- fast SCHEME_OBJECT *scan;
- fast SCHEME_OBJECT *end_scan;
- fast SCHEME_OBJECT *pair_scan;
+ SCHEME_OBJECT *scan;
+ SCHEME_OBJECT *end_scan;
+ SCHEME_OBJECT *pair_scan;
if (start == end)
return (EMPTY_LIST);
Primitive_GC_If_Needed (2 * (end - start));
while (scan < end_scan)
{
Free += 2;
- (*pair_scan++) = (MEMORY_FETCH (*scan++));
+ (*pair_scan++) = (*scan++);
(*pair_scan++) = (MAKE_POINTER_OBJECT (TC_LIST, Free));
}
Free += 2;
- (*pair_scan++) = (MEMORY_FETCH (*scan));
+ (*pair_scan++) = (*scan);
(*pair_scan) = EMPTY_LIST;
return (result);
}
SUBVECTOR_TO_LIST_PRIMITIVE (ARG_GC_VECTOR)
\f
static SCHEME_OBJECT
-DEFUN (list_to_vector, (result_type, argument_number),
- long result_type AND long argument_number)
+list_to_vector (unsigned long result_type, long argument_number)
{
- fast SCHEME_OBJECT list;
- fast long count;
+ SCHEME_OBJECT list;
+ unsigned long count;
SCHEME_OBJECT *result;
list = (ARG_REF (argument_number));
- TOUCH_IN_PRIMITIVE (list, list);
count = 0;
result = (Free++);
while (PAIR_P (list))
Primitive_GC_If_Needed (0);
count += 1;
(*Free++) = (PAIR_CAR (list));
- TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
+ list = (PAIR_CDR (list));
}
if (!EMPTY_LIST_P (list))
error_wrong_type_arg (argument_number);
DEFINE_PRIMITIVE ("SYSTEM-LIST-TO-VECTOR", Prim_sys_list_to_vector, 2, 2, 0)
{
- long type_code;
+ unsigned long type_code;
PRIMITIVE_HEADER (2);
- type_code = (arg_index_integer (1, (MAX_TYPE_CODE + 1)));
- if ((GC_Type_Code (type_code)) != GC_Vector)
+ type_code = (arg_ulong_index_integer (1, N_TYPE_CODES));
+ if ((GC_TYPE_CODE (type_code)) != GC_VECTOR)
error_bad_range_arg (1);
PRIMITIVE_RETURN (list_to_vector (type_code, 2));
}
#define SUBVECTOR_MOVE_PREFIX() \
SCHEME_OBJECT vector1, vector2; \
long start1, end1, start2, end2; \
- fast long length; \
- fast SCHEME_OBJECT *scan1, *scan2; \
+ long length; \
+ SCHEME_OBJECT *scan1, *scan2; \
PRIMITIVE_HEADER (5); \
- TOUCH_IN_PRIMITIVE ((ARG_VECTOR (1)), vector1); \
+ vector1 = (ARG_VECTOR (1)); \
start1 = (arg_nonnegative_integer (2)); \
end1 = (arg_nonnegative_integer (3)); \
- TOUCH_IN_PRIMITIVE ((ARG_VECTOR (4)), vector2); \
+ vector2 = (ARG_VECTOR (4)); \
start2 = (arg_nonnegative_integer (5)); \
if (end1 > ((long) (VECTOR_LENGTH (vector1)))) \
error_bad_range_arg (3); \
length = (end1 - start1); \
end2 = (start2 + length); \
if (end2 > ((long) (VECTOR_LENGTH (vector2)))) \
- error_bad_range_arg (5); \
- if (ADDRESS_PURE_P (OBJECT_ADDRESS (vector2))) \
- signal_error_from_primitive (ERR_WRITE_INTO_PURE_SPACE)
+ error_bad_range_arg (5);
DEFINE_PRIMITIVE ("SUBVECTOR-MOVE-RIGHT!", Prim_subvector_move_right, 5, 5, 0)
{
{
SCHEME_OBJECT vector;
long start, end;
- fast SCHEME_OBJECT fill_value;
- fast SCHEME_OBJECT *scan;
- fast long length;
+ SCHEME_OBJECT fill_value;
+ SCHEME_OBJECT *scan;
+ long length;
PRIMITIVE_HEADER (4);
- TOUCH_IN_PRIMITIVE ((ARG_VECTOR (1)), vector);
+ vector = (ARG_VECTOR (1));
start = (arg_nonnegative_integer (2));
end = (arg_nonnegative_integer (3));
fill_value = (ARG_REF (4));
if (start > end)
error_bad_range_arg (2);
length = (end - start);
- SIDE_EFFECT_IMPURIFY (vector, fill_value);
scan = (VECTOR_LOC (vector, start));
while ((length--) > 0)
(*scan++) = fill_value;
+++ /dev/null
-/* -*-C-*-
-
-$Id: wabbit.c,v 1.13 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/*
- *
- * What's opera, doc?!
- * This file contains the wabbit-hunting garbage collector,
- * by Ziggy and GJR.
- *
- */
-
-#include "scheme.h"
-#include "gccode.h"
-
-extern SCHEME_OBJECT Weak_Chain;
-
-extern SCHEME_OBJECT *
- EXFUN (wabbit_hunting_gcloop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
-
-extern void
- EXFUN (wabbit_season, (SCHEME_OBJECT));
-
-extern void
- EXFUN (duck_season, (SCHEME_OBJECT));
-
-extern void
- EXFUN (fix_weak_chain_and_hunt_wabbits, (void));
-\f
-/* Wabbit hunting code */
-/* Be wary, wary, quiet... */
-
-#define TC_HEADLESS_REFERENCE TC_NULL
-#define TC_REFERENCE_TO_STACK TC_STACK_ENVIRONMENT
-#define TC_REFERENCE_TO_CONSTANT_SPACE TC_CHARACTER
-
-Boolean
- wabbit_holes_discarded_p,
- wabbit_holes_overwritten_p,
- wabbit_all_dead_p;
-
-SCHEME_OBJECT
- * wabbit_holes,
- * wabbit_holes_hi,
- * wabbit_lo_address,
- * wabbit_hi_address,
- * wabbit_of_Seville,
- * wabbit_buffer_lo,
- * wabbit_buffer_ptr,
- * wabbit_buffer_hi,
- * old_wabbit_buffer,
- * old_wabbit_buffer_end,
- * hares_lo,
- * hares_hi;
-
-#define ELMER_FUDGE_FACTOR 4 /* Size of QUAD */
-#define ELMER_HUNG_FACTOR 20 /* 1 / (Sales tax in MA in 1994) */
-#define RAJIV_SURATI_FACTOR -20 /* -1 * ELMER_HUNG_FACTOR */
-
-void EXFUN (kill_da_wabbit, (SCHEME_OBJECT *, SCHEME_OBJECT));
-Boolean EXFUN (discard_wabbit_holes_p, (SCHEME_OBJECT *, SCHEME_OBJECT *));
-
-/* We need not check wabbit_lo_address by construction:
- wabbit_lo_address is Free at the beginning of the GC, and
- all forwarded objects will point above that, except for
- the wabbit of Seville, a.k.a. the wabbit vector.
- */
-
-#define WABBIT_P(addr) \
- (((addr) < wabbit_hi_address) \
- && ((addr) != wabbit_of_Seville))
-
-#define HARE_P(addr) \
- (((OBJECT_TYPE (* addr)) == TC_BROKEN_HEART) \
- && ((OBJECT_ADDRESS (* addr)) >= old_wabbit_buffer) \
- && ((OBJECT_ADDRESS (* addr)) < old_wabbit_buffer_end))
-
-#define RECORD_WABBIT_HOLE(tag, address) do \
-{ \
- if ((wabbit_holes > (new_space_free + ELMER_FUDGE_FACTOR)) \
- || (discard_wabbit_holes_p (scan, new_space_free))) \
- *--wabbit_holes = (MAKE_POINTER_OBJECT (tag, address)); \
-} while (0)
-
-#define KILL_DA_WABBIT(where, last_object) do \
-{ \
- if ((wabbit_buffer_ptr + 2) <= wabbit_buffer_hi) \
- kill_da_wabbit (where, last_object); \
- else \
- wabbit_all_dead_p = false; \
-} while (0)
-
-/* Oh, what have I done! I've killed the little bunny wabbit... */
-\f
-#define COPY_CELL() \
-{ \
- *new_space_free++ = *old_space_addr; \
-}
-
-#define COPY_PAIR() \
-{ \
- *new_space_free++ = *old_space_addr++; \
- *new_space_free++ = *old_space_addr; \
-}
-
-#define COPY_TRIPLE() \
-{ \
- *new_space_free++ = *old_space_addr++; \
- *new_space_free++ = *old_space_addr++; \
- *new_space_free++ = *old_space_addr; \
-}
-
-#define COPY_QUADRUPLE() \
-{ \
- *new_space_free++ = *old_space_addr++; \
- *new_space_free++ = *old_space_addr++; \
- *new_space_free++ = *old_space_addr++; \
- *new_space_free++ = *old_space_addr; \
-}
-
-#define COPY_VECTOR() \
-{ \
- long veclen = (1 + (OBJECT_DATUM (* old_space_addr))); \
- SCHEME_OBJECT * vecend = (new_space_free + veclen); \
- \
- if (vecend > wabbit_holes) \
- discard_wabbit_holes_p (scan, new_space_free); \
- while (new_space_free != vecend) \
- *new_space_free++ = *old_space_addr++; \
-}
-
-#define COPY_WEAK_PAIR() \
-{ \
- long car_tag = (OBJECT_TYPE (* old_space_addr)); \
- (*new_space_free++) \
- = (OBJECT_NEW_TYPE (TC_NULL, (* old_space_addr))); \
- *new_space_free++ = *++old_space_addr; \
- * old_space_addr = (OBJECT_NEW_TYPE (car_tag, Weak_Chain)); \
- Weak_Chain = this_object; \
-}
-\f
-#define RELOCATE_NORMAL_SETUP() \
-{ \
- old_space_addr = (OBJECT_ADDRESS (this_object)); \
- if (old_space_addr < low_heap) \
- { \
- if (HARE_P (old_space_addr)) \
- KILL_DA_WABBIT (scan, SHARP_F); \
- continue; \
- } \
- if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART) \
- { \
- new_space_addr = (OBJECT_ADDRESS (* old_space_addr)); \
- if (WABBIT_P (new_space_addr)) \
- KILL_DA_WABBIT (scan, SHARP_F); \
- * scan = (MAKE_OBJECT_FROM_OBJECTS (this_object, \
- (* old_space_addr))); \
- continue; \
- } \
-}
-
-#define RELOCATE_NORMAL_END() \
-{ \
- (* (OBJECT_ADDRESS (this_object))) \
- = (MAKE_BROKEN_HEART (new_space_addr)); \
- (* scan) = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (this_object)), \
- new_space_addr)); \
- continue; \
-}
-
-#define RELOCATE_NORMAL_POINTER(copy_code) \
-{ \
- RELOCATE_NORMAL_SETUP (); \
- new_space_addr = new_space_free; \
- copy_code; \
- RECORD_WABBIT_HOLE ((OBJECT_TYPE (this_object)), new_space_addr); \
- RELOCATE_NORMAL_END (); \
-}
-
-#define RELOCATE_ALIGNED_POINTER(copy_code) \
-{ \
- RELOCATE_NORMAL_SETUP (); \
- ALIGN_FLOAT (new_space_free); \
- new_space_addr = new_space_free; \
- copy_code; \
- RECORD_WABBIT_HOLE ((OBJECT_TYPE (this_object)), new_space_addr); \
- RELOCATE_NORMAL_END (); \
-}
-\f
-#define RELOCATE_RAW_POINTER(tag, copy_code, last_object) \
-{ \
- old_space_addr = ((SCHEME_OBJECT *) this_object); \
- if (old_space_addr < low_heap) \
- { \
- if (HARE_P (old_space_addr)) \
- KILL_DA_WABBIT (scan, last_object); \
- continue; \
- } \
- if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART) \
- { \
- new_space_addr = (OBJECT_ADDRESS (* old_space_addr)); \
- if (WABBIT_P (new_space_addr)) \
- KILL_DA_WABBIT (scan, last_object); \
- * scan = ((SCHEME_OBJECT) new_space_addr); \
- continue; \
- } \
- { \
- SCHEME_OBJECT * saved_old_addr = old_space_addr; \
- \
- new_space_addr = new_space_free; \
- copy_code; \
- RECORD_WABBIT_HOLE (tag, new_space_addr); \
- (* saved_old_addr) = (MAKE_BROKEN_HEART (new_space_addr)); \
- (* scan) = ((SCHEME_OBJECT) new_space_addr); \
- continue; \
- } \
-}
-
-#define RELOCATE_COMPILED_ENTRY(last_object) \
-{ \
- Get_Compiled_Block (old_space_addr, \
- ((SCHEME_OBJECT *) this_entry)); \
- if (old_space_addr < low_heap) \
- { \
- if (HARE_P (old_space_addr)) \
- KILL_DA_WABBIT (scan, last_object); \
- new_entry = this_entry; \
- } \
- else if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART) \
- { \
- new_space_addr = (OBJECT_ADDRESS (* old_space_addr)); \
- if (WABBIT_P (new_space_addr)) \
- KILL_DA_WABBIT (scan, last_object); \
- new_entry = \
- ((SCHEME_OBJECT) \
- (RELOCATE_COMPILED_INTERNAL (this_entry, \
- new_space_addr, \
- old_space_addr))); \
- } \
- else \
- { \
- SCHEME_OBJECT * saved_old_addr = old_space_addr; \
- \
- ALIGN_FLOAT (new_space_free); \
- new_space_addr = new_space_free; \
- new_entry = \
- ((SCHEME_OBJECT) \
- (RELOCATE_COMPILED_INTERNAL (this_entry, \
- new_space_addr, \
- old_space_addr))); \
- COPY_VECTOR (); \
- RECORD_WABBIT_HOLE (TC_COMPILED_CODE_BLOCK, new_space_addr); \
- (* saved_old_addr) = (MAKE_BROKEN_HEART (new_space_addr)); \
- } \
-}
-\f
-SCHEME_OBJECT *
-DEFUN (wabbit_hunting_gcloop, (scan, new_space_free_loc),
- fast SCHEME_OBJECT * scan
- AND SCHEME_OBJECT ** new_space_free_loc)
-{
- long last_nmv_length;
- fast SCHEME_OBJECT
- * new_space_free, * old_space_addr, this_object,
- * low_heap, * new_space_addr, this_entry, new_entry;
- SCHEME_OBJECT
- last_object, * last_object_end, * last_nmv, * last_hare, last_hare_head,
- magic_cookie, saved_cookie, * saved_addr;
-
- last_object = SHARP_F;
- last_object_end = 0;
- last_nmv = (scan - 2); /* Make comparison fail until */
- last_nmv_length = 0; /* an NMV is found. */
- last_hare = (scan - 2); /* Same here */
- last_hare_head = SHARP_F;
- magic_cookie = SHARP_F;
- saved_cookie = SHARP_F;
- saved_addr = 0;
- new_space_free = * new_space_free_loc;
- low_heap = Constant_Top;
- for ( ; scan != new_space_free; scan++)
- {
- this_object = * scan;
-
-repeat_dispatch:
- Switch_by_GC_Type (this_object)
- {
- case TC_BROKEN_HEART:
- old_space_addr = (OBJECT_ADDRESS (this_object));
- if (scan == old_space_addr)
- {
- if (this_object == magic_cookie)
- {
- magic_cookie = SHARP_F;
- last_hare = (scan - 1);
- last_hare_head = scan[-1];
- saved_addr[0] = scan[-1];
- scan[-1] = (MAKE_BROKEN_HEART (saved_addr));
- *scan = saved_cookie;
- this_object = saved_cookie;
- goto repeat_dispatch;
- }
- else
- {
- * new_space_free_loc = new_space_free;
- return (scan);
- }
- }
- else if ((old_space_addr < old_wabbit_buffer)
- || (old_space_addr >= old_wabbit_buffer_end))
- {
- sprintf (gc_death_message_buffer,
- "wabbit_hunting_gcloop: broken heart (0x%lx) in scan",
- this_object);
- gc_death (TERM_BROKEN_HEART, gc_death_message_buffer,
- scan, new_space_free);
- /*NOTREACHED*/
- }
- else
- {
- SCHEME_OBJECT old_head = old_space_addr[0];
-\f
- switch (GC_Type_Map [(OBJECT_TYPE (old_head))])
- {
- default:
- case GC_Non_Pointer:
- last_hare = scan;
- last_hare_head = old_head;
- break;
-
- case GC_Special:
- if (((OBJECT_TYPE (old_head)) != TC_REFERENCE_TRAP)
- || ((OBJECT_DATUM (old_head)) <= TRAP_MAX_IMMEDIATE))
- {
- this_object = old_head;
- last_hare = scan;
- last_hare_head = old_head;
- goto repeat_dispatch;
- }
- /* fall through */
-
- case GC_Cell:
- case GC_Pair:
- case GC_Triple:
- case GC_Quadruple:
- case GC_Vector:
- if ((OBJECT_ADDRESS (old_head)) == scan)
- {
- last_hare = scan;
- last_hare_head = old_head;
- KILL_DA_WABBIT (scan, old_head);
- break;
- }
- /* fall through */
-
- case GC_Compiled:
- saved_addr = old_space_addr;
- saved_cookie = scan[1];
- magic_cookie = (MAKE_BROKEN_HEART (scan + 1));
- scan[1] = magic_cookie;
- this_object = old_head;
- *scan = old_head;
- goto repeat_dispatch;
- }
- }
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- if ((last_nmv + (1 + last_nmv_length)) == scan)
- last_object = SHARP_F;
- else if ((OBJECT_TYPE (scan[-1])) == TC_MANIFEST_VECTOR)
- {
- last_object
- = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (scan - 1)));
- last_object_end = (scan + (OBJECT_DATUM (scan [-1])));
- }
- else if (((scan - 1) == last_hare)
- && ((OBJECT_TYPE (last_hare_head)) == TC_MANIFEST_VECTOR))
- {
- last_object
- = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (scan - 1)));
- last_object_end = (scan + (OBJECT_DATUM (last_hare_head)));
- }
- else
- last_object = SHARP_F;
-
- last_nmv = scan;
- last_nmv_length = (OBJECT_DATUM (this_object));
- scan += last_nmv_length;
- break;
-\f
- /* Compiled code relocation. */
-
- case TC_LINKAGE_SECTION:
- {
- SCHEME_OBJECT saved_last_object, * saved_last_object_end;
-
- saved_last_object = last_object;
- saved_last_object_end = last_object_end;
- if ((last_object == SHARP_F) || (last_object_end < scan))
- {
- last_object = (MAKE_POINTER_OBJECT (TC_HEADLESS_REFERENCE, scan));
- last_object_end
- = (scan + (1 + (READ_CACHE_LINKAGE_COUNT (this_object))));
- }
-
- switch (READ_LINKAGE_KIND (this_object))
- {
- case REFERENCE_LINKAGE_KIND:
- case ASSIGNMENT_LINKAGE_KIND:
- {
- /* Assumes that all others are objects of type TC_QUAD without
- their type codes.
- */
-
- fast long count;
-
- scan++;
- for (count = (READ_CACHE_LINKAGE_COUNT (this_object));
- --count >= 0;
- scan += 1)
- {
- this_object = (* scan);
- RELOCATE_RAW_POINTER (TC_QUAD, COPY_QUADRUPLE (), last_object);
- }
- scan -= 1;
- break;
- }
-
- case OPERATOR_LINKAGE_KIND:
- case GLOBAL_OPERATOR_LINKAGE_KIND:
- {
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * end_scan;
-
- START_OPERATOR_RELOCATION (scan);
- count = (READ_OPERATOR_LINKAGE_COUNT (this_object));
- word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (scan));
- end_scan = (END_OPERATOR_LINKAGE_AREA (scan, count));
-
- while (--count >= 0)
- {
- scan = ((SCHEME_OBJECT *) word_ptr);
- word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
- EXTRACT_OPERATOR_LINKAGE_ADDRESS (this_entry, scan);
- RELOCATE_COMPILED_ENTRY (last_object);
- STORE_OPERATOR_LINKAGE_ADDRESS (new_entry, scan);
- }
- scan = end_scan;
- END_OPERATOR_RELOCATION (scan);
- break;
- }
-
- case CLOSURE_PATTERN_LINKAGE_KIND:
- scan += (READ_CACHE_LINKAGE_COUNT (this_object));
- break;
-
- default:
- {
- gc_death (TERM_EXIT,
- "GC: Unknown compiler linkage kind.",
- scan, Free);
- /*NOTREACHED*/
- }
- }
- last_object = saved_last_object;
- last_object_end = saved_last_object_end;
- break;
- }
-\f
- case TC_MANIFEST_CLOSURE:
- {
- fast long count;
- fast char * word_ptr;
- SCHEME_OBJECT * area_end;
- SCHEME_OBJECT saved_last_object, * saved_last_object_end;
-
- saved_last_object = last_object;
- saved_last_object_end = last_object_end;
- if ((last_object == SHARP_F) || (last_object_end < scan))
- {
- last_object = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, scan));
- last_object_end = (scan + (1 + (OBJECT_DATUM (this_object))));
- }
- START_CLOSURE_RELOCATION (scan);
- scan += 1;
- count = (MANIFEST_CLOSURE_COUNT (scan));
- word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan));
- area_end = ((MANIFEST_CLOSURE_END (scan, count)) - 1);
-
- while ((--count) >= 0)
- {
- scan = ((SCHEME_OBJECT *) (word_ptr));
- word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
- EXTRACT_CLOSURE_ENTRY_ADDRESS (this_entry, scan);
- RELOCATE_COMPILED_ENTRY (last_object);
- STORE_CLOSURE_ENTRY_ADDRESS (new_entry, scan);
- }
-
- scan = area_end;
- END_CLOSURE_RELOCATION (scan);
- last_object = saved_last_object;
- last_object_end = saved_last_object_end;
- break;
- }
-
- case_compiled_entry_point:
- {
- this_entry = ((SCHEME_OBJECT) (OBJECT_ADDRESS (this_object)));
- RELOCATE_COMPILED_ENTRY (SHARP_F);
- (* scan) = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (this_object)),
- ((SCHEME_OBJECT *) new_entry)));
- continue;
- }
-
- case_Cell:
- RELOCATE_NORMAL_POINTER (COPY_CELL ());
- break;
-
- case TC_REFERENCE_TRAP:
- if ((OBJECT_DATUM (this_object)) <= TRAP_MAX_IMMEDIATE)
- {
- /* It is a non pointer. */
- break;
- }
- /* Fall Through. */
-
- case_Pair:
- RELOCATE_NORMAL_POINTER (COPY_PAIR ());
- break;
-\f
- case TC_VARIABLE:
- case_Triple:
- RELOCATE_NORMAL_POINTER (COPY_TRIPLE ());
- break;
-
- case_Quadruple:
- RELOCATE_NORMAL_POINTER (COPY_QUADRUPLE ());
- break;
-
- case_Aligned_Vector:
- RELOCATE_ALIGNED_POINTER (COPY_VECTOR ());
- break;
-
- case TC_FUTURE:
- if (Future_Spliceable (this_object))
- {
- * scan = (Future_Value (this_object));
- scan -= 1;
- continue;
- }
- /* fall through */
-
- case_Vector:
- RELOCATE_NORMAL_POINTER (COPY_VECTOR ());
- break;
-
- case TC_WEAK_CONS:
- RELOCATE_NORMAL_POINTER (COPY_WEAK_PAIR ());
- break;
-
- default:
- sprintf (gc_death_message_buffer,
- "wabbit_hunting_gcloop: bad type code (0x%02x)",
- ((unsigned int) (OBJECT_TYPE (this_object))));
- gc_death (TERM_INVALID_TYPE_CODE,
- gc_death_message_buffer,
- scan, new_space_free);
- /*NOTREACHED*/
-
- case_Non_Pointer:
- break;
-
- } /* Switch_by_GC_Type */
- } /* For loop */
-
- * new_space_free_loc = new_space_free;
- return (new_space_free);
-
-} /* wabbit_hunting_gcloop */
-\f
-void
-DEFUN (wabbit_season, (wabbit_descriptor),
- SCHEME_OBJECT wabbit_descriptor)
-{
- long n_wabbits, buf_len, ctr;
- SCHEME_OBJECT
- * result, * area, * saved_area,
- wabbit_buffer, wabbit_vector, * wabbit_vector_ptr;
-
- wabbit_vector = (VECTOR_REF (wabbit_descriptor, 1));
- wabbit_buffer = (VECTOR_REF (wabbit_descriptor, 2));
-
- buf_len = (VECTOR_LENGTH (wabbit_buffer));
- n_wabbits = (VECTOR_LENGTH (wabbit_vector));
-
- wabbit_all_dead_p = true;
- wabbit_holes_overwritten_p = false;
- wabbit_holes_discarded_p = false;
- wabbit_holes_hi = Heap_Top;
- wabbit_holes = wabbit_holes_hi;
-
- saved_area = area = Free;
- wabbit_lo_address = saved_area;
- wabbit_hi_address = saved_area;
- wabbit_of_Seville = saved_area;
-
- wabbit_vector_ptr = (MEMORY_LOC (wabbit_vector, 0));
- for (ctr = n_wabbits; ctr >= 0; ctr -= 1)
- *area++ = *wabbit_vector_ptr++;
-
- MEMORY_SET (wabbit_vector, 0, (MAKE_BROKEN_HEART (saved_area)));
- *area = (MAKE_BROKEN_HEART (area));
- Free = (area + 1);
-
- result = (wabbit_hunting_gcloop (saved_area, &Free));
- if (result != area)
- {
- outf_fatal ("\nwabbit_hunt Wabbit scan ended too early.\n");
- Microcode_Termination (TERM_BROKEN_HEART);
- }
-
- *area = SHARP_F; /* Remove broken heart on Valentine's day */
- wabbit_lo_address = (area + 1);
- wabbit_hi_address = Free;
-
- if (BROKEN_HEART_P (MEMORY_REF (wabbit_buffer, 0)))
- /* One of the wabbits is the wabbit buffer itself! */
- wabbit_buffer_lo = (OBJECT_ADDRESS (MEMORY_REF (wabbit_buffer, 0)));
- else
- {
- wabbit_buffer_lo = Free;
- MEMORY_SET (wabbit_buffer, 0, (MAKE_BROKEN_HEART (wabbit_buffer_lo)));
- Free += (1 + buf_len);
- }
- wabbit_buffer_hi = (wabbit_buffer_lo + (1 + buf_len));
- * wabbit_buffer_lo = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, buf_len));
- wabbit_buffer_ptr = (wabbit_buffer_lo + 3);
-\f
- /* Check whether any wabbits are hares, and if so, mark them so. */
-
- old_wabbit_buffer = ((OBJECT_ADDRESS (wabbit_buffer)) + 3);
- old_wabbit_buffer[-1] = (MAKE_BROKEN_HEART (old_wabbit_buffer - 1));
-
- wabbit_vector_ptr = (MEMORY_LOC (wabbit_vector, 1));
-
- for (area = old_wabbit_buffer, ctr = n_wabbits; --ctr >= 0; )
- {
- SCHEME_OBJECT wabbit = *wabbit_vector_ptr++;
- SCHEME_OBJECT old_head;
-
- switch (GC_Type_Map [(OBJECT_TYPE (wabbit))])
- {
- case GC_Non_Pointer:
- /* Sucker -- should crash his scheme */
- break;
-
- case GC_Special:
- if (((OBJECT_TYPE (wabbit)) != TC_REFERENCE_TRAP)
- || ((OBJECT_DATUM (wabbit)) <= TRAP_MAX_IMMEDIATE))
- break;
- /* fall through */
-
- case GC_Cell:
- case GC_Pair:
- case GC_Triple:
- case GC_Quadruple:
- case GC_Vector:
- if ((OBJECT_ADDRESS (wabbit)) >= Constant_Top)
- break;
- old_head = (MEMORY_REF (wabbit, 0));
- MEMORY_SET (wabbit, 0, (MAKE_BROKEN_HEART (area)));
- *area++ = old_head;
- *area++ = wabbit;
- break;
-
- case GC_Compiled:
- {
- SCHEME_OBJECT * block;
-
- if ((OBJECT_ADDRESS (wabbit)) >= Constant_Top)
- break;
-
- Get_Compiled_Block (block, (OBJECT_ADDRESS (wabbit)));
- old_head = *block;
- *block = (MAKE_BROKEN_HEART (area));
- *area++ = old_head;
- *area++ = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block));
- break;
- }
-
- default:
- /* Loser -- shouldn't happen */
- break;
- }
- }
- old_wabbit_buffer_end = area;
-
- result = (wabbit_hunting_gcloop (wabbit_lo_address, &Free));
- if (Free != result)
- {
- outf_fatal ("\nwabbit_hunt: heap scan ended too early.\n");
- Microcode_Termination (TERM_BROKEN_HEART);
- }
- return;
-}
-\f
-void
-DEFUN (duck_season, (wabbit_descriptor),
- SCHEME_OBJECT wabbit_descriptor)
-{
- SCHEME_OBJECT * ptr;
-
- /* Restore hares' heads */
-
- for (ptr = old_wabbit_buffer; ptr < old_wabbit_buffer_end; ptr += 2)
- MEMORY_SET (ptr[1], 0, ptr[0]);
-
- wabbit_buffer_lo[2] =
- (LONG_TO_UNSIGNED_FIXNUM (wabbit_buffer_ptr - (wabbit_buffer_lo + 1)));
- while (wabbit_buffer_ptr < wabbit_buffer_hi)
- *wabbit_buffer_ptr++ = SHARP_F;
- wabbit_buffer_lo[1] = (BOOLEAN_TO_OBJECT (wabbit_all_dead_p));
- wabbit_buffer_lo[0]
- = (MAKE_OBJECT (TC_MANIFEST_VECTOR,
- (wabbit_buffer_hi - (wabbit_buffer_lo + 1))));
-
- if ((VECTOR_REF (wabbit_descriptor, 3)) == SHARP_T)
- {
- SCHEME_OBJECT * guaranteed_free = (Free + (GC_Reserve + 2));
- SCHEME_OBJECT * source, * dest, result;
- long len;
-
- if (guaranteed_free > wabbit_holes)
- {
- wabbit_holes_discarded_p = true;
- wabbit_holes = guaranteed_free;
- }
- dest = Free;
- result = (MAKE_POINTER_OBJECT (TC_VECTOR, dest));
- source = wabbit_holes;
- len = (wabbit_holes_hi - source);
- *dest++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (len + 1)));
- *dest++ = (BOOLEAN_TO_OBJECT (! (wabbit_holes_discarded_p
- || wabbit_holes_overwritten_p)));
- while (--len >= 0)
- *dest++ = *source++;
- Free = dest;
- VECTOR_SET (wabbit_descriptor, 3, result);
- }
-
- VECTOR_SET (wabbit_descriptor, 0, SHARP_T);
- return;
-}
-\f
-SCHEME_OBJECT *
-DEFUN (hunt_wabbit, (where), SCHEME_OBJECT * where)
-{
- SCHEME_OBJECT * ptr_lo, * ptr_hi, * ptr_mid, * hole;
-
- ptr_lo = wabbit_holes;
- ptr_hi = (wabbit_holes_hi - 1);
-
- while (ptr_lo < ptr_hi)
- {
- ptr_mid = (ptr_lo + ((ptr_hi - ptr_lo) / 2));
- hole = (OBJECT_ADDRESS (* ptr_mid));
- if (where < hole)
- ptr_lo = (ptr_mid + 1);
- else if (where > hole)
- ptr_hi = ptr_mid;
- else
- {
- ptr_hi = ptr_mid;
- ptr_lo = ptr_mid;
- break;
- }
- }
- return (ptr_lo);
-}
-
-Boolean
-DEFUN (discard_wabbit_holes_p, (scan, free),
- SCHEME_OBJECT * scan AND SCHEME_OBJECT * free)
-{
- SCHEME_OBJECT * hole, * new_hole;
- long keep_index;
-
- if (free > wabbit_holes)
- {
- wabbit_holes_overwritten_p = true;
- wabbit_holes = free;
- }
- if (scan < Constant_Top)
- return (free < wabbit_holes);
-
- hole = ((hunt_wabbit (scan)) + 1);
-
- /* This guarantees that we don't get into quadratic copying:
- We discard only if the fraction of holes being discarded
- is at least 1/ELMER_HUNG_FACTOR of the total number of holes.
- */
-
- if ((ELMER_HUNG_FACTOR * (wabbit_holes_hi - hole))
- < (wabbit_holes_hi - wabbit_holes))
- return (free < wabbit_holes);
-
- keep_index = (hole - wabbit_holes);
- new_hole = wabbit_holes_hi;
-
- while (--keep_index >= 0)
- *--new_hole = *--hole;
-
- wabbit_holes = new_hole;
- wabbit_holes_discarded_p = true;
- return (free < wabbit_holes);
-}
-\f
-void
-DEFUN (kill_da_wabbit, (where, current_object),
- SCHEME_OBJECT * where AND SCHEME_OBJECT current_object)
-{
- SCHEME_OBJECT * hole, wabbit, * wabbit_addr;
- long offset, max_offset;
-
- /* With my sword and magic helmet... */
-
- if (where < Constant_Top)
- {
- SCHEME_OBJECT head;
-
- if (current_object != SHARP_F)
- {
- offset = (where - (OBJECT_ADDRESS (current_object)));
- head = current_object;
- }
- else
- {
- /* If we do cwcc before calling the special garbage collector,
- there should be no references to the stack.
- */
- offset = 0;
- if (where < Stack_Top)
- head = (MAKE_POINTER_OBJECT (TC_REFERENCE_TO_STACK, where));
- else
- head = (MAKE_POINTER_OBJECT (TC_REFERENCE_TO_CONSTANT_SPACE, where));
- }
-
- *wabbit_buffer_ptr++ = head;
- *wabbit_buffer_ptr++ = (LONG_TO_UNSIGNED_FIXNUM (offset));
- return;
- }
- if (wabbit_holes >= wabbit_holes_hi)
- return;
-\f
- hole = (hunt_wabbit (where));
- wabbit = (* hole);
- wabbit_addr = (OBJECT_ADDRESS (wabbit));
- offset = (where - wabbit_addr);
- *wabbit_buffer_ptr++ = wabbit;
- *wabbit_buffer_ptr++ = (LONG_TO_UNSIGNED_FIXNUM (offset));
-
- if ((hole == wabbit_holes)
- && wabbit_holes_overwritten_p && (where != wabbit_addr))
- {
- switch (GC_Type_Map[(OBJECT_TYPE (wabbit))])
- {
- case GC_Pair:
- max_offset = 2;
- break;
-
- case GC_Triple:
- max_offset = 3;
- break;
-
- case GC_Quadruple:
- max_offset = 4;
- break;
-
- case GC_Vector:
- max_offset = (1 + (OBJECT_DATUM (* wabbit_addr)));
- break;
-
- case GC_Special:
- if ((OBJECT_TYPE (* hole)) == TC_REFERENCE_TRAP)
- {
- max_offset = 2;
- break;
- }
- /* fall through */
-
- case GC_Cell: /* => (where == wabbit_addr), already tested */
- default:
- max_offset = -1;
- }
- if ((max_offset == -1) || (where > (wabbit_addr + max_offset)))
- {
- wabbit_buffer_ptr -= 2;
- wabbit_all_dead_p = false;
- }
- }
- return;
-}
-\f
-/* Alternate version of Fix_Weak_Chain that hunts wabbits. */
-
-#ifndef EMPTY_WEAK_CHAIN
-#define EMPTY_WEAK_CHAIN EMPTY_LIST
-#endif
-
-void
-DEFUN_VOID (fix_weak_chain_and_hunt_wabbits)
-{
- fast SCHEME_OBJECT
- * old_weak_pair, * scan, nulled_car, * new_space_addr,
- this_object, * old_space_addr, * low_heap;
-
- low_heap = Constant_Top;
- while (Weak_Chain != EMPTY_WEAK_CHAIN)
- {
- old_weak_pair = (OBJECT_ADDRESS (Weak_Chain));
- scan = (OBJECT_ADDRESS (*old_weak_pair++));
- Weak_Chain = * old_weak_pair;
- nulled_car = * scan;
- this_object = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, nulled_car));
- Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
-
- switch (GC_Type (this_object))
- {
- case GC_Non_Pointer:
- *scan = this_object;
- continue;
-
- case GC_Special:
- if ((OBJECT_TYPE (this_object)) != TC_REFERENCE_TRAP)
- {
- /* No other special type makes sense here. */
- goto fail;
- }
- if ((OBJECT_DATUM (this_object)) <= TRAP_MAX_IMMEDIATE)
- {
- * scan = this_object;
- continue;
- }
- /* Otherwise, it is a pointer. Fall through */
-
- /* Normal pointer types, the broken heart is in the first word.
- Note that most special types are treated normally here.
- */
- case GC_Cell:
- case GC_Pair:
- case GC_Triple:
- case GC_Quadruple:
- case GC_Vector:
- * scan = this_object; /* In case it points to constant space */
- RELOCATE_NORMAL_SETUP ();
- * scan = SHARP_F;
- continue;
-\f
- case GC_Compiled:
- * scan = this_object;
- old_space_addr = (OBJECT_ADDRESS (this_object));
- if (old_space_addr < low_heap)
- continue;
- Get_Compiled_Block (old_space_addr, old_space_addr);
- if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)
- {
- new_space_addr = (OBJECT_ADDRESS (* old_space_addr));
- if (WABBIT_P (new_space_addr))
- KILL_DA_WABBIT (scan, (MAKE_POINTER_OBJECT (TC_WEAK_CONS, scan)));
-
- * scan = (RELOCATE_COMPILED (this_object,
- new_space_addr,
- old_space_addr));
- continue;
- }
- * scan = SHARP_F;
- continue;
-
- case GC_Undefined:
- outf_error
- ("\nfix_weak_chain_and_hunt_wabbits: Clearing bad object 0x%08lx.\n",
- this_object);
- * scan = SHARP_F;
- continue;
-
- default: /* Non Marked Headers and Broken Hearts */
- fail:
- outf_fatal
- ("\nfix_weak_chain_and_hunt_wabbits: Bad Object: 0x%08lx.\n",
- this_object);
- * scan = SHARP_F;
- /*NOTREACHED*/
- }
- }
- return;
-}
-
-/* What did you expect from opera, a happy ending? */
/* -*-C-*-
-$Id: wind.c,v 1.11 2007/01/05 21:19:25 cph Exp $
+$Id: wind.c,v 1.12 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
-#include <stdio.h>
+#include "config.h"
#include "obstack.h"
#include "dstack.h"
#include "outf.h"
-extern void EXFUN (free, (PTR ptr));
-#define obstack_chunk_alloc xmalloc
+#include "os.h"
+#define obstack_chunk_alloc OS_malloc
#define obstack_chunk_free free
-extern void EXFUN (block_signals, (void));
-extern void EXFUN (unblock_signals, (void));
+extern void block_signals (void);
+extern void unblock_signals (void);
static void
-DEFUN (error, (procedure_name, message),
- CONST char * procedure_name AND
- CONST char * message)
+error (const char * procedure_name, const char * message)
{
outf_fatal ("%s: %s\n", procedure_name, message);
outf_flush_fatal ();
abort ();
}
-static PTR
-DEFUN (xmalloc, (length), unsigned int length)
-{
-#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__)
-#else
- extern PTR EXFUN (malloc, (unsigned int length));
-#endif
-
- PTR result = (malloc (length));
- if (result == 0)
- error ("malloc", "memory allocation failed");
- return (result);
-}
-
struct winding_record
{
struct winding_record * next;
- void EXFUN ((*protector), (PTR environment));
- PTR environment;
+ void (*protector) (void * environment);
+ void * environment;
};
static struct obstack dstack;
static struct winding_record * current_winding_record;
-PTR dstack_position;
+void * dstack_position;
void
-DEFUN_VOID (dstack_initialize)
+dstack_initialize (void)
{
obstack_init (&dstack);
dstack_position = 0;
}
void
-DEFUN_VOID (dstack_reset)
+dstack_reset (void)
{
block_signals ();
obstack_free ((&dstack), 0);
unblock_signals ();
}
-#define EXPORT(sp) ((PTR) (((char *) (sp)) + (sizeof (PTR))))
+#define EXPORT(sp) ((void *) (((char *) (sp)) + (sizeof (void *))))
-PTR
-DEFUN (dstack_alloc, (length), unsigned int length)
+void *
+dstack_alloc (unsigned int length)
{
- PTR chunk;
+ void * chunk;
block_signals ();
- chunk = (obstack_alloc ((&dstack), ((sizeof (PTR)) + length)));
- (* ((PTR *) chunk)) = dstack_position;
+ chunk = (obstack_alloc ((&dstack), ((sizeof (void *)) + length)));
+ (* ((void **) chunk)) = dstack_position;
dstack_position = chunk;
unblock_signals ();
return (EXPORT (chunk));
}
void
-DEFUN (dstack_protect, (protector, environment),
- void EXFUN ((*protector), (PTR environment)) AND
- PTR environment)
+dstack_protect (void (*protector) (void * environment),
+ void * environment)
{
struct winding_record * record =
(dstack_alloc (sizeof (struct winding_record)));
}
void
-DEFUN (dstack_alloc_and_protect, (length, initializer, protector),
- unsigned int length AND
- void EXFUN ((*initializer), (PTR environment)) AND
- void EXFUN ((*protector), (PTR environment)))
+dstack_alloc_and_protect (unsigned int length,
+ void (*initializer) (void * environment),
+ void (*protector) (void * environment))
{
struct winding_record * record =
(dstack_alloc ((sizeof (struct winding_record)) + length));
- PTR environment = (((char *) record) + (sizeof (struct winding_record)));
+ void * environment = (((char *) record) + (sizeof (struct winding_record)));
(*initializer) (environment);
(record -> next) = current_winding_record;
(record -> protector) = protector;
}
void
-DEFUN (dstack_set_position, (position), PTR position)
+dstack_set_position (void * position)
{
block_signals ();
#define DEBUG_DSTACK
#ifdef DEBUG_DSTACK
{
- PTR * sp = dstack_position;
+ void ** sp = dstack_position;
while (sp != position)
{
if (sp == 0)
error ("dstack_set_position", "no more stack");
if ((EXPORT (dstack_position)) == current_winding_record)
{
- PTR sp = dstack_position;
+ void * sp = dstack_position;
struct winding_record * record = current_winding_record;
/* Must unblock signals while the protector runs, and
re-block afterwards, in case the protector does something
current_winding_record = (record -> next);
}
{
- PTR * sp = dstack_position;
+ void ** sp = dstack_position;
dstack_position = (*sp);
obstack_free ((&dstack), sp);
}
struct binding_record
{
- PTR * location;
- PTR value;
+ void ** location;
+ void * value;
};
static void
-DEFUN (undo_binding, (environment), PTR environment)
+undo_binding (void * environment)
{
(* (((struct binding_record *) environment) -> location)) =
(((struct binding_record *) environment) -> value);
}
-static PTR * save_binding_location;
+static void ** save_binding_location;
static void
-DEFUN (save_binding, (environment), PTR environment)
+save_binding (void * environment)
{
(((struct binding_record *) environment) -> location) =
save_binding_location;
}
void
-DEFUN (dstack_bind, (location, value), PTR location AND PTR value)
+dstack_bind (void * location, void * value)
{
save_binding_location = location;
dstack_alloc_and_protect
((sizeof (struct binding_record)), save_binding, undo_binding);
- (* ((PTR *) location)) = value;
+ (* ((void **) location)) = value;
}
/* -*-C-*-
-$Id: winder.h,v 9.30 2007/01/05 21:19:25 cph Exp $
+$Id: winder.h,v 9.31 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
*/
/* Header file for dynamic winder. */
-\f
+
#define STATE_SPACE_P(object) \
- ((VECTOR_P (object)) && \
- ((VECTOR_LENGTH (object)) == STATE_SPACE_LENGTH) && \
- ((MEMORY_REF ((object), STATE_SPACE_TAG)) == \
- (Get_Fixed_Obj_Slot (State_Space_Tag))))
+ ((VECTOR_P (object)) \
+ && ((VECTOR_LENGTH (object)) == STATE_SPACE_LENGTH) \
+ && ((MEMORY_REF ((object), STATE_SPACE_TAG)) \
+ == (VECTOR_REF (fixed_objects, State_Space_Tag))))
#define STATE_SPACE_TAG 1
#define STATE_SPACE_NEAREST_POINT 2
#define STATE_SPACE_LENGTH 2
#define STATE_POINT_P(object) \
- ((VECTOR_P (object)) && \
- ((VECTOR_LENGTH (object)) == STATE_POINT_LENGTH) && \
- ((MEMORY_REF ((object), STATE_POINT_TAG)) == \
- (Get_Fixed_Obj_Slot (State_Point_Tag))))
+ ((VECTOR_P (object)) \
+ && ((VECTOR_LENGTH (object)) == STATE_POINT_LENGTH) \
+ && ((MEMORY_REF ((object), STATE_POINT_TAG)) \
+ == (VECTOR_REF (fixed_objects, State_Point_Tag))))
#define STATE_POINT_TAG 1
#define STATE_POINT_BEFORE_THUNK 2
#define STATE_POINT_NEARER_POINT 4
#define STATE_POINT_DISTANCE_TO_ROOT 5
#define STATE_POINT_LENGTH 5
-
-
-#ifdef butterfly
-
-#define guarantee_state_point() \
-{ \
- if (Current_State_Point == SHARP_F) \
- Current_State_Point = (Get_Fixed_Obj_Slot (State_Space_Root)); \
-}
-
-#else
-
-#define guarantee_state_point()
-
-#endif
+++ /dev/null
-/* -*-C-*-
-
-$Id: wsize.c,v 9.38 2007/01/05 21:19:25 cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-\f
-#include <stdio.h>
-#include <math.h>
-#include <errno.h>
-#include <signal.h>
-#include "ansidecl.h"
-/* #include "config.h" */
-
-#ifndef TYPE_CODE_LENGTH
-/* This MUST match object.h */
-#define TYPE_CODE_LENGTH 8
-#endif
-
-#define ASCII_LOWER_A 0141
-#define ASCII_UPPER_A 0101
-
-#define boolean int
-#define false 0
-#define true 1
-
-extern int errno;
-extern PTR EXFUN (malloc, ());
-extern void EXFUN (free, ());
-
-/* The following hanky-panky courtesy of some buggy compilers. */
-
-int
-mul (x, y)
- int x; int y;
-{
- return (x * y);
-}
-
-double
-itod (n)
- int n;
-{
- return ((double) (mul (n, 1)));
-}
-
-double
-power (base, expo)
- double base;
- unsigned expo;
-{
- double result = (itod (1));
- while (expo != 0)
- {
- if ((expo & 1) == 1)
- {
- result *= base;
- expo -= 1;
- }
- else
- {
- base *= base;
- expo >>= 1;
- }
- }
- return (result);
-}
-
-/* Some machines do not set ERANGE by default. */
-/* This attempts to fix this. */
-
-#ifdef SIGFPE
-
-# define setup_error() signal(SIGFPE, range_error)
-
-void
-range_error()
-{
- setup_error();
- errno = ERANGE;
- return;
-}
-
-#else /* not SIGFPE */
-
-# define setup_error()
-
-#endif /* SIGFPE */
-
-/* Force program data to be relatively large. */
-
-#define ARR_SIZE 20000
-#define MEM_SIZE 400000
-
-static long dummy[ARR_SIZE];
-
-/* Structure used to find double alignment constraints. */
-
-struct double_probe {
- long field_1;
- double field_2;
-} proble_double[2];
-\f
-/* Note: comments are printed in a weird way because some
- C compilers eliminate them even from strings.
-*/
-
-main()
-{
- double accum[3], delta, dtemp, zero, one, two;
- int count, expt_size, char_size, mant_size, double_size, extra;
- unsigned long to_be_shifted;
- unsigned bogus;
- struct { long pad; char real_buffer[sizeof(long)]; } padding_buf;
- char * buffer, * temp;
- boolean confused;
-
- buffer = &padding_buf.real_buffer[0];
- confused = false;
- setup_error ();
-
- printf ("/%c CSCHEME configuration parameters. %c/\n", '*', '*');
- printf ("/%c REMINDER: Insert these definitions in config.h. %c/\n\n",
- '*', '*');
-
- printf ("/%c REMINDER: Change the following definitions! %c/\n",
- '*', '*');
- printf ("#define MACHINE_TYPE \"Unknown machine, fix config.h\"\n");
- printf ("#define FASL_INTERNAL_FORMAT FASL_UNKNOWN\n\n");
-
- if ((((int) 'a') == ASCII_LOWER_A) &&
- (((int) 'A') == ASCII_UPPER_A))
- {
- printf ("/%c The ASCII character set is used. %c/\n", '*', '*');
- }
- else
- {
- printf ("/%c The ASCII character set is NOT used. %c/\n", '*', '*');
- printf ("/%c REMINDER: Change the following definition! %c/\n",
- '*', '*');
- }
-
- for (bogus = ((unsigned) -1), count = 0;
- bogus != 0;
- count += 1)
- {
- bogus >>= 1;
- }
-
- char_size = (count / (sizeof(unsigned)));
-
- temp = (malloc (MEM_SIZE * (sizeof(long))));
- if (temp == NULL)
- {
- confused = true;
- printf ("/%c CONFUSION: Could not allocate %d Objects. %c/\n",
- '*', MEM_SIZE, '*');
- printf ("/%c Will not assume that the Heap is in Low Memory. %c/\n",
- '*', '*');
- }
- else
- {
- free (temp);
- if (((unsigned long) temp) <
- (1 << ((char_size * sizeof(long)) - TYPE_CODE_LENGTH)))
- printf ("#define HEAP_IN_LOW_MEMORY 1\n");
- else
- printf ("/%c Heap is not in Low Memory. %c/\n", '*', '*');
- }
-
- to_be_shifted = -1;
- if ((to_be_shifted >> 1) == to_be_shifted)
- {
- printf ("/%c unsigned longs use arithmetic shifting. %c/\n", '*', '*');
- printf ("#define UNSIGNED_SHIFT_BUG\n");
- }
- else
- {
- printf ("/%c unsigned longs use logical shifting. %c/\n", '*', '*');
- }
-\f
- if ((sizeof(long)) == (sizeof(char)))
- {
- printf ("/%c sizeof(long) == sizeof(char); no byte order problems! %c/\n",
- '*', '*');
- }
- else
- {
- buffer[0] = 1;
- for (count = 1; count < sizeof(long); )
- {
- buffer[count++] = 0;
- }
- if (*((long *) &buffer[0]) == 1)
- {
- printf("#define VAX_BYTE_ORDER 1\n\n");
- }
- else
- {
- printf("/%c VAX_BYTE_ORDER not used. %c/\n\n", '*', '*');
- }
- }
-
- double_size = (char_size*sizeof(double));
-
- printf ("#define CHAR_BIT %d\n",
- char_size);
-
- if (sizeof(struct double_probe) == (sizeof(double) + sizeof(long)))
- {
- printf ("/%c Flonums have no special alignment constraints. %c/\n",
- '*', '*');
- }
- else if ((sizeof(struct double_probe) != (2 * sizeof(double))) ||
- ((sizeof(double) % sizeof(long)) != 0))
- {
- confused = true;
- printf ("/%c CONFUSION: Can't determine float alignment constraints! %c/\n",
- '*', '*');
- printf ("/%c Please define FLOATING_ALIGNMENT by hand. %c/\n", '*', '*');
- }
- else
- {
- printf ("#define FLOATING_ALIGNMENT 0x%lx\n", (sizeof(double)-1));
- }
-\f
- mant_size = 1;
-
- zero = (itod (0));
- one = (itod (1));
- two = (itod (2));
-
- accum[0] = one;
- accum[1] = zero;
- delta = (one / two);
-
- while (true)
- {
- accum[2] = accum[1];
- accum[1] = (accum[0] + delta);
- if ((accum[1] == accum[0]) ||
- (accum[2] == accum[1]) ||
- (mant_size == double_size))
- break;
- delta = (delta / two);
- mant_size += 1;
- }
-
- printf ("#define FLONUM_MANTISSA_BITS %d\n", mant_size);
-
- for (errno = 0, expt_size = 0, bogus = 1, dtemp = zero;
- ((errno != ERANGE) && (expt_size <= double_size));
- expt_size += 1, bogus <<= 1)
- {
- delta = dtemp;
- dtemp = (power (two, bogus));
- if (dtemp == delta)
- break;
- }
-
- expt_size -= 1;
-
- printf ("#define FLONUM_EXPT_SIZE %d\n", expt_size);
- printf ("#define MAX_FLONUM_EXPONENT %d\n", ((1 << expt_size) - 1));
-
- extra = ((2 + expt_size + mant_size) - double_size);
-
- if (extra > 1)
- {
- confused = true;
- printf ("/%c CONFUSION: Can't determine floating parameters! %c/\n",
- '*', '*');
- printf ("/%c Please fix above three parameters by hand. %c/\n", '*', '*');
- }
- else
- {
- printf ("/%c Floating point representation %s hidden bit. %c/\n", '*',
- ((extra == 1) ? "uses" : "does not use"), '*');
- }
- if (confused)
- {
- fprintf (stderr, "Please examine carefully the \"confused\" parameters.\n");
- exit(1);
- }
- return;
-}
/* -*-C-*-
-$Id: x11.h,v 1.23 2007/01/05 21:19:25 cph Exp $
+$Id: x11.h,v 1.24 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include <X11/keysym.h>
#include <X11/Xutil.h>
#include <X11/Xatom.h>
-#include "ansidecl.h"
\f
struct xdisplay
{
#define X_MODIFIER_MASK_HYPER_P(modifier_mask, xd) \
((modifier_mask) & (XD_MODIFIER_MASK_HYPER (xd)))
-extern struct xdisplay * EXFUN (x_display_arg, (unsigned int arg));
+extern struct xdisplay * x_display_arg (unsigned int arg);
struct drawing_attributes
{
unsigned long mouse_pixel;
};
-#ifdef HAVE_STDC
/* This incomplete type definition is needed because the scope of the
implicit definition in the following typedefs is incorrect. */
struct xwindow;
-#endif
-typedef void EXFUN ((*x_deallocator_t), (struct xwindow *));
-typedef void EXFUN ((*x_event_processor_t), (struct xwindow *, XEvent *));
-typedef SCHEME_OBJECT EXFUN
- ((*x_coordinate_map_t), (struct xwindow *, unsigned int));
-typedef void EXFUN ((*x_update_normal_hints_t), (struct xwindow *));
+typedef void (*x_deallocator_t) (struct xwindow *);
+typedef void (*x_event_processor_t) (struct xwindow *, XEvent *);
+typedef SCHEME_OBJECT (*x_coordinate_map_t)
+ (struct xwindow *, unsigned int);
+typedef void (*x_update_normal_hints_t) (struct xwindow *);
struct xwindow_methods
{
int move_offset_y;
#ifdef __GNUC__
- PTR extra [0];
+ void * extra [0];
#else
- PTR extra [1];
+ void * extra [1];
#endif
};
#define FONT_HEIGHT(f) (((f) -> ascent) + ((f) -> descent))
#define FONT_BASE(f) ((f) -> ascent)
-extern struct xwindow * EXFUN (x_window_arg, (unsigned int arg));
+extern struct xwindow * x_window_arg (unsigned int arg);
\f
struct ximage
{
#define X_IMAGE_TO_OBJECT(image) \
(LONG_TO_UNSIGNED_FIXNUM (allocate_x_image (image)))
-extern struct ximage * EXFUN (x_image_arg, (unsigned int arg));
-extern unsigned int EXFUN (allocate_x_image, (XImage * image));
-extern void EXFUN (deallocate_x_image, (struct ximage * xi));
+extern struct ximage * x_image_arg (unsigned int arg);
+extern unsigned int allocate_x_image (XImage * image);
+extern void deallocate_x_image (struct ximage * xi);
struct xvisual
{
#define X_VISUAL_TO_OBJECT(visual) \
(LONG_TO_UNSIGNED_FIXNUM (allocate_x_visual (visual)))
-extern struct xvisual * EXFUN (x_visual_arg, (unsigned int arg));
-extern unsigned int EXFUN (allocate_x_visual, (Visual * visual));
-extern void EXFUN (deallocate_x_visual, (struct xvisual * xv));
+extern struct xvisual * x_visual_arg (unsigned int arg);
+extern unsigned int allocate_x_visual (Visual * visual);
+extern void deallocate_x_visual (struct xvisual * xv);
struct xcolormap
{
(LONG_TO_UNSIGNED_FIXNUM (allocate_x_colormap ((colormap), (xd))))
#define XCM_DISPLAY(xcm) (XD_DISPLAY (XCM_XD (xcm)))
-extern struct xcolormap * EXFUN (x_colormap_arg, (unsigned int arg));
-extern unsigned int EXFUN
- (allocate_x_colormap, (Colormap colormap, struct xdisplay * xd));
-extern void EXFUN (deallocate_x_colormap, (struct xcolormap * xcm));
+extern struct xcolormap * x_colormap_arg (unsigned int arg);
+extern unsigned int allocate_x_colormap
+ (Colormap colormap, struct xdisplay * xd);
+extern void deallocate_x_colormap (struct xcolormap * xcm);
\f
extern int x_debug;
-extern PTR EXFUN (x_malloc, (unsigned int size));
-extern PTR EXFUN (x_realloc, (PTR ptr, unsigned int size));
-
-extern char * EXFUN
- (x_get_default,
- (Display * display,
- CONST char * resource_name,
- CONST char * resource_class,
- CONST char * property_name,
- CONST char * property_class,
- char * sdefault));
-
-extern void EXFUN
- (x_default_attributes,
- (Display * display,
- CONST char * resource_name,
- CONST char * resource_class,
- struct drawing_attributes * attributes));
-
-extern struct xwindow * EXFUN
- (x_make_window,
- (struct xdisplay * xd,
- Window window,
- int x_size,
- int y_size,
- struct drawing_attributes * attributes,
- struct xwindow_methods * methods,
- unsigned int extra));
-
-extern void EXFUN
- (xw_set_wm_input_hint, (struct xwindow * xw, int input_hint));
-
-extern void EXFUN
- (xw_set_wm_name, (struct xwindow * xw, CONST char * name));
-
-extern void EXFUN
- (xw_set_wm_icon_name, (struct xwindow * xw, CONST char * name));
-
-extern void EXFUN
- (x_decode_window_map_arg,
- (SCHEME_OBJECT map_arg,
- CONST char ** resource_class,
- CONST char ** resource_name,
- int * map_p));
-
-extern void EXFUN
- (xw_make_window_map,
- (struct xwindow * xw,
- CONST char * resource_name,
- CONST char * resource_class,
- int map_p));
+extern void * x_malloc (unsigned int size);
+extern void * x_realloc (void * ptr, unsigned int size);
+
+extern char * x_get_default
+ (Display * display,
+ const char * resource_name,
+ const char * resource_class,
+ const char * property_name,
+ const char * property_class,
+ char * sdefault);
+
+extern void x_default_attributes
+ (Display * display,
+ const char * resource_name,
+ const char * resource_class,
+ struct drawing_attributes * attributes);
+
+extern struct xwindow * x_make_window
+ (struct xdisplay * xd,
+ Window window,
+ int x_size,
+ int y_size,
+ struct drawing_attributes * attributes,
+ struct xwindow_methods * methods,
+ unsigned int extra);
+
+extern void xw_set_wm_input_hint (struct xwindow * xw, int input_hint);
+extern void xw_set_wm_name (struct xwindow * xw, const char * name);
+extern void xw_set_wm_icon_name (struct xwindow * xw, const char * name);
+
+extern void x_decode_window_map_arg
+ (SCHEME_OBJECT map_arg,
+ const char ** resource_class,
+ const char ** resource_name,
+ int * map_p);
+
+extern void xw_make_window_map
+ (struct xwindow * xw,
+ const char * resource_name,
+ const char * resource_class,
+ int map_p);
/* -*-C-*-
-$Id: x11base.c,v 1.93 2007/02/04 18:39:05 riastradh Exp $
+$Id: x11base.c,v 1.94 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include <X11/Xmd.h>
#include <X11/keysym.h>
-extern void EXFUN (block_signals, (void));
-extern void EXFUN (unblock_signals, (void));
+extern void block_signals (void);
+extern void unblock_signals (void);
#ifndef X_DEFAULT_FONT
# define X_DEFAULT_FONT "fixed"
initialize_once (); \
}
-static void EXFUN (initialize_once, (void));
+static void initialize_once (void);
static void move_window (struct xwindow *, int, int);
static void check_expected_move (struct xwindow *);
-PTR
-DEFUN (x_malloc, (size), unsigned int size)
+void *
+x_malloc (unsigned int size)
{
- PTR result = (UX_malloc (size));
+ void * result = (UX_malloc (size));
if (result == 0)
error_external_return ();
return (result);
}
-PTR
-DEFUN (x_realloc, (ptr, size), PTR ptr AND unsigned int size)
+void *
+x_realloc (void * ptr, unsigned int size)
{
- PTR result = (UX_realloc (ptr, size));
+ void * result = (UX_realloc (ptr, size));
if (result == 0)
error_external_return ();
return (result);
struct allocation_table
{
- PTR * items;
+ void ** items;
int length;
};
static struct allocation_table x_colormap_table;
static void
-DEFUN (allocation_table_initialize, (table), struct allocation_table * table)
+allocation_table_initialize (struct allocation_table * table)
{
(table -> length) = 0;
}
static unsigned int
-DEFUN (allocate_table_index, (table, item),
- struct allocation_table * table AND
- PTR item)
+allocate_table_index (struct allocation_table * table, void * item)
{
unsigned int length = (table -> length);
unsigned int new_length;
- PTR * items = (table -> items);
- PTR * new_items;
- PTR * scan;
- PTR * end;
+ void ** items = (table -> items);
+ void ** new_items;
+ void ** scan;
+ void ** end;
if (length == 0)
{
new_length = 4;
- new_items = (x_malloc ((sizeof (PTR)) * new_length));
+ new_items = (x_malloc ((sizeof (void *)) * new_length));
}
else
{
return (scan - items);
}
new_length = (length * 2);
- new_items = (x_realloc (items, ((sizeof (PTR)) * new_length)));
+ new_items = (x_realloc (items, ((sizeof (void *)) * new_length)));
}
scan = (new_items + length);
end = (new_items + new_length);
return (length);
}
-static PTR
-DEFUN (allocation_item_arg, (arg, table),
- unsigned int arg AND
- struct allocation_table * table)
+static void *
+allocation_item_arg (unsigned int arg, struct allocation_table * table)
{
unsigned int index = (arg_index_integer (arg, (table -> length)));
- PTR item = ((table -> items) [index]);
+ void * item = ((table -> items) [index]);
if (item == 0)
error_bad_range_arg (arg);
return (item);
}
struct xdisplay *
-DEFUN (x_display_arg, (arg), unsigned int arg)
+x_display_arg (unsigned int arg)
{
INITIALIZE_ONCE ();
return (allocation_item_arg (arg, (&x_display_table)));
}
struct xwindow *
-DEFUN (x_window_arg, (arg), unsigned int arg)
+x_window_arg (unsigned int arg)
{
INITIALIZE_ONCE ();
return (allocation_item_arg (arg, (&x_window_table)));
}
static struct xwindow *
-DEFUN (x_window_to_xw, (display, window),
- Display * display AND
- Window window)
+x_window_to_xw (Display * display, Window window)
{
struct xwindow ** scan = ((struct xwindow **) (x_window_table . items));
struct xwindow ** end = (scan + (x_window_table . length));
}
struct ximage *
-DEFUN (x_image_arg, (arg), unsigned int arg)
+x_image_arg (unsigned int arg)
{
INITIALIZE_ONCE ();
return (allocation_item_arg (arg, (&x_image_table)));
}
unsigned int
-DEFUN (allocate_x_image, (image), XImage * image)
+allocate_x_image (XImage * image)
{
struct ximage * xi = (x_malloc (sizeof (struct ximage)));
unsigned int index = (allocate_table_index ((&x_image_table), xi));
}
void
-DEFUN (deallocate_x_image, (xi), struct ximage * xi)
+deallocate_x_image (struct ximage * xi)
{
((x_image_table . items) [XI_ALLOCATION_INDEX (xi)]) = 0;
free (xi);
}
struct xvisual *
-DEFUN (x_visual_arg, (arg), unsigned int arg)
+x_visual_arg (unsigned int arg)
{
INITIALIZE_ONCE ();
return (allocation_item_arg (arg, (&x_visual_table)));
}
unsigned int
-DEFUN (allocate_x_visual, (visual), Visual * visual)
+allocate_x_visual (Visual * visual)
{
struct xvisual * xv = (x_malloc (sizeof (struct xvisual)));
unsigned int index = (allocate_table_index ((&x_visual_table), xv));
}
void
-DEFUN (deallocate_x_visual, (xv), struct xvisual * xv)
+deallocate_x_visual (struct xvisual * xv)
{
((x_visual_table . items) [XV_ALLOCATION_INDEX (xv)]) = 0;
free (xv);
}
struct xcolormap *
-DEFUN (x_colormap_arg, (arg), unsigned int arg)
+x_colormap_arg (unsigned int arg)
{
INITIALIZE_ONCE ();
return (allocation_item_arg (arg, (&x_colormap_table)));
}
unsigned int
-DEFUN (allocate_x_colormap, (colormap, xd),
- Colormap colormap AND
- struct xdisplay * xd)
+allocate_x_colormap (Colormap colormap, struct xdisplay * xd)
{
struct xcolormap * xcm = (x_malloc (sizeof (struct xcolormap)));
unsigned int index = (allocate_table_index ((&x_colormap_table), xcm));
}
void
-DEFUN (deallocate_x_colormap, (xcm), struct xcolormap * xcm)
+deallocate_x_colormap (struct xcolormap * xcm)
{
((x_colormap_table . items) [XCM_ALLOCATION_INDEX (xcm)]) = 0;
free (xcm);
/* Error Handlers */
static int
-DEFUN (x_io_error_handler, (display), Display * display)
+x_io_error_handler (Display * display)
{
fprintf (stderr, "\nX IO Error\n");
fflush (stderr);
}
static void
-DEFUN (unbind_x_error_info, (storage), PTR storage)
+unbind_x_error_info (void * storage)
{
x_error_info = (* ((x_error_info_t *) storage));
}
/* Defaults and Attributes */
static int
-DEFUN (x_decode_color, (display, color_map, color_name, color_return),
- Display * display AND
- Colormap color_map AND
- char * color_name AND
- unsigned long * color_return)
+x_decode_color (Display * display,
+ Colormap color_map,
+ char * color_name,
+ unsigned long * color_return)
{
XColor cdef;
if ((XParseColor (display, color_map, color_name, (&cdef)))
}
Colormap
-DEFUN (xw_color_map, (xw), struct xwindow * xw)
+xw_color_map (struct xwindow * xw)
{
XWindowAttributes a;
if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
}
static unsigned long
-DEFUN (arg_window_color, (arg, display, xw),
- unsigned int arg AND
- Display * display AND
- struct xwindow * xw)
+arg_window_color (unsigned int arg, Display * display, struct xwindow * xw)
{
unsigned long result;
SCHEME_OBJECT object = (ARG_REF (arg));
}
static void
-DEFUN (x_set_mouse_colors,
- (display, color_map, mouse_cursor, mouse_pixel, background_pixel),
- Display * display AND
- Colormap color_map AND
- Cursor mouse_cursor AND
- unsigned long mouse_pixel AND
- unsigned long background_pixel)
+x_set_mouse_colors (Display * display,
+ Colormap color_map,
+ Cursor mouse_cursor,
+ unsigned long mouse_pixel,
+ unsigned long background_pixel)
{
XColor mouse_color;
XColor background_color;
}
char *
-DEFUN (x_get_default,
- (display, resource_name, resource_class,
- property_name, property_class, sdefault),
- Display * display AND
- CONST char * resource_name AND
- CONST char * resource_class AND
- CONST char * property_name AND
- CONST char * property_class AND
- char * sdefault)
+x_get_default (Display * display,
+ const char * resource_name,
+ const char * resource_class,
+ const char * property_name,
+ const char * property_class,
+ char * sdefault)
{
char * result = (XGetDefault (display, resource_name, property_name));
if (result != 0)
}
static unsigned long
-DEFUN (x_default_color,
- (display, resource_name, resource_class,
- property_name, property_class, default_color),
- Display * display AND
- CONST char * resource_name AND
- CONST char * resource_class AND
- CONST char * property_name AND
- CONST char * property_class AND
- unsigned long default_color)
+x_default_color (Display * display,
+ const char * resource_name,
+ const char * resource_class,
+ const char * property_name,
+ const char * property_class,
+ unsigned long default_color)
{
char * color_name =
(x_get_default
}
void
-DEFUN (x_default_attributes,
- (display, resource_name, resource_class, attributes),
- Display * display AND
- CONST char * resource_name AND
- CONST char * resource_class AND
- struct drawing_attributes * attributes)
+x_default_attributes (Display * display,
+ const char * resource_name,
+ const char * resource_class,
+ struct drawing_attributes * attributes)
{
int screen_number = (DefaultScreen (display));
(attributes -> font) =
}
struct xwindow *
-DEFUN (x_make_window, (xd, window, x_size, y_size, attributes, methods, extra),
- struct xdisplay * xd AND
- Window window AND
- int x_size AND
- int y_size AND
- struct drawing_attributes * attributes AND
- struct xwindow_methods * methods AND
- unsigned int extra)
+x_make_window (struct xdisplay * xd,
+ Window window,
+ int x_size,
+ int y_size,
+ struct drawing_attributes * attributes,
+ struct xwindow_methods * methods,
+ unsigned int extra)
{
GC normal_gc;
GC reverse_gc;
static jmp_buf x_close_window_jmp_buf;
static int
-DEFUN (x_close_window_io_error, (display), Display * display)
+x_close_window_io_error (Display * display)
{
longjmp (x_close_window_jmp_buf, 1);
/*NOTREACHED*/
}
static void
-DEFUN (x_close_window, (xw), struct xwindow * xw)
+x_close_window (struct xwindow * xw)
{
Display * display = (XW_DISPLAY (xw));
((x_window_table . items) [XW_ALLOCATION_INDEX (xw)]) = 0;
Adapted from GNU Emacs. */
static void
-DEFUN (x_initialize_display_modifier_masks, (xd), struct xdisplay * xd)
+x_initialize_display_modifier_masks (struct xdisplay * xd)
{
int min_keycode;
int max_keycode;
}
static void
-DEFUN (x_close_display, (xd), struct xdisplay * xd)
+x_close_display (struct xdisplay * xd)
{
struct xwindow ** scan = ((struct xwindow **) (x_window_table . items));
struct xwindow ** end = (scan + (x_window_table . length));
}
static void
-DEFUN_VOID (x_close_all_displays)
+x_close_all_displays (void)
{
struct xdisplay ** scan = ((struct xdisplay **) (x_display_table . items));
struct xdisplay ** end = (scan + (x_display_table . length));
/* Window Manager Properties */
static void
-DEFUN (xw_set_class_hint, (xw, name, class),
- struct xwindow * xw AND
- CONST char * name AND
- CONST char * class)
+xw_set_class_hint (struct xwindow * xw, const char * name, const char * class)
{
XClassHint * class_hint = (XAllocClassHint ());
if (class_hint == 0)
}
void
-DEFUN (xw_set_wm_input_hint, (xw, input_hint),
- struct xwindow * xw AND
- int input_hint)
+xw_set_wm_input_hint (struct xwindow * xw, int input_hint)
{
XWMHints * hints = (XAllocWMHints ());
if (hints == 0)
}
void
-DEFUN (xw_set_wm_name, (xw, name), struct xwindow * xw AND CONST char * name)
+xw_set_wm_name (struct xwindow * xw, const char * name)
{
XTextProperty property;
if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0)
}
void
-DEFUN (xw_set_wm_icon_name, (xw, name),
- struct xwindow * xw AND
- CONST char * name)
+xw_set_wm_icon_name (struct xwindow * xw, const char * name)
{
XTextProperty property;
if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0)
}
void
-DEFUN (x_decode_window_map_arg,
- (map_arg, resource_name, resource_class, map_p),
- SCHEME_OBJECT map_arg AND
- CONST char ** resource_name AND
- CONST char ** resource_class AND
- int * map_p)
+x_decode_window_map_arg (SCHEME_OBJECT map_arg,
+ const char ** resource_name,
+ const char ** resource_class,
+ int * map_p)
{
(*map_p) = 0;
if (map_arg == SHARP_F)
&& (STRING_P (PAIR_CAR (map_arg)))
&& (STRING_P (PAIR_CDR (map_arg))))
{
- (*resource_name) =
- ((CONST char *) (STRING_LOC ((PAIR_CAR (map_arg)), 0)));
- (*resource_class) =
- ((CONST char *) (STRING_LOC ((PAIR_CDR (map_arg)), 0)));
+ (*resource_name) = (STRING_POINTER (PAIR_CAR (map_arg)));
+ (*resource_class) = (STRING_POINTER (PAIR_CDR (map_arg)));
(*map_p) = 1;
}
else if ((VECTOR_P (map_arg))
&& (STRING_P (VECTOR_REF (map_arg, 1)))
&& (STRING_P (VECTOR_REF (map_arg, 2))))
{
- (*resource_name) =
- ((CONST char *) (STRING_LOC ((VECTOR_REF (map_arg, 1)), 0)));
- (*resource_class) =
- ((CONST char *) (STRING_LOC ((VECTOR_REF (map_arg, 2)), 0)));
+ (*resource_name) = (STRING_POINTER (VECTOR_REF (map_arg, 1)));
+ (*resource_class) = (STRING_POINTER (VECTOR_REF (map_arg, 2)));
(*map_p) = (OBJECT_TO_BOOLEAN (VECTOR_REF (map_arg, 0)));
}
}
void
-DEFUN (xw_make_window_map, (xw, resource_name, resource_class, map_p),
- struct xwindow * xw AND
- CONST char * resource_name AND
- CONST char * resource_class AND
- int map_p)
+xw_make_window_map (struct xwindow * xw,
+ const char * resource_name,
+ const char * resource_class,
+ int map_p)
{
xw_set_class_hint (xw, resource_name, resource_class);
if (map_p)
VECTOR_SET ((event), (slot), (ulong_to_integer (number)))
static SCHEME_OBJECT
-DEFUN (make_event_object, (xw, type, extra),
- struct xwindow * xw AND
- enum event_type type AND
- unsigned int extra)
+make_event_object (struct xwindow * xw,
+ enum event_type type,
+ unsigned int extra)
{
SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, (2 + extra), 1));
VECTOR_SET (result, 0, (LONG_TO_UNSIGNED_FIXNUM ((long) type)));
other than Scheme characters to convey key presses. */
static unsigned long
-DEFUN (x_modifier_mask_to_bucky_bits, (mask, xd),
- unsigned int mask AND
- struct xdisplay * xd)
+x_modifier_mask_to_bucky_bits (unsigned int mask, struct xdisplay * xd)
{
unsigned long bucky = 0;
if (X_MODIFIER_MASK_CONTROL_P (mask, xd)) bucky |= CHAR_BITS_CONTROL;
/* I'm not sure why we have a function for this. */
static SCHEME_OBJECT
-DEFUN (x_key_button_mask_to_scheme, (x_state), unsigned int x_state)
+x_key_button_mask_to_scheme (unsigned int x_state)
{
unsigned long scheme_state = 0;
if (x_state & ControlMask) scheme_state |= 0x0001;
}
static SCHEME_OBJECT
-DEFUN (button_event, (xw, event, type),
- struct xwindow * xw AND
- XButtonEvent * event AND
- enum event_type type)
+button_event (struct xwindow * xw, XButtonEvent * event, enum event_type type)
{
SCHEME_OBJECT result = (make_event_object (xw, type, 4));
- EVENT_INTEGER (result, EVENT_0, (event -> x));
- EVENT_INTEGER (result, EVENT_1, (event -> y));
+ EVENT_INTEGER (result, EVENT_0, (event->x));
+ EVENT_INTEGER (result, EVENT_1, (event->y));
VECTOR_SET
(result, EVENT_2,
- ((((event -> button) >= 1) && ((event -> button) <= 256))
+ ((((event->button) >= 1) && ((event->button) <= 256))
? (ULONG_TO_FIXNUM
- (((event -> button) - 1)
- | ((x_modifier_mask_to_bucky_bits ((event -> state), (XW_XD (xw))))
+ (((event->button) - 1)
+ | ((x_modifier_mask_to_bucky_bits ((event->state), (XW_XD (xw))))
<< 8)))
: SHARP_F));
- EVENT_ULONG_INTEGER (result, EVENT_3, (event -> time));
+ EVENT_ULONG_INTEGER (result, EVENT_3, (event->time));
return (result);
}
static XComposeStatus compose_status;
static SCHEME_OBJECT
-DEFUN (key_event, (xw, event, type),
- struct xwindow * xw AND
- XKeyEvent * event AND
- enum event_type type)
+key_event (struct xwindow * xw, XKeyEvent * event, enum event_type type)
{
char copy_buffer [80];
KeySym keysym;
break
static SCHEME_OBJECT
-DEFUN (x_event_to_object, (event), XEvent * event)
+x_event_to_object (XEvent * event)
{
struct xwindow * xw
= (x_window_to_xw (((event -> xany) . display),
}
static void
-DEFUN (update_input_mask, (xw), struct xwindow * xw)
+update_input_mask (struct xwindow * xw)
{
{
unsigned long event_mask = 0;
}
static void
-DEFUN (ping_server, (xd, arg), struct xdisplay * xd)
+ping_server (struct xdisplay * xd)
{
/* Periodically ping the server connection to see if it has died. */
(XD_SERVER_PING_TIMER (xd)) += 1;
cooperate with this strategy. */
static SCHEME_OBJECT
-DEFUN (xd_process_events, (xd, non_block_p, use_select_p),
- struct xdisplay * xd AND
- int non_block_p AND
- int use_select_p)
+xd_process_events (struct xdisplay * xd, int non_block_p, int use_select_p)
{
Display * display = (XD_DISPLAY (xd));
unsigned int events_queued;
/* Open/Close Primitives */
static void
-DEFUN_VOID (initialize_once)
+initialize_once (void)
{
allocation_table_initialize (&x_display_table);
allocation_table_initialize (&x_window_table);
PRIMITIVE_HEADER (1);
INITIALIZE_ONCE ();
{
- struct xdisplay * xd = (x_malloc (sizeof (struct xdisplay)));
+ struct xdisplay * xd = (x_malloc (sizeof (struct xdisplay)));
/* Added 7/95 by Nick in an attempt to fix problem Hal was having
with SWAT over PPP (i.e. slow connections). */
block_signals ();
(XInternAtom ((XD_DISPLAY (xd)), "WM_TAKE_FOCUS", False));
(XD_CACHED_EVENT_P (xd)) = 0;
x_initialize_display_modifier_masks (xd);
- XRebindKeysym ((XD_DISPLAY (xd)), XK_BackSpace, 0, 0, "\177", 1);
+ XRebindKeysym ((XD_DISPLAY (xd)), XK_BackSpace, 0, 0,
+ ((unsigned char *) "\177"), 1);
PRIMITIVE_RETURN (XD_TO_OBJECT (xd));
}
}
PRIMITIVE_RETURN (SHARP_F);
XFreeFont (display, font);
if (x_default_font != 0)
- OS_free ((PTR) x_default_font);
+ OS_free ((void *) x_default_font);
{
char * copy = (OS_malloc ((strlen (name)) + 1));
const char * s1 = name;
char * result =
(XGetDefault
((XD_DISPLAY (x_display_arg (1))), (STRING_ARG (2)), (STRING_ARG (3))));
- PRIMITIVE_RETURN
- ((result == 0) ? SHARP_F : (char_pointer_to_string (result)));
+ PRIMITIVE_RETURN ((result == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (result)));
}
}
char-struct-words * maximum-number-possible */
static SCHEME_OBJECT
-DEFUN (convert_char_struct, (char_struct), XCharStruct * char_struct)
+convert_char_struct (XCharStruct * char_struct)
{
if (((char_struct -> lbearing) == 0)
&& ((char_struct -> rbearing) == 0)
}
static SCHEME_OBJECT
-DEFUN (convert_font_struct, (font_name, font),
- SCHEME_OBJECT font_name AND
- XFontStruct * font)
+convert_font_struct (SCHEME_OBJECT font_name, XFontStruct * font)
{
SCHEME_OBJECT result;
if (font == 0)
}
DEFINE_PRIMITIVE ("X-FONT-STRUCTURE", Prim_x_font_structure, 2, 2,
- "(display font)\n\
- FONT is either a font name or a font ID.")
+ "(DISPLAY FONT)\n\
+FONT is either a font name or a font ID.")
{
PRIMITIVE_HEADER (2);
Primitive_GC_If_Needed (FONT_STRUCTURE_MAX_CONVERTED_SIZE);
SCHEME_OBJECT font_name = (ARG_REF (2));
Display * display = (XD_DISPLAY (x_display_arg (1)));
XFontStruct * font = 0;
- Boolean by_name = STRING_P (font_name);
+ bool by_name = STRING_P (font_name);
SCHEME_OBJECT result;
if (by_name)
- font = XLoadQueryFont (display, ((char *) (STRING_LOC (font_name, 0))));
+ font = XLoadQueryFont (display, (STRING_POINTER (font_name)));
else
font = XQueryFont (display, ((XID) (integer_to_ulong (ARG_REF (2)))));
if (font == 0)
PRIMITIVE_RETURN (SHARP_F);
-
+
result = convert_font_struct (font_name, font);
if (by_name)
}
}
-DEFINE_PRIMITIVE ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure, 1, 1,
- "(x-window)\n\
- Returns the font-structure for the font currently associated with X-WINDOW")
+DEFINE_PRIMITIVE ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure,
+ 1, 1, "(X-WINDOW)\n\
+Returns the font-structure for the font currently associated with X-WINDOW.")
{
XFontStruct *font;
PRIMITIVE_HEADER (1);
}
DEFINE_PRIMITIVE ("X-LIST-FONTS", Prim_x_list_fonts, 3, 3,
- "(display pattern limit)\n\
- LIMIT is an exact non-negative integer or #F for no limit.\n\
- Returns #F or a vector of at least one string.")
+ "(DISPLAY PATTERN LIMIT)\n\
+LIMIT is an exact non-negative integer or #F for no limit.\n\
+Returns #F or a vector of at least one string.")
{
PRIMITIVE_HEADER (1);
{
unsigned int i;
for (i = 0; (i < actual_count); i += 1)
words += (STRING_LENGTH_TO_GC_LENGTH (strlen (names[i])));
- if (GC_Check (words))
+ if (GC_NEEDED_P (words))
{
/* this causes the primitive to be restarted, so deallocate names */
XFreeFontNames (names);
/* Window Properties */
static SCHEME_OBJECT
-DEFUN (char_ptr_to_prop_data_32, (data, nitems),
- CONST unsigned char * data AND
- unsigned long nitems)
+char_ptr_to_prop_data_32 (const unsigned char * data, unsigned long nitems)
{
SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, nitems, 1));
unsigned long index;
}
static SCHEME_OBJECT
-DEFUN (char_ptr_to_prop_data_16, (data, nitems),
- CONST unsigned char * data AND
- unsigned long nitems)
+char_ptr_to_prop_data_16 (const unsigned char * data, unsigned long nitems)
{
SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, nitems, 1));
unsigned long index;
}
static const unsigned char *
-DEFUN (prop_data_32_to_char_ptr, (vector, length_return),
- SCHEME_OBJECT vector AND
- unsigned long * length_return)
+prop_data_32_to_char_ptr (SCHEME_OBJECT vector, unsigned long * length_return)
{
unsigned long nitems = (VECTOR_LENGTH (vector));
unsigned long length = (nitems * 4);
}
static const unsigned char *
-DEFUN (prop_data_16_to_char_ptr, (vector, length_return),
- SCHEME_OBJECT vector AND
- unsigned long * length_return)
+prop_data_16_to_char_ptr (SCHEME_OBJECT vector, unsigned long * length_return)
{
unsigned long nitems = (VECTOR_LENGTH (vector));
unsigned long length = (nitems * 2);
Atom type = (arg_ulong_integer (4));
int format = (arg_nonnegative_integer (5));
int mode = (arg_index_integer (6, 3));
+ unsigned long dlen = 0;
const unsigned char * data = 0;
- unsigned long dlen;
void * handle;
unsigned char error_code;
{
case 8:
CHECK_ARG (7, STRING_P);
- data = (STRING_LOC ((ARG_REF (7)), 0));
+ data = (STRING_BYTE_PTR (ARG_REF (7)));
dlen = (STRING_LENGTH (ARG_REF (7)));
break;
case 16:
/* -*-C-*-
-$Id: x11color.c,v 1.9 2007/01/05 21:19:25 cph Exp $
+$Id: x11color.c,v 1.10 2007/04/22 16:31:23 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
if (ARG_REF(3) == SHARP_F)
{ struct xwindow * xw = x_window_arg (1);
XWindowAttributes attrs;
-
+
dpy = XW_DISPLAY(xw);
XGetWindowAttributes(dpy, XW_WINDOW(xw), &attrs);
ScreenNumber = XScreenNumberOfScreen(attrs.screen);
LOAD_IF(10, (int), bits_per_rgb, VisualBitsPerRGBMask);
VIList = XGetVisualInfo(dpy, VIMask, &VI, &AnswerCount);
AnswerSize = (AnswerCount + 1) + (11 * AnswerCount);
- if (GC_Check (AnswerSize))
- { XFree((PTR) VIList);
+ if (GC_NEEDED_P (AnswerSize))
+ { XFree((void *) VIList);
Primitive_GC (AnswerSize);
}
Result = allocate_marked_vector (TC_VECTOR, AnswerCount, false);
VECTOR_SET(This_Vector, 9, long_to_integer(ThisVI->bits_per_rgb));
VECTOR_SET(Result, i, This_Vector);
}
- XFree((PTR) VIList);
+ XFree((void *) VIList);
PRIMITIVE_RETURN(Result);
}
}
}
}
-DEFINE_PRIMITIVE ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1,
+DEFINE_PRIMITIVE ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free,
+ 1, 1,
"Return a new copy of COLORMAP.")
{
PRIMITIVE_HEADER (1);
{
/* Input: colormap, pixel ... */
PRIMITIVE_HEADER (LEXPR);
- if ((LEXPR_N_ARGUMENTS ()) < 1)
+ if (GET_LEXPR_ACTUALS < 1)
signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
{
struct xcolormap * xcm = (x_colormap_arg (1));
- unsigned int n_pixels = ((LEXPR_N_ARGUMENTS ()) - 1);
+ unsigned int n_pixels = (GET_LEXPR_ACTUALS - 1);
unsigned long * pixels =
(dstack_alloc ((sizeof (unsigned long)) * n_pixels));
unsigned int i;
/* Input: colormap, pixel ...
Output: a vector of vectors, each with #(red, green, blue) */
PRIMITIVE_HEADER (LEXPR);
- if ((LEXPR_N_ARGUMENTS ()) < 1)
+ if (GET_LEXPR_ACTUALS < 1)
signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
{
struct xcolormap * xcm = (x_colormap_arg (1));
- unsigned int n_colors = ((LEXPR_N_ARGUMENTS ()) - 1);
+ unsigned int n_colors = (GET_LEXPR_ACTUALS - 1);
XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
unsigned int i;
for (i = 0; (i < n_colors); i += 1)
/* -*-C-*-
-$Id: x11graph.c,v 1.45 2007/01/05 21:19:25 cph Exp $
+$Id: x11graph.c,v 1.46 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "scheme.h"
#include "prims.h"
#include "x11.h"
-#include "float.h"
-#include <math.h>
\f
#define RESOURCE_NAME "schemeGraphics"
#define RESOURCE_CLASS "SchemeGraphics"
: (ROUND_FLOAT ((fabs (XW_Y_SLOPE (xw))) * (virtual_length))))
static int
-DEFUN (arg_x_coordinate, (arg, xw, direction),
- unsigned int arg AND
- struct xwindow * xw AND
- int direction)
+arg_x_coordinate (unsigned int arg, struct xwindow * xw, int direction)
{
return (X_COORDINATE (((float) (arg_real_number (arg))), xw, direction));
}
static int
-DEFUN (arg_y_coordinate, (arg, xw, direction),
- unsigned int arg AND
- struct xwindow * xw AND
- int direction)
+arg_y_coordinate (unsigned int arg, struct xwindow * xw, int direction)
{
return (Y_COORDINATE (((float) (arg_real_number (arg))), xw, direction));
}
static SCHEME_OBJECT
-DEFUN (x_coordinate_map, (xw, x), struct xwindow * xw AND unsigned int x)
+x_coordinate_map (struct xwindow * xw, unsigned int x)
{
return
(FLOAT_TO_FLONUM
}
static SCHEME_OBJECT
-DEFUN (y_coordinate_map, (xw, y), struct xwindow * xw AND unsigned int y)
+y_coordinate_map (struct xwindow * xw, unsigned int y)
{
return
(FLOAT_TO_FLONUM
}
\f
static void
-DEFUN (set_clip_rectangle, (xw, x_left, y_bottom, x_right, y_top),
- struct xwindow * xw AND
- int x_left AND
- int y_bottom AND
- int x_right AND
- int y_top)
+set_clip_rectangle (struct xwindow * xw,
+ int x_left,
+ int y_bottom,
+ int x_right,
+ int y_top)
{
XRectangle rectangles [1];
Display * display = (XW_DISPLAY (xw));
}
static void
-DEFUN (reset_clip_rectangle, (xw), struct xwindow * xw)
+reset_clip_rectangle (struct xwindow * xw)
{
set_clip_rectangle
(xw, 0, ((XW_Y_SIZE (xw)) - 1), ((XW_X_SIZE (xw)) - 1), 0);
}
static void
-DEFUN (reset_virtual_device_coordinates, (xw), struct xwindow * xw)
+reset_virtual_device_coordinates (struct xwindow * xw)
{
/* Note that the expression ((XW_c_SIZE (xw)) - 1) guarantees that
both limits of the device coordinates will be inside the window. */
reset_clip_rectangle (xw);
}
\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-SET-VDC-EXTENT", Prim_x_graphics_set_vdc_extent, 5, 5,
+DEFINE_PRIMITIVE ("X-GRAPHICS-SET-VDC-EXTENT", Prim_x_graphics_set_vdc_extent,
+ 5, 5,
"(X-GRAPHICS-SET-VDC-EXTENT WINDOW X-MIN Y-MIN X-MAX Y-MAX)\n\
Set the virtual device coordinates to the given values.")
{
PRIMITIVE_RETURN (UNSPECIFIC);
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-SET-CLIP-RECTANGLE", Prim_x_graphics_set_clip_rectangle, 5, 5,
+DEFINE_PRIMITIVE ("X-GRAPHICS-SET-CLIP-RECTANGLE",
+ Prim_x_graphics_set_clip_rectangle, 5, 5,
"(X-GRAPHICS-SET-CLIP-RECTANGLE WINDOW X-LEFT Y-BOTTOM X-RIGHT Y-TOP)\n\
Set the clip rectangle to the given coordinates.")
{
}
\f
static void
-DEFUN (process_event, (xw, event),
- struct xwindow * xw AND
- XEvent * event)
+process_event (struct xwindow * xw, XEvent * event)
{
}
static void
-DEFUN (reconfigure, (xw, width, height),
- struct xwindow * xw AND
- unsigned int width AND
- unsigned int height)
+reconfigure (struct xwindow * xw, unsigned int width, unsigned int height)
{
unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
unsigned int x_size = ((width < extra) ? 0 : (width - extra));
}
static void
-DEFUN (wm_set_size_hint, (xw, geometry_mask, x, y),
- struct xwindow * xw AND
- int geometry_mask AND
- int x AND
- int y)
+wm_set_size_hint (struct xwindow * xw, int geometry_mask, int x, int y)
{
unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
XSizeHints * size_hints = (XAllocSizeHints ());
struct drawing_attributes attributes;
struct xwindow_methods methods;
XSetWindowAttributes wattributes;
- CONST char * resource_name = RESOURCE_NAME;
- CONST char * resource_class = RESOURCE_CLASS;
+ const char * resource_name = RESOURCE_NAME;
+ const char * resource_class = RESOURCE_CLASS;
int map_p;
x_decode_window_map_arg
/* we assume a virtual coordinate system with X increasing left to
* right and Y increasing top to bottom. If we are wrong then we
* have to flip the axes and adjust the angles */
-
+
int x1 = (X_COORDINATE (virtual_device_x - radius_x, xw, 0));
int x2 = (X_COORDINATE (virtual_device_x + radius_x, xw, 0));
int y1 = (Y_COORDINATE (virtual_device_y + radius_y, xw, 0));
(graphics-operation g 'draw-arc x y r r a1 a2 #T)
(graphics-operation g 'set-foreground-color "black")
(graphics-operation g 'draw-arc x y r r a1 (+ a2 (if (< a2 0) 10 -10)) #T)
-
+
(graphics-operation g 'set-foreground-color "red")
(graphics-draw-text g x y ".O")
-
+
(let ((b1 (min a1 (+ a1 a2)))
(b2 (max a1 (+ a1 a2))))
(do ((a b1 (+ a 5)))
}
\f
static XPoint *
-DEFUN (floating_vector_point_args, (xw, x_index, y_index, return_n_points),
- struct xwindow * xw AND
- unsigned int x_index AND
- unsigned int y_index AND
- unsigned int * return_n_points)
+floating_vector_point_args (struct xwindow * xw,
+ unsigned int x_index,
+ unsigned int y_index,
+ unsigned int * return_n_points)
{
SCHEME_OBJECT x_vector = (ARG_REF (x_index));
SCHEME_OBJECT y_vector = (ARG_REF (y_index));
{
PRIMITIVE_HEADER (3);
{
- PTR position = dstack_position;
+ void * position = dstack_position;
struct xwindow * xw = (x_window_arg (1));
unsigned int n_points;
XPoint * points = (floating_vector_point_args (xw, 2, 3, (&n_points)));
{
PRIMITIVE_HEADER (3);
{
- PTR position = dstack_position;
+ void * position = dstack_position;
struct xwindow * xw = (x_window_arg (1));
unsigned int n_points;
XPoint * points = (floating_vector_point_args (xw, 2, 3, (&n_points)));
}
\f
static XPoint *
-DEFUN (x_polygon_vector_arg, (xw, argno),
- struct xwindow * xw AND
- unsigned int argno)
+x_polygon_vector_arg (struct xwindow * xw, unsigned int argno)
{
SCHEME_OBJECT vector = (VECTOR_ARG (argno));
unsigned long length = (VECTOR_LENGTH (vector));
if ((STRING_LENGTH (vector)) != (width * height))
error_bad_range_arg (1);
- vscan = (STRING_LOC (vector, 0));
+ vscan = (STRING_BYTE_PTR (vector));
for (y = 0; (y < height); y += 1)
for (x = 0; (x < width); x += 1)
XPutPixel (image, x, y, ((unsigned long) (*vscan++)));
/* -*-C-*-
-$Id: x11term.c,v 1.34 2007/01/05 21:19:25 cph Exp $
+$Id: x11term.c,v 1.35 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
&& ((XW_CURSOR_Y (xw)) < (y_end)))
static void
-DEFUN (xterm_erase_cursor, (xw), struct xwindow * xw)
+xterm_erase_cursor (struct xwindow * xw)
{
if (XW_CURSOR_VISIBLE_P (xw))
{
}
static void
-DEFUN (xterm_draw_cursor, (xw), struct xwindow * xw)
+xterm_draw_cursor (struct xwindow * xw)
{
if ((XW_CURSOR_ENABLED_P (xw)) && (! (XW_CURSOR_VISIBLE_P (xw))))
{
}
static void
-DEFUN (xterm_process_event, (xw, event),
- struct xwindow * xw AND
- XEvent * event)
+xterm_process_event (struct xwindow * xw, XEvent * event)
{
}
\f
static XSizeHints *
-DEFUN (xterm_make_size_hints, (font, extra),
- XFontStruct * font AND
- unsigned int extra)
+xterm_make_size_hints (XFontStruct * font, unsigned int extra)
{
XSizeHints * size_hints = (XAllocSizeHints ());
if (size_hints == 0)
xterm_set_wm_normal_hints (struct xwindow * xw, XSizeHints * size_hints)
{
XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints);
- XFree ((void *) size_hints);
+ XFree (size_hints);
}
static void
}
static void
-DEFUN (xterm_deallocate, (xw), struct xwindow * xw)
+xterm_deallocate (struct xwindow * xw)
{
free (XW_CHARACTER_MAP (xw));
free (XW_HIGHLIGHT_MAP (xw));
}
static SCHEME_OBJECT
-DEFUN (xterm_x_coordinate_map, (xw, x), struct xwindow * xw AND unsigned int x)
+xterm_x_coordinate_map (struct xwindow * xw, unsigned int x)
{
return (ulong_to_integer (x / (FONT_WIDTH (XW_FONT (xw)))));
}
static SCHEME_OBJECT
-DEFUN (xterm_y_coordinate_map, (xw, y), struct xwindow * xw AND unsigned int y)
+xterm_y_coordinate_map (struct xwindow * xw, unsigned int y)
{
return (ulong_to_integer (y / (FONT_HEIGHT (XW_FONT (xw)))));
}
static void
-DEFUN (xterm_copy_map_line, (xw, x_start, x_end, y_from, y_to),
- struct xwindow * xw AND
- unsigned int x_start AND
- unsigned int x_end AND
- unsigned int y_from AND
- unsigned int y_to)
+xterm_copy_map_line (struct xwindow * xw,
+ unsigned int x_start,
+ unsigned int x_end,
+ unsigned int y_from,
+ unsigned int y_to)
{
{
char * from_scan =
}
\f
static void
-DEFUN (xterm_dump_contents, (xw, x_start, x_end, y_start, y_end),
- struct xwindow * xw AND
- unsigned int x_start AND
- unsigned int x_end AND
- unsigned int y_start AND
- unsigned int y_end)
+xterm_dump_contents (struct xwindow * xw,
+ unsigned int x_start,
+ unsigned int x_end,
+ unsigned int y_start,
+ unsigned int y_end)
{
char * character_map = (XW_CHARACTER_MAP (xw));
char * highlight_map = (XW_HIGHLIGHT_MAP (xw));
}
static void
-DEFUN (xterm_dump_rectangle, (xw, x, y, width, height),
- struct xwindow * xw AND
- unsigned int x AND
- unsigned int y AND
- unsigned int width AND
- unsigned int height)
+xterm_dump_rectangle (struct xwindow * xw,
+ unsigned int x,
+ unsigned int y,
+ unsigned int width,
+ unsigned int height)
{
XFontStruct * font = (XW_FONT (xw));
unsigned int fwidth = (FONT_WIDTH (font));
#define MIN(x, y) (((x) < (y)) ? (x) : (y))
static void
-DEFUN (xterm_reconfigure, (xw, width, height),
- struct xwindow * xw AND
- unsigned int x_csize AND
- unsigned int y_csize)
+xterm_reconfigure (struct xwindow * xw,
+ unsigned int x_csize,
+ unsigned int y_csize)
{
if ((x_csize != (XW_X_CSIZE (xw))) || (y_csize != (XW_Y_CSIZE (xw))))
{
}
\f
static void
-DEFUN (xterm_clear_rectangle, (xw, x_start, x_end, y_start, y_end, hl),
- struct xwindow * xw AND
- unsigned int x_start AND
- unsigned int x_end AND
- unsigned int y_start AND
- unsigned int y_end AND
- unsigned int hl)
+xterm_clear_rectangle (struct xwindow * xw,
+ unsigned int x_start,
+ unsigned int x_end,
+ unsigned int y_start,
+ unsigned int y_end,
+ unsigned int hl)
{
unsigned int x_length = (x_end - x_start);
unsigned int y;
}
\f
static void
-DEFUN (xterm_scroll_lines_up, (xw, x_start, x_end, y_start, y_end, lines),
- struct xwindow * xw AND
- unsigned int x_start AND
- unsigned int x_end AND
- unsigned int y_start AND
- unsigned int y_end AND
- unsigned int lines)
+xterm_scroll_lines_up (struct xwindow * xw,
+ unsigned int x_start,
+ unsigned int x_end,
+ unsigned int y_start,
+ unsigned int y_end,
+ unsigned int lines)
{
{
unsigned int y_to = y_start;
}
\f
static void
-DEFUN (xterm_scroll_lines_down, (xw, x_start, x_end, y_start, y_end, lines),
- struct xwindow * xw AND
- unsigned int x_start AND
- unsigned int x_end AND
- unsigned int y_start AND
- unsigned int y_end AND
- unsigned int lines)
+xterm_scroll_lines_down (struct xwindow * xw,
+ unsigned int x_start,
+ unsigned int x_end,
+ unsigned int y_start,
+ unsigned int y_end,
+ unsigned int lines)
{
{
unsigned int y_to = y_end;
(XTERM_Y_PIXEL (xw, (y_start + lines))));
}
-DEFINE_PRIMITIVE ("XTERM-SCROLL-LINES-DOWN", Prim_xterm_scroll_lines_down, 6, 6,
+DEFINE_PRIMITIVE ("XTERM-SCROLL-LINES-DOWN", Prim_xterm_scroll_lines_down,
+ 6, 6,
"(XTERM-SCROLL-LINES-DOWN XTERM X-START X-END Y-START Y-END LINES)\n\
Scroll the contents of the region down by LINES.")
{
SCHEME_OBJECT string = (allocate_string (string_length));
if (string_length > 0)
{
- char * string_scan = ((char *) (STRING_LOC (string, 0)));
+ char * string_scan = (STRING_POINTER (string));
unsigned int y;
for (y = y_start; (y < y_end); y += 1)
{
error_bad_range_arg (6);
if (string_length > 0)
{
- char * string_scan = ((char *) (STRING_LOC (string, 0)));
+ char * string_scan = (STRING_POINTER (string));
unsigned int y;
for (y = y_start; (y < y_end); y += 1)
{
/* -*-C-*-
-$Id: xdebug.c,v 9.39 2007/01/05 21:19:25 cph Exp $
+$Id: xdebug.c,v 9.40 2007/04/22 16:31:24 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define DATUM_EQ 3
static SCHEME_OBJECT *
-DEFUN (Find_Occurrence, (From, To, What, Mode),
- fast SCHEME_OBJECT * From
- AND fast SCHEME_OBJECT * To
- AND SCHEME_OBJECT What
- AND int Mode)
+Find_Occurrence (SCHEME_OBJECT * From,
+ SCHEME_OBJECT * To,
+ SCHEME_OBJECT What,
+ int Mode)
{
- fast SCHEME_OBJECT Obj;
+ SCHEME_OBJECT Obj;
switch (Mode)
{ default:
{
From += OBJECT_DATUM (*From);
}
- else if ((OBJECT_DATUM (*From) == Obj) &&
- (!(GC_Type_Non_Pointer(*From))))
- {
+ else if ((OBJECT_DATUM (*From) == Obj)
+ && (!GC_TYPE_NON_POINTER (*From)))
return From;
- }
}
return To;
}
#define STORE_P 2
static long
-DEFUN (Find_In_Area, (Name, From, To, Obj, Mode, print_p, store_p),
- char * Name
- AND SCHEME_OBJECT * From AND SCHEME_OBJECT * To AND SCHEME_OBJECT Obj
- AND int Mode
- AND Boolean print_p AND Boolean store_p)
+Find_In_Area (char * Name,
+ SCHEME_OBJECT * From, SCHEME_OBJECT * To, SCHEME_OBJECT Obj,
+ int Mode,
+ bool print_p, bool store_p)
{
- fast SCHEME_OBJECT *Where;
- fast long occurrences = 0;
+ SCHEME_OBJECT *Where;
+ long occurrences = 0;
if (print_p)
{
}
\f
SCHEME_OBJECT
-DEFUN (Find_Who_Points, (Obj, Find_Mode, Collect_Mode),
- SCHEME_OBJECT Obj
- AND int Find_Mode AND int Collect_Mode)
+Find_Who_Points (SCHEME_OBJECT Obj, int Find_Mode, int Collect_Mode)
{
long n = 0;
SCHEME_OBJECT *Saved_Free = Free;
- Boolean print_p = (Collect_Mode & PRINT_P);
- Boolean store_p = (Collect_Mode & STORE_P);
+ bool print_p = (Collect_Mode & PRINT_P);
+ bool store_p = (Collect_Mode & STORE_P);
/* No overflow check done. Hopefully referenced few times, or invoked before
to find the count and insure that there is enough space. */
#endif
}
n += Find_In_Area("Constant Space",
- Constant_Space, Free_Constant, Obj,
+ constant_start, constant_alloc_next, Obj,
Find_Mode, print_p, store_p);
n += Find_In_Area("the Heap",
- Heap_Bottom, Saved_Free, Obj,
+ heap_start, Saved_Free, Obj,
Find_Mode, print_p, store_p);
-#ifndef USE_STACKLETS
n += Find_In_Area("the Stack",
- sp_register, Stack_Top, Obj,
+ stack_pointer, stack_end, Obj,
Find_Mode, print_p, store_p);
-#endif
if (print_p)
{
outf_console("Done.\n");
}
\f
void
-DEFUN (Print_Memory, (Where, How_Many),
- SCHEME_OBJECT * Where
- AND long How_Many)
+Print_Memory (SCHEME_OBJECT * Where, long How_Many)
{
- fast SCHEME_OBJECT *End = &Where[How_Many];
+ SCHEME_OBJECT *End = &Where[How_Many];
#if (SIZEOF_UNSIGNED_LONG == 4)
outf_console ("\n*** Memory from 0x%08lx to 0x%08lx (excluded) ***\n",
\f
/* Primitives to give scheme a handle on utilities from DEBUG.C */
-DEFINE_PRIMITIVE ("DEBUG-SHOW-PURE", Prim_debug_show_pure, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
-
- outf_console ("\n*** Constant & Pure Space: ***\n");
- Show_Pure ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
DEFINE_PRIMITIVE ("DEBUG-SHOW-ENV", Prim_debug_show_env, 1, 1, 0)
{
SCHEME_OBJECT environment;
PRIMITIVE_HEADER (0);
outf_console ("\n*** Back Trace: ***\n");
- Back_Trace (console_output);
+ Back_Trace (CONSOLE_OUTPUT);
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("DEBUG-FIND-SYMBOL", Prim_debug_find_symbol, 1, 1, 0)
{
- extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *));
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
{
- fast SCHEME_OBJECT string = (ARG_REF (1));
- fast SCHEME_OBJECT symbol = (find_symbol ((STRING_LENGTH (string)),
- (STRING_LOC (string, 0))));
+ SCHEME_OBJECT string = (ARG_REF (1));
+ SCHEME_OBJECT symbol = (find_symbol ((STRING_LENGTH (string)),
+ (STRING_POINTER (string))));
if (symbol == SHARP_F)
outf_console ("\nNot interned.\n");
else
PRIMITIVE_HEADER (2);
object = (ARG_REF (1));
Print_Memory
- (((GC_Type_Non_Pointer (object))
+ (((GC_TYPE_NON_POINTER (object))
? ((SCHEME_OBJECT *) (OBJECT_DATUM (object)))
: (OBJECT_ADDRESS (object))),
(OBJECT_DATUM (ARG_REF (2))));
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* $Id: zones.h,v 9.30 2007/01/05 21:19:25 cph Exp $
- *
- * Metering stuff.
- * We break all times into time zones suitable for external analysis.
- * Primitives may be included for accessing this information if desired
- * by supplying additional files.
- */
-\f
-#ifdef METERING
-extern long New_Time, Old_Time, Time_Meters[], Current_Zone;
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-#define Set_Time_Zone(Zone) \
-{ \
- New_Time = (OS_process_clock ()); \
- Time_Meters[Current_Zone] += New_Time-Old_Time; \
- Old_Time = New_Time; \
- Current_Zone = Zone; \
-}
-#else
-#define Set_Time_Zone(Zone) Current_Zone = Zone;
-#endif
-
-#define Save_Time_Zone(Zone) Saved_Zone = Current_Zone; Set_Time_Zone(Zone);
-#define Restore_Time_Zone() Set_Time_Zone(Saved_Zone);
-#else
-#define Set_Time_Zone(Zone)
-#define Save_Time_Zone(Zone)
-#define Restore_Time_Zone()
-#endif
-
-#define Zone_Working 0
-#define Zone_GetWork 1
-#define Zone_TTY_IO 2
-#define Zone_Disk_IO 3
-#define Zone_Purify 4
-#define Zone_GCLoop 5
-#define Zone_Global_Int 6
-#define Zone_Store_Lock 7
-#define Zone_Math 8
-#define Zone_GCIdle 9
-#define Zone_Lookup 10
-#define Zone_Scheduler 11
-
-#define Max_Meters 20
projects / mit-scheme.git / commitdiff