mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Incorporate %inherit-magic! into %init-layout!

Browse source 
* libguile/goops.c (scm_make_standard_class, scm_sys_init_layout_x):
  Move definitions up.  Incorporate scm_sys_inherit_magic_x into
  scm_sys_init_layout_x.

* libguile/goops.h: Remove scm_sys_init_layout_x declaration.
This commit is contained in:
Andy Wingo 2015-01-11 22:01:47 +01:00
parent 2025a02793
commit 60061fe0fe
3 changed files with 32 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

63
libguile/goops.c
View file

@ -164,6 +164,35 @@ static SCM scm_sys_goops_early_init (void);
static SCM scm_sys_goops_loaded (void); static SCM scm_sys_goops_loaded (void);
SCM
scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
{
return scm_call_4 (scm_variable_ref (var_make_standard_class),
meta, name, dsupers, dslots);
}
SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
(SCM class, SCM layout),
"")
#define FUNC_NAME s_scm_sys_init_layout_x
{
SCM_VALIDATE_INSTANCE (1, class);
SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, layout);
SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* This function is used for efficient type dispatch. */ /* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
(SCM x), (SCM x),
@ -287,42 +316,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
(SCM class, SCM layout),
"")
#define FUNC_NAME s_scm_sys_init_layout_x
{
SCM_VALIDATE_INSTANCE (1, class);
SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, layout);
SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
(SCM class, SCM dsupers),
"")
#define FUNC_NAME s_scm_sys_inherit_magic_x
{
SCM_VALIDATE_INSTANCE (1, class);
scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/******************************************************************************/ /******************************************************************************/
SCM
scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
{
return scm_call_4 (scm_variable_ref (var_make_standard_class),
meta, name, dsupers, dslots);
}
/******************************************************************************/ /******************************************************************************/
SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0, SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0,

1
libguile/goops.h
View file

@ -102,7 +102,6 @@ SCM_API SCM scm_slot_ref (SCM obj, SCM slot_name);
SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value); SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value);
SCM_INTERNAL void scm_i_inherit_applicable (SCM c); SCM_INTERNAL void scm_i_inherit_applicable (SCM c);
SCM_API SCM scm_sys_inherit_magic_x (SCM c, SCM dsupers);
SCM_API SCM scm_instance_p (SCM obj); SCM_API SCM scm_instance_p (SCM obj);
SCM_API int scm_is_generic (SCM x); SCM_API int scm_is_generic (SCM x);
SCM_API int scm_is_method (SCM x); SCM_API int scm_is_method (SCM x);

10
module/oop/goops.scm
View file

@ -447,7 +447,6 @@
(cons z subclasses)))) (cons z subclasses))))
dsupers) dsupers)
(%prep-layout! z) (%prep-layout! z)
(%inherit-magic! z dsupers)
z))) z)))
(define <class> (define <class>
@ -2471,12 +2470,9 @@ var{initargs}."
(cons class dsubs)))) (cons class dsubs))))
supers) supers)
;; Support for the underlying structs: ;; Compute struct layout of instances, set the `layout' slot, and
;; update class flags.
;; Set the layout slot (%prep-layout! class)))
(%prep-layout! class)
;; Inherit class flags (invisible on scheme level) from supers
(%inherit-magic! class supers)))
(define (initialize-object-procedure object initargs) (define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f))) (let ((proc (get-keyword #:procedure initargs #f)))