From: Chris Hanson Date: Wed, 14 Mar 2018 05:54:25 +0000 (-0700) Subject: Implement applicable records. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~213 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=83ed3f3a474eb6d6793801ed1c29e04385a8a996;p=mit-scheme.git Implement applicable records. --- diff --git a/src/microcode/cmpint.c b/src/microcode/cmpint.c index f04b1c629..ed2babfb4 100644 --- a/src/microcode/cmpint.c +++ b/src/microcode/cmpint.c @@ -626,9 +626,21 @@ DEFINE_SCHEME_UTILITY_2 (comutil_apply, procedure, frame_size) STACK_PUSH (procedure); procedure = operator; frame_size += 1; + goto invoke_compiled_entry; } - /* fall through */ + case TC_RECORD: + { + SCHEME_OBJECT applicator = record_applicator(procedure); + if (!CC_ENTRY_P (applicator)) + goto handle_in_interpreter; + STACK_PUSH (procedure); + procedure = applicator; + frame_size += 1; + goto invoke_compiled_entry; + } + + invoke_compiled_entry: case TC_COMPILED_ENTRY: { long code @@ -1437,40 +1449,50 @@ DEFINE_SCHEME_ENTRY (comp_error_restart) void apply_compiled_from_primitive (unsigned long n_args, SCHEME_OBJECT procedure) { - while ((OBJECT_TYPE (procedure)) == TC_ENTITY) + while (true) { - { - 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)))) + switch (OBJECT_TYPE (procedure)) + { + case TC_COMPILED_ENTRY: + setup_compiled_invocation_from_primitive (procedure, n_args); + return; + + case TC_ENTITY: { - procedure = (VECTOR_REF (data, frame_size)); - continue; + unsigned long frame_size = (n_args + 1); + SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA)); + if ((VECTOR_P (data)) + && (frame_size < (VECTOR_LENGTH (data))) + && ((VECTOR_REF (data, 0)) + == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG)))) + procedure = (VECTOR_REF (data, frame_size)); + else + { + STACK_PUSH (procedure); + n_args += 1; + procedure = (MEMORY_REF (procedure, ENTITY_OPERATOR)); + } } - } - { - SCHEME_OBJECT operator = (MEMORY_REF (procedure, ENTITY_OPERATOR)); - if (CC_ENTRY_P (operator)) + continue; + + case TC_RECORD: { + SCHEME_OBJECT applicator = record_applicator(procedure); + if (applicator == SHARP_F) + goto handle_in_interpreter; STACK_PUSH (procedure); n_args += 1; - procedure = operator; + procedure = applicator; } - } - break; - } + continue; - if (CC_ENTRY_P (procedure)) - setup_compiled_invocation_from_primitive (procedure, n_args); - else - { - STACK_PUSH (procedure); - PUSH_APPLY_FRAME_HEADER (n_args); - PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); + handle_in_interpreter: + default: + STACK_PUSH (procedure); + PUSH_APPLY_FRAME_HEADER (n_args); + PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); + return; + } } } diff --git a/src/microcode/cmpint.h b/src/microcode/cmpint.h index 779de267a..6eb875699 100644 --- a/src/microcode/cmpint.h +++ b/src/microcode/cmpint.h @@ -450,7 +450,6 @@ extern void declare_builtin (unsigned long, const char *); 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; diff --git a/src/microcode/extern.h b/src/microcode/extern.h index 4e59c8783..bedf025d2 100644 --- a/src/microcode/extern.h +++ b/src/microcode/extern.h @@ -291,6 +291,7 @@ extern SCHEME_OBJECT allocate_non_marked_vector extern SCHEME_OBJECT allocate_marked_vector (unsigned int, unsigned long, bool); extern SCHEME_OBJECT make_vector (unsigned long, SCHEME_OBJECT, bool); +extern SCHEME_OBJECT record_applicator (SCHEME_OBJECT); 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 *); diff --git a/src/microcode/fixobj.h b/src/microcode/fixobj.h index 49343a40a..e1269bc52 100644 --- a/src/microcode/fixobj.h +++ b/src/microcode/fixobj.h @@ -47,8 +47,8 @@ USA. #define STEPPER_STATE 0x0E #define FIXED_OBJECTS_SLOTS 0x0F /* Names of these slots. */ #define FIXOBJ_FILES_TO_DELETE 0x10 /* Temporary files to delete. */ -/* #define UNUSED 0x11 */ -/* #define UNUSED 0x12 */ +#define FIXOBJ_RECORD_TAG 0x11 /* Tag identifying standard record. */ +#define FIXOBJ_RECORD_APP_INDEX 0x12 /* Index of record applicator. */ #define DUMMY_HISTORY 0x13 /* Empty history structure. */ #define Bignum_One 0x14 /* Cache for bignum one. */ /* #define UNUSED 0x15 */ @@ -137,8 +137,8 @@ USA. /* 0x0E */ "stepper-state", \ /* 0x0F */ "microcode-fixed-objects-slots", \ /* 0x10 */ "files-to-delete", \ - /* 0x11 */ 0, \ - /* 0x12 */ 0, \ + /* 0x11 */ "record-dispatch-tag", \ + /* 0x12 */ "record-applicator-index", \ /* 0x13 */ "dummy-history", \ /* 0x14 */ "bignum-one", \ /* 0x15 */ 0, \ diff --git a/src/microcode/interp.c b/src/microcode/interp.c index a26260f16..dc4a3a4f5 100644 --- a/src/microcode/interp.c +++ b/src/microcode/interp.c @@ -426,6 +426,7 @@ Interpret (void) case TC_PROCEDURE: case TC_QUAD: case TC_RATNUM: + case TC_RECORD: case TC_REFERENCE_TRAP: case TC_RETURN_CODE: case TC_UNICODE_STRING: @@ -875,6 +876,7 @@ Interpret (void) (STACK_REF (0)) = (MEMORY_REF (Function, ENTITY_OPERATOR)); PUSH_APPLY_FRAME_HEADER (frame_size); + entity_apply: /* 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 @@ -883,190 +885,201 @@ Interpret (void) goto internal_apply; } - case TC_PROCEDURE: + case TC_RECORD: { + SCHEME_OBJECT applicator = record_applicator(Function); + if (applicator == SHARP_F) + APPLICATION_ERROR (ERR_INAPPLICABLE_OBJECT); unsigned long frame_size = (APPLY_FRAME_SIZE ()); - Function = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR)); + (STACK_REF (0)) = applicator; + PUSH_APPLY_FRAME_HEADER (frame_size); + goto entity_apply; + } + + case TC_PROCEDURE: { - SCHEME_OBJECT formals - = (MEMORY_REF (Function, LAMBDA_FORMALS)); + unsigned long frame_size = (APPLY_FRAME_SIZE ()); + Function = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR)); + { + SCHEME_OBJECT formals + = (MEMORY_REF (Function, LAMBDA_FORMALS)); - if ((frame_size != (VECTOR_LENGTH (formals))) - && (((OBJECT_TYPE (Function)) != TC_LEXPR) - || (frame_size < (VECTOR_LENGTH (formals))))) - APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - if (GC_NEEDED_P (frame_size + 1)) + if ((frame_size != (VECTOR_LENGTH (formals))) + && (((OBJECT_TYPE (Function)) != TC_LEXPR) + || (frame_size < (VECTOR_LENGTH (formals))))) + APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); + } + if (GC_NEEDED_P (frame_size + 1)) + { + PREPARE_APPLY_INTERRUPT (); + IMMEDIATE_GC (frame_size + 1); + } { - PREPARE_APPLY_INTERRUPT (); - IMMEDIATE_GC (frame_size + 1); + 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)); } - { - 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 ((APPLY_FRAME_SIZE ()) != 2) - APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); - SET_VAL (* (APPLY_FRAME_ARGS ())); - unpack_control_point (Function); - RESET_HISTORY (); - goto pop_return; + case TC_CONTROL_POINT: + if ((APPLY_FRAME_SIZE ()) != 2) + APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); + 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. */ + /* After checking the number of arguments, remove the + frame header since primitives do not expect it. */ - case TC_PRIMITIVE: - if (!IMPLEMENTED_PRIMITIVE_P (Function)) - APPLICATION_ERROR (ERR_UNIMPLEMENTED_PRIMITIVE); - { - unsigned long n_args = (APPLY_FRAME_N_ARGS ()); - - /* Note that the first test below will fail for lexpr - primitives. */ + case TC_PRIMITIVE: + if (!IMPLEMENTED_PRIMITIVE_P (Function)) + APPLICATION_ERROR (ERR_UNIMPLEMENTED_PRIMITIVE); + { + unsigned long n_args = (APPLY_FRAME_N_ARGS ()); + + /* Note that the first test below will fail for lexpr + primitives. */ + + if (n_args != (PRIMITIVE_ARITY (Function))) + { + if ((PRIMITIVE_ARITY (Function)) != LEXPR_PRIMITIVE_ARITY) + APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); + 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; + } - if (n_args != (PRIMITIVE_ARITY (Function))) - { - if ((PRIMITIVE_ARITY (Function)) != LEXPR_PRIMITIVE_ARITY) + case TC_EXTENDED_PROCEDURE: + { + SCHEME_OBJECT lambda; + SCHEME_OBJECT temp; + 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 = (POP_APPLY_FRAME_HEADER ()); + lambda = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR)); + Function = (MEMORY_REF (lambda, ELAMBDA_NAMES)); + nparams = ((VECTOR_LENGTH (Function)) - 1); + Function = (Get_Count_Elambda (lambda)); + formals = (Elambda_Formals_Count (Function)); + params = ((Elambda_Opts_Count (Function)) + formals); + rest_flag = (Elambda_Rest_Flag (Function)); + auxes = (nparams - (params + rest_flag)); + + if ((nargs < formals) || (!rest_flag && (nargs > params))) + { + PUSH_APPLY_FRAME_HEADER (nargs); APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); - 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; - } - - case TC_EXTENDED_PROCEDURE: - { - SCHEME_OBJECT lambda; - SCHEME_OBJECT temp; - 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 = (POP_APPLY_FRAME_HEADER ()); - lambda = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR)); - Function = (MEMORY_REF (lambda, ELAMBDA_NAMES)); - nparams = ((VECTOR_LENGTH (Function)) - 1); - Function = (Get_Count_Elambda (lambda)); - formals = (Elambda_Formals_Count (Function)); - params = ((Elambda_Opts_Count (Function)) + formals); - rest_flag = (Elambda_Rest_Flag (Function)); - auxes = (nparams - (params + rest_flag)); - - if ((nargs < formals) || (!rest_flag && (nargs > params))) - { - 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_NEEDED_P - (size + 1 - + ((nargs > params) - ? (2 * (nargs - params)) - : 0))) - { - PUSH_APPLY_FRAME_HEADER (nargs); - PREPARE_APPLY_INTERRUPT (); - IMMEDIATE_GC + } + /* size includes the procedure slot, but not the header. */ + size = (params + rest_flag + auxes + 1); + if (GC_NEEDED_P (size + 1 + ((nargs > params) ? (2 * (nargs - params)) - : 0)); - } - scan = Free; - temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan)); - (*scan++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, size)); - if (nargs <= params) - { - for (i = (nargs + 1); (--i) >= 0; ) - (*scan++) = (STACK_POP ()); - for (i = (params - nargs); (--i) >= 0; ) - (*scan++) = DEFAULT_OBJECT; - if (rest_flag) - (*scan++) = EMPTY_LIST; - for (i = auxes; (--i) >= 0; ) - (*scan++) = UNASSIGNED_OBJECT; - } - else - { - /* rest_flag must be true. */ - SCHEME_OBJECT list - = (MAKE_POINTER_OBJECT (TC_LIST, (scan + size))); - for (i = (params + 1); (--i) >= 0; ) - (*scan++) = (STACK_POP ()); - (*scan++) = list; - for (i = auxes; (--i) >= 0; ) - (*scan++) = UNASSIGNED_OBJECT; - /* Now scan == OBJECT_ADDRESS (list) */ - for (i = (nargs - params); (--i) >= 0; ) - { + : 0))) + { + PUSH_APPLY_FRAME_HEADER (nargs); + PREPARE_APPLY_INTERRUPT (); + IMMEDIATE_GC + (size + 1 + + ((nargs > params) + ? (2 * (nargs - params)) + : 0)); + } + scan = Free; + temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan)); + (*scan++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, size)); + if (nargs <= params) + { + for (i = (nargs + 1); (--i) >= 0; ) (*scan++) = (STACK_POP ()); - (*scan) = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1)); - scan += 1; - } - (scan[-1]) = EMPTY_LIST; - } - - Free = scan; - SET_ENV (temp); - REDUCES_TO (Get_Body_Elambda (lambda)); - } + for (i = (params - nargs); (--i) >= 0; ) + (*scan++) = DEFAULT_OBJECT; + if (rest_flag) + (*scan++) = EMPTY_LIST; + for (i = auxes; (--i) >= 0; ) + (*scan++) = UNASSIGNED_OBJECT; + } + else + { + /* rest_flag must be true. */ + SCHEME_OBJECT list + = (MAKE_POINTER_OBJECT (TC_LIST, (scan + size))); + for (i = (params + 1); (--i) >= 0; ) + (*scan++) = (STACK_POP ()); + (*scan++) = list; + for (i = auxes; (--i) >= 0; ) + (*scan++) = UNASSIGNED_OBJECT; + /* Now scan == OBJECT_ADDRESS (list) */ + for (i = (nargs - params); (--i) >= 0; ) + { + (*scan++) = (STACK_POP ()); + (*scan) = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1)); + scan += 1; + } + (scan[-1]) = EMPTY_LIST; + } + + Free = scan; + SET_ENV (temp); + REDUCES_TO (Get_Body_Elambda (lambda)); + } #ifdef CC_SUPPORT_P - case TC_COMPILED_ENTRY: - { - guarantee_cc_return (1 + (APPLY_FRAME_SIZE ())); - dispatch_code = (apply_compiled_procedure ()); + case TC_COMPILED_ENTRY: + { + guarantee_cc_return (1 + (APPLY_FRAME_SIZE ())); + dispatch_code = (apply_compiled_procedure ()); - return_from_compiled_code: - switch (dispatch_code) - { - case PRIM_DONE: - goto pop_return; + return_from_compiled_code: + switch (dispatch_code) + { + case PRIM_DONE: + goto pop_return; - case PRIM_APPLY: - goto internal_apply; + case PRIM_APPLY: + goto internal_apply; - case PRIM_INTERRUPT: - SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); + case PRIM_INTERRUPT: + SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); - case PRIM_APPLY_INTERRUPT: - PREPARE_APPLY_INTERRUPT (); - SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); + case PRIM_APPLY_INTERRUPT: + PREPARE_APPLY_INTERRUPT (); + SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); - case ERR_INAPPLICABLE_OBJECT: - case ERR_WRONG_NUMBER_OF_ARGUMENTS: - APPLICATION_ERROR (dispatch_code); + case ERR_INAPPLICABLE_OBJECT: + case ERR_WRONG_NUMBER_OF_ARGUMENTS: + APPLICATION_ERROR (dispatch_code); - default: - Do_Micro_Error (dispatch_code, true); - goto internal_apply; - } - } + default: + Do_Micro_Error (dispatch_code, true); + goto internal_apply; + } + } #endif - default: - APPLICATION_ERROR (ERR_INAPPLICABLE_OBJECT); - } + default: + APPLICATION_ERROR (ERR_INAPPLICABLE_OBJECT); + } } case RC_JOIN_STACKLETS: diff --git a/src/microcode/utils.c b/src/microcode/utils.c index 3d564af0d..8052c5500 100644 --- a/src/microcode/utils.c +++ b/src/microcode/utils.c @@ -506,6 +506,16 @@ interpreter_applicable_p (SCHEME_OBJECT object) object = (MEMORY_REF (object, ENTITY_OPERATOR)); goto tail_recurse; } + + case TC_RECORD: + { + SCHEME_OBJECT applicator = record_applicator(object); + if (applicator == SHARP_F) + return (false); + object = applicator; + goto tail_recurse; + } + #ifdef CC_SUPPORT_P case TC_COMPILED_ENTRY: { diff --git a/src/microcode/vector.c b/src/microcode/vector.c index a7193bf7d..526dacb81 100644 --- a/src/microcode/vector.c +++ b/src/microcode/vector.c @@ -392,3 +392,31 @@ DEFINE_PRIMITIVE ("SUBVECTOR-FILL!", Prim_vector_fill, 4, 4, 0) (*scan++) = fill_value; PRIMITIVE_RETURN (UNSPECIFIC); } + +/* An applicable record is one whose tag is FIXOBJ_RECORD_TAG and + which has an applicator at FIXOBJ_RECORD_APP_INDEX within that tag. + It is applied just like an entity: the record is passed as the + first argument. + + Returns the applicator if present, else #F. */ +SCHEME_OBJECT +record_applicator (SCHEME_OBJECT record) +{ + SCHEME_OBJECT metatag = (VECTOR_REF (fixed_objects, FIXOBJ_RECORD_TAG)); + SCHEME_OBJECT index_object + = (VECTOR_REF (fixed_objects, FIXOBJ_RECORD_APP_INDEX)); + + if ((RECORD_P (metatag)) + && (FIXNUM_P (index_object)) + && (FIXNUM_TO_ULONG_P (index_object))) + { + unsigned long index = (FIXNUM_TO_ULONG (index_object)); + SCHEME_OBJECT tag = (VECTOR_REF (record, 0)); + if (RECORD_P (tag) + && ((VECTOR_REF (tag, 0)) == metatag) + && (index < (VECTOR_LENGTH (tag)))) { + return (VECTOR_REF (tag, index)); + } + } + return SHARP_F; +} diff --git a/src/runtime/dispatch-tag.scm b/src/runtime/dispatch-tag.scm index 88e91cbb6..b740c78c1 100644 --- a/src/runtime/dispatch-tag.scm +++ b/src/runtime/dispatch-tag.scm @@ -77,12 +77,18 @@ USA. (define-integrable (%tag-supersets tag) (%record-ref tag 11)) -(define-integrable (%dispatch-tag-extra-ref tag index) - (%record-ref tag (fix:+ 12 index))) - (define-integrable (%dispatch-tag-extra-length tag) (fix:- (%record-length tag) 12)) +(define-integrable (%dispatch-tag-extra-ref tag index) + (%record-ref tag (%dispatch-tag-extra-index index))) + +(define-integrable (%dispatch-tag-extra-set! tag index value) + (%record-set! tag (%dispatch-tag-extra-index index) value)) + +(define-integrable (%dispatch-tag-extra-index index) + (fix:+ 12 index)) + (define-integrable tag-cache-number-adds-ok ;; This constant controls the number of non-zero bits tag cache ;; numbers will have. diff --git a/src/runtime/record.scm b/src/runtime/record.scm index f0c28ac86..84f2195ae 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -73,7 +73,8 @@ USA. names (if (default-object? default-inits) (vector-cons n #f) - (list->vector default-inits))))) + (list->vector default-inits)) + #f))) (set-predicate<=! predicate record?) (if (and unparser-method (not (default-object? unparser-method))) @@ -91,17 +92,18 @@ USA. (or (not init) (thunk? init))) default-inits)))) - unspecific) + (%initialize-applicator-context!)) +(define %record-metatag) (define record-type?) (define %make-record-type) (add-boot-init! (lambda () - (let ((metatag (make-dispatch-metatag 'record-tag))) - (set! record-type? (dispatch-tag->predicate metatag)) - (set! %make-record-type - (dispatch-metatag-constructor metatag 'make-record-type)) - unspecific))) + (set! %record-metatag (make-dispatch-metatag 'record-tag)) + (set! record-type? (dispatch-tag->predicate %record-metatag)) + (set! %make-record-type + (dispatch-metatag-constructor %record-metatag 'make-record-type)) + unspecific)) ;; Can be deleted after 9.3 release: (define (record-type-dispatch-tag record-type) @@ -113,6 +115,17 @@ USA. (define-integrable (%record-type-default-inits record-type) (dispatch-tag-extra-ref record-type 1)) +(define-integrable (%record-type-applicator record-type) + (dispatch-tag-extra-ref record-type 2)) + +(define-integrable (%set-record-type-applicator! record-type applicator) + (%dispatch-tag-extra-set! record-type 2 applicator)) + +(define (%initialize-applicator-context!) + (set-fixed-objects-item! 'record-dispatch-tag %record-metatag) + (set-fixed-objects-item! 'record-applicator-index + (%dispatch-tag-extra-index 2))) + (define-integrable (%record-type-n-fields record-type) (vector-length (%record-type-field-names record-type))) @@ -133,6 +146,16 @@ USA. (fix:- field-index 1)))) (and init (init)))) + +(define (record-type-applicator record-type) + (guarantee record-type? record-type 'record-type-applicator) + (%record-type-applicator record-type)) + +(define (set-record-type-applicator! record-type applicator) + (guarantee record-type? record-type 'set-record-type-applicator!) + (if applicator + (guarantee procedure? applicator 'set-record-type-applicator!)) + (%set-record-type-applicator! record-type applicator)) ;;;; Constructors diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index fdeed14ba..2615bb589 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3719,6 +3719,7 @@ USA. record-keyword-constructor record-modifier record-predicate + record-type-applicator record-type-default-value-by-index record-type-descriptor record-type-dispatch-tag ;can be deleted after 9.3 release @@ -3726,7 +3727,8 @@ USA. record-type-name record-type? record-updater - record?) + record? + set-record-type-applicator!) (export (runtime) error:no-such-slot error:uninitialized-slot @@ -5100,7 +5102,10 @@ USA. probe-cache-1 probe-cache-2 probe-cache-3 - probe-cache-4)) + probe-cache-4) + (export (runtime record) + %dispatch-tag-extra-index + %dispatch-tag-extra-set!)) (define-package (runtime crypto) (files "crypto")