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 (""); 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 (""); 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 ;; Three fields: the procedure itself, the fluid, and the converter. - (make-struct 0 'pwprpr)) + (make-struct/no-tail 'pwprpr)) (set-struct-vtable-name! ') (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 0 - (case-lambda - (() (fluid-ref fluid)) - ((x) (let ((prev (fluid-ref fluid))) - (fluid-set! fluid (conv x)) - prev))) - fluid conv))) + (make-struct/no-tail + + (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) ))) @@ -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 0 - (case-lambda - (() (fluid-ref fluid)) - ((x) (let ((prev (fluid-ref fluid))) - (fluid-set! fluid (conv x)) - prev))) - fluid conv)) + (make-struct/no-tail + + (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 - (make-struct - 0 - (make-struct-layout "pwpw") - (lambda (object port) - (format port "#" (falias-object object))))) + (make-struct/no-tail + + (make-struct-layout "pwpw") + (lambda (object port) + (format port "#" (falias-object object))))) (set-struct-vtable-name! 'falias) @@ -18,7 +18,7 @@ (eq? (struct-vtable object) ))) (define (make-falias f object) - (make-struct 0 f object)) + (make-struct/no-tail 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 "#" name)) + fields-layout + (lambda (obj port) + (simple-format + port "#" 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* (( (make-struct 0 'pw)) + (let* (( (make-struct/no-tail 'pw)) (proc (lambda args (length args))) - (b (make-struct 0 proc))) + (b (make-struct/no-tail 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 , 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 "#" - (color ball) - (owner ball))) - ball-color)) + (make-struct/no-tail ball-root + (make-struct-layout "pw") + (lambda (ball port) + (format port "#" + (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)))))