From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 5 Dec 1993 06:08:10 +0000 (+0000)
Subject: Generalize support for flonum vectors.
X-Git-Tag: 20090517-FFI~7398
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1fb02f9bc961524d7eb572dda6f21b903c8e1e2a;p=mit-scheme.git

Generalize support for flonum vectors.
---

diff --git a/v7/src/microcode/dfloat.c b/v7/src/microcode/dfloat.c
index 873e2a74a..32c53a76b 100644
--- 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"
 
-#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 4d0ed3f82..ed64cff64 100644
--- 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 dcc7d9699..040d2e1e8 100644
--- 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 4d0ed3f82..ed64cff64 100644
--- 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)					\