Generalize support for flonum vectors.

diff --git a/v7/src/microcode/dfloat.c b/v7/src/microcode/dfloat.c
index 873e2a74a84fca6ecace0956afb138fad562ac9c..32c53a76b0213e08ec23c14ddb2157e3b2def33e 100644 (file)
--- a/v7/src/microcode/dfloat.c
+++ b/v7/src/microcode/dfloat.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: dfloat.c,v 1.4 1993/06/24 07:07:55 gjr Exp $
+$Id: dfloat.c,v 1.5 1993/12/05 06:08:10 cph Exp $
 
-Copyright (c) 1991 Massachusetts Institute of Technology
+Copyright (c) 1991-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -37,68 +37,62 @@ MIT in each case. */
 #include "scheme.h"
 #include "prims.h"
 \f
-#define FLONUM_SIZE (BYTES_TO_WORDS (sizeof (double)))
-
-#define ARG_DOUBLE_VECTOR(argument_number)                             \
-  ((FLONUM_P (ARG_REF (argument_number)))                              \
-   ? (ARG_REF (argument_number))                                       \
-   : ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
-
-#define ARG_DOUBLE_VECTOR_INDEX(argument_number, vector)               \
-  (arg_index_integer (argument_number,                                  \
-                     ((VECTOR_LENGTH (vector)) / FLONUM_SIZE)))
+#define FLOATING_VECTOR_INDEX_ARG(argument_number, vector)             \
+  (arg_index_integer ((argument_number), (FLOATING_VECTOR_LENGTH (vector))))
 
 DEFINE_PRIMITIVE ("FLOATING-VECTOR-CONS", Prim_floating_vector_cons, 1, 1, 0)
 {
-  long length = (arg_nonnegative_integer (1));
-  long length_in_words = length * FLONUM_SIZE;
-  SCHEME_OBJECT result;
-  fast double *vect;
-
   PRIMITIVE_HEADER (1);
-  ALIGN_FLOAT (Free);
-  Primitive_GC_If_Needed(length_in_words + 1);
-  result = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, Free));
-  *Free++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length_in_words));
-  vect = (double *) Free;
-  while ((length--) > 0) (*vect++) = 0.0;
-  Free = (SCHEME_OBJECT *) vect;
-  PRIMITIVE_RETURN (result);
+  {
+    long length = (arg_nonnegative_integer (1));
+    long length_in_words = (length * FLONUM_SIZE);
+    SCHEME_OBJECT result;
+    fast double *vect;
+
+    ALIGN_FLOAT (Free);
+    Primitive_GC_If_Needed (length_in_words + 1);
+    result = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, Free));
+    (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length_in_words));
+    vect = ((double *) Free);
+    while ((length--) > 0) (*vect++) = 0.0;
+    Free = ((SCHEME_OBJECT *) vect);
+    PRIMITIVE_RETURN (result);
+  }
 }
 
