summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/goops.c19
-rw-r--r--libguile/goops.h1
-rw-r--r--libguile/struct.h14
-rw-r--r--module/oop/goops.scm10
-rw-r--r--module/rnrs/records/procedural.scm22
-rw-r--r--module/srfi/srfi-35.scm1
-rw-r--r--module/system/base/types.scm4
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