mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
remove self field of vtables
* libguile/struct.h (SCM_VTABLE_BASE_LAYOUT, scm_vtable_index_self): Remove "self" field. Renumber the other fields. * module/oop/goops.scm (<self-slot>): Remove. (fold-class-slots): Adapt for "self" slot removal. Adapt all users. (class-redefinition): Now that there is no "self" slot to update, use %modify-instance instead of %modify-class. * libguile/goops.c (class_self): Remove. (scm_sys_modify_class): Remove. * libguile/goops.h (scm_sys_modify_class): Remove. * module/rnrs/records/procedural.scm: Import vtable-offset-user. Renumber rtd indexes using vtable-offset-user. * module/srfi/srfi-35.scm (%condition-type-vtable): Remove mention of vtable fields. * module/system/base/types.scm (address->inferior-struct): Adapt for different vtable field layout.
This commit is contained in:
Andy Wingo
parent
7e91ff651b
commit
ee5994a517
7 changed files with 23 additions and 48 deletions
|
|
@ -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>"));
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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!
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue