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

Merge stable-2.2 into master

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

100
libguile/struct.c
View file

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