mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
Move <class> 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 (<class>): Compute layout for <class>, and initialize <class> from here.
This commit is contained in:
Andy Wingo
parent
2b5812c64d
commit
4702cbeb37
4 changed files with 49 additions and 34 deletions
|
|
@ -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;
|
||||
SCM 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);
|
||||
z = scm_i_make_vtable_vtable (layout);
|
||||
SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS));
|
||||
|
||||
return z;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 ("<standard-vtable>");
|
||||
scm_set_struct_vtable_name_x (scm_standard_vtable_vtable, name);
|
||||
scm_define (name, scm_standard_vtable_vtable);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -452,14 +452,44 @@
|
|||
z)))
|
||||
|
||||
(define <class>
|
||||
(let-syntax ((visit
|
||||
(let-syntax ((cons-dslot
|
||||
;; The specialized slot classes have not been defined
|
||||
;; yet; initialize <class> with unspecialized slots.
|
||||
(syntax-rules ()
|
||||
((_ (name) tail) (cons (list 'name) tail))
|
||||
((_ (name class) tail) (cons (list 'name) tail)))))
|
||||
(let ((dslots (fold-<class>-slots macro-fold-right visit '())))
|
||||
(%make-root-class '<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 <class>.
|
||||
(syntax-rules (<protected-read-only-slot> <self-slot>
|
||||
<hidden-slot> <protected-hidden-slot>)
|
||||
((_ (name) tail)
|
||||
(string-append "pw" tail))
|
||||
((_ (name <protected-read-only-slot>) tail)
|
||||
(string-append "pr" tail))
|
||||
((_ (name <self-slot>) tail)
|
||||
(string-append "sr" tail))
|
||||
((_ (name <hidden-slot>) tail)
|
||||
(string-append "uh" tail))
|
||||
((_ (name <protected-hidden-slot>) tail)
|
||||
(string-append "ph" tail)))))
|
||||
(let* ((dslots (fold-<class>-slots macro-fold-right cons-dslot '()))
|
||||
(layout (fold-<class>-slots macro-fold-right cons-layout ""))
|
||||
(<class> (%make-root-class layout)))
|
||||
;; The `direct-supers', `direct-slots', `cpl', `slots', and
|
||||
;; `getters-n-setters' fields will be updated later.
|
||||
(struct-set! <class> class-index-name '<class>)
|
||||
(struct-set! <class> class-index-direct-supers '())
|
||||
(struct-set! <class> class-index-direct-slots dslots)
|
||||
(struct-set! <class> class-index-direct-subclasses '())
|
||||
(struct-set! <class> class-index-direct-methods '())
|
||||
(struct-set! <class> class-index-cpl '())
|
||||
(struct-set! <class> class-index-slots dslots)
|
||||
(struct-set! <class> class-index-nfields (length dslots))
|
||||
(struct-set! <class> class-index-getters-n-setters
|
||||
(%compute-getters-n-setters dslots))
|
||||
(struct-set! <class> class-index-redefined #f)
|
||||
<class>)))
|
||||
|
||||
(define-syntax define-standard-class
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue