summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--NEWS41
-rw-r--r--doc/ref/api-data.texi93
-rw-r--r--doc/ref/api-foreign.texi2
-rw-r--r--libguile/filesys.c8
-rw-r--r--libguile/print.c6
-rw-r--r--libguile/print.h4
-rw-r--r--libguile/procs.c5
-rw-r--r--libguile/r6rs-ports.c4
-rw-r--r--libguile/stacks.c4
-rw-r--r--libguile/struct.c100
-rw-r--r--libguile/struct.h5
-rw-r--r--module/ice-9/boot-9.scm73
-rw-r--r--module/ice-9/psyntax-pp.scm56
-rw-r--r--module/ice-9/psyntax.scm5
-rw-r--r--module/language/cps/effects-analysis.scm3
-rw-r--r--module/language/elisp/falias.scm12
-rw-r--r--module/language/tree-il.scm4
-rw-r--r--module/language/tree-il/primitives.scm13
-rw-r--r--module/rnrs/records/procedural.scm37
-rw-r--r--module/srfi/srfi-35.scm22
-rw-r--r--module/system/base/syntax.scm2
-rw-r--r--test-suite/tests/coverage.test6
-rw-r--r--test-suite/tests/ports.test28
-rw-r--r--test-suite/tests/structs.test70
24 files changed, 293 insertions, 310 deletions
diff --git a/NEWS b/NEWS
index 2989660ed..76dc44e36 100644
--- a/NEWS
+++ b/NEWS
@@ -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".
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 7b10d34f4..faddc3f65 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -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
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 2f5375d28..bb93d6d1f 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -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
diff --git a/libguile/filesys.c b/libguile/filesys.c
index f18560162..af283dd5e 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -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
diff --git a/libguile/print.c b/libguile/print.c
index 7667d24bb..24c532f29 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -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;
diff --git a/libguile/print.h b/libguile/print.h
index 14318c031..11f533c79 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -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? */
diff --git a/libguile/procs.c b/libguile/procs.c
index 08c5c355e..2329f4a1b 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -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
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index c2f97ffa1..e944c7aab 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -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;
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 9bd2db8de..76e10faf3 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -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));
diff --git a/libguile/struct.c b/libguile/struct.c
index 67e2e62df..53bf3f302 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -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,
diff --git a/libguile/struct.h b/libguile/struct.h
index 25d5ae53f..32af8ab5a 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -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,
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 5af2950f2..c2d3a2625 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -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 ()
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index e2ebeced1..be0f524c1 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -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
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 08b3dae04..262b4e7d7 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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))))))))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 4eff0d261..1cc03c037 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -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)
diff --git a/module/language/elisp/falias.scm b/module/language/elisp/falias.scm
index f043548fb..60eb9f1b5 100644
--- a/module/language/elisp/falias.scm
+++ b/module/language/elisp/falias.scm
@@ -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))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index dcd03466a..5fb0ce05f 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -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)))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 90c1d2d1a..e716714fb 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -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)
diff --git a/module/rnrs/records/procedural.scm b/module/rnrs/records/procedural.scm
index d925263d8..69c5d1c56 100644
--- a/module/rnrs/records/procedural.scm
+++ b/module/rnrs/records/procedural.scm
@@ -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))
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 0f0ab3c70..433032031 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -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?
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 1cabbbcb7..0bc16e584 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -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)
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index c1b417f03..96d174418 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -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)
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 007f56605..3c8ae3050 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -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)
diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index 0e3b2417e..c18e42194 100644
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -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)))))