Merge 'stable-2.2'

Resolve conflicts by removing capability of struct-ref / struct-set! to
access unboxed slots.

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

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''
+Scheme level it's read and written as an unsigned integer.  ``u'' stands
-stands for ``uninterpreted'' (it's not treated as a Scheme value), or
+for ``unboxed'', as it's stored as a raw value without additional type
-``unprotected'' (it's not marked during GC), or ``unsigned long'' (its
+annotations.
-size), or all of these things.
 @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}.

libguile/struct.c

@@ -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_t_bits field1, field2;
-      SCM field1, field2;
 
-      /* We have to use `scm_struct_ref ()' here so that fields are accessed
+      field1 = SCM_STRUCT_DATA_REF (s1, field_num);
-	 consistently, notably wrt. field types and access rights.  */
+      field2 = SCM_STRUCT_DATA_REF (s2, field_num);
-      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
+      if (field1 != field2) {
-	 recursion.  */
+        if (scm_i_symbol_ref (layout, field_num * 2) == 'u')
-      if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
-	if (scm_is_false (scm_equal_p (field1, field2)))
           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 vtable, layout;
-  scm_t_bits data;
   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)))
+  return SCM_STRUCT_SLOT_REF (handle, p);
-    /* 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);
-    }
 }
 #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)))
+  /* Only 'p' fields.  */
-    /* The fast path: HANDLE is a struct with only "p" fields.  */
+  SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
-    SCM_STRUCT_SLOT_SET (handle, p, val);
-  else
-    {
-      SCM layout;
-      scm_t_wchar field_type;
 
-      layout = SCM_STRUCT_LAYOUT (handle);
-      field_type = scm_i_symbol_ref (layout, p * 2);
-
-      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;
 }

libguile/struct.h

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

module/oop/goops.scm

@@ -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
+  (struct-set!/unboxed
-               (logior flags (struct-ref class class-index-flags))))
+   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
+  (struct-set!/unboxed
-               (logand (lognot flags) (struct-ref class class-index-flags))))
+   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)))
+  (let ((index (struct-ref/unboxed class class-index-nfields)))
-    (struct-set! class class-index-nfields (1+ index))
+    (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"))
+               (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)
@@ -769,12 +788,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)
@@ -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)))
+     (let ((already-allocated (struct-ref/unboxed class class-index-nfields)))
-       (struct-set! class class-index-nfields (+ already-allocated 1))
+       (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)))