mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
Code Activity

Add struct-ref/unboxed, struct-set!/unboxed

Browse source 
* NEWS: Add news entry.
* doc/ref/api-data.texi (Vtables, Structure Basics): Update
  documentation.
* libguile/struct.c (scm_i_struct_equalp): Avoid using struct-ref on
  unboxed fields.
  (scm_struct_ref, scm_struct_set_x_unboxed): Issue deprecation warning
  when accessing unboxed fields.
  (scm_struct_ref_unboxed, scm_struct_set_x_unboxed): New functions.
* libguile/struct.h (scm_struct_ref_unboxed, scm_struct_set_x_unboxed):
  New functions.
* module/oop/goops.scm (class-add-flags!, class-clear-flags!):
  (class-has-flags?, <class>, %allocate-instance, <slot>):
  (compute-get-n-set, unboxed-get, unboxed-set, unboxed-slot?):
  (allocate-slots, %prep-layout!, make-standard-class, initialize):
  Adapt to access unboxed nfields and flags fields via the new
  accessors.
This commit is contained in:
Andy Wingo 2017-09-25 21:33:22 +02:00
parent f23415589a
commit a74d4ee4f6
5 changed files with 198 additions and 47 deletions
Download patch file Download diff file Expand all files Collapse all files

9
NEWS
View file

@ -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".

25
doc/ref/api-data.texi
View file

@ -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}.

119
libguile/struct.c
View file

@ -676,21 +676,38 @@ 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)))
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"

2
libguile/struct.h
View file

@ -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);

70
module/oop/goops.scm
View file

@ -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"))
(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)))
(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)
(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)))))
(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 '())