summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-09-23 15:16:04 +0200
committerAndy Wingo <wingo@pobox.com>2017-09-23 15:33:02 +0200
commit5870188eb4b6c4246569a1aaaf358bc8a9e6a65d (patch)
tree239d2b31275520a409576073b67a8cd952a87fc8
parent0f14a9e59826c1c304d1f50c741e91d99760ff43 (diff)
downloadguile-5870188eb4b6c4246569a1aaaf358bc8a9e6a65d.tar.gz
Replace "pr" struct fields with "pw" fields
* libguile/struct.h (SCM_VTABLE_BASE_LAYOUT): Layout is a "pr" field. * module/ice-9/boot-9.scm (record-type-vtable): Record vtable fields are writable. (<parameter>): "pw" fields. * module/oop/goops.scm (<class>, %compute-layout): <read-only> fields are "pw" underneath. * module/rnrs/records/procedural.scm (record-type-vtable) (record-constructor-vtable, make-record-type-descriptor): Use "pw" fields in vtables. * module/srfi/srfi-35.scm (%condition-type-vtable) (struct-layout-for-condition): "pw" fields in vtables. * test-suite/tests/goops.test: * test-suite/tests/structs.test: Use "pw" fields only. * benchmark-suite/benchmarks/structs.bm: Update for make-struct/no-tail, to use pw fields, and also to remove useless tests that the compiler would optimize away. * doc/ref/api-data.texi (Vtables): Add a note about the now-vestigial permissions character and update documentation. (Structure Basics, Meta-Vtables): Update examples. * libguile/hash.c (scm_i_struct_hash): Remove code that would handle opaque/self fields. * libguile/print.h (SCM_PRINT_STATE_LAYOUT): Use "pw" fields. * libguile/struct.c (scm_struct_init): Simplify check for hidden fields. * libguile/values.c (scm_init_values): Field is "pw".
-rw-r--r--benchmark-suite/benchmarks/structs.bm35
-rw-r--r--doc/ref/api-data.texi40
-rw-r--r--libguile/hash.c32
-rw-r--r--libguile/print.h2
-rw-r--r--libguile/struct.c25
-rw-r--r--libguile/struct.h2
-rw-r--r--libguile/values.c4
-rw-r--r--module/ice-9/boot-9.scm4
-rw-r--r--module/oop/goops.scm3
-rw-r--r--module/rnrs/records/procedural.scm8
-rw-r--r--module/srfi/srfi-35.scm6
-rw-r--r--test-suite/tests/goops.test6
-rw-r--r--test-suite/tests/structs.test28
13 files changed, 83 insertions, 112 deletions
diff --git a/benchmark-suite/benchmarks/structs.bm b/benchmark-suite/benchmarks/structs.bm
index 65c8e975e..465afbd24 100644
--- a/benchmark-suite/benchmarks/structs.bm
+++ b/benchmark-suite/benchmarks/structs.bm
@@ -1,7 +1,7 @@
;;; -*- mode: scheme; coding: iso-8859-1; -*-
;;; Structs.
;;;
-;;; Copyright 2009 Free Software Foundation, Inc.
+;;; Copyright 2009, 2017 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
@@ -25,44 +25,27 @@
(define iterations 2000000)
(define vtable2
- (make-vtable "prpr"))
+ (make-vtable "pwpw"))
(define vtable7
- (make-vtable (string-concatenate (make-list 7 "pr"))))
+ (make-vtable (string-concatenate (make-list 7 "pw"))))
(with-benchmark-prefix "constructors"
- (benchmark "make-struct2 (opcode)" iterations
- (make-struct vtable2 0 1 2))
+ (benchmark "make-struct2" iterations
+ (make-struct/no-tail vtable2 1 2))
- (benchmark "make-struct2 (procedure)" iterations
- (let ((s make-struct))
- (s vtable2 0 1 2)))
-
- (benchmark "make-struct7 (opcode)" iterations
- (make-struct vtable7 0 1 2 3 4 5 6 7))
-
- (benchmark "make-struct7 (procedure)" iterations
- (let ((s make-struct))
- (s vtable7 0 1 2 3 4 5 6 7))))
+ (benchmark "make-struct7" iterations
+ (make-struct/no-tail vtable7 1 2 3 4 5 6 7)))
(with-benchmark-prefix "pairs" ;; for comparison
-
- (benchmark "cons (opcode)" iterations
+ (benchmark "cons" iterations
(cons 1 2))
- (benchmark "cons (procedure)" iterations
- (let ((c cons))
- (c 1 2)))
-
- (benchmark "list (opcode)" iterations
+ (benchmark "list" iterations
(list 1 2 3 4 5 6 7))
- (benchmark "list (procedure)" iterations
- (let ((l list))
- (l 1 2 3 4 5 6 7)))
-
(benchmark "make-list" iterations
(make-list 7)))
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index e0f8be324..923d0f20b 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -8787,22 +8787,24 @@ stands for ``uninterpreted'' (it's not treated as a Scheme value), or
size), or all of these things.
@end itemize
-The second letter for each field is a permission code,
-
-@itemize @bullet{}
-@item
-@code{w} -- writable, the field can be read and written.
-@item
-@code{r} -- read-only, the field can be read but not written.
-@item
-@end itemize
-
-Here are some examples.
+It used to be that the second letter for each field was a permission
+code, such as @code{w} for writable or @code{r} for read-only. However
+over time structs have become more of a raw low-level facility; access
+control is better implemented as a layer on top. After all,
+@code{struct-set!} is a cross-cutting operator that can bypass
+abstractions made by higher-level record facilities; it's not generally
+safe (in the sense of abstraction-preserving) to expose
+@code{struct-set!} to ``untrusted'' code, even if the fields happen to
+be writable. Additionally, permission checks added overhead to every
+structure access in a way that couldn't be optimized out, hampering the
+ability of structs to act as a low-level building block. For all of
+these reasons, all fields in Guile structs are now writable; attempting
+to make a read-only field will now issue a deprecation warning, and the
+field will be writable regardless.
@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 "pw") ;; one scheme field
+(make-vtable "pwuwuw") ;; one scheme and two uninterpreted fields
@end example
The optional @var{print} argument is a function called by
@@ -8816,7 +8818,7 @@ The following print function for example shows the two fields of its
structure.
@example
-(make-vtable "prpw"
+(make-vtable "pwpw"
(lambda (struct port)
(format port "#<~a and ~a>"
(struct-ref struct 0)
@@ -8850,7 +8852,7 @@ new name for this functionality.
For example,
@example
-(define v (make-vtable "prpwpw"))
+(define v (make-vtable "pwpwpw"))
(define s (make-struct/no-tail v 123 "abc" 456))
(struct-ref s 0) @result{} 123
(struct-ref s 1) @result{} "abc"
@@ -9032,11 +9034,11 @@ vtables with additional data:
@example
scheme@@(guile-user)> (struct-ref $3 vtable-index-layout)
-$6 = pruhsruhpwphuhuhprprpw
+$6 = pwuhuhpwphuhuhpwpwpw
scheme@@(guile-user)> (struct-ref $4 vtable-index-layout)
-$7 = pruhsruhpwphuhuh
+$7 = pwuhuhpwphuhuh
scheme@@(guile-user)> standard-vtable-fields
-$8 = "pruhsruhpwphuhuh"
+$8 = "pwuhuhpwphuhuh"
scheme@@(guile-user)> (struct-ref $2 vtable-offset-user)
$9 = module
@end example
diff --git a/libguile/hash.c b/libguile/hash.c
index 604708438..84285aa11 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
- * 2009, 2010, 2011, 2012, 2014, 2015 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 2012, 2014, 2015, 2017 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -240,25 +240,19 @@ scm_i_struct_hash (SCM obj, size_t depth)
if (depth > 0)
for (field_num = 0; field_num < struct_size; field_num++)
{
- int protection;
-
- protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
- if (protection != 'h' && protection != 'o')
+ int type;
+ type = scm_i_symbol_ref (layout, field_num * 2);
+ switch (type)
{
- int type;
- type = scm_i_symbol_ref (layout, field_num * 2);
- switch (type)
- {
- case 'p':
- hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
- depth / 2);
- break;
- case 'u':
- hash ^= scm_raw_ihashq (data[field_num]);
- break;
- default:
- /* Ignore 's' fields. */;
- }
+ case 'p':
+ hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
+ depth / 2);
+ break;
+ case 'u':
+ hash ^= scm_raw_ihashq (data[field_num]);
+ break;
+ default:
+ abort ();
}
}
diff --git a/libguile/print.h b/libguile/print.h
index 11f533c79..2cfc39273 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -53,7 +53,7 @@ do { \
#define SCM_COERCE_OUTPORT(p) \
(SCM_PORT_WITH_PS_P (p) ? SCM_PORT_WITH_PS_PORT (p) : p)
-#define SCM_PRINT_STATE_LAYOUT "pruwuwuwuwuwpwuwuwurprpw"
+#define SCM_PRINT_STATE_LAYOUT "pwuwuwuwuwuwpwuwuwuwpwpw"
typedef struct scm_print_state {
SCM handle; /* Struct handle */
int revealed; /* Has the state escaped to Scheme? */
diff --git a/libguile/struct.c b/libguile/struct.c
index 4ee5a81ba..eb2bfbb56 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -67,9 +67,8 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
"strung together. The first character of each pair describes a field\n"
"type, the second a field protection. Allowed types are 'p' for\n"
"GC-protected Scheme data, 'u' for unprotected binary data. \n"
- "Allowed protections\n"
- "are 'w' for mutable fields, 'h' for hidden fields, and\n"
- "'r' for read-only fields.\n\n"
+ "Allowed protections are 'w' for normal fields or 'h' for \n"
+ "hidden fields.\n\n"
"Hidden fields are writable, but they will not consume an initializer arg\n"
"passed to @code{make-struct}. They are useful to add slots to a struct\n"
"in a way that preserves backward-compatibility with existing calls to\n"
@@ -188,7 +187,12 @@ scm_is_valid_vtable_layout (SCM layout)
{
case 'w':
case 'h':
+ break;
case 'r':
+ scm_c_issue_deprecation_warning
+ ("Read-only struct fields are deprecated. Implement access "
+ "control at a higher level instead, as structs no longer "
+ "enforce field permissions.");
break;
default:
return 0;
@@ -293,7 +297,7 @@ scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits)
switch (scm_i_symbol_ref (layout, i))
{
case 'u':
- if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
+ if (prot == 'h' || inits_idx == n_inits)
*mem = 0;
else
{
@@ -303,7 +307,7 @@ scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits)
break;
case 'p':
- if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
+ if (prot == 'h' || inits_idx == n_inits)
*mem = SCM_UNPACK (SCM_BOOL_F);
else
{
@@ -470,9 +474,8 @@ SCM_DEFINE (scm_make_struct_no_tail, "make-struct/no-tail", 1, 0, 1,
"@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
"The @var{init1}, @dots{} are optional arguments describing how\n"
"successive fields of the structure should be initialized.\n"
- "Only fields with protection 'r' or 'w' can be initialized.\n"
- "Hidden fields (those with protection 'h') have to be manually\n"
- "set.\n\n"
+ "Note that hidden fields (those with protection 'h') have to be\n"
+ "manually set.\n\n"
"If fewer optional arguments than initializable fields are supplied,\n"
"fields of type 'p' get default value #f while fields of type 'u' are\n"
"initialized to 0.")
@@ -677,14 +680,10 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
else
{
SCM layout;
- scm_t_wchar field_type, protection;
+ scm_t_wchar field_type;
layout = SCM_STRUCT_LAYOUT (handle);
field_type = scm_i_symbol_ref (layout, p * 2);
- protection = scm_i_symbol_ref (layout, p * 2 + 1);
-
- if (protection == 'r')
- SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
if (field_type == 'p')
SCM_STRUCT_SLOT_SET (handle, p, val);
diff --git a/libguile/struct.h b/libguile/struct.h
index 32af8ab5a..58228daa1 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -55,7 +55,7 @@
/* All vtables have the following fields. */
#define SCM_VTABLE_BASE_LAYOUT \
- "pr" /* layout */ \
+ "pw" /* layout */ \
"uh" /* flags */ \
"uh" /* finalizer */ \
"pw" /* printer */ \
diff --git a/libguile/values.c b/libguile/values.c
index 2b2ec3f51..f77a977c9 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011, 2012, 2017 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -141,7 +141,7 @@ scm_init_values (void)
{
SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values);
- scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pr"), print);
+ scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pw"), print);
scm_add_feature ("values");
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index c2d3a2625..a735bf44d 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1178,7 +1178,7 @@ VALUE."
;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable
- (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+ (let ((s (make-vtable (string-append standard-vtable-fields "pwpwpw")
(lambda (s p)
(display "#<record-type " p)
(display (record-type-name s) p)
@@ -1328,7 +1328,7 @@ VALUE."
(define <parameter>
;; Three fields: the procedure itself, the fluid, and the converter.
- (make-struct/no-tail <applicable-struct-vtable> 'pwprpr))
+ (make-struct/no-tail <applicable-struct-vtable> 'pwpwpw))
(set-struct-vtable-name! <parameter> '<parameter>)
(define* (make-parameter init #:optional (conv (lambda (x) x)))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 39bff0667..a8a02f5bc 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -309,7 +309,7 @@
((_ (name) tail)
(string-append "pw" tail))
((_ (name #:class <protected-read-only-slot>) tail)
- (string-append "pr" tail))
+ (string-append "pw" tail))
((_ (name #:class <hidden-slot>) tail)
(string-append "uh" tail))
((_ (name #:class <protected-hidden-slot>) tail)
@@ -795,7 +795,6 @@ slots as we go."
((subclass? type <protected-slot>) #\p)
(else #\u))
(cond
- ((subclass? type <read-only-slot>) #\r)
((subclass? type <hidden-slot>) #\h)
(else #\w)))
(values #\p #\w))))
diff --git a/module/rnrs/records/procedural.scm b/module/rnrs/records/procedural.scm
index 69c5d1c56..cbcd4e5ce 100644
--- a/module/rnrs/records/procedural.scm
+++ b/module/rnrs/records/procedural.scm
@@ -80,13 +80,13 @@
(define vtable-base-layout (symbol->string (struct-layout (make-vtable ""))))
(define record-type-vtable
- (make-vtable (string-append vtable-base-layout "prprprprprprprprprpr")
+ (make-vtable (string-append vtable-base-layout "pwpwpwpwpwpwpwpwpwpw")
(lambda (obj port)
(simple-format port "#<r6rs:record-type:~A>"
(struct-ref obj rtd-index-name)))))
(define record-constructor-vtable
- (make-vtable "prprpr"
+ (make-vtable "pwpwpw"
(lambda (obj port)
(simple-format port "#<r6rs:record-constructor:~A>"
(struct-ref (struct-ref obj rctd-index-rtd)
@@ -97,7 +97,7 @@
(define (make-record-type-descriptor name parent uid sealed? opaque? fields)
(define fields-pair
(let loop ((field-list (vector->list fields))
- (layout-sym 'pr)
+ (layout-sym 'pw)
(layout-bit-field 0)
(counter 0))
(if (null? field-list)
@@ -105,7 +105,7 @@
(case (caar field-list)
((immutable)
(loop (cdr field-list)
- (symbol-append layout-sym 'pr)
+ (symbol-append layout-sym 'pw)
layout-bit-field
(+ counter 1)))
((mutable)
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 433032031..626026d74 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -47,7 +47,7 @@
(define %condition-type-vtable
;; The vtable of all condition types.
;; user fields: id, parent, all-field-names
- (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
+ (let ((s (make-vtable (string-append standard-vtable-fields "pwpwpw")
(lambda (ct port)
(format port "#<condition-type ~a ~a>"
(condition-type-id ct)
@@ -92,11 +92,11 @@
;; Return a string denoting the layout required to hold the fields listed
;; in FIELD-NAMES.
(let loop ((field-names field-names)
- (layout '("pr")))
+ (layout '("pw")))
(if (null? field-names)
(string-concatenate/shared layout)
(loop (cdr field-names)
- (cons "pr" layout)))))
+ (cons "pw" layout)))))
(define (print-condition c port)
;; Print condition C to PORT in a way similar to how records print:
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 390cd8c74..4536a468d 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,6 +1,6 @@
;;;; goops.test --- test suite for GOOPS -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -148,7 +148,7 @@
;; Previously, `class-of' would fail for nameless structs, i.e., structs
;; for which `struct-vtable-name' is #f.
(is-a? (class-of (make-vtable
- (string-append standard-vtable-fields "prprpr")))
+ (string-append standard-vtable-fields "pwpwpw")))
<class>))
;; Two cases: one for structs created before goops, one after.
@@ -157,7 +157,7 @@
(class-of (current-module))))
(pass-if "late vtable class cached"
(let ((vtable (make-vtable
- (string-append standard-vtable-fields "prprpr"))))
+ (string-append standard-vtable-fields "pwpwpw"))))
(eq? (class-of vtable)
(class-of vtable)))))
diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index c18e42194..3cbc67db3 100644
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -27,7 +27,7 @@
;;;
(define ball-root
- (make-vtable (string-append standard-vtable-fields "pr") 0))
+ (make-vtable (string-append standard-vtable-fields "pw") 0))
(define (make-ball-type ball-color)
(make-struct/no-tail ball-root
@@ -69,13 +69,7 @@
;; end of the vtable tower
(eq? (struct-vtable <standard-vtable>) <standard-vtable>)))
- (pass-if-exception "write-access denied"
- exception:struct-set!-denied
-
- ;; The first field of instances of BALL-ROOT is read-only.
- (struct-set! red vtable-offset-user "blue"))
-
- (pass-if "write-access granted"
+ (pass-if "write"
(set-owner! (make-ball red "Bob") "Fred")
#t)
@@ -98,7 +92,7 @@
(pass-if-exception "struct-ref out-of-range"
exception:out-of-range
- (let* ((v (make-vtable "prpr"))
+ (let* ((v (make-vtable "pwpw"))
(s (make-struct/no-tail v 'a 'b)))
(struct-ref s 2)))
@@ -112,7 +106,7 @@
(with-test-prefix "equal?"
(pass-if "simple structs"
- (let* ((vtable (make-vtable "pr"))
+ (let* ((vtable (make-vtable "pw"))
(s1 (make-struct/no-tail vtable "hello"))
(s2 (make-struct/no-tail vtable "hello")))
(equal? s1 s2)))
@@ -130,21 +124,21 @@
(with-test-prefix "hash"
(pass-if "simple structs"
- (let* ((v (make-vtable "pr"))
+ (let* ((v (make-vtable "pw"))
(s1 (make-struct/no-tail v "hello"))
(s2 (make-struct/no-tail v "hello")))
(= (hash s1 7777) (hash s2 7777))))
(pass-if "different structs"
- (let* ((v (make-vtable "pr"))
+ (let* ((v (make-vtable "pw"))
(s1 (make-struct/no-tail v "hello"))
(s2 (make-struct/no-tail v "world")))
(or (not (= (hash s1 7777) (hash s2 7777)))
(throw 'unresolved))))
(pass-if "different struct types"
- (let* ((v1 (make-vtable "pr"))
- (v2 (make-vtable "pr"))
+ (let* ((v1 (make-vtable "pw"))
+ (v2 (make-vtable "pw"))
(s1 (make-struct/no-tail v1 "hello"))
(s2 (make-struct/no-tail v2 "hello")))
(or (not (= (hash s1 7777) (hash s2 7777)))
@@ -156,7 +150,7 @@
(= (hash s1 7777) (hash s2 7777))))
(pass-if "struct with weird fields"
- (let* ((v (make-vtable "prurph"))
+ (let* ((v (make-vtable "pwuwph"))
(s1 (make-struct/no-tail v "hello" 123 "invisible-secret1"))
(s2 (make-struct/no-tail v "hello" 123 "invisible-secret2")))
(= (hash s1 7777) (hash s2 7777))))
@@ -191,7 +185,7 @@
(with-test-prefix "make-vtable"
(pass-if "without printer"
- (let* ((vtable (make-vtable "pwpr"))
+ (let* ((vtable (make-vtable "pwpw"))
(struct (make-struct/no-tail vtable 'x 'y)))
(and (eq? 'x (struct-ref struct 0))
(eq? 'y (struct-ref struct 1)))))
@@ -201,7 +195,7 @@
(define (print struct port)
(display "hello" port))
- (let* ((vtable (make-vtable "pwpr" print))
+ (let* ((vtable (make-vtable "pwpw" print))
(struct (make-struct/no-tail vtable 'x 'y))
(str (call-with-output-string
(lambda (port)