mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-18 09:40:25 +02:00
Merge 'stable-2.2'
Resolve conflicts by removing capability of struct-ref / struct-set! to access unboxed slots.
This commit is contained in:
Andy Wingo
commit
84259f54e3
5 changed files with 172 additions and 82 deletions
9
NEWS
9
NEWS
|
|
@ -68,6 +68,11 @@ The URI standard, RFC 3986, defines additional "relative-ref" and
|
|||
for these URI subtypes has been improved. See "Universal Resource
|
||||
Identifiers" in the manual, for more.
|
||||
|
||||
** `struct-ref/unboxed' and `struct-set!/unboxed'
|
||||
|
||||
These procedures should be used when accessing struct fields with type
|
||||
`u' (unboxed). See "Structure Basics" in the manual, for full details.
|
||||
|
||||
* New deprecations
|
||||
|
||||
** Using `uri?' as a predicate on relative-refs deprecated
|
||||
|
|
@ -132,6 +137,10 @@ To enforce permissions on struct fields, instead layer on an abstraction
|
|||
at a higher level, in the same way that immutable record fields are
|
||||
simply those which don't have an accessor.
|
||||
|
||||
** Using `struct-ref' and `struct-set!' on unboxed fields is deprecated
|
||||
|
||||
Use the new `struct-ref/unboxed' and `struct-set!/unboxed' instead.
|
||||
|
||||
* Bug fixes
|
||||
|
||||
** Enable GNU Readline 7.0's support for "bracketed paste".
|
||||
|
|
|
|||
|
|
@ -8781,10 +8781,9 @@ it's protected against garbage collection.
|
|||
|
||||
@item
|
||||
@code{u} -- an arbitrary word of data (an @code{scm_t_bits}). At the
|
||||
Scheme level it's read and written as an unsigned integer. ``u''
|
||||
stands for ``uninterpreted'' (it's not treated as a Scheme value), or
|
||||
``unprotected'' (it's not marked during GC), or ``unsigned long'' (its
|
||||
size), or all of these things.
|
||||
Scheme level it's read and written as an unsigned integer. ``u'' stands
|
||||
for ``unboxed'', as it's stored as a raw value without additional type
|
||||
annotations.
|
||||
@end itemize
|
||||
|
||||
It used to be that the second letter for each field was a permission
|
||||
|
|
@ -8804,7 +8803,7 @@ field will be writable regardless.
|
|||
|
||||
@example
|
||||
(make-vtable "pw") ;; one scheme field
|
||||
(make-vtable "pwuwuw") ;; one scheme and two uninterpreted fields
|
||||
(make-vtable "pwuwuw") ;; one scheme and two unboxed fields
|
||||
@end example
|
||||
|
||||
The optional @var{print} argument is a function called by
|
||||
|
|
@ -8842,7 +8841,7 @@ The optional @var{init}@dots{} arguments are initial values for the
|
|||
fields of the structure. This is the only way to
|
||||
put values in read-only fields. If there are fewer @var{init}
|
||||
arguments than fields then the defaults are @code{#f} for a Scheme
|
||||
field (type @code{p}) or 0 for an uninterpreted field (type @code{u}).
|
||||
field (type @code{p}) or 0 for an unboxed field (type @code{u}).
|
||||
|
||||
The name is a bit strange, we admit. The reason for it is that Guile
|
||||
used to have a @code{make-struct} that took an additional argument;
|
||||
|
|
@ -8892,6 +8891,20 @@ An error is thrown if @var{n} is out of range, or if the field cannot
|
|||
be written because it's @code{r} read-only.
|
||||
@end deffn
|
||||
|
||||
Unboxed fields (those with type @code{u}) need to be accessed with
|
||||
special procedures.
|
||||
|
||||
@deffn {Scheme Procedure} struct-ref/unboxed struct n
|
||||
@deffnx {Scheme Procedure} struct-set!/unboxed struct n value
|
||||
@deffnx {C Function} scm_struct_ref_unboxed (struct, n)
|
||||
@deffnx {C Function} scm_struct_set_x_unboxed (struct, n, value)
|
||||
Like @code{struct-ref} and @code{struct-set!}, except that these may
|
||||
only be used on unboxed fields. @code{struct-ref/unboxed} will always
|
||||
return a positive integer. Likewise, @code{struct-set!/unboxed} takes
|
||||
an unsigned integer as the @var{value} argument, and will signal an
|
||||
error otherwise.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} struct-vtable struct
|
||||
@deffnx {C Function} scm_struct_vtable (struct)
|
||||
Return the vtable that describes @var{struct}.
|
||||
|
|
|
|||
|
|
@ -587,20 +587,25 @@ scm_i_struct_equalp (SCM s1, SCM s2)
|
|||
|
||||
for (field_num = 0; field_num < struct_size; field_num++)
|
||||
{
|
||||
SCM s_field_num;
|
||||
SCM field1, field2;
|
||||
scm_t_bits field1, field2;
|
||||
|
||||
/* We have to use `scm_struct_ref ()' here so that fields are accessed
|
||||
consistently, notably wrt. field types and access rights. */
|
||||
s_field_num = scm_from_size_t (field_num);
|
||||
field1 = scm_struct_ref (s1, s_field_num);
|
||||
field2 = scm_struct_ref (s2, s_field_num);
|
||||
field1 = SCM_STRUCT_DATA_REF (s1, field_num);
|
||||
field2 = SCM_STRUCT_DATA_REF (s2, field_num);
|
||||
|
||||
/* Self-referencing fields (type `s') must be skipped to avoid infinite
|
||||
recursion. */
|
||||
if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
|
||||
if (scm_is_false (scm_equal_p (field1, field2)))
|
||||
return SCM_BOOL_F;
|
||||
if (field1 != field2) {
|
||||
if (scm_i_symbol_ref (layout, field_num * 2) == 'u')
|
||||
return SCM_BOOL_F;
|
||||
|
||||
/* Having a normal field point to the object itself is a bit
|
||||
bonkers, but R6RS enums do it, so here we have a horrible
|
||||
hack. */
|
||||
if (field1 != SCM_UNPACK (s1) && field2 != SCM_UNPACK (s2))
|
||||
{
|
||||
if (scm_is_false
|
||||
(scm_equal_p (SCM_PACK (field1), SCM_PACK (field2))))
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return SCM_BOOL_T;
|
||||
|
|
@ -624,34 +629,22 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
|
|||
"word.")
|
||||
#define FUNC_NAME s_scm_struct_ref
|
||||
{
|
||||
SCM vtable;
|
||||
scm_t_bits data;
|
||||
SCM vtable, layout;
|
||||
size_t nfields, p;
|
||||
|
||||
SCM_VALIDATE_STRUCT (1, handle);
|
||||
|
||||
vtable = SCM_STRUCT_VTABLE (handle);
|
||||
layout = SCM_VTABLE_LAYOUT (vtable);
|
||||
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
|
||||
p = scm_to_size_t (pos);
|
||||
|
||||
SCM_ASSERT_RANGE (2, pos, p < nfields);
|
||||
|
||||
data = SCM_STRUCT_DATA_REF (handle, p);
|
||||
/* Only 'p' fields. */
|
||||
SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
|
||||
|
||||
if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
|
||||
/* The fast path: HANDLE is a struct with only readable "p"
|
||||
fields. */
|
||||
return SCM_PACK (data);
|
||||
else
|
||||
{
|
||||
SCM layout;
|
||||
scm_t_wchar field_type;
|
||||
|
||||
layout = SCM_STRUCT_LAYOUT (handle);
|
||||
field_type = scm_i_symbol_ref (layout, p * 2);
|
||||
|
||||
return (field_type == 'p') ? SCM_PACK (data) : scm_from_uintptr_t (data);
|
||||
}
|
||||
return SCM_STRUCT_SLOT_REF (handle, p);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -663,33 +656,77 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
|
|||
"to.")
|
||||
#define FUNC_NAME s_scm_struct_set_x
|
||||
{
|
||||
SCM vtable;
|
||||
SCM vtable, layout;
|
||||
size_t nfields, p;
|
||||
|
||||
SCM_VALIDATE_STRUCT (1, handle);
|
||||
|
||||
vtable = SCM_STRUCT_VTABLE (handle);
|
||||
layout = SCM_VTABLE_LAYOUT (vtable);
|
||||
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
|
||||
p = scm_to_size_t (pos);
|
||||
|
||||
SCM_ASSERT_RANGE (2, pos, p < nfields);
|
||||
|
||||
if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW)))
|
||||
/* The fast path: HANDLE is a struct with only "p" fields. */
|
||||
SCM_STRUCT_SLOT_SET (handle, p, val);
|
||||
else
|
||||
{
|
||||
SCM layout;
|
||||
scm_t_wchar field_type;
|
||||
/* Only 'p' fields. */
|
||||
SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
|
||||
|
||||
layout = SCM_STRUCT_LAYOUT (handle);
|
||||
field_type = scm_i_symbol_ref (layout, p * 2);
|
||||
SCM_STRUCT_SLOT_SET (handle, p, val);
|
||||
|
||||
if (field_type == 'p')
|
||||
SCM_STRUCT_SLOT_SET (handle, p, val);
|
||||
else
|
||||
SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));
|
||||
}
|
||||
return val;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_struct_ref_unboxed, "struct-ref/unboxed", 2, 0, 0,
|
||||
(SCM handle, SCM pos),
|
||||
"Access the @var{pos}th field of struct associated with\n"
|
||||
"@var{handle}. The field must be of type 'u'.")
|
||||
#define FUNC_NAME s_scm_struct_ref_unboxed
|
||||
{
|
||||
SCM vtable, layout;
|
||||
size_t nfields, p;
|
||||
|
||||
SCM_VALIDATE_STRUCT (1, handle);
|
||||
|
||||
vtable = SCM_STRUCT_VTABLE (handle);
|
||||
layout = SCM_VTABLE_LAYOUT (vtable);
|
||||
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
|
||||
p = scm_to_size_t (pos);
|
||||
|
||||
SCM_ASSERT_RANGE (2, pos, p < nfields);
|
||||
|
||||
/* Only 'u' fields. */
|
||||
SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME);
|
||||
|
||||
return scm_from_uintptr_t (SCM_STRUCT_DATA_REF (handle, p));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_struct_set_x_unboxed, "struct-set!/unboxed", 3, 0, 0,
|
||||
(SCM handle, SCM pos, SCM val),
|
||||
"Set the slot of the structure @var{handle} with index @var{pos}\n"
|
||||
"to @var{val}. Signal an error if the slot can not be written\n"
|
||||
"to.")
|
||||
#define FUNC_NAME s_scm_struct_set_x_unboxed
|
||||
{
|
||||
SCM vtable, layout;
|
||||
size_t nfields, p;
|
||||
|
||||
SCM_VALIDATE_STRUCT (1, handle);
|
||||
|
||||
vtable = SCM_STRUCT_VTABLE (handle);
|
||||
layout = SCM_VTABLE_LAYOUT (vtable);
|
||||
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
|
||||
p = scm_to_size_t (pos);
|
||||
|
||||
SCM_ASSERT_RANGE (2, pos, p < nfields);
|
||||
|
||||
/* Only 'u' fields. */
|
||||
SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME);
|
||||
|
||||
SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));
|
||||
|
||||
return val;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -163,6 +163,8 @@ SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
|
|||
SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM fields);
|
||||
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
|
||||
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
|
||||
SCM_API SCM scm_struct_ref_unboxed (SCM handle, SCM pos);
|
||||
SCM_API SCM scm_struct_set_x_unboxed (SCM handle, SCM pos, SCM val);
|
||||
SCM_API SCM scm_struct_vtable (SCM handle);
|
||||
SCM_API SCM scm_struct_vtable_name (SCM vtable);
|
||||
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
|
||||
|
|
|
|||
|
|
@ -261,16 +261,20 @@
|
|||
(logior vtable-flag-vtable vtable-flag-goops-class))
|
||||
|
||||
(define-inlinable (class-add-flags! class flags)
|
||||
(struct-set! class class-index-flags
|
||||
(logior flags (struct-ref class class-index-flags))))
|
||||
(struct-set!/unboxed
|
||||
class
|
||||
class-index-flags
|
||||
(logior flags (struct-ref/unboxed class class-index-flags))))
|
||||
|
||||
(define-inlinable (class-clear-flags! class flags)
|
||||
(struct-set! class class-index-flags
|
||||
(logand (lognot flags) (struct-ref class class-index-flags))))
|
||||
(struct-set!/unboxed
|
||||
class
|
||||
class-index-flags
|
||||
(logand (lognot flags) (struct-ref/unboxed class class-index-flags))))
|
||||
|
||||
(define-inlinable (class-has-flags? class flags)
|
||||
(eqv? flags
|
||||
(logand (struct-ref class class-index-flags) flags)))
|
||||
(logand (struct-ref/unboxed class class-index-flags) flags)))
|
||||
|
||||
(define-inlinable (class? obj)
|
||||
(class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
|
||||
|
|
@ -319,7 +323,7 @@
|
|||
(<class> (%make-vtable-vtable layout)))
|
||||
(class-add-flags! <class> vtable-flag-goops-class)
|
||||
(struct-set! <class> class-index-name '<class>)
|
||||
(struct-set! <class> class-index-nfields nfields)
|
||||
(struct-set!/unboxed <class> class-index-nfields nfields)
|
||||
(struct-set! <class> class-index-direct-supers '())
|
||||
(struct-set! <class> class-index-direct-slots '())
|
||||
(struct-set! <class> class-index-direct-subclasses '())
|
||||
|
|
@ -413,7 +417,8 @@ followed by its associated value. If @var{l} does not hold a value for
|
|||
(eq? x *unbound*))
|
||||
|
||||
(define (%allocate-instance class)
|
||||
(let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
|
||||
(let ((obj (allocate-struct class
|
||||
(struct-ref/unboxed class class-index-nfields))))
|
||||
(%clear-fields! obj *unbound*)
|
||||
obj))
|
||||
|
||||
|
|
@ -428,7 +433,7 @@ followed by its associated value. If @var{l} does not hold a value for
|
|||
(class-add-flags! <slot> (logior vtable-flag-goops-class
|
||||
vtable-flag-goops-slot))
|
||||
(struct-set! <slot> class-index-name '<slot>)
|
||||
(struct-set! <slot> class-index-nfields nfields)
|
||||
(struct-set!/unboxed <slot> class-index-nfields nfields)
|
||||
(struct-set! <slot> class-index-direct-supers '())
|
||||
(struct-set! <slot> class-index-direct-slots '())
|
||||
(struct-set! <slot> class-index-direct-subclasses '())
|
||||
|
|
@ -690,8 +695,8 @@ followed by its associated value. If @var{l} does not hold a value for
|
|||
|
||||
;; Boot definition.
|
||||
(define (compute-get-n-set class slot)
|
||||
(let ((index (struct-ref class class-index-nfields)))
|
||||
(struct-set! class class-index-nfields (1+ index))
|
||||
(let ((index (struct-ref/unboxed class class-index-nfields)))
|
||||
(struct-set!/unboxed class class-index-nfields (1+ index))
|
||||
index))
|
||||
|
||||
;;; Pre-generate getters and setters for the first 20 slots.
|
||||
|
|
@ -723,9 +728,18 @@ followed by its associated value. If @var{l} does not hold a value for
|
|||
(define-standard-accessor-method ((standard-set n) o v)
|
||||
(struct-set! o n v))
|
||||
|
||||
(define-standard-accessor-method ((unboxed-get n) o)
|
||||
(struct-ref/unboxed o n))
|
||||
|
||||
(define-standard-accessor-method ((unboxed-set n) o v)
|
||||
(struct-set!/unboxed o n v))
|
||||
|
||||
;; Boot definitions.
|
||||
(define (opaque-slot? slot) #f)
|
||||
(define (read-only-slot? slot) #f)
|
||||
(define (unboxed-slot? slot)
|
||||
(memq (%slot-definition-name slot)
|
||||
'(flags instance-finalizer nfields %reserved)))
|
||||
|
||||
(define (allocate-slots class slots)
|
||||
"Transform the computed list of direct slot definitions @var{slots}
|
||||
|
|
@ -737,20 +751,25 @@ slots as we go."
|
|||
;; the behavior for backward compatibility.
|
||||
(let* ((slot (compute-effective-slot-definition class slot))
|
||||
(name (%slot-definition-name slot))
|
||||
(index (struct-ref class class-index-nfields))
|
||||
(index (struct-ref/unboxed class class-index-nfields))
|
||||
(g-n-s (compute-get-n-set class slot))
|
||||
(size (- (struct-ref class class-index-nfields) index)))
|
||||
(size (- (struct-ref/unboxed class class-index-nfields) index)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(match g-n-s
|
||||
((? integer?)
|
||||
(unless (= size 1)
|
||||
(error "unexpected return from compute-get-n-set"))
|
||||
(values (standard-get g-n-s)
|
||||
(if (slot-definition-init-thunk slot)
|
||||
(standard-get g-n-s)
|
||||
(bound-check-get g-n-s))
|
||||
(standard-set g-n-s)))
|
||||
(cond
|
||||
((unboxed-slot? slot)
|
||||
(let ((get (unboxed-get g-n-s)))
|
||||
(values get get (unboxed-set g-n-s))))
|
||||
(else
|
||||
(values (standard-get g-n-s)
|
||||
(if (slot-definition-init-thunk slot)
|
||||
(standard-get g-n-s)
|
||||
(bound-check-get g-n-s))
|
||||
(standard-set g-n-s)))))
|
||||
(((? procedure? get) (? procedure? set))
|
||||
(values get
|
||||
(lambda (o)
|
||||
|
|
@ -769,12 +788,19 @@ slots as we go."
|
|||
(lambda (o v)
|
||||
(error "Slot is opaque" name)))
|
||||
((read-only-slot? slot)
|
||||
(lambda (o v)
|
||||
(let ((v* (get/raw o)))
|
||||
(if (unbound? v*)
|
||||
;; Allow initialization.
|
||||
(set o v)
|
||||
(error "Slot is read-only" name)))))
|
||||
(if (unboxed-slot? slot)
|
||||
(lambda (o v)
|
||||
(let ((v* (get/raw o)))
|
||||
(if (zero? v*)
|
||||
;; Allow initialization.
|
||||
(set o v)
|
||||
(error "Slot is read-only" name))))
|
||||
(lambda (o v)
|
||||
(let ((v* (get/raw o)))
|
||||
(if (unbound? v*)
|
||||
;; Allow initialization.
|
||||
(set o v)
|
||||
(error "Slot is read-only" name))))))
|
||||
(else set))))
|
||||
(struct-set! slot slot-index-slot-ref/raw get/raw)
|
||||
(struct-set! slot slot-index-slot-ref get)
|
||||
|
|
@ -782,7 +808,7 @@ slots as we go."
|
|||
(struct-set! slot slot-index-index index)
|
||||
(struct-set! slot slot-index-size size))))
|
||||
slot))
|
||||
(struct-set! class class-index-nfields 0)
|
||||
(struct-set!/unboxed class class-index-nfields 0)
|
||||
(map-in-order make-effective-slot-definition slots))
|
||||
|
||||
(define (%compute-layout slots nfields is-class?)
|
||||
|
|
@ -830,7 +856,7 @@ slots as we go."
|
|||
(define (%prep-layout! class)
|
||||
(let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
|
||||
(layout (%compute-layout (struct-ref class class-index-slots)
|
||||
(struct-ref class class-index-nfields)
|
||||
(struct-ref/unboxed class class-index-nfields)
|
||||
is-class?)))
|
||||
(%init-layout! class layout)))
|
||||
|
||||
|
|
@ -841,7 +867,7 @@ slots as we go."
|
|||
(compute-direct-slot-definition z initargs)))
|
||||
|
||||
(struct-set! z class-index-name name)
|
||||
(struct-set! z class-index-nfields 0)
|
||||
(struct-set!/unboxed z class-index-nfields 0)
|
||||
(struct-set! z class-index-direct-supers dsupers)
|
||||
(struct-set! z class-index-direct-subclasses '())
|
||||
(struct-set! z class-index-direct-methods '())
|
||||
|
|
@ -911,6 +937,9 @@ slots as we go."
|
|||
|
||||
(define (opaque-slot? slot) (is-a? slot <opaque-slot>))
|
||||
(define (read-only-slot? slot) (is-a? slot <read-only-slot>))
|
||||
(define (unboxed-slot? slot)
|
||||
(and (is-a? slot <foreign-slot>)
|
||||
(not (is-a? slot <protected-slot>))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -2607,8 +2636,8 @@ function."
|
|||
(case (slot-definition-allocation s)
|
||||
((#:instance) ;; Instance slot
|
||||
;; get-n-set is just its offset
|
||||
(let ((already-allocated (struct-ref class class-index-nfields)))
|
||||
(struct-set! class class-index-nfields (+ already-allocated 1))
|
||||
(let ((already-allocated (struct-ref/unboxed class class-index-nfields)))
|
||||
(struct-set!/unboxed class class-index-nfields (+ already-allocated 1))
|
||||
already-allocated))
|
||||
|
||||
((#:class) ;; Class slot
|
||||
|
|
@ -2720,7 +2749,7 @@ var{initargs}."
|
|||
(next-method)
|
||||
(class-add-flags! class vtable-flag-goops-class)
|
||||
(struct-set! class class-index-name (get-keyword #:name initargs '???))
|
||||
(struct-set! class class-index-nfields 0)
|
||||
(struct-set!/unboxed class class-index-nfields 0)
|
||||
(struct-set! class class-index-direct-supers
|
||||
(get-keyword #:dsupers initargs '()))
|
||||
(struct-set! class class-index-direct-subclasses '())
|
||||
|
|
@ -3084,10 +3113,10 @@ var{initargs}."
|
|||
|
||||
(define-method (allocate-instance (class <redefinable-class>) initargs)
|
||||
(let ((instance (next-method))
|
||||
(nfields (struct-ref class class-index-nfields))
|
||||
(nfields (struct-ref/unboxed class class-index-nfields))
|
||||
(indirect-slots-class (slot-ref class 'indirect-slots-class)))
|
||||
;; Indirect slots will be last struct field.
|
||||
(struct-set! instance (1- nfields) (make indirect-slots-class))
|
||||
(struct-set!/unboxed instance (1- nfields) (make indirect-slots-class))
|
||||
instance))
|
||||
|
||||
;; Called when redefining an existing binding, and the new binding is a
|
||||
|
|
@ -3227,7 +3256,7 @@ var{initargs}."
|
|||
(stack '()))
|
||||
(lambda (instance)
|
||||
(let* ((new-class (struct-vtable instance))
|
||||
(nfields (struct-ref new-class class-index-nfields))
|
||||
(nfields (struct-ref/unboxed new-class class-index-nfields))
|
||||
;; Indirect slots are in last instance slot. For normal
|
||||
;; instances last slot is 0 of course.
|
||||
(slots (struct-ref instance (1- nfields)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue