summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--NEWS9
-rw-r--r--doc/ref/api-data.texi25
-rw-r--r--libguile/struct.c125
-rw-r--r--libguile/struct.h2
-rw-r--r--module/oop/goops.scm88
5 files changed, 200 insertions, 49 deletions
diff --git a/NEWS b/NEWS
index fec9af30f..06d4d383f 100644
--- a/NEWS
+++ b/NEWS
@@ -17,6 +17,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
@@ -81,6 +86,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".
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index e0f8be324..677454bbe 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -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
The second letter for each field is a permission code,
@@ -8802,7 +8801,7 @@ Here are some examples.
@example
(make-vtable "pw") ;; one writable field
(make-vtable "prpw") ;; one read-only and one writable
-(make-vtable "pwuwuw") ;; one scheme and two uninterpreted
+(make-vtable "pwuwuw") ;; one scheme and two unboxed
@end example
The optional @var{print} argument is a function called by
@@ -8840,7 +8839,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;
@@ -8890,6 +8889,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}.
diff --git a/libguile/struct.c b/libguile/struct.c
index 1363fea90..b0604f7e1 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -676,20 +676,37 @@ 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;
-
- /* 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);
-
- /* 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;
+ scm_t_bits field1, field2;
+
+ field1 = SCM_STRUCT_DATA_REF (s1, field_num);
+ field2 = SCM_STRUCT_DATA_REF (s2, field_num);
+
+ if (field1 != field2) {
+ switch (scm_i_symbol_ref (layout, field_num * 2))
+ {
+ case 'p':
+ /* 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;
+ }
+ break;
+ case 's':
+ /* Skip to avoid infinite recursion. */
+ break;
+ case 'u':
+ return SCM_BOOL_F;
+ default:
+ /* Don't bother inspecting tail arrays; we never did this in
+ the past and in the future tail arrays are going away
+ anyway. */
+ return SCM_BOOL_F;
+ }
+ }
}
/* FIXME: Tail elements should be tested for equality. */
@@ -765,6 +782,9 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
switch (field_type)
{
case 'u':
+ scm_c_issue_deprecation_warning
+ ("Accessing unboxed struct fields with struct-ref is deprecated. "
+ "Use struct-ref/unboxed instead.");
answer = scm_from_ulong (data[p]);
break;
@@ -838,6 +858,9 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
switch (field_type)
{
case 'u':
+ scm_c_issue_deprecation_warning
+ ("Accessing unboxed struct fields with struct-set! is deprecated. "
+ "Use struct-set!/unboxed instead.");
data[p] = SCM_NUM2ULONG (3, val);
break;
@@ -859,6 +882,80 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
#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 layout_len, n_fields;
+ size_t p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ vtable = SCM_STRUCT_VTABLE (handle);
+ p = scm_to_size_t (pos);
+
+ layout = SCM_VTABLE_LAYOUT (vtable);
+ layout_len = scm_i_symbol_length (layout);
+ n_fields = layout_len / 2;
+
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ /* Only 'u' fields, no tail arrays. */
+ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u',
+ layout, 0, FUNC_NAME);
+
+ /* Don't support opaque fields. */
+ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2 + 1) != 'o',
+ 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 layout_len, n_fields;
+ size_t p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ vtable = SCM_STRUCT_VTABLE (handle);
+ p = scm_to_size_t (pos);
+
+ layout = SCM_VTABLE_LAYOUT (vtable);
+ layout_len = scm_i_symbol_length (layout);
+ n_fields = layout_len / 2;
+
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ /* Only 'u' fields, no tail arrays. */
+ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u',
+ layout, 0, FUNC_NAME);
+
+ /* Don't support opaque fields. */
+ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2 + 1) != 'o',
+ layout, 0, FUNC_NAME);
+
+ if (scm_i_symbol_ref (layout, p * 2 + 1) == 'r')
+ SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
+
+ SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));
+
+ return val;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
(SCM handle),
"Return the vtable structure that describes the type of struct\n"
diff --git a/libguile/struct.h b/libguile/struct.h
index 257e40e1e..e53bf4f0d 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -185,6 +185,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);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 4569336a9..3c787d763 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -256,16 +256,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))
@@ -312,7 +316,7 @@
(class-add-flags! <class> (logior vtable-flag-goops-class
vtable-flag-goops-valid))
(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 '())
@@ -407,7 +411,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))
@@ -423,7 +428,7 @@ followed by its associated value. If @var{l} does not hold a value for
vtable-flag-goops-slot
vtable-flag-goops-valid))
(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 '())
@@ -686,8 +691,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.
@@ -719,9 +724,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}
@@ -733,20 +747,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)
@@ -765,12 +784,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)
@@ -778,7 +804,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?)
@@ -828,7 +854,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)))
@@ -839,7 +865,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 '())
@@ -914,6 +940,10 @@ 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 <self-slot>))
+ (not (is-a? slot <protected-slot>))))
@@ -2748,8 +2778,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
@@ -2862,7 +2892,7 @@ var{initargs}."
(class-add-flags! class (logior vtable-flag-goops-class
vtable-flag-goops-valid))
(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 '())