mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Replace "pr" struct fields with "pw" fields

Browse source 
* 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".
This commit is contained in:
Andy Wingo 2017-09-23 15:16:04 +02:00
parent 0f14a9e598
commit 5870188eb4
13 changed files with 83 additions and 112 deletions
Download patch file Download diff file Expand all files Collapse all files

35
benchmark-suite/benchmarks/structs.bm
View file

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

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

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

32
libguile/hash.c
View file

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

2
libguile/print.h
View file

@ -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? */

25
libguile/struct.c
View file

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

2
libguile/struct.h
View file

@ -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 */ \

4
libguile/values.c
View file

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

4
module/ice-9/boot-9.scm
View file

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

3
module/oop/goops.scm
View file

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

8
module/rnrs/records/procedural.scm
View file

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

6
module/srfi/srfi-35.scm
View file

@ -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:

6
test-suite/tests/goops.test
View file

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

28
test-suite/tests/structs.test
View file

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