diff options
| -rw-r--r-- | NEWS | 31 | ||||
| -rw-r--r-- | libguile/deprecated.c | 51 | ||||
| -rw-r--r-- | libguile/deprecated.h | 6 | ||||
| -rw-r--r-- | libguile/print.c | 5 | ||||
| -rw-r--r-- | libguile/procs.c | 5 | ||||
| -rw-r--r-- | libguile/stacks.c | 4 | ||||
| -rw-r--r-- | libguile/struct.c | 29 | ||||
| -rw-r--r-- | libguile/struct.h | 5 | ||||
| -rw-r--r-- | module/ice-9/boot-9.scm | 8 | ||||
| -rw-r--r-- | test-suite/tests/coverage.test | 6 | ||||
| -rw-r--r-- | test-suite/tests/structs.test | 70 |
11 files changed, 139 insertions, 81 deletions
@@ -26,6 +26,37 @@ 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. +** 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! + * Bug fixes ** Enable GNU Readline 7.0's support for "bracketed paste". diff --git a/libguile/deprecated.c b/libguile/deprecated.c index cee6b1d74..9d94bc2d8 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -2,7 +2,7 @@ deprecate something, move it here when that is feasible. */ -/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. +/* Copyright (C) 2003, 2004, 2006, 2008, 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 @@ -26,6 +26,7 @@ #define SCM_BUILDING_DEPRECATED_CODE +#include <alloca.h> #include <sys/types.h> #include <unistd.h> @@ -954,6 +955,54 @@ SCM_FDES_RANDOM_P (int fdes) +SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, + (SCM vtable, SCM tail_array_size, 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" + "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 +{ + size_t i, n_init; + long ilen; + scm_t_bits *v; + + scm_c_issue_deprecation_warning + ("make-struct is deprecated. Use make-struct/no-tail instead."); + + SCM_VALIDATE_VTABLE (1, vtable); + ilen = scm_ilength (init); + if (ilen < 0) + SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL); + + n_init = (size_t)ilen; + + /* best to use alloca, but init could be big, so hack to avoid a possible + stack overflow */ + if (n_init < 64) + v = alloca (n_init * sizeof(scm_t_bits)); + else + v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct"); + + 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); +} +#undef FUNC_NAME + + + void scm_i_init_deprecated () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 2c49076a1..68cd65448 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -5,7 +5,7 @@ #ifndef SCM_DEPRECATED_H #define SCM_DEPRECATED_H -/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. +/* Copyright (C) 2003,2004, 2005, 2006, 2007, 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 @@ -274,6 +274,10 @@ SCM_DEPRECATED int SCM_FDES_RANDOM_P (int fdes); +SCM_DEPRECATED SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init); + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/print.c b/libguile/print.c index 7667d24bb..4d57a877d 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,8 +194,7 @@ 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->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED); pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect); 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/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 51c0f111d..78099ac45 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 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 @@ -553,13 +553,10 @@ 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" @@ -569,7 +566,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, "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; @@ -592,7 +589,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 @@ -638,9 +635,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 @@ -1002,8 +999,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); @@ -1011,8 +1008,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 e8db316c8..257e40e1e 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 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 @@ -175,7 +176,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 7f8962b51..7127d73f7 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -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} ;;; 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/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))))) |