mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
This anticipates deprecation of make-vtable-vtable in stable-2.0, which hasn't happened yet. Conflicts: libguile/deprecated.c libguile/deprecated.h libguile/print.c libguile/struct.c
This commit is contained in:
Andy Wingo
commit
a38da400d7
4 changed files with 43 additions and 162 deletions
|
|
@ -1,7 +1,7 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
|
||||
@c 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
@c 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
@node Compound Data Types
|
||||
|
|
@ -2372,7 +2372,7 @@ to be stored along side usual Scheme @code{SCM} values.
|
|||
* Vtable Vtables::
|
||||
@end menu
|
||||
|
||||
@node Vtables, Structure Basics, Structures, Structures
|
||||
@node Vtables
|
||||
@subsubsection Vtables
|
||||
|
||||
A vtable is a structure type, specifying its layout, and other
|
||||
|
|
@ -2460,7 +2460,7 @@ structure.
|
|||
@end deffn
|
||||
|
||||
|
||||
@node Structure Basics, Vtable Contents, Vtables, Structures
|
||||
@node Structure Basics
|
||||
@subsubsection Structure Basics
|
||||
|
||||
This section describes the basic procedures for working with
|
||||
|
|
@ -2542,7 +2542,7 @@ This can be used to examine the layout of an unknown structure, see
|
|||
@end deffn
|
||||
|
||||
|
||||
@node Vtable Contents, Vtable Vtables, Structure Basics, Structures
|
||||
@node Vtable Contents
|
||||
@subsubsection Vtable Contents
|
||||
|
||||
A vtable is itself a structure, with particular fields that hold
|
||||
|
|
@ -2614,16 +2614,8 @@ from @var{vtable}.
|
|||
@end example
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} struct-vtable-tag vtable
|
||||
@deffnx {C Function} scm_struct_vtable_tag (vtable)
|
||||
Return the tag of the given @var{vtable}.
|
||||
@c
|
||||
@c FIXME: what can be said about what this means?
|
||||
@c
|
||||
@end deffn
|
||||
|
||||
|
||||
@node Vtable Vtables, , Vtable Contents, Structures
|
||||
@node Vtable Vtables
|
||||
@subsubsection Vtable Vtables
|
||||
|
||||
As noted above, a vtable is a structure and that structure is itself
|
||||
|
|
|
|||
|
|
@ -561,108 +561,9 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
|
||||
#if SCM_ENABLE_DEPRECATED == 1
|
||||
SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
|
||||
(SCM user_fields, SCM tail_array_size, SCM init),
|
||||
"Return a new, self-describing vtable structure.\n\n"
|
||||
"@var{user-fields} is a string describing user defined fields of the\n"
|
||||
"vtable beginning at index @code{vtable-offset-user}\n"
|
||||
"(see @code{make-struct-layout}).\n\n"
|
||||
"@var{tail_array_size} specifies the size of the tail-array (if any) of\n"
|
||||
"this vtable.\n\n"
|
||||
"@var{init1}, @dots{} are the optional initializers for the fields of\n"
|
||||
"the vtable.\n\n"
|
||||
"Vtables have one initializable system field---the struct printer.\n"
|
||||
"This field comes before the user fields in the initializers passed\n"
|
||||
"to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
|
||||
"a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
|
||||
"@code{make-struct} when creating vtables:\n\n"
|
||||
"If the value is a procedure, it will be called instead of the standard\n"
|
||||
"printer whenever a struct described by this vtable is printed.\n"
|
||||
"The procedure will be called with arguments STRUCT and PORT.\n\n"
|
||||
"The structure of a struct is described by a vtable, so the vtable is\n"
|
||||
"in essence the type of the struct. The vtable is itself a struct with\n"
|
||||
"a vtable. This could go on forever if it weren't for the\n"
|
||||
"vtable-vtables which are self-describing vtables, and thus terminate\n"
|
||||
"the chain.\n\n"
|
||||
"There are several potential ways of using structs, but the standard\n"
|
||||
"one is to use three kinds of structs, together building up a type\n"
|
||||
"sub-system: one vtable-vtable working as the root and one or several\n"
|
||||
"\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
|
||||
"compared to the class <class> which is the class of itself.)\n\n"
|
||||
"@lisp\n"
|
||||
"(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
|
||||
"(define (make-ball-type ball-color)\n"
|
||||
" (make-struct ball-root 0\n"
|
||||
" (make-struct-layout \"pw\")\n"
|
||||
" (lambda (ball port)\n"
|
||||
" (format port \"#<a ~A ball owned by ~A>\"\n"
|
||||
" (color ball)\n"
|
||||
" (owner ball)))\n"
|
||||
" ball-color))\n"
|
||||
"(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
|
||||
"(define (owner ball) (struct-ref ball 0))\n\n"
|
||||
"(define red (make-ball-type 'red))\n"
|
||||
"(define green (make-ball-type 'green))\n\n"
|
||||
"(define (make-ball type owner) (make-struct type 0 owner))\n\n"
|
||||
"(define ball (make-ball green 'Nisse))\n"
|
||||
"ball @result{} #<a green ball owned by Nisse>\n"
|
||||
"@end lisp")
|
||||
#define FUNC_NAME s_scm_make_vtable_vtable
|
||||
{
|
||||
SCM fields, layout, obj;
|
||||
size_t basic_size, n_tail, i, n_init;
|
||||
long ilen;
|
||||
scm_t_bits *v;
|
||||
|
||||
SCM_VALIDATE_STRING (1, user_fields);
|
||||
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 + 1; /* + 1 for the layout */
|
||||
|
||||
/* 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");
|
||||
|
||||
fields = scm_string_append (scm_list_2 (required_vtable_fields,
|
||||
user_fields));
|
||||
layout = scm_make_struct_layout (fields);
|
||||
if (!scm_is_valid_vtable_layout (layout))
|
||||
SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields));
|
||||
|
||||
basic_size = scm_i_symbol_length (layout) / 2;
|
||||
n_tail = scm_to_size_t (tail_array_size);
|
||||
|
||||
i = 0;
|
||||
v[i++] = SCM_UNPACK (layout);
|
||||
for (; i < n_init; i++, init = SCM_CDR (init))
|
||||
v[i] = SCM_UNPACK (SCM_CAR (init));
|
||||
|
||||
SCM_CRITICAL_SECTION_START;
|
||||
obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
|
||||
/* Make it so that the vtable of OBJ is itself. */
|
||||
SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | scm_tc3_struct);
|
||||
SCM_CRITICAL_SECTION_END;
|
||||
|
||||
scm_struct_init (obj, layout, n_tail, n_init, v);
|
||||
SCM_SET_VTABLE_FLAGS (obj,
|
||||
SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
|
||||
|
||||
return obj;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
#endif
|
||||
|
||||
SCM
|
||||
scm_i_make_vtable_vtable (SCM user_fields)
|
||||
#define FUNC_NAME s_scm_make_vtable_vtable
|
||||
#define FUNC_NAME "make-vtable-vtable"
|
||||
{
|
||||
SCM fields, layout, obj;
|
||||
size_t basic_size;
|
||||
|
|
@ -950,17 +851,6 @@ SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
|
||||
(SCM handle),
|
||||
"Return the vtable tag of the structure @var{handle}.")
|
||||
#define FUNC_NAME s_scm_struct_vtable_tag
|
||||
{
|
||||
SCM_VALIDATE_VTABLE (1, handle);
|
||||
return scm_from_unsigned_integer
|
||||
(((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
/* {Associating names and classes with vtables}
|
||||
*
|
||||
* The name of a vtable should probably be stored as a slot. This is
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef SCM_STRUCT_H
|
||||
#define SCM_STRUCT_H
|
||||
|
||||
/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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
|
||||
|
|
@ -181,13 +181,9 @@ SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
|
|||
scm_t_bits init[]);
|
||||
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
|
||||
SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM extra_fields);
|
||||
#if SCM_ENABLE_DEPRECATED == 1
|
||||
SCM_DEPRECATED SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
|
||||
#endif
|
||||
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
|
||||
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
|
||||
SCM_API SCM scm_struct_vtable (SCM handle);
|
||||
SCM_API SCM scm_struct_vtable_tag (SCM handle);
|
||||
SCM_API SCM scm_struct_vtable_name (SCM vtable);
|
||||
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
|
||||
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
|
||||
|
|
|
|||
|
|
@ -94,17 +94,18 @@
|
|||
(uri=? (build-uri 'http #:host "1.good.host")
|
||||
#:scheme 'http #:host "1.good.host" #:path ""))
|
||||
|
||||
(pass-if "http://192.0.2.1"
|
||||
(uri=? (build-uri 'http #:host "192.0.2.1")
|
||||
#:scheme 'http #:host "192.0.2.1" #:path ""))
|
||||
(when (memq 'socket *features*)
|
||||
(pass-if "http://192.0.2.1"
|
||||
(uri=? (build-uri 'http #:host "192.0.2.1")
|
||||
#:scheme 'http #:host "192.0.2.1" #:path ""))
|
||||
|
||||
(pass-if "http://[2001:db8::1]"
|
||||
(uri=? (build-uri 'http #:host "2001:db8::1")
|
||||
#:scheme 'http #:host "2001:db8::1" #:path ""))
|
||||
(pass-if "http://[2001:db8::1]"
|
||||
(uri=? (build-uri 'http #:host "2001:db8::1")
|
||||
#:scheme 'http #:host "2001:db8::1" #:path ""))
|
||||
|
||||
(pass-if "http://[::ffff:192.0.2.1]"
|
||||
(uri=? (build-uri 'http #:host "::ffff:192.0.2.1")
|
||||
#:scheme 'http #:host "::ffff:192.0.2.1" #:path ""))
|
||||
(pass-if "http://[::ffff:192.0.2.1]"
|
||||
(uri=? (build-uri 'http #:host "::ffff:192.0.2.1")
|
||||
#:scheme 'http #:host "::ffff:192.0.2.1" #:path "")))
|
||||
|
||||
(pass-if-uri-exception "http://foo:not-a-port"
|
||||
"Expected.*port"
|
||||
|
|
@ -155,24 +156,25 @@
|
|||
(uri=? (string->uri "http://1.good.host")
|
||||
#:scheme 'http #:host "1.good.host" #:path ""))
|
||||
|
||||
(pass-if "http://192.0.2.1"
|
||||
(uri=? (string->uri "http://192.0.2.1")
|
||||
#:scheme 'http #:host "192.0.2.1" #:path ""))
|
||||
(when (memq 'socket *features*)
|
||||
(pass-if "http://192.0.2.1"
|
||||
(uri=? (string->uri "http://192.0.2.1")
|
||||
#:scheme 'http #:host "192.0.2.1" #:path ""))
|
||||
|
||||
(pass-if "http://[2001:db8::1]"
|
||||
(uri=? (string->uri "http://[2001:db8::1]")
|
||||
#:scheme 'http #:host "2001:db8::1" #:path ""))
|
||||
(pass-if "http://[2001:db8::1]"
|
||||
(uri=? (string->uri "http://[2001:db8::1]")
|
||||
#:scheme 'http #:host "2001:db8::1" #:path ""))
|
||||
|
||||
(pass-if "http://[2001:db8::1]:80"
|
||||
(uri=? (string->uri "http://[2001:db8::1]:80")
|
||||
#:scheme 'http
|
||||
#:host "2001:db8::1"
|
||||
#:port 80
|
||||
#:path ""))
|
||||
(pass-if "http://[2001:db8::1]:80"
|
||||
(uri=? (string->uri "http://[2001:db8::1]:80")
|
||||
#:scheme 'http
|
||||
#:host "2001:db8::1"
|
||||
#:port 80
|
||||
#:path ""))
|
||||
|
||||
(pass-if "http://[::ffff:192.0.2.1]"
|
||||
(uri=? (string->uri "http://[::ffff:192.0.2.1]")
|
||||
#:scheme 'http #:host "::ffff:192.0.2.1" #:path ""))
|
||||
(pass-if "http://[::ffff:192.0.2.1]"
|
||||
(uri=? (string->uri "http://[::ffff:192.0.2.1]")
|
||||
#:scheme 'http #:host "::ffff:192.0.2.1" #:path "")))
|
||||
|
||||
(pass-if "http://foo:"
|
||||
(uri=? (string->uri "http://foo:")
|
||||
|
|
@ -227,17 +229,18 @@
|
|||
(equal? "ftp://foo@bar:22/baz"
|
||||
(uri->string (string->uri "ftp://foo@bar:22/baz"))))
|
||||
|
||||
(pass-if "http://192.0.2.1"
|
||||
(equal? "http://192.0.2.1"
|
||||
(uri->string (string->uri "http://192.0.2.1"))))
|
||||
(when (memq 'socket *features*)
|
||||
(pass-if "http://192.0.2.1"
|
||||
(equal? "http://192.0.2.1"
|
||||
(uri->string (string->uri "http://192.0.2.1"))))
|
||||
|
||||
(pass-if "http://[2001:db8::1]"
|
||||
(equal? "http://[2001:db8::1]"
|
||||
(uri->string (string->uri "http://[2001:db8::1]"))))
|
||||
(pass-if "http://[2001:db8::1]"
|
||||
(equal? "http://[2001:db8::1]"
|
||||
(uri->string (string->uri "http://[2001:db8::1]"))))
|
||||
|
||||
(pass-if "http://[::ffff:192.0.2.1]"
|
||||
(equal? "http://[::ffff:192.0.2.1]"
|
||||
(uri->string (string->uri "http://[::ffff:192.0.2.1]"))))
|
||||
(pass-if "http://[::ffff:192.0.2.1]"
|
||||
(equal? "http://[::ffff:192.0.2.1]"
|
||||
(uri->string (string->uri "http://[::ffff:192.0.2.1]")))))
|
||||
|
||||
(pass-if "http://foo:"
|
||||
(equal? "http://foo"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue