From 5d312f3c2c5db3a7677a9c8ec4306feabce8445f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 6 Jul 2012 17:45:23 +0200 Subject: [PATCH 1/7] disable some uri tests if --disable-networking * test-suite/tests/web-uri.test: Disable some tests if we don't have inet-pton. --- test-suite/tests/web-uri.test | 69 ++++++++++++++++++----------------- 1 file changed, 36 insertions(+), 33 deletions(-) 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" From d192791373b79e905eb02f9c0b01413051a7b2f8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 6 Jul 2012 18:12:59 +0200 Subject: [PATCH 2/7] deprecate struct-vtable-tag * libguile/deprecated.c: * libguile/deprecated.h: * libguile/struct.c: * libguile/struct.h: * doc/ref/api-compound.texi: Deprecate struct-vtable-tag. --- doc/ref/api-compound.texi | 18 +++++------------- libguile/deprecated.c | 17 +++++++++++++++++ libguile/deprecated.h | 4 ++++ libguile/struct.c | 11 ----------- libguile/struct.h | 3 +-- 5 files changed, 27 insertions(+), 26 deletions(-) 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/deprecated.c b/libguile/deprecated.c index af0752c61..f0211a52f 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -2820,6 +2820,23 @@ SCM_DEFINE (scm_eval_closure_module, #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); + scm_c_issue_deprecation_warning + ("struct-vtable-tag is deprecated. What were you doing with it anyway?"); + + return scm_from_unsigned_integer + (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3); +} +#undef FUNC_NAME + + void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 2970262b2..ae0891f88 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -835,6 +835,10 @@ SCM_DEPRECATED SCM scm_eval_closure_module (SCM eval_closure); +SCM_DEPRECATED SCM scm_struct_vtable_tag (SCM handle); + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/struct.c b/libguile/struct.c index 326f306ac..e6c7f4bdc 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -917,17 +917,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 c3c7d8f12..743e7ae66 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 @@ -184,7 +184,6 @@ SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM i 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 *); From 66b1dbf649c82e34aa6d62a982cae3218419d160 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Nov 2011 10:50:35 +0100 Subject: [PATCH 3/7] simplify scm_init_print * libguile/print.c (scm_init_print): Simplify creation of print-state vtable. --- libguile/print.c | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 2fc536b02..cb3c0b95a 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1544,14 +1544,12 @@ SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0, void scm_init_print () { - SCM vtable, layout, type; + SCM type; scm_gc_register_root (&print_state_pool); scm_gc_register_root (&scm_print_state_vtable); - vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); - layout = - scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT)); - type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout)); + type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT), + SCM_BOOL_F); scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state")); scm_print_state_vtable = type; From 0bb1353a6b618f1b355da13b6b7c3b56b201a2dc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Nov 2011 11:15:43 +0100 Subject: [PATCH 4/7] add Scheme binding for scm_standard_vtable_vtable * libguile/struct.c (scm_init_struct): Export to Scheme. --- libguile/struct.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/struct.c b/libguile/struct.c index e6c7f4bdc..74b903e9d 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1027,6 +1027,7 @@ scm_init_struct () scm_standard_vtable_vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); + scm_c_define ("", scm_standard_vtable_vtable); scm_applicable_struct_vtable_vtable = scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0, From 2921f537609547e7c9ee0df555a840407313eabd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Nov 2011 11:31:52 +0100 Subject: [PATCH 5/7] Scheme standard-vtable-fields binding * libguile/struct.c (scm_init_struct): Export standard-vtable-fields to Scheme. --- libguile/struct.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/struct.c b/libguile/struct.c index 74b903e9d..a5c4e3a60 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1022,6 +1022,7 @@ scm_init_struct () GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits)); required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT); + scm_c_define ("standard-vtable-fields", required_vtable_fields); required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT); required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT); From 581bd72a7d8346d32d02379d64b3012fdd6eef31 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Nov 2011 11:32:24 +0100 Subject: [PATCH 6/7] record-type-vtable is not a new root of the vtable hierarchy * module/ice-9/boot-9.scm (record-type-vtable): Simplify to use make-vtable instead of make-vtable-vtable. --- module/ice-9/boot-9.scm | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index f4ed1df38..5ed543a1c 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1050,16 +1050,13 @@ VALUE." ;; 0: type-name, 1: fields, 2: constructor (define record-type-vtable - ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for - ;; that we need to expose the bare vtable-vtable to Scheme. - (make-vtable-vtable "prprpw" 0 - (lambda (s p) - (cond ((eq? s record-type-vtable) - (display "#" p)) - (else - (display "#" p)))))) + (let ((s (make-vtable (string-append standard-vtable-fields "prprpw") + (lambda (s p) + (display "#" p))))) + (set-struct-vtable-name! s 'record-type) + s)) (define (record-type? obj) (and (struct? obj) (eq? record-type-vtable (struct-vtable obj)))) From 5f8d67ad09d21263d1ea2d537afcc5464d922dc5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Nov 2011 11:35:07 +0100 Subject: [PATCH 7/7] simplify %condition-type-vtable * module/srfi/srfi-35.scm (%condition-type-vtable): Use make-vtable instead of make-vtable-vtable. --- module/srfi/srfi-35.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm index d2b9c9420..8f86bce57 100644 --- a/module/srfi/srfi-35.scm +++ b/module/srfi/srfi-35.scm @@ -48,14 +48,14 @@ ;; The vtable of all condition types. ;; vtable fields: vtable, self, printer ;; user fields: id, parent, all-field-names - (make-vtable-vtable "prprpr" 0 - (lambda (ct port) - (if (eq? ct %condition-type-vtable) - (display "#") - (format port "#" - (condition-type-id ct) - (number->string (object-address ct) - 16)))))) + (let ((s (make-vtable (string-append standard-vtable-fields "prprpr") + (lambda (ct port) + (format port "#" + (condition-type-id ct) + (number->string (object-address ct) + 16)))))) + (set-struct-vtable-name! s 'condition-type) + s)) (define (%make-condition-type layout id parent all-fields) (let ((struct (make-struct %condition-type-vtable 0