diff options
-rw-r--r-- | libguile/goops.c | 19 | ||||
-rw-r--r-- | libguile/goops.h | 1 | ||||
-rw-r--r-- | libguile/struct.h | 14 | ||||
-rw-r--r-- | module/oop/goops.scm | 10 | ||||
-rw-r--r-- | module/rnrs/records/procedural.scm | 22 | ||||
-rw-r--r-- | module/srfi/srfi-35.scm | 1 | ||||
-rw-r--r-- | module/system/base/types.scm | 4 |
7 files changed, 23 insertions, 48 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 7e7a26553..d0e646339 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -115,7 +115,7 @@ static SCM class_atomic_box; static SCM class_port, class_input_output_port; static SCM class_input_port, class_output_port; static SCM class_foreign_slot; -static SCM class_self, class_protected; +static SCM class_protected; static SCM class_hidden, class_opaque, class_read_only; static SCM class_protected_hidden, class_protected_opaque, class_protected_read_only; static SCM class_scm; @@ -542,22 +542,6 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, - (SCM old, SCM new), - "") -#define FUNC_NAME s_scm_sys_modify_class -{ - SCM_VALIDATE_CLASS (1, old); - SCM_VALIDATE_CLASS (2, new); - - scm_sys_modify_instance (old, new); - SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old); - SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - /* Primitive generics: primitives that can dispatch to generics if their @@ -920,7 +904,6 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>")); class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>")); class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>")); - class_self = scm_variable_ref (scm_c_lookup ("<self-slot>")); class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>")); class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>")); class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>")); diff --git a/libguile/goops.h b/libguile/goops.h index 202fef9eb..332635bd9 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -130,7 +130,6 @@ SCM_API SCM scm_method_procedure (SCM obj); SCM_API SCM scm_slot_bound_p (SCM obj, SCM slot_name); SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name); SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst); -SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls); SCM_API SCM scm_generic_capability_p (SCM proc); SCM_API SCM scm_enable_primitive_generic_x (SCM subrs); SCM_INTERNAL SCM scm_set_primitive_generic_x (SCM subr, SCM generic); diff --git a/libguile/struct.h b/libguile/struct.h index 0dfcf4618..25d5ae53f 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -56,7 +56,6 @@ #define SCM_VTABLE_BASE_LAYOUT \ "pr" /* layout */ \ "uh" /* flags */ \ - "sr" /* self */ \ "uh" /* finalizer */ \ "pw" /* printer */ \ "ph" /* name (hidden from make-struct for back-compat reasons) */ \ @@ -65,13 +64,12 @@ #define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */ #define scm_vtable_index_flags 1 /* Class flags */ -#define scm_vtable_index_self 2 /* A pointer to the vtable itself */ -#define scm_vtable_index_instance_finalize 3 /* Finalizer for instances of this struct type. */ -#define scm_vtable_index_instance_printer 4 /* A printer for this struct type. */ -#define scm_vtable_index_name 5 /* Name of this vtable. */ -#define scm_vtable_index_size 6 /* Number of fields, for simple structs. */ -#define scm_vtable_index_reserved_7 7 -#define scm_vtable_offset_user 8 /* Where do user fields start in the vtable? */ +#define scm_vtable_index_instance_finalize 2 /* Finalizer for instances of this struct type. */ +#define scm_vtable_index_instance_printer 3 /* A printer for this struct type. */ +#define scm_vtable_index_name 4 /* Name of this vtable. */ +#define scm_vtable_index_size 5 /* Number of fields, for simple structs. */ +#define scm_vtable_index_reserved_7 6 +#define scm_vtable_offset_user 7 /* Where do user fields start in the vtable? */ /* All applicable structs have the following fields. */ #define SCM_APPLICABLE_BASE_LAYOUT \ diff --git a/module/oop/goops.scm b/module/oop/goops.scm index f94332472..19e68ad59 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -42,7 +42,7 @@ ;; Slot types. <slot> <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot> - <read-only-slot> <self-slot> <protected-opaque-slot> + <read-only-slot> <protected-opaque-slot> <protected-hidden-slot> <protected-read-only-slot> <scm-slot> <int-slot> <float-slot> <double-slot> @@ -186,7 +186,6 @@ (define-macro-folder fold-class-slots (layout #:class <protected-read-only-slot>) (flags #:class <hidden-slot>) - (self #:class <self-slot>) (instance-finalizer #:class <hidden-slot>) (print) (name #:class <protected-hidden-slot>) @@ -306,15 +305,12 @@ ;; A simple way to compute class layout for the concrete ;; types used in <class>. (syntax-rules (<protected-read-only-slot> - <self-slot> <hidden-slot> <protected-hidden-slot>) ((_ (name) tail) (string-append "pw" tail)) ((_ (name #:class <protected-read-only-slot>) tail) (string-append "pr" tail)) - ((_ (name #:class <self-slot>) tail) - (string-append "sr" tail)) ((_ (name #:class <hidden-slot>) tail) (string-append "uh" tail)) ((_ (name #:class <protected-hidden-slot>) tail) @@ -779,7 +775,6 @@ slots as we go." (let ((type (get-keyword #:class (%slot-definition-options slot)))) (if (and type (subclass? type <foreign-slot>)) (values (cond - ((subclass? type <self-slot>) #\s) ((subclass? type <protected-slot>) #\p) (else #\u)) (cond @@ -892,7 +887,6 @@ slots as we go." (define-standard-class <hidden-slot> (<foreign-slot>)) (define-standard-class <opaque-slot> (<foreign-slot>)) (define-standard-class <read-only-slot> (<foreign-slot>)) -(define-standard-class <self-slot> (<read-only-slot>)) (define-standard-class <protected-opaque-slot> (<protected-slot> <opaque-slot>)) (define-standard-class <protected-hidden-slot> (<protected-slot> @@ -3110,7 +3104,7 @@ var{initargs}." (class-direct-supers new)) ;; Swap object headers - (%modify-class old new) + (%modify-instance old new) ;; Now old is NEW! diff --git a/module/rnrs/records/procedural.scm b/module/rnrs/records/procedural.scm index 6976eebdd..d925263d8 100644 --- a/module/rnrs/records/procedural.scm +++ b/module/rnrs/records/procedural.scm @@ -54,22 +54,24 @@ hashq-ref hashq-set! - vector->list) + vector->list + + vtable-offset-user) (ice-9 receive) (only (srfi :1) fold split-at take)) (define (record-internal? obj) (and (struct? obj) (record-type-descriptor? (struct-vtable obj)))) - (define rtd-index-name 8) - (define rtd-index-uid 9) - (define rtd-index-parent 10) - (define rtd-index-sealed? 11) - (define rtd-index-opaque? 12) - (define rtd-index-predicate 13) - (define rtd-index-field-names 14) - (define rtd-index-field-bit-field 15) - (define rtd-index-field-binder 16) + (define rtd-index-name (+ vtable-offset-user 0)) + (define rtd-index-uid (+ vtable-offset-user 1)) + (define rtd-index-parent (+ vtable-offset-user 2)) + (define rtd-index-sealed? (+ vtable-offset-user 3)) + (define rtd-index-opaque? (+ vtable-offset-user 4)) + (define rtd-index-predicate (+ vtable-offset-user 5)) + (define rtd-index-field-names (+ vtable-offset-user 6)) + (define rtd-index-field-bit-field (+ vtable-offset-user 7)) + (define rtd-index-field-binder (+ vtable-offset-user 8)) (define rctd-index-rtd 0) (define rctd-index-parent 1) diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm index 8f86bce57..0f0ab3c70 100644 --- a/module/srfi/srfi-35.scm +++ b/module/srfi/srfi-35.scm @@ -46,7 +46,6 @@ (define %condition-type-vtable ;; The vtable of all condition types. - ;; vtable fields: vtable, self, printer ;; user fields: id, parent, all-field-names (let ((s (make-vtable (string-append standard-vtable-fields "prprpr") (lambda (ct port) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 06528853c..daf8bdfe2 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -369,8 +369,8 @@ TYPE-NUMBER." (define (address->inferior-struct address vtable-address backend) "Read the struct at ADDRESS using BACKEND. Return an 'inferior-struct' object representing it." - (define %vtable-layout-index 0) - (define %vtable-name-index 5) + (define %vtable-layout-index vtable-index-layout) + (define %vtable-name-index 4) (let* ((vtable-data-address (+ vtable-address %word-size)) (layout-address (+ vtable-data-address |