mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Merge stable-2.2 into master

Browse source 
This commit resolves conflicts by removing the deprecated make-struct.
This commit is contained in:
Andy Wingo 2017-09-22 11:59:51 +02:00
commit 2f9ad7d9bc
24 changed files with 293 additions and 310 deletions
Download patch file Download diff file Expand all files Collapse all files

41
NEWS
View file

@ -77,6 +77,47 @@ If you don't care whether the URI is a relative-ref or not, use
In the future `uri?' will return a true value only for URIs that specify
a scheme.
** Struct tail arrays deprecated
Guile's structures used to have a facility whereby each instance of a
vtable can contain a variable-length tail array of values. The length
of the tail array was stored in the structure. This facility was
originally intended to allow C code to expose raw C structures with
word-sized tail arrays to Scheme.
However, the tail array facility was confusing and doesn't work very
well. It was very rarely used, but it insinuates itself into all
invocations of `make-struct'. For this reason the clumsily-named
`make-struct/no-tail' procedure can actually be more elegant in actual
use, because it doesn't have a random `0' argument stuck in the middle.
Tail arrays also inhibit optimization by allowing instances to affect
their shapes. In the absence of tail arrays, all instances of a given
vtable have the same number and kinds of fields. This uniformity can be
exploited by the runtime and the optimizer. The presence of tail arrays
make some of these optimizations more difficult.
Finally, the tail array facility is ad-hoc and does not compose with the
rest of Guile. If a Guile user wants an array with user-specified
length, it's best to use a vector. It is more clear in the code, and
the standard optimization techniques will do a good job with it.
For all of these reasons, tail arrays are deprecated in Guile 2.2 and
will be removed from Guile 3.0. Likewise, `make-struct' /
`scm_make_struct' is deprecated in favor of `make-struct/no-tail' /
`scm_make_struct_no_tail'. Perhaps one day we will be able to reclaim
the `make-struct' name!
** Struct "self" slots deprecated
It used to be that you could make a structure vtable that had "self"
slots. Instances of that vtable would have those slots initialized to
the instance itself. This can be useful in C code where you might have
a pointer to the data array, and want to get the `SCM' handle for the
structure. However this was a little used complication without any use
in Scheme code. To replace it, just use "p" slots and initialize the
slot values manually on initialization.
* Bug fixes
** Enable GNU Readline 7.0's support for "bracketed paste".

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

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000-2004, 2006-2016
@c Copyright (C) 1996, 1997, 2000-2004, 2006-2017
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -8757,7 +8757,6 @@ records in Guile are implemented with structures.
* Vtable Contents::
* Meta-Vtables::
* Vtable Example::
* Tail Arrays::
@end menu
@node Vtables
@ -8786,13 +8785,6 @@ Scheme level it's read and written as an unsigned integer. ``u''
stands for ``uninterpreted'' (it's not treated as a Scheme value), or
``unprotected'' (it's not marked during GC), or ``unsigned long'' (its
size), or all of these things.
@item
@code{s} -- a self-reference. Such a field holds the @code{SCM} value
of the structure itself (a circular reference). This can be useful in
C code where you might have a pointer to the data array, and want to
get the Scheme @code{SCM} handle for the structure. In Scheme code it
has no use.
@end itemize
The second letter for each field is a permission code,
@ -8808,8 +8800,7 @@ Scheme level. This can be used for fields which should only be used
from C code.
@end itemize
Here are some examples. @xref{Tail Arrays}, for information on the
legacy tail array facility.
Here are some examples.
@example
(make-vtable "pw") ;; one writable field
@ -8840,12 +8831,11 @@ structure.
@node Structure Basics
@subsubsection Structure Basics
This section describes the basic procedures for working with
structures. @code{make-struct} creates a structure, and
@code{struct-ref} and @code{struct-set!} access its fields.
This section describes the basic procedures for working with structures.
@code{make-struct/no-tail} creates a structure, and @code{struct-ref}
and @code{struct-set!} access its fields.
@deffn {Scheme Procedure} make-struct vtable tail-size init @dots{}
@deffnx {Scheme Procedure} make-struct/no-tail vtable init @dots{}
@deffn {Scheme Procedure} make-struct/no-tail vtable init @dots{}
Create a new structure, with layout per the given @var{vtable}
(@pxref{Vtables}).
@ -8855,25 +8845,21 @@ 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}).
Structures also have the ability to allocate a variable number of
additional cells at the end, at their tails. However, this legacy
@dfn{tail array} facilty is confusing and inefficient, and so we do not
recommend it. @xref{Tail Arrays}, for more on the legacy tail array
interface.
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;
while we deprecate that old interface, @code{make-struct/no-tail} is the
new name for this functionality.
Type @code{s} self-reference fields, permission @code{o} opaque
fields, and the count field of a tail array are all ignored for the
@var{init} arguments, ie.@: an argument is not consumed by such a
field. An @code{s} is always set to the structure itself, an @code{o}
is always set to @code{#f} or 0 (with the intention that C code will
do something to it later), and the tail count is always the given
@var{tail-size}.
Fields with permission @code{o} opaque fields are ignored for the
@var{init} arguments, ie.@: an argument is not consumed by such a field.
An @code{o} slot is always set to @code{#f} or 0 (with the intention
that C code will do something to it later).
For example,
@example
(define v (make-vtable "prpwpw"))
(define s (make-struct v 0 123 "abc" 456))
(define s (make-struct/no-tail v 123 "abc" 456))
(struct-ref s 0) @result{} 123
(struct-ref s 1) @result{} "abc"
@end example
@ -8886,6 +8872,8 @@ There are a few ways to make structures from C. @code{scm_make_struct}
takes a list, @code{scm_c_make_struct} takes variable arguments
terminated with SCM_UNDEFINED, and @code{scm_c_make_structv} takes a
packed array.
For all of these, @var{tail_size} should be zero (as a SCM value).
@end deftypefn
@deffn {Scheme Procedure} struct? obj
@ -9197,53 +9185,6 @@ cases, the records facility is usually sufficient. But sometimes you
need to make new kinds of data abstractions, and for that purpose,
structs are here.
@node Tail Arrays
@subsubsection Tail Arrays
Guile's structures have a facility whereby each instance of a vtable can
contain a variable-length tail array of values. The length of the tail
array is stored in the structure. This facility was originally intended
to allow C code to expose raw C structures with word-sized tail arrays
to Scheme.
However, the tail array facility is confusing and doesn't work very
well. It is very rarely used, but it insinuates itself into all
invocations of @code{make-struct}. For this reason the clumsily-named
@code{make-struct/no-tail} procedure can actually be more elegant in
actual use, because it doesn't have a random @code{0} argument stuck in
the middle.
Tail arrays also inhibit optimization by allowing instances to affect
their shapes. In the absence of tail arrays, all instances of a given
vtable have the same number and kinds of fields. This uniformity can be
exploited by the runtime and the optimizer. The presence of tail arrays
make some of these optimizations more difficult.
Finally, the tail array facility is ad-hoc and does not compose with the
rest of Guile. If a Guile user wants an array with user-specified
length, it's best to use a vector. It is more clear in the code, and
the standard optimization techniques will do a good job with it.
That said, we should mention some details about the interface. A vtable
that has tail array has upper-case permission descriptors: @code{W},
@code{R} or @code{O}, correspoding to tail arrays of writable,
read-only, or opaque elements. A tail array permission descriptor may
only appear in the last element of a vtable layout.
For exampple, @samp{pW} indicates a tail of writable Scheme-valued
fields. The @samp{pW} field itself holds the tail size, and the tail
fields come after it.
@example
(define v (make-vtable "prpW")) ;; one fixed then a tail array
(define s (make-struct v 6 "fixed field" 'x 'y))
(struct-ref s 0) @result{} "fixed field"
(struct-ref s 1) @result{} 2 ;; tail size
(struct-ref s 2) @result{} x ;; tail array ...
(struct-ref s 3) @result{} y
(struct-ref s 4) @result{} #f
@end example
@node Dictionary Types
@subsection Dictionary Types

2
doc/ref/api-foreign.texi
View file

@ -493,6 +493,8 @@ platform-dependent size:
@defvrx {Scheme Variable} unsigned-int
@defvrx {Scheme Variable} long
@defvrx {Scheme Variable} unsigned-long
@defvrx {Scheme Variable} short
@defvrx {Scheme Variable} unsigned-short
@defvrx {Scheme Variable} size_t
@defvrx {Scheme Variable} ssize_t
@defvrx {Scheme Variable} ptrdiff_t

8
libguile/filesys.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006,
* 2009, 2010, 2011, 2012, 2013, 2014, 2016 Free Software Foundation, Inc.
* 2009, 2010, 2011, 2012, 2013, 2014, 2016, 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
@ -1679,7 +1679,11 @@ scm_i_relativize_path (SCM path, SCM in_path)
if (len > 0
&& scm_is_true (scm_string_prefix_p (dir, scanon,
SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED, SCM_UNDEFINED)))
SCM_UNDEFINED, SCM_UNDEFINED))
/* Make sure SCANON starts with DIR followed by a separator. */
&& (is_file_name_separator (scm_c_string_ref (dir, len - 1))
|| is_file_name_separator (scm_c_string_ref (scanon, len))))
{
/* DIR either has a trailing delimiter or doesn't. SCANON
will be delimited by single delimiters. When DIR does not

6
libguile/print.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
* 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
* 2009, 2010, 2011, 2012, 2013, 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
@ -194,9 +194,9 @@ SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0,
static SCM
make_print_state (void)
{
SCM print_state
= scm_make_struct (scm_print_state_vtable, SCM_INUM0, SCM_EOL);
SCM print_state = scm_make_struct_no_tail (scm_print_state_vtable, SCM_EOL);
scm_print_state *pstate = SCM_PRINT_STATE (print_state);
pstate->handle = print_state;
pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect);
pstate->highlight_objects = SCM_EOL;

4
libguile/print.h
View file

@ -4,7 +4,7 @@
#define SCM_PRINT_H
/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006, 2008,
* 2010, 2012 Free Software Foundation, Inc.
* 2010, 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
@ -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 "sruwuwuwuwuwpwuwuwurprpw"
#define SCM_PRINT_STATE_LAYOUT "pruwuwuwuwuwpwuwuwurprpw"
typedef struct scm_print_state {
SCM handle; /* Struct handle */
int revealed; /* Has the state escaped to Scheme? */

5
libguile/procs.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2006, 2008, 2009,
* 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
* 2010, 2011, 2012, 2013, 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
@ -90,8 +90,7 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
{
SCM_VALIDATE_PROC (1, procedure);
SCM_VALIDATE_PROC (2, setter);
return scm_make_struct (pws_vtable, SCM_INUM0,
scm_list_2 (procedure, setter));
return scm_make_struct_no_tail (pws_vtable, scm_list_2 (procedure, setter));
}
#undef FUNC_NAME

4
libguile/r6rs-ports.c
View file

@ -602,7 +602,7 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
}
else
{
if (SCM_UNLIKELY (c_start >= c_len))
if (SCM_UNLIKELY (c_start > c_len))
scm_out_of_range (FUNC_NAME, start);
else
c_count = c_len - c_start;
@ -645,7 +645,7 @@ SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2, 2, 0,
}
else
{
if (SCM_UNLIKELY (c_start >= c_len))
if (SCM_UNLIKELY (c_start > c_len))
scm_out_of_range (FUNC_NAME, start);
else
c_count = c_len - c_start;

4
libguile/stacks.c
View file

@ -1,5 +1,5 @@
/* A stack holds a frame chain
* Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation
* Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -388,7 +388,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
if (n > 0)
{
/* Make the stack object. */
SCM stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
SCM stack = scm_make_struct_no_tail (scm_stack_type, SCM_EOL);
SCM_SET_STACK_LENGTH (stack, n);
SCM_SET_STACK_ID (stack, scm_stack_id (obj));
SCM_SET_STACK_FRAME (stack, scm_c_make_frame (kind, &frame));

100
libguile/struct.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
* 2008, 2009, 2010, 2011, 2012, 2013, 2015, 2017 Free Software Foundation, Inc.
/* Copyright (C) 1996-2001, 2003-2004, 2006-2013, 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
@ -30,6 +30,7 @@
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
#include "libguile/deprecation.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
#include "libguile/hashtab.h"
@ -68,16 +69,14 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
"@var{fields} must be a string made up of pairs of characters\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"
"GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
"a field that points to the structure itself. Allowed protections\n"
"GC-protected Scheme data, 'u' for unprotected binary data. \n"
"Allowed protections\n"
"are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n"
"fields, and 'o' for opaque 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"
"@code{make-struct}, especially for derived vtables.\n\n"
"The last field protection specification may be capitalized to indicate\n"
"that the field is a tail-array.")
"@code{make-struct}, especially for derived vtables.")
#define FUNC_NAME s_scm_make_struct_layout
{
SCM new_sym;
@ -100,10 +99,6 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
{
case 'u':
case 'p':
#if 0
case 'i':
case 'd':
#endif
case 's':
break;
default:
@ -134,16 +129,6 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
SCM_MISC_ERROR ("unrecognized ref specification: ~S",
scm_list_1 (SCM_MAKE_CHAR (c)));
}
#if 0
if (scm_i_string_ref (fields, x, 'd'))
{
if (!scm_i_string_ref (fields, x+2, '-'))
SCM_MISC_ERROR ("missing dash field at position ~A",
scm_list_1 (scm_from_int (x / 2)));
x += 2;
goto recheck_ref;
}
#endif
}
new_sym = scm_string_to_symbol (fields);
}
@ -243,6 +228,23 @@ scm_is_valid_vtable_layout (SCM layout)
return 1;
}
static void
issue_deprecation_warning_for_self_slots (SCM vtable)
{
SCM olayout;
size_t idx, first_user_slot = 0;
olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (vtable));
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE))
first_user_slot = scm_vtable_offset_user;
for (idx = first_user_slot * 2; idx < scm_c_string_length (olayout); idx += 2)
if (scm_is_eq (scm_c_string_ref (olayout, idx), SCM_MAKE_CHAR ('s')))
scm_c_issue_deprecation_warning
("Vtables with \"self\" slots are deprecated. Initialize these "
"fields manually.");
}
/* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
vtable-vtable and OBJ is an instance of VTABLE. */
void
@ -302,6 +304,8 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
}
issue_deprecation_warning_for_self_slots (obj);
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VALIDATED);
}
#undef FUNC_NAME
@ -540,23 +544,19 @@ SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
SCM_DEFINE (scm_make_struct_no_tail, "make-struct/no-tail", 1, 0, 1,
(SCM vtable, SCM init),
"Create a new structure.\n\n"
"@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
"@var{tail_array_size} must be a non-negative integer. If the layout\n"
"specification indicated by @var{vtable} includes a tail-array,\n"
"this is the number of elements allocated to that array.\n\n"
"The @var{init1}, @dots{} are optional arguments describing how\n"
"successive fields of the structure should be initialized. Only fields\n"
"with protection 'r' or 'w' can be initialized, except for fields of\n"
"type 's', which are automatically initialized to point to the new\n"
"structure itself. Fields with protection 'o' can not be initialized by\n"
"Scheme programs.\n\n"
"successive fields of the structure should be initialized.\n"
"Only fields with protection 'r' or 'w' can be initialized.\n"
"Fields with protection 'o' can not be initialized by Scheme\n"
"programs.\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.")
#define FUNC_NAME s_scm_make_struct
#define FUNC_NAME s_scm_make_struct_no_tail
{
size_t i, n_init;
long ilen;
@ -579,7 +579,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
for (i = 0; i < n_init; i++, init = SCM_CDR (init))
v[i] = SCM_UNPACK (SCM_CAR (init));
return scm_c_make_structv (vtable, scm_to_size_t (tail_array_size), n_init, v);
return scm_c_make_structv (vtable, 0, n_init, v);
}
#undef FUNC_NAME
@ -625,9 +625,9 @@ SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
if (SCM_UNBNDP (printer))
printer = SCM_BOOL_F;
return scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_2 (scm_make_struct_layout (fields),
printer));
return scm_c_make_struct (scm_standard_vtable_vtable, 0, 2,
SCM_UNPACK (scm_make_struct_layout (fields)),
SCM_UNPACK (printer));
}
#undef FUNC_NAME
@ -748,16 +748,6 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
answer = scm_from_ulong (data[p]);
break;
#if 0
case 'i':
answer = scm_from_long (data[p]);
break;
case 'd':
answer = scm_make_real (*((double *)&(data[p])));
break;
#endif
case 's':
case 'p':
answer = SCM_PACK (data[p]);
@ -831,16 +821,6 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
data[p] = SCM_NUM2ULONG (3, val);
break;
#if 0
case 'i':
data[p] = SCM_NUM2LONG (3, val);
break;
case 'd':
*((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
break;
#endif
case 'p':
data[p] = SCM_UNPACK (val);
break;
@ -979,8 +959,8 @@ scm_init_struct ()
scm_define (name, scm_standard_vtable_vtable);
scm_applicable_struct_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
scm_c_make_struct (scm_standard_vtable_vtable, 0, 1,
SCM_UNPACK (scm_make_struct_layout (required_vtable_fields)));
name = scm_from_utf8_symbol ("<applicable-struct-vtable>");
SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
@ -988,8 +968,8 @@ scm_init_struct ()
scm_define (name, scm_applicable_struct_vtable_vtable);
scm_applicable_struct_with_setter_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
scm_c_make_struct (scm_standard_vtable_vtable, 0, 1,
SCM_UNPACK (scm_make_struct_layout (required_vtable_fields)));
name = scm_from_utf8_symbol ("<applicable-struct-with-setter-vtable>");
scm_set_struct_vtable_name_x (scm_applicable_struct_with_setter_vtable_vtable, name);
SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,

5
libguile/struct.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2015, 2017 Free Software Foundation, Inc.
/* Copyright (C) 1995,1997,1999-2001, 2006-2013, 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
@ -153,7 +154,7 @@ SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x);
SCM_INTERNAL SCM scm_allocate_struct (SCM vtable, SCM n_words);
SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
SCM_API SCM scm_make_struct_no_tail (SCM vtable, SCM init);
SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
scm_t_bits init, ...);
SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,

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

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;; Copyright (C) 1995-2014, 2016 Free Software Foundation, Inc.
;;;; Copyright (C) 1995-2014, 2016-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
@ -208,14 +208,6 @@ This is handy for tracing function calls, e.g.:
;;; {Structs}
;;;
(define (make-struct/no-tail vtable . args)
(apply make-struct vtable 0 args))
;;; {map and for-each}
;;;
@ -1233,7 +1225,7 @@ VALUE."
(else
(lambda args
(if (= (length args) nfields)
(apply make-struct rtd 0 args)
(apply make-struct/no-tail rtd args)
(scm-error 'wrong-number-of-args
(format #f "make-~a" type-name)
"Wrong number of arguments" '() #f)))))))))
@ -1252,13 +1244,14 @@ VALUE."
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
(let ((rtd (make-struct record-type-vtable 0
(make-struct-layout
(apply string-append
(map (lambda (f) "pw") fields)))
(or printer default-record-printer)
type-name
(copy-tree fields))))
(let ((rtd (make-struct/no-tail
record-type-vtable
(make-struct-layout
(apply string-append
(map (lambda (f) "pw") fields)))
(or printer default-record-printer)
type-name
(copy-tree fields))))
(struct-set! rtd (+ vtable-offset-user 2)
(make-constructor rtd (length fields)))
;; Temporary solution: Associate a name to the record type descriptor
@ -1283,7 +1276,8 @@ VALUE."
(struct-ref rtd (+ 2 vtable-offset-user))
(primitive-eval
`(lambda ,field-names
(make-struct ',rtd 0 ,@(map (lambda (f)
(make-struct/no-tail ',rtd
,@(map (lambda (f)
(if (memq f field-names)
f
#f))
@ -1334,7 +1328,7 @@ VALUE."
(define <parameter>
;; Three fields: the procedure itself, the fluid, and the converter.
(make-struct <applicable-struct-vtable> 0 'pwprpr))
(make-struct/no-tail <applicable-struct-vtable> 'pwprpr))
(set-struct-vtable-name! <parameter> '<parameter>)
(define* (make-parameter init #:optional (conv (lambda (x) x)))
@ -1367,13 +1361,14 @@ including INIT, the initial value. The default CONV procedure is the
identity procedure. CONV is commonly used to ensure some set of
invariants on the values that a parameter may have."
(let ((fluid (make-fluid (conv init))))
(make-struct <parameter> 0
(case-lambda
(() (fluid-ref fluid))
((x) (let ((prev (fluid-ref fluid)))
(fluid-set! fluid (conv x))
prev)))
fluid conv)))
(make-struct/no-tail
<parameter>
(case-lambda
(() (fluid-ref fluid))
((x) (let ((prev (fluid-ref fluid)))
(fluid-set! fluid (conv x))
prev)))
fluid conv)))
(define (parameter? x)
(and (struct? x) (eq? (struct-vtable x) <parameter>)))
@ -1412,13 +1407,14 @@ If the parameter is rebound in some dynamic extent, perhaps via
`parameterize', the new value will be run through the optional CONV
procedure, as with any parameter. Note that unlike `make-parameter',
CONV is not applied to the initial value."
(make-struct <parameter> 0
(case-lambda
(() (fluid-ref fluid))
((x) (let ((prev (fluid-ref fluid)))
(fluid-set! fluid (conv x))
prev)))
fluid conv))
(make-struct/no-tail
<parameter>
(case-lambda
(() (fluid-ref fluid))
((x) (let ((prev (fluid-ref fluid)))
(fluid-set! fluid (conv x))
prev)))
fluid conv))
@ -1946,11 +1942,12 @@ name extensions listed in %load-extensions."
(constructor rtd type-name fields
#`(begin
(define #,rtd
(make-struct record-type-vtable 0
'#,(make-layout)
#,printer
'#,type-name
'#,(field-list fields)))
(make-struct/no-tail
record-type-vtable
'#,(make-layout)
#,printer
'#,type-name
'#,(field-list fields)))
(set-struct-vtable-name! #,rtd '#,type-name)))))
(syntax-case x ()

56
module/ice-9/psyntax-pp.scm
View file

@ -8,27 +8,41 @@
(syntax-module (module-ref (current-module) 'syntax-module)))
(letrec*
((make-void
(lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
(lambda (src)
(make-struct/no-tail (vector-ref %expanded-vtables 0) src)))
(make-const
(lambda (src exp)
(make-struct (vector-ref %expanded-vtables 1) 0 src exp)))
(make-struct/no-tail (vector-ref %expanded-vtables 1) src exp)))
(make-primitive-ref
(lambda (src name)
(make-struct (vector-ref %expanded-vtables 2) 0 src name)))
(make-struct/no-tail (vector-ref %expanded-vtables 2) src name)))
(make-lexical-ref
(lambda (src name gensym)
(make-struct (vector-ref %expanded-vtables 3) 0 src name gensym)))
(make-struct/no-tail
(vector-ref %expanded-vtables 3)
src
name
gensym)))
(make-lexical-set
(lambda (src name gensym exp)
(make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp)))
(make-struct/no-tail
(vector-ref %expanded-vtables 4)
src
name
gensym
exp)))
(make-module-ref
(lambda (src mod name public?)
(make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?)))
(make-struct/no-tail
(vector-ref %expanded-vtables 5)
src
mod
name
public?)))
(make-module-set
(lambda (src mod name public? exp)
(make-struct
(make-struct/no-tail
(vector-ref %expanded-vtables 6)
0
src
mod
name
@ -36,39 +50,37 @@
exp)))
(make-toplevel-ref
(lambda (src name)
(make-struct (vector-ref %expanded-vtables 7) 0 src name)))
(make-struct/no-tail (vector-ref %expanded-vtables 7) src name)))
(make-toplevel-set
(lambda (src name exp)
(make-struct (vector-ref %expanded-vtables 8) 0 src name exp)))
(make-struct/no-tail (vector-ref %expanded-vtables 8) src name exp)))
(make-toplevel-define
(lambda (src name exp)
(make-struct (vector-ref %expanded-vtables 9) 0 src name exp)))
(make-struct/no-tail (vector-ref %expanded-vtables 9) src name exp)))
(make-conditional
(lambda (src test consequent alternate)
(make-struct
(make-struct/no-tail
(vector-ref %expanded-vtables 10)
0
src
test
consequent
alternate)))
(make-call
(lambda (src proc args)
(make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
(make-struct/no-tail (vector-ref %expanded-vtables 11) src proc args)))
(make-primcall
(lambda (src name args)
(make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
(make-struct/no-tail (vector-ref %expanded-vtables 12) src name args)))
(make-seq
(lambda (src head tail)
(make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
(make-struct/no-tail (vector-ref %expanded-vtables 13) src head tail)))
(make-lambda
(lambda (src meta body)
(make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
(make-struct/no-tail (vector-ref %expanded-vtables 14) src meta body)))
(make-lambda-case
(lambda (src req opt rest kw inits gensyms body alternate)
(make-struct
(make-struct/no-tail
(vector-ref %expanded-vtables 15)
0
src
req
opt
@ -80,9 +92,8 @@
alternate)))
(make-let
(lambda (src names gensyms vals body)
(make-struct
(make-struct/no-tail
(vector-ref %expanded-vtables 16)
0
src
names
gensyms
@ -90,9 +101,8 @@
body)))
(make-letrec
(lambda (src in-order? names gensyms vals body)
(make-struct
(make-struct/no-tail
(vector-ref %expanded-vtables 17)
0
src
in-order?
names

5
module/ice-9/psyntax.scm
View file

@ -184,8 +184,9 @@
(sfields (map (lambda (f) (datum->syntax x f)) fields))
(ctor (datum->syntax x (symbol-append 'make- stem))))
(cons #`(define (#,ctor #,@sfields)
(make-struct (vector-ref %expanded-vtables #,n) 0
#,@sfields))
(make-struct/no-tail
(vector-ref %expanded-vtables #,n)
#,@sfields))
out)))
#`(begin #,@(reverse out))))))))

3
module/language/cps/effects-analysis.scm
View file

@ -1,6 +1,6 @@
;;; Effects analysis on CPS
;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
;; Copyright (C) 2011-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
@ -347,7 +347,6 @@ is or might be a read or a write to the same location as A."
(define-primitive-effects* constants
((allocate-struct vt n) (&allocate &struct) &type-check)
((allocate-struct/immediate v n) (&allocate &struct) &type-check)
((make-struct vt ntail . _) (&allocate &struct) &type-check)
((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
((struct-ref s n) (read-struct-field n constants) &type-check)
((struct-ref/immediate s n) (read-struct-field n constants) &type-check)

12
module/language/elisp/falias.scm
View file

@ -5,11 +5,11 @@
falias-object))
(define <falias-vtable>
(make-struct <applicable-struct-vtable>
0
(make-struct-layout "pwpw")
(lambda (object port)
(format port "#<falias ~S>" (falias-object object)))))
(make-struct/no-tail
<applicable-struct-vtable>
(make-struct-layout "pwpw")
(lambda (object port)
(format port "#<falias ~S>" (falias-object object)))))
(set-struct-vtable-name! <falias-vtable> 'falias)
@ -18,7 +18,7 @@
(eq? (struct-vtable object) <falias-vtable>)))
(define (make-falias f object)
(make-struct <falias-vtable> 0 f object))
(make-struct/no-tail <falias-vtable> f object))
(define (falias-function object)
(struct-ref object 0))

4
module/language/tree-il.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;; Copyright (C) 2009-2014, 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
@ -86,7 +86,7 @@
(let lp ((n 0) (fields fields)
(out (cons*
#`(define (#,ctor #,@sfields)
(make-struct #,type 0 #,@sfields))
(make-struct/no-tail #,type #,@sfields))
#`(define (#,pred x)
(and (struct? x)
(eq? (struct-vtable x) #,type)))

13
module/language/tree-il/primitives.scm
View file

@ -1,6 +1,6 @@
;;; open-coding primitive procedures
;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
;; Copyright (C) 2009-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
@ -94,7 +94,7 @@
string-length string-ref string-set!
allocate-struct struct-vtable make-struct struct-ref struct-set!
allocate-struct struct-vtable make-struct/no-tail struct-ref struct-set!
bytevector-length
@ -139,7 +139,7 @@
(define *primitive-constructors*
;; Primitives that return a fresh object.
'(acons cons cons* list vector make-vector
allocate-struct make-struct make-struct/no-tail
allocate-struct make-struct/no-tail
make-prompt-tag))
(define *primitive-accessors*
@ -467,13 +467,6 @@
(define-primitive-expander call/cc (proc)
(call-with-current-continuation proc))
(define-primitive-expander make-struct (vtable tail-size . args)
(if (and (const? tail-size)
(let ((n (const-exp tail-size)))
(and (number? n) (exact? n) (zero? n))))
(make-struct/no-tail vtable . args)
#f))
(define-primitive-expander u8vector-ref (vec i)
(bytevector-u8-ref vec i))
(define-primitive-expander u8vector-set! (vec i x)

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

@ -1,6 +1,6 @@
;;; procedural.scm --- Procedural interface to R6RS records
;; Copyright (C) 2010 Free Software Foundation, Inc.
;; Copyright (C) 2010, 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
@ -36,7 +36,7 @@
and=>
throw
display
make-struct
make-struct/no-tail
make-vtable
map
simple-format
@ -127,7 +127,7 @@
(and=> (struct-ref obj 0) private-record-predicate))))
(define (field-binder parent-struct . args)
(apply make-struct (cons* late-rtd 0 parent-struct args)))
(apply make-struct/no-tail late-rtd parent-struct args))
(if (and parent (struct-ref parent rtd-index-sealed?))
(r6rs-raise (make-assertion-violation)))
@ -152,23 +152,24 @@
matching-rtd
(r6rs-raise (make-assertion-violation)))
(let ((rtd (make-struct record-type-vtable 0
(let ((rtd (make-struct/no-tail
record-type-vtable
fields-layout
(lambda (obj port)
(simple-format
port "#<r6rs:record:~A>" name))
fields-layout
(lambda (obj port)
(simple-format
port "#<r6rs:record:~A>" name))
name
uid
parent
sealed?
opaque?
name
uid
parent
sealed?
opaque?
private-record-predicate
field-names
fields-bit-field
field-binder)))
private-record-predicate
field-names
fields-bit-field
field-binder)))
(set! late-rtd rtd)
(if uid (hashq-set! uid-table uid rtd))
rtd))))
@ -196,7 +197,7 @@
(prot (or protocol (if pcd
default-inherited-protocol
default-protocol))))
(make-struct record-constructor-vtable 0 rtd pcd prot)))
(make-struct/no-tail record-constructor-vtable rtd pcd prot)))
(define (record-constructor rctd)
(let* ((rtd (struct-ref rctd rctd-index-rtd))

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

@ -1,6 +1,6 @@
;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*-
;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2007-2011, 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
@ -57,10 +57,10 @@
s))
(define (%make-condition-type layout id parent all-fields)
(let ((struct (make-struct %condition-type-vtable 0
(make-struct-layout layout) ;; layout
print-condition ;; printer
id parent all-fields)))
(let ((struct (make-struct/no-tail %condition-type-vtable
(make-struct-layout layout) ;; layout
print-condition ;; printer
id parent all-fields)))
;; Hack to associate STRUCT with a name, providing a better name for
;; GOOPS classes as returned by `class-of' et al.
@ -201,7 +201,7 @@ supertypes."
"Wrong type argument: ~S" c)))
(define (make-condition-from-values type values)
(apply make-struct type 0 values))
(apply make-struct/no-tail type values))
(define (make-condition type . field+value)
"Return a new condition of type TYPE with fields initialized as specified
@ -331,11 +331,11 @@ by C."
(define &condition
;; The root condition type.
(make-struct %condition-type-vtable 0
(make-struct-layout "")
(lambda (c port)
(display "<&condition>"))
'&condition #f '() '()))
(make-struct/no-tail %condition-type-vtable
(make-struct-layout "")
(lambda (c port)
(display "<&condition>"))
'&condition #f '() '()))
(define-condition-type &message &condition
message-condition?

2
module/system/base/syntax.scm
View file

@ -80,7 +80,7 @@
(set! ,tail (cdr ,tail))
_x)))))
opts)
(make-struct ,name 0 ,@slot-names))))
(make-struct/no-tail ,name ,@slot-names))))
(define ,(symbol-append stem '?) (record-predicate ,name))
,@(map (lambda (sname)
`(define ,(symbol-append stem '- sname)

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

@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; Copyright (C) 2010, 2011, 2012, 2013, 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
@ -248,9 +248,9 @@
(zero? (procedure-execution-count data proc))))))
(pass-if "applicable struct"
(let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
(let* ((<box> (make-struct/no-tail <applicable-struct-vtable> 'pw))
(proc (lambda args (length args)))
(b (make-struct <box> 0 proc)))
(b (make-struct/no-tail <box> proc)))
(let-values (((data result)
(with-code-coverage b)))
(and (coverage-data? data)

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

@ -1890,6 +1890,10 @@
(lambda ()
(set! %load-path old)))))
(define %temporary-directory
(string-append (or (getenv "TMPDIR") "/tmp") "/guile-ports-test."
(number->string (getpid))))
(with-test-prefix "%file-port-name-canonicalization"
(pass-if-equal "absolute file name & empty %load-path entry" "/dev/null"
@ -1916,6 +1920,30 @@
(port-filename
(open-input-file (%search-load-path "ice-9/q.scm")))))
(pass-if-equal "relative canonicalization with common prefixes"
"x.scm"
;; In Guile up to 2.2.2, this would return "wrong/x.scm'.
(let* ((dir1 (string-append %temporary-directory "/something"))
(dir2 (string-append dir1 "-wrong")))
(with-load-path (append (list dir1 dir2) %load-path)
(dynamic-wind
(lambda ()
(mkdir %temporary-directory)
(mkdir dir1)
(mkdir dir2)
(call-with-output-file (string-append dir2 "/x.scm")
(const #t)))
(lambda ()
(with-fluids ((%file-port-name-canonicalization 'relative))
(port-filename
(open-input-file (string-append dir2 "/x.scm")))))
(lambda ()
(delete-file (string-append dir2 "/x.scm"))
(rmdir dir2)
(rmdir dir1)
(rmdir %temporary-directory))))))
(pass-if-equal "absolute canonicalization from ice-9"
(canonicalize-path
(string-append (assoc-ref %guile-build-info 'top_srcdir)

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

@ -1,7 +1,7 @@
;;;; structs.test --- Structures. -*- mode: scheme; coding: utf-8; -*-
;;;; Ludovic Courtès <ludo@gnu.org>, 2006-06-12.
;;;;
;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012 Free Software Foundation, Inc.
;;;; Copyright (C) 2006, 2007, 2009, 2010, 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
@ -30,13 +30,13 @@
(make-vtable (string-append standard-vtable-fields "pr") 0))
(define (make-ball-type ball-color)
(make-struct ball-root 0
(make-struct-layout "pw")
(lambda (ball port)
(format port "#<a ~A ball owned by ~A>"
(color ball)
(owner ball)))
ball-color))
(make-struct/no-tail ball-root
(make-struct-layout "pw")
(lambda (ball port)
(format port "#<a ~A ball owned by ~A>"
(color ball)
(owner ball)))
ball-color))
(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
(define (owner ball) (struct-ref ball 0))
@ -45,7 +45,7 @@
(define red (make-ball-type 'red))
(define green (make-ball-type 'green))
(define (make-ball type owner) (make-struct type 0 owner))
(define (make-ball type owner) (make-struct/no-tail type owner))
@ -90,7 +90,7 @@
(pass-if "struct-set!"
(let* ((v (make-vtable "pw"))
(s (make-struct v 0))
(s (make-struct/no-tail v))
(r (struct-set! s 0 'a)))
(eq? r
(struct-ref s 0)
@ -99,13 +99,13 @@
(pass-if-exception "struct-ref out-of-range"
exception:out-of-range
(let* ((v (make-vtable "prpr"))
(s (make-struct v 0 'a 'b)))
(s (make-struct/no-tail v 'a 'b)))
(struct-ref s 2)))
(pass-if-exception "struct-set! out-of-range"
exception:out-of-range
(let* ((v (make-vtable "pwpw"))
(s (make-struct v 0 'a 'b)))
(s (make-struct/no-tail v 'a 'b)))
(struct-set! s 2 'c))))
@ -113,8 +113,8 @@
(pass-if "simple structs"
(let* ((vtable (make-vtable "pr"))
(s1 (make-struct vtable 0 "hello"))
(s2 (make-struct vtable 0 "hello")))
(s1 (make-struct/no-tail vtable "hello"))
(s2 (make-struct/no-tail vtable "hello")))
(equal? s1 s2)))
(pass-if "more complex structs"
@ -131,22 +131,22 @@
(pass-if "simple structs"
(let* ((v (make-vtable "pr"))
(s1 (make-struct v 0 "hello"))
(s2 (make-struct v 0 "hello")))
(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"))
(s1 (make-struct v 0 "hello"))
(s2 (make-struct v 0 "world")))
(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"))
(s1 (make-struct v1 0 "hello"))
(s2 (make-struct v2 0 "hello")))
(s1 (make-struct/no-tail v1 "hello"))
(s2 (make-struct/no-tail v2 "hello")))
(or (not (= (hash s1 7777) (hash s2 7777)))
(throw 'unresolved))))
@ -157,14 +157,14 @@
(pass-if "struct with weird fields"
(let* ((v (make-vtable "prurph"))
(s1 (make-struct v 0 "hello" 123 "invisible-secret1"))
(s2 (make-struct v 0 "hello" 123 "invisible-secret2")))
(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))))
(pass-if "cyclic structs"
(let* ((v (make-vtable "pw"))
(a (make-struct v 0 #f))
(b (make-struct v 0 a)))
(a (make-struct/no-tail v #f))
(b (make-struct/no-tail v a)))
(struct-set! a 0 b)
(and (hash a 7777) (hash b 7777) #t))))
@ -173,9 +173,6 @@
;; make-struct
;;
(define exception:bad-tail
(cons 'misc-error "tail array not allowed unless"))
(with-test-prefix "make-struct"
;; in guile 1.8.1 and earlier, this caused an error throw out of an
@ -184,19 +181,8 @@
;;
(pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
(let* ((vv (make-vtable standard-vtable-fields))
(v (make-struct vv 0 (make-struct-layout "uw"))))
(make-struct v 0 'x)))
;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
;; on a tail array being created without an R/W/O type for it. This left
;; it uninitialized by scm_struct_init(), resulting in garbage getting
;; into an SCM when struct-ref read it (and attempting to print a garbage
;; SCM can cause a segv).
;;
(pass-if-exception "no R/W/O for tail array" exception:bad-tail
(let* ((vv (make-vtable standard-vtable-fields))
(v (make-struct vv 0 (make-struct-layout "pw"))))
(make-struct v 123 'x))))
(v (make-struct/no-tail vv (make-struct-layout "uw"))))
(make-struct/no-tail v 'x))))
;;
;; make-vtable
@ -206,7 +192,7 @@
(pass-if "without printer"
(let* ((vtable (make-vtable "pwpr"))
(struct (make-struct vtable 0 'x 'y)))
(struct (make-struct/no-tail vtable 'x 'y)))
(and (eq? 'x (struct-ref struct 0))
(eq? 'y (struct-ref struct 1)))))
@ -216,7 +202,7 @@
(display "hello" port))
(let* ((vtable (make-vtable "pwpr" print))
(struct (make-struct vtable 0 'x 'y))
(struct (make-struct/no-tail vtable 'x 'y))
(str (call-with-output-string
(lambda (port)
(display struct port)))))