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; + 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) { + 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! (logior vtable-flag-goops-class vtable-flag-goops-valid)) (struct-set! class-index-name ') - (struct-set! class-index-nfields nfields) + (struct-set!/unboxed class-index-nfields nfields) (struct-set! class-index-direct-supers '()) (struct-set! class-index-direct-slots '()) (struct-set! 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! class-index-name ') - (struct-set! class-index-nfields nfields) + (struct-set!/unboxed class-index-nfields nfields) (struct-set! class-index-direct-supers '()) (struct-set! class-index-direct-slots '()) (struct-set! 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 (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 )) (define (read-only-slot? slot) (is-a? slot )) +(define (unboxed-slot? slot) + (and (is-a? slot ) + (not (is-a? slot )) + (not (is-a? 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 '())