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 "# ;; Three fields: the procedure itself, the fluid, and the converter. - (make-struct/no-tail 'pwprpr)) + (make-struct/no-tail 'pwpwpw)) (set-struct-vtable-name! ') (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 ) tail) - (string-append "pr" tail)) + (string-append "pw" tail)) ((_ (name #:class ) tail) (string-append "uh" tail)) ((_ (name #:class ) tail) @@ -795,7 +795,6 @@ slots as we go." ((subclass? type ) #\p) (else #\u)) (cond - ((subclass? type ) #\r) ((subclass? type ) #\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 "#" (struct-ref obj rtd-index-name))))) (define record-constructor-vtable - (make-vtable "prprpr" + (make-vtable "pwpwpw" (lambda (obj port) (simple-format port "#" (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-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"))) )) ;; 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 ) ))) - (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)