-DEFINE_PRIMITIVE( "FLOATING-VECTOR-REF", Prim_floating_vector_ref,
-                2, 2, 0)
-{ SCHEME_OBJECT vector = ARG_DOUBLE_VECTOR(1);
-  long index = ARG_DOUBLE_VECTOR_INDEX(2, vector);
-  double *where = ((double *) VECTOR_LOC(vector, (index * FLONUM_SIZE)));
-
+DEFINE_PRIMITIVE ("FLOATING-VECTOR-REF", Prim_floating_vector_ref, 2, 2, 0)
+{
   PRIMITIVE_HEADER (2);
-  Primitive_GC_If_Needed(FLONUM_SIZE + 1);
-  PRIMITIVE_RETURN (FLOAT_TO_FLONUM(*where));
+  {
+    SCHEME_OBJECT vector = (FLOATING_VECTOR_ARG (1));
+    Primitive_GC_If_Needed (FLONUM_SIZE + 1);
+    PRIMITIVE_RETURN
+      (FLOAT_TO_FLONUM
+       (FLOATING_VECTOR_REF (vector,
+                            (FLOATING_VECTOR_INDEX_ARG (2, vector)))));
+  }
 }
 
 extern double EXFUN (arg_flonum, (int));
 
-DEFINE_PRIMITIVE( "FLOATING-VECTOR-SET!", Prim_floating_vector_set,
-                3, 3, 0)
-{ SCHEME_OBJECT vector = ARG_DOUBLE_VECTOR(1);
-  long index = ARG_DOUBLE_VECTOR_INDEX(2, vector);
-  double new_value = arg_flonum(3);
-  double * where = ((double *) VECTOR_LOC(vector, (index * FLONUM_SIZE)));
-
+DEFINE_PRIMITIVE ("FLOATING-VECTOR-SET!", Prim_floating_vector_set, 3, 3, 0)
+{
   PRIMITIVE_HEADER (3);
-  /* Primitive_GC_If_Needed(FLONUM_SIZE + 1); */
-  *where = new_value;
-  /* double value = *where; */
-  PRIMITIVE_RETURN (SHARP_F);
+  {
+    SCHEME_OBJECT vector = (FLOATING_VECTOR_ARG (1));
+    FLOATING_VECTOR_SET
+      (vector,
+       (FLOATING_VECTOR_INDEX_ARG (2, vector)),
+       (arg_flonum (3)));
+  }
+  PRIMITIVE_RETURN (UNSPECIFIC);
 }
 
-DEFINE_PRIMITIVE ("FLOATING-VECTOR-LENGTH", Prim_floating_vector_length,
-                 1, 1, 0)
+DEFINE_PRIMITIVE ("FLOATING-VECTOR-LENGTH", Prim_floating_vector_length, 1, 1,
+                 0)
 {
-  SCHEME_OBJECT vector = (ARG_DOUBLE_VECTOR (1));
   PRIMITIVE_HEADER (1);
-
   PRIMITIVE_RETURN
-    (LONG_TO_UNSIGNED_FIXNUM ((VECTOR_LENGTH (vector)) / FLONUM_SIZE));
+    (LONG_TO_UNSIGNED_FIXNUM
+     (FLOATING_VECTOR_LENGTH (FLOATING_VECTOR_ARG (1))));
 }

diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h
index 4d0ed3f82d156757169bc0633a7cb17c32a5946f..ed64cff649a6418dc0c0ec1a715cfc2562d1b780 100644 (file)
--- a/v7/src/microcode/object.h
+++ b/v7/src/microcode/object.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: object.h,v 9.43 1993/10/14 19:19:02 gjr Exp $
+$Id: object.h,v 9.44 1993/12/05 06:07:52 cph Exp $
 
 Copyright (c) 1987-1993 Massachusetts Institute of Technology
 
@@ -447,6 +447,8 @@ extern SCHEME_OBJECT * memory_base;
 
 /* Flonum Operations */
 
+#define FLONUM_SIZE (BYTES_TO_WORDS (sizeof (double)))
+
 #define FLONUM_TO_DOUBLE(object)                                       \
   (* ((double *) (MEMORY_LOC ((object), 1))))
 
@@ -456,6 +458,20 @@ extern SCHEME_OBJECT * memory_base;
 #define FLONUM_TRUNCATE(object)                                                \
   (double_to_flonum (double_truncate (FLONUM_TO_DOUBLE (object))))
 
+/* Flonum-vector Operations */
+
+#define FLOATING_VECTOR_LENGTH(vector)                                 \
+  ((VECTOR_LENGTH (vector)) / FLONUM_SIZE)
+
+#define FLOATING_VECTOR_LOC(vector, index)                             \
+  ((double *) (VECTOR_LOC ((vector), ((index) * FLONUM_SIZE))))
+
+#define FLOATING_VECTOR_REF(vector, index)                             \
+  (* (FLOATING_VECTOR_LOC ((vector), (index))))
+
+#define FLOATING_VECTOR_REF(vector, index, x)                          \
+  (* (FLOATING_VECTOR_LOC ((vector), (index)))) = ((double) (x))
+
 /* Numeric Type Conversions */
 
 #define BIGNUM_TO_FIXNUM_P(bignum)                                     \

diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h
index dcc7d9699d2c8d450c5f74c3d2f8fc02f4baa848..040d2e1e85503e6df8100ad0dd4f4ed13c95312f 100644 (file)
--- a/v7/src/microcode/prims.h
+++ b/v7/src/microcode/prims.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: prims.h,v 9.43 1993/08/03 08:29:59 gjr Exp $
+$Id: prims.h,v 9.44 1993/12/05 06:08:03 cph Exp $
 
 Copyright (c) 1987-1993 Massachusetts Institute of Technology
 
@@ -136,7 +136,7 @@ extern long EXFUN (arg_ascii_integer, (int));
 
 #define FLOATING_VECTOR_ARG(arg)                                       \
   ((FLONUM_P (ARG_REF (arg)))                                          \
-   ? ((double *) (VECTOR_LOC (ARG_REF(arg), 0)))                       \
-   : ((error_wrong_type_arg (arg)), ((double *) 0)))
+   ? (ARG_REF (arg))                                                   \
+   : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
 
 #endif /* SCM_PRIMS_H */

diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h
index 4d0ed3f82d156757169bc0633a7cb17c32a5946f..ed64cff649a6418dc0c0ec1a715cfc2562d1b780 100644 (file)
--- a/v8/src/microcode/object.h
+++ b/v8/src/microcode/object.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: object.h,v 9.43 1993/10/14 19:19:02 gjr Exp $
+$Id: object.h,v 9.44 1993/12/05 06:07:52 cph Exp $
 
 Copyright (c) 1987-1993 Massachusetts Institute of Technology
 
@@ -447,6 +447,8 @@ extern SCHEME_OBJECT * memory_base;
 
 /* Flonum Operations */
 
+#define FLONUM_SIZE (BYTES_TO_WORDS (sizeof (double)))
+
 #define FLONUM_TO_DOUBLE(object)                                       \
   (* ((double *) (MEMORY_LOC ((object), 1))))
 
@@ -456,6 +458,20 @@ extern SCHEME_OBJECT * memory_base;
 #define FLONUM_TRUNCATE(object)                                                \
   (double_to_flonum (double_truncate (FLONUM_TO_DOUBLE (object))))
 
+/* Flonum-vector Operations */
+
+#define FLOATING_VECTOR_LENGTH(vector)                                 \
+  ((VECTOR_LENGTH (vector)) / FLONUM_SIZE)
+
+#define FLOATING_VECTOR_LOC(vector, index)                             \
+  ((double *) (VECTOR_LOC ((vector), ((index) * FLONUM_SIZE))))
+
+#define FLOATING_VECTOR_REF(vector, index)                             \
+  (* (FLOATING_VECTOR_LOC ((vector), (index))))
+
+#define FLOATING_VECTOR_REF(vector, index, x)                          \
+  (* (FLOATING_VECTOR_LOC ((vector), (index)))) = ((double) (x))
+
 /* Numeric Type Conversions */
 
 #define BIGNUM_TO_FIXNUM_P(bignum)                                     \