From 4702cbeb3780d0c81076bae0723a1fd544576471 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 11 Jan 2015 16:27:16 +0100 Subject: [PATCH 1/1] Move initialization to Scheme * libguile/goops.c (scm_sys_make_root_class): Just make the vtable-vtable, and leave initialization to Scheme. * libguile/struct.c (scm_i_make_vtable_vtable): Change to take a full list of fields, not just the extra fields. (scm_init_struct): Adapt to scm_i_make_vtable_vtable change. * module/oop/goops.scm (): Compute layout for , and initialize from here. --- libguile/goops.c | 28 +++++++--------------------- libguile/struct.c | 15 +++++++-------- libguile/struct.h | 4 ++-- module/oop/goops.scm | 38 ++++++++++++++++++++++++++++++++++---- 4 files changed, 50 insertions(+), 35 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 1ea7a94f4..37e3fd2b5 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -151,8 +151,7 @@ static SCM scm_unbound_p (SCM obj); static SCM scm_class_p (SCM obj); static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable, SCM setter); -static SCM scm_sys_make_root_class (SCM name, SCM dslots, - SCM getters_n_setters); +static SCM scm_sys_make_root_class (SCM layout); static SCM scm_sys_init_layout_x (SCM class, SCM layout); static SCM scm_sys_goops_early_init (void); static SCM scm_sys_goops_loaded (void); @@ -317,28 +316,15 @@ scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots) /******************************************************************************/ -SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 3, 0, 0, - (SCM name, SCM dslots, SCM getters_n_setters), +SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0, + (SCM layout), "") #define FUNC_NAME s_scm_sys_make_root_class { - SCM cs, z; - - cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT); - z = scm_i_make_vtable_vtable (cs); - SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID - | SCM_CLASSF_METACLASS)); - - SCM_SET_SLOT (z, scm_vtable_index_name, name); - SCM_SET_SLOT (z, scm_si_direct_supers, SCM_EOL); /* will be changed */ - SCM_SET_SLOT (z, scm_si_direct_slots, dslots); /* will be changed */ - SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL); - SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL); - SCM_SET_SLOT (z, scm_si_cpl, SCM_EOL); /* will be changed */ - SCM_SET_SLOT (z, scm_si_slots, dslots); /* will be changed */ - SCM_SET_SLOT (z, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS)); - SCM_SET_SLOT (z, scm_si_getters_n_setters, getters_n_setters); /* will be changed */ - SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F); + SCM z; + + z = scm_i_make_vtable_vtable (layout); + SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS)); return z; } diff --git a/libguile/struct.c b/libguile/struct.c index 1b61aa4af..8bfbcf433 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 Free Software Foundation, Inc. + * 2008, 2009, 2010, 2011, 2012, 2013, 2015 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 @@ -597,20 +597,18 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, #undef FUNC_NAME SCM -scm_i_make_vtable_vtable (SCM user_fields) +scm_i_make_vtable_vtable (SCM fields) #define FUNC_NAME "make-vtable-vtable" { - SCM fields, layout, obj; + SCM layout, obj; size_t basic_size; scm_t_bits v; - SCM_VALIDATE_STRING (1, user_fields); + SCM_VALIDATE_STRING (1, fields); - 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)); + SCM_MISC_ERROR ("invalid user fields", scm_list_1 (fields)); basic_size = scm_i_symbol_length (layout) / 2; @@ -997,7 +995,8 @@ scm_init_struct () 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); - scm_standard_vtable_vtable = scm_i_make_vtable_vtable (scm_nullstr); + scm_standard_vtable_vtable = + scm_i_make_vtable_vtable (required_vtable_fields); name = scm_from_utf8_symbol (""); scm_set_struct_vtable_name_x (scm_standard_vtable_vtable, name); scm_define (name, scm_standard_vtable_vtable); diff --git a/libguile/struct.h b/libguile/struct.h index f1f6c4768..e8db316c8 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, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2015 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,7 +181,7 @@ SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits, 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); +SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM fields); 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); diff --git a/module/oop/goops.scm b/module/oop/goops.scm index ed60d4cc5..9114e4640 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -452,14 +452,44 @@ z))) (define - (let-syntax ((visit + (let-syntax ((cons-dslot ;; The specialized slot classes have not been defined ;; yet; initialize with unspecialized slots. (syntax-rules () ((_ (name) tail) (cons (list 'name) tail)) - ((_ (name class) tail) (cons (list 'name) tail))))) - (let ((dslots (fold--slots macro-fold-right visit '()))) - (%make-root-class ' dslots (%compute-getters-n-setters dslots))))) + ((_ (name class) tail) (cons (list 'name) tail)))) + (cons-layout + ;; A simple way to compute class layout for the concrete + ;; types used in . + (syntax-rules ( + ) + ((_ (name) tail) + (string-append "pw" tail)) + ((_ (name ) tail) + (string-append "pr" tail)) + ((_ (name ) tail) + (string-append "sr" tail)) + ((_ (name ) tail) + (string-append "uh" tail)) + ((_ (name ) tail) + (string-append "ph" tail))))) + (let* ((dslots (fold--slots macro-fold-right cons-dslot '())) + (layout (fold--slots macro-fold-right cons-layout "")) + ( (%make-root-class layout))) + ;; The `direct-supers', `direct-slots', `cpl', `slots', and + ;; `getters-n-setters' fields will be updated later. + (struct-set! class-index-name ') + (struct-set! class-index-direct-supers '()) + (struct-set! class-index-direct-slots dslots) + (struct-set! class-index-direct-subclasses '()) + (struct-set! class-index-direct-methods '()) + (struct-set! class-index-cpl '()) + (struct-set! class-index-slots dslots) + (struct-set! class-index-nfields (length dslots)) + (struct-set! class-index-getters-n-setters + (%compute-getters-n-setters dslots)) + (struct-set! class-index-redefined #f) + ))) (define-syntax define-standard-class (syntax-rules () -- 2.20.1