From 916d3a82f3700a0a1bd97c21bcc470d3b050f26f Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 2 Dec 1992 18:35:10 +0000 Subject: [PATCH] Add support for TC_RECORD data type. --- v7/src/microcode/interp.c | 23 ++++++++++++++++++++- v7/src/microcode/vector.c | 41 ++++++++++++++++++++++++++++++++++---- v7/src/microcode/version.h | 4 ++-- v8/src/microcode/interp.c | 23 ++++++++++++++++++++- v8/src/microcode/version.h | 4 ++-- 5 files changed, 85 insertions(+), 10 deletions(-) diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index 475bc36ac..6ca580058 100644 --- 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: /* 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 ff104a76b..674ee52a1 100644 --- 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))); } - + #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) diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 25e5c54de..45fef2c29 100644 --- 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 475bc36ac..6ca580058 100644 --- 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: /* 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 25e5c54de..45fef2c29 100644 --- 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 -- 2.25.1