mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 23:50:19 +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; -*- ;;; -*- mode: scheme; coding: iso-8859-1; -*-
;;; Structs. ;;; 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 ;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License ;;; modify it under the terms of the GNU Lesser General Public License
@ -25,44 +25,27 @@
(define iterations 2000000) (define iterations 2000000)
(define vtable2 (define vtable2
(make-vtable "prpr")) (make-vtable "pwpw"))
(define vtable7 (define vtable7
(make-vtable (string-concatenate (make-list 7 "pr")))) (make-vtable (string-concatenate (make-list 7 "pw"))))
(with-benchmark-prefix "constructors" (with-benchmark-prefix "constructors"
(benchmark "make-struct2 (opcode)" iterations (benchmark "make-struct2" iterations
(make-struct vtable2 0 1 2)) (make-struct/no-tail vtable2 1 2))
(benchmark "make-struct2 (procedure)" iterations (benchmark "make-struct7" iterations
(let ((s make-struct)) (make-struct/no-tail vtable7 1 2 3 4 5 6 7)))
(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))))
(with-benchmark-prefix "pairs" ;; for comparison (with-benchmark-prefix "pairs" ;; for comparison
(benchmark "cons" iterations
(benchmark "cons (opcode)" iterations
(cons 1 2)) (cons 1 2))
(benchmark "cons (procedure)" iterations (benchmark "list" iterations
(let ((c cons))
(c 1 2)))
(benchmark "list (opcode)" iterations
(list 1 2 3 4 5 6 7)) (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 (benchmark "make-list" iterations
(make-list 7))) (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. size), or all of these things.
@end itemize @end itemize
The second letter for each field is a permission code, 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
@itemize @bullet{} over time structs have become more of a raw low-level facility; access
@item control is better implemented as a layer on top. After all,
@code{w} -- writable, the field can be read and written. @code{struct-set!} is a cross-cutting operator that can bypass
@item abstractions made by higher-level record facilities; it's not generally
@code{r} -- read-only, the field can be read but not written. safe (in the sense of abstraction-preserving) to expose
@item @code{struct-set!} to ``untrusted'' code, even if the fields happen to
@end itemize be writable. Additionally, permission checks added overhead to every
structure access in a way that couldn't be optimized out, hampering the
Here are some examples. 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 @example
(make-vtable "pw") ;; one writable field (make-vtable "pw") ;; one scheme field
(make-vtable "prpw") ;; one read-only and one writable (make-vtable "pwuwuw") ;; one scheme and two uninterpreted fields
(make-vtable "pwuwuw") ;; one scheme and two uninterpreted
@end example @end example
The optional @var{print} argument is a function called by 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. structure.
@example @example
(make-vtable "prpw" (make-vtable "pwpw"
(lambda (struct port) (lambda (struct port)
(format port "#<~a and ~a>" (format port "#<~a and ~a>"
(struct-ref struct 0) (struct-ref struct 0)
@ -8850,7 +8852,7 @@ new name for this functionality.
For example, For example,
@example @example
(define v (make-vtable "prpwpw")) (define v (make-vtable "pwpwpw"))
(define s (make-struct/no-tail v 123 "abc" 456)) (define s (make-struct/no-tail v 123 "abc" 456))
(struct-ref s 0) @result{} 123 (struct-ref s 0) @result{} 123
(struct-ref s 1) @result{} "abc" (struct-ref s 1) @result{} "abc"
@ -9032,11 +9034,11 @@ vtables with additional data:
@example @example
scheme@@(guile-user)> (struct-ref $3 vtable-index-layout) scheme@@(guile-user)> (struct-ref $3 vtable-index-layout)
$6 = pruhsruhpwphuhuhprprpw $6 = pwuhuhpwphuhuhpwpwpw
scheme@@(guile-user)> (struct-ref $4 vtable-index-layout) scheme@@(guile-user)> (struct-ref $4 vtable-index-layout)
$7 = pruhsruhpwphuhuh $7 = pwuhuhpwphuhuh
scheme@@(guile-user)> standard-vtable-fields scheme@@(guile-user)> standard-vtable-fields
$8 = "pruhsruhpwphuhuh" $8 = "pwuhuhpwphuhuh"
scheme@@(guile-user)> (struct-ref $2 vtable-offset-user) scheme@@(guile-user)> (struct-ref $2 vtable-offset-user)
$9 = module $9 = module
@end example @end example

32
libguile/hash.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008, /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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) if (depth > 0)
for (field_num = 0; field_num < struct_size; field_num++) for (field_num = 0; field_num < struct_size; field_num++)
{ {
int protection; int type;
type = scm_i_symbol_ref (layout, field_num * 2);
protection = scm_i_symbol_ref (layout, field_num * 2 + 1); switch (type)
if (protection != 'h' && protection != 'o')
{ {
int type; case 'p':
type = scm_i_symbol_ref (layout, field_num * 2); hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
switch (type) depth / 2);
{ break;
case 'p': case 'u':
hash ^= scm_raw_ihash (SCM_PACK (data[field_num]), hash ^= scm_raw_ihashq (data[field_num]);
depth / 2); break;
break; default:
case 'u': abort ();
hash ^= scm_raw_ihashq (data[field_num]);
break;
default:
/* Ignore 's' fields. */;
}
} }
} }

2
libguile/print.h
View file

@ -53,7 +53,7 @@ do { \
#define SCM_COERCE_OUTPORT(p) \ #define SCM_COERCE_OUTPORT(p) \
(SCM_PORT_WITH_PS_P (p) ? SCM_PORT_WITH_PS_PORT (p) : 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 { typedef struct scm_print_state {
SCM handle; /* Struct handle */ SCM handle; /* Struct handle */
int revealed; /* Has the state escaped to Scheme? */ 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" "strung together. The first character of each pair describes a field\n"
"type, the second a field protection. Allowed types are 'p' for\n" "type, the second a field protection. Allowed types are 'p' for\n"
"GC-protected Scheme data, 'u' for unprotected binary data. \n" "GC-protected Scheme data, 'u' for unprotected binary data. \n"
"Allowed protections\n" "Allowed protections are 'w' for normal fields or 'h' for \n"
"are 'w' for mutable fields, 'h' for hidden fields, and\n" "hidden fields.\n\n"
"'r' for read-only fields.\n\n"
"Hidden fields are writable, but they will not consume an initializer arg\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" "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" "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 'w':
case 'h': case 'h':
break;
case 'r': 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; break;
default: default:
return 0; 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)) switch (scm_i_symbol_ref (layout, i))
{ {
case 'u': case 'u':
if ((prot != 'r' && prot != 'w') || inits_idx == n_inits) if (prot == 'h' || inits_idx == n_inits)
*mem = 0; *mem = 0;
else else
{ {
@ -303,7 +307,7 @@ scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits)
break; break;
case 'p': case 'p':
if ((prot != 'r' && prot != 'w') || inits_idx == n_inits) if (prot == 'h' || inits_idx == n_inits)
*mem = SCM_UNPACK (SCM_BOOL_F); *mem = SCM_UNPACK (SCM_BOOL_F);
else 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" "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
"The @var{init1}, @dots{} are optional arguments describing how\n" "The @var{init1}, @dots{} are optional arguments describing how\n"
"successive fields of the structure should be initialized.\n" "successive fields of the structure should be initialized.\n"
"Only fields with protection 'r' or 'w' can be initialized.\n" "Note that hidden fields (those with protection 'h') have to be\n"
"Hidden fields (those with protection 'h') have to be manually\n" "manually set.\n\n"
"set.\n\n"
"If fewer optional arguments than initializable fields are supplied,\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" "fields of type 'p' get default value #f while fields of type 'u' are\n"
"initialized to 0.") "initialized to 0.")
@ -677,14 +680,10 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
else else
{ {
SCM layout; SCM layout;
scm_t_wchar field_type, protection; scm_t_wchar field_type;
layout = SCM_STRUCT_LAYOUT (handle); layout = SCM_STRUCT_LAYOUT (handle);
field_type = scm_i_symbol_ref (layout, p * 2); 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') if (field_type == 'p')
SCM_STRUCT_SLOT_SET (handle, p, val); SCM_STRUCT_SLOT_SET (handle, p, val);

2
libguile/struct.h
View file

@ -55,7 +55,7 @@
/* All vtables have the following fields. */ /* All vtables have the following fields. */
#define SCM_VTABLE_BASE_LAYOUT \ #define SCM_VTABLE_BASE_LAYOUT \
"pr" /* layout */ \ "pw" /* layout */ \
"uh" /* flags */ \ "uh" /* flags */ \
"uh" /* finalizer */ \ "uh" /* finalizer */ \
"pw" /* printer */ \ "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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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 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"); 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 ;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable (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) (lambda (s p)
(display "#<record-type " p) (display "#<record-type " p)
(display (record-type-name s) p) (display (record-type-name s) p)
@ -1328,7 +1328,7 @@ VALUE."
(define <parameter> (define <parameter>
;; Three fields: the procedure itself, the fluid, and the converter. ;; 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>) (set-struct-vtable-name! <parameter> '<parameter>)
(define* (make-parameter init #:optional (conv (lambda (x) x))) (define* (make-parameter init #:optional (conv (lambda (x) x)))

3
module/oop/goops.scm
View file

@ -309,7 +309,7 @@
((_ (name) tail) ((_ (name) tail)
(string-append "pw" tail)) (string-append "pw" tail))
((_ (name #:class <protected-read-only-slot>) tail) ((_ (name #:class <protected-read-only-slot>) tail)
(string-append "pr" tail)) (string-append "pw" tail))
((_ (name #:class <hidden-slot>) tail) ((_ (name #:class <hidden-slot>) tail)
(string-append "uh" tail)) (string-append "uh" tail))
((_ (name #:class <protected-hidden-slot>) tail) ((_ (name #:class <protected-hidden-slot>) tail)
@ -795,7 +795,6 @@ slots as we go."
((subclass? type <protected-slot>) #\p) ((subclass? type <protected-slot>) #\p)
(else #\u)) (else #\u))
(cond (cond
((subclass? type <read-only-slot>) #\r)
((subclass? type <hidden-slot>) #\h) ((subclass? type <hidden-slot>) #\h)
(else #\w))) (else #\w)))
(values #\p #\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 vtable-base-layout (symbol->string (struct-layout (make-vtable ""))))
(define record-type-vtable (define record-type-vtable
(make-vtable (string-append vtable-base-layout "prprprprprprprprprpr") (make-vtable (string-append vtable-base-layout "pwpwpwpwpwpwpwpwpwpw")
(lambda (obj port) (lambda (obj port)
(simple-format port "#<r6rs:record-type:~A>" (simple-format port "#<r6rs:record-type:~A>"
(struct-ref obj rtd-index-name))))) (struct-ref obj rtd-index-name)))))
(define record-constructor-vtable (define record-constructor-vtable
(make-vtable "prprpr" (make-vtable "pwpwpw"
(lambda (obj port) (lambda (obj port)
(simple-format port "#<r6rs:record-constructor:~A>" (simple-format port "#<r6rs:record-constructor:~A>"
(struct-ref (struct-ref obj rctd-index-rtd) (struct-ref (struct-ref obj rctd-index-rtd)
@ -97,7 +97,7 @@
(define (make-record-type-descriptor name parent uid sealed? opaque? fields) (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
(define fields-pair (define fields-pair
(let loop ((field-list (vector->list fields)) (let loop ((field-list (vector->list fields))
(layout-sym 'pr) (layout-sym 'pw)
(layout-bit-field 0) (layout-bit-field 0)
(counter 0)) (counter 0))
(if (null? field-list) (if (null? field-list)
@ -105,7 +105,7 @@
(case (caar field-list) (case (caar field-list)
((immutable) ((immutable)
(loop (cdr field-list) (loop (cdr field-list)
(symbol-append layout-sym 'pr) (symbol-append layout-sym 'pw)
layout-bit-field layout-bit-field
(+ counter 1))) (+ counter 1)))
((mutable) ((mutable)

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

@ -47,7 +47,7 @@
(define %condition-type-vtable (define %condition-type-vtable
;; The vtable of all condition types. ;; The vtable of all condition types.
;; user fields: id, parent, all-field-names ;; 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) (lambda (ct port)
(format port "#<condition-type ~a ~a>" (format port "#<condition-type ~a ~a>"
(condition-type-id ct) (condition-type-id ct)
@ -92,11 +92,11 @@
;; Return a string denoting the layout required to hold the fields listed ;; Return a string denoting the layout required to hold the fields listed
;; in FIELD-NAMES. ;; in FIELD-NAMES.
(let loop ((field-names field-names) (let loop ((field-names field-names)
(layout '("pr"))) (layout '("pw")))
(if (null? field-names) (if (null? field-names)
(string-concatenate/shared layout) (string-concatenate/shared layout)
(loop (cdr field-names) (loop (cdr field-names)
(cons "pr" layout))))) (cons "pw" layout)))))
(define (print-condition c port) (define (print-condition c port)
;; Print condition C to PORT in a way similar to how records print: ;; 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 -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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 ;; Previously, `class-of' would fail for nameless structs, i.e., structs
;; for which `struct-vtable-name' is #f. ;; for which `struct-vtable-name' is #f.
(is-a? (class-of (make-vtable (is-a? (class-of (make-vtable
(string-append standard-vtable-fields "prprpr"))) (string-append standard-vtable-fields "pwpwpw")))
<class>)) <class>))
;; Two cases: one for structs created before goops, one after. ;; Two cases: one for structs created before goops, one after.
@ -157,7 +157,7 @@
(class-of (current-module)))) (class-of (current-module))))
(pass-if "late vtable class cached" (pass-if "late vtable class cached"
(let ((vtable (make-vtable (let ((vtable (make-vtable
(string-append standard-vtable-fields "prprpr")))) (string-append standard-vtable-fields "pwpwpw"))))
(eq? (class-of vtable) (eq? (class-of vtable)
(class-of vtable))))) (class-of vtable)))))

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

@ -27,7 +27,7 @@
;;; ;;;
(define ball-root (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) (define (make-ball-type ball-color)
(make-struct/no-tail ball-root (make-struct/no-tail ball-root
@ -69,13 +69,7 @@
;; end of the vtable tower ;; end of the vtable tower
(eq? (struct-vtable <standard-vtable>) <standard-vtable>))) (eq? (struct-vtable <standard-vtable>) <standard-vtable>)))
(pass-if-exception "write-access denied" (pass-if "write"
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"
(set-owner! (make-ball red "Bob") "Fred") (set-owner! (make-ball red "Bob") "Fred")
#t) #t)
@ -98,7 +92,7 @@
(pass-if-exception "struct-ref out-of-range" (pass-if-exception "struct-ref out-of-range"
exception: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))) (s (make-struct/no-tail v 'a 'b)))
(struct-ref s 2))) (struct-ref s 2)))
@ -112,7 +106,7 @@
(with-test-prefix "equal?" (with-test-prefix "equal?"
(pass-if "simple structs" (pass-if "simple structs"
(let* ((vtable (make-vtable "pr")) (let* ((vtable (make-vtable "pw"))
(s1 (make-struct/no-tail vtable "hello")) (s1 (make-struct/no-tail vtable "hello"))
(s2 (make-struct/no-tail vtable "hello"))) (s2 (make-struct/no-tail vtable "hello")))
(equal? s1 s2))) (equal? s1 s2)))
@ -130,21 +124,21 @@
(with-test-prefix "hash" (with-test-prefix "hash"
(pass-if "simple structs" (pass-if "simple structs"
(let* ((v (make-vtable "pr")) (let* ((v (make-vtable "pw"))
(s1 (make-struct/no-tail v "hello")) (s1 (make-struct/no-tail v "hello"))
(s2 (make-struct/no-tail v "hello"))) (s2 (make-struct/no-tail v "hello")))
(= (hash s1 7777) (hash s2 7777)))) (= (hash s1 7777) (hash s2 7777))))
(pass-if "different structs" (pass-if "different structs"
(let* ((v (make-vtable "pr")) (let* ((v (make-vtable "pw"))
(s1 (make-struct/no-tail v "hello")) (s1 (make-struct/no-tail v "hello"))
(s2 (make-struct/no-tail v "world"))) (s2 (make-struct/no-tail v "world")))
(or (not (= (hash s1 7777) (hash s2 7777))) (or (not (= (hash s1 7777) (hash s2 7777)))
(throw 'unresolved)))) (throw 'unresolved))))
(pass-if "different struct types" (pass-if "different struct types"
(let* ((v1 (make-vtable "pr")) (let* ((v1 (make-vtable "pw"))
(v2 (make-vtable "pr")) (v2 (make-vtable "pw"))
(s1 (make-struct/no-tail v1 "hello")) (s1 (make-struct/no-tail v1 "hello"))
(s2 (make-struct/no-tail v2 "hello"))) (s2 (make-struct/no-tail v2 "hello")))
(or (not (= (hash s1 7777) (hash s2 7777))) (or (not (= (hash s1 7777) (hash s2 7777)))
@ -156,7 +150,7 @@
(= (hash s1 7777) (hash s2 7777)))) (= (hash s1 7777) (hash s2 7777))))
(pass-if "struct with weird fields" (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")) (s1 (make-struct/no-tail v "hello" 123 "invisible-secret1"))
(s2 (make-struct/no-tail v "hello" 123 "invisible-secret2"))) (s2 (make-struct/no-tail v "hello" 123 "invisible-secret2")))
(= (hash s1 7777) (hash s2 7777)))) (= (hash s1 7777) (hash s2 7777))))
@ -191,7 +185,7 @@
(with-test-prefix "make-vtable" (with-test-prefix "make-vtable"
(pass-if "without printer" (pass-if "without printer"
(let* ((vtable (make-vtable "pwpr")) (let* ((vtable (make-vtable "pwpw"))
(struct (make-struct/no-tail vtable 'x 'y))) (struct (make-struct/no-tail vtable 'x 'y)))
(and (eq? 'x (struct-ref struct 0)) (and (eq? 'x (struct-ref struct 0))
(eq? 'y (struct-ref struct 1))))) (eq? 'y (struct-ref struct 1)))))
@ -201,7 +195,7 @@
(define (print struct port) (define (print struct port)
(display "hello" port)) (display "hello" port))
(let* ((vtable (make-vtable "pwpr" print)) (let* ((vtable (make-vtable "pwpw" print))
(struct (make-struct/no-tail vtable 'x 'y)) (struct (make-struct/no-tail vtable 'x 'y))
(str (call-with-output-string (str (call-with-output-string
(lambda (port) (lambda (port)