Add support for TC_RECORD data type.

diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c
index 475bc36ac1d3161723915ba874fee0d507c2ab5b..6ca5800585b67ca2033851ed095d2e85ce58b1bd 100644 (file)
--- a/v7/src/microcode/interp.c
+++ b/v7/src/microcode/interp.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: interp.c,v 9.70 1992/10/27 01:25:01 jinx Exp $
+$Id: interp.c,v 9.71 1992/12/02 18:34:52 cph Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -1527,6 +1527,26 @@ apply_dispatch:
 \f
 /* Interpret(), continued */
 
+         case TC_RECORD:
+         {
+           SCHEME_OBJECT record_type = (VECTOR_REF (Function, 0));
+           if ((RECORD_P (record_type))
+               && ((VECTOR_LENGTH (record_type)) >= 2)
+               && ((VECTOR_REF (record_type, 1)) != SHARP_F)
+               && ((VECTOR_REF (record_type, 1)) != Function))
+             {
+               SCHEME_OBJECT nargs_object = (STACK_POP ());
+               STACK_PUSH (VECTOR_REF (record_type, 1));
+               STACK_PUSH
+                 (MAKE_OBJECT ((OBJECT_TYPE (nargs_object)),
+                               ((OBJECT_DATUM (nargs_object)) + 1)));
+               Stack_Check (Stack_Pointer);
+               goto Internal_Apply;
+             }
+           else
+             goto internal_apply_inapplicable;
+         }
+
          case TC_PROCEDURE:
          {
            fast long nargs;
@@ -1827,6 +1847,7 @@ return_from_compiled_code:
           }
 
           default:
+         internal_apply_inapplicable:
             Apply_Error (ERR_INAPPLICABLE_OBJECT);
         }       /* End of switch in RC_INTERNAL_APPLY */
       }         /* End of RC_INTERNAL_APPLY case */

diff --git a/v7/src/microcode/vector.c b/v7/src/microcode/vector.c
index ff104a76b35711b9fa6b77b971fefa51dcacfbf8..674ee52a136a72505dc2e4a98141d21cd8282e8c 100644 (file)
--- a/v7/src/microcode/vector.c
+++ b/v7/src/microcode/vector.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/vector.c,v 9.34 1991/10/29 22:55:11 jinx Exp $
+$Id: vector.c,v 9.35 1992/12/02 18:34:46 cph Exp $
 
-Copyright (c) 1987-1991 Massachusetts Institute of Technology
+Copyright (c) 1987-92 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -42,6 +42,11 @@ MIT in each case. */
    ? (ARG_REF (argument_number))                                       \
    : ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
 
+#define ARG_RECORD(argument_number)                                    \
+  ((RECORD_P (ARG_REF (argument_number)))                              \
+   ? (ARG_REF (argument_number))                                       \
+   : ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
+
 #define ARG_VECTOR_INDEX(argument_number, vector)                      \
   (arg_index_integer (argument_number, (VECTOR_LENGTH (vector))))
 
@@ -116,6 +121,25 @@ DEFINE_PRIMITIVE ("VECTOR", Prim_vector, 0, LEXPR, 0)
   }
 }
 
+DEFINE_PRIMITIVE ("%RECORD", Prim_record, 0, LEXPR, 0)
+{
+  PRIMITIVE_HEADER (LEXPR);
+  {
+    long nargs = (LEXPR_N_ARGUMENTS ());
+    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));
+      while (argument_scan != argument_limit)
+       (*result_scan++) = (STACK_LOCATIVE_POP (argument_scan));
+      PRIMITIVE_RETURN (result);
+    }
+  }
+}
+
 DEFINE_PRIMITIVE ("SYSTEM-VECTOR?", Prim_sys_vector, 1, 1, 0)
 {
   fast SCHEME_OBJECT object;
@@ -123,7 +147,7 @@ DEFINE_PRIMITIVE ("SYSTEM-VECTOR?", Prim_sys_vector, 1, 1, 0)
   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_VECTOR_P (object)));
 }
-
+\f
 #define VECTOR_LENGTH_PRIMITIVE(arg_type)                              \
 {                                                                      \
   fast SCHEME_OBJECT vector;                                           \
@@ -132,9 +156,12 @@ DEFINE_PRIMITIVE ("SYSTEM-VECTOR?", Prim_sys_vector, 1, 1, 0)
   PRIMITIVE_RETURN (long_to_integer (VECTOR_LENGTH (vector)));         \
 }
 
-DEFINE_PRIMITIVE ("VECTOR-LENGTH", Prim_vector_size, 1, 1, 0)
+DEFINE_PRIMITIVE ("VECTOR-LENGTH", Prim_vector_length, 1, 1, 0)
      VECTOR_LENGTH_PRIMITIVE (ARG_VECTOR)
 
+DEFINE_PRIMITIVE ("%RECORD-LENGTH", Prim_record_length, 1, 1, 0)
+     RECORD_LENGTH_PRIMITIVE (ARG_RECORD)
+
 DEFINE_PRIMITIVE ("SYSTEM-VECTOR-SIZE", Prim_sys_vec_size, 1, 1, 0)
      VECTOR_LENGTH_PRIMITIVE (ARG_GC_VECTOR)
 
@@ -150,6 +177,9 @@ DEFINE_PRIMITIVE ("SYSTEM-VECTOR-SIZE", Prim_sys_vec_size, 1, 1, 0)
 DEFINE_PRIMITIVE ("VECTOR-REF", Prim_vector_ref, 2, 2, 0)
      VECTOR_REF_PRIMITIVE (ARG_VECTOR)
 
+DEFINE_PRIMITIVE ("%RECORD-REF", Prim_record_ref, 2, 2, 0)
+     RECORD_REF_PRIMITIVE (ARG_RECORD)
+
 DEFINE_PRIMITIVE ("SYSTEM-VECTOR-REF", Prim_sys_vector_ref, 2, 2, 0)
      VECTOR_REF_PRIMITIVE (ARG_GC_VECTOR)
 
@@ -169,6 +199,9 @@ DEFINE_PRIMITIVE ("SYSTEM-VECTOR-REF", Prim_sys_vector_ref, 2, 2, 0)
 DEFINE_PRIMITIVE ("VECTOR-SET!", Prim_vector_set, 3, 3, 0)
      VECTOR_SET_PRIMITIVE (ARG_VECTOR)
 
+DEFINE_PRIMITIVE ("%RECORD-SET!", Prim_record_set, 3, 3, 0)
+     RECORD_SET_PRIMITIVE (ARG_RECORD)
+
 DEFINE_PRIMITIVE ("SYSTEM-VECTOR-SET!", Prim_sys_vec_set, 3, 3, 0)
      VECTOR_SET_PRIMITIVE (ARG_GC_VECTOR)
 \f

diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h
index 25e5c54de57a5369b00ce463e01aa19b614a2a16..45fef2c2950da8c6c95637776985b3483d58df09 100644 (file)
--- a/v7/src/microcode/version.h
+++ b/v7/src/microcode/version.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: version.h,v 11.122 1992/10/27 21:59:55 jinx Exp $
+$Id: version.h,v 11.123 1992/12/02 18:35:10 cph Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -46,5 +46,5 @@ MIT in each case. */
 #define VERSION                11
 #endif
 #ifndef SUBVERSION
-#define SUBVERSION     122
+#define SUBVERSION     123
 #endif

diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c
index 475bc36ac1d3161723915ba874fee0d507c2ab5b..6ca5800585b67ca2033851ed095d2e85ce58b1bd 100644 (file)
--- a/v8/src/microcode/interp.c
+++ b/v8/src/microcode/interp.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: interp.c,v 9.70 1992/10/27 01:25:01 jinx Exp $
+$Id: interp.c,v 9.71 1992/12/02 18:34:52 cph Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -1527,6 +1527,26 @@ apply_dispatch:
 \f
 /* Interpret(), continued */
 
+         case TC_RECORD:
+         {
+           SCHEME_OBJECT record_type = (VECTOR_REF (Function, 0));
+           if ((RECORD_P (record_type))
+               && ((VECTOR_LENGTH (record_type)) >= 2)
+               && ((VECTOR_REF (record_type, 1)) != SHARP_F)
+               && ((VECTOR_REF (record_type, 1)) != Function))
+             {
+               SCHEME_OBJECT nargs_object = (STACK_POP ());
+               STACK_PUSH (VECTOR_REF (record_type, 1));
+               STACK_PUSH
+                 (MAKE_OBJECT ((OBJECT_TYPE (nargs_object)),
+                               ((OBJECT_DATUM (nargs_object)) + 1)));
+               Stack_Check (Stack_Pointer);
+               goto Internal_Apply;
+             }
+           else
+             goto internal_apply_inapplicable;
+         }
+
          case TC_PROCEDURE:
          {
            fast long nargs;
@@ -1827,6 +1847,7 @@ return_from_compiled_code:
           }
 
           default:
+         internal_apply_inapplicable:
             Apply_Error (ERR_INAPPLICABLE_OBJECT);
         }       /* End of switch in RC_INTERNAL_APPLY */
       }         /* End of RC_INTERNAL_APPLY case */

diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h
index 25e5c54de57a5369b00ce463e01aa19b614a2a16..45fef2c2950da8c6c95637776985b3483d58df09 100644 (file)
--- a/v8/src/microcode/version.h
+++ b/v8/src/microcode/version.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: version.h,v 11.122 1992/10/27 21:59:55 jinx Exp $
+$Id: version.h,v 11.123 1992/12/02 18:35:10 cph Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -46,5 +46,5 @@ MIT in each case. */
 #define VERSION                11
 #endif
 #ifndef SUBVERSION
-#define SUBVERSION     122
+#define SUBVERSION     123
 #endif