diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 6fc5b2e46..78d678975 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -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 diff --git a/libguile/struct.c b/libguile/struct.c index e8182a2fd..fe6b04265 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -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 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 \"#\"\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{} #\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 diff --git a/libguile/struct.h b/libguile/struct.h index 3e2bc5353..97b6768ad 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -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 *); diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 74310258e..4621a19f9 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -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"