1682 |
{ |
{ |
1683 |
if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr)) |
if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr)) |
1684 |
{ |
{ |
1685 |
SCM gf = *SCM_SUBR_GENERIC (subr); |
if (!*SCM_SUBR_GENERIC (subr)) |
1686 |
if (gf) |
scm_enable_primitive_generic_x (scm_list_1 (subr)); |
1687 |
return gf; |
return *SCM_SUBR_GENERIC (subr); |
1688 |
} |
} |
1689 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, subr); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, subr); |
1690 |
} |
} |
1691 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1692 |
|
|
1693 |
|
typedef struct t_extension { |
1694 |
|
struct t_extension *next; |
1695 |
|
SCM extended; |
1696 |
|
SCM extension; |
1697 |
|
} t_extension; |
1698 |
|
|
1699 |
|
static t_extension *extensions = 0; |
1700 |
|
|
1701 |
|
SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); |
1702 |
|
|
1703 |
|
void |
1704 |
|
scm_c_extend_primitive_generic (SCM extended, SCM extension) |
1705 |
|
{ |
1706 |
|
if (goops_loaded_p) |
1707 |
|
{ |
1708 |
|
SCM gf, gext; |
1709 |
|
if (!*SCM_SUBR_GENERIC (extended)) |
1710 |
|
scm_enable_primitive_generic_x (scm_list_1 (extended)); |
1711 |
|
gf = *SCM_SUBR_GENERIC (extended); |
1712 |
|
gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), |
1713 |
|
gf, |
1714 |
|
SCM_SNAME (extension)); |
1715 |
|
*SCM_SUBR_GENERIC (extension) = gext; |
1716 |
|
} |
1717 |
|
else |
1718 |
|
{ |
1719 |
|
t_extension *e = scm_malloc (sizeof (t_extension)); |
1720 |
|
t_extension **loc = &extensions; |
1721 |
|
/* Make sure that extensions are placed before their own |
1722 |
|
* extensions in the extensions list. O(N^2) algorithm, but |
1723 |
|
* extensions of primitive generics are rare. |
1724 |
|
*/ |
1725 |
|
while (*loc && extension != (*loc)->extended) |
1726 |
|
loc = &(*loc)->next; |
1727 |
|
e->next = *loc; |
1728 |
|
e->extended = extended; |
1729 |
|
e->extension = extension; |
1730 |
|
*loc = e; |
1731 |
|
} |
1732 |
|
} |
1733 |
|
|
1734 |
|
static void |
1735 |
|
setup_extended_primitive_generics () |
1736 |
|
{ |
1737 |
|
while (extensions) |
1738 |
|
{ |
1739 |
|
t_extension *e = extensions; |
1740 |
|
scm_c_extend_primitive_generic (e->extended, e->extension); |
1741 |
|
extensions = e->next; |
1742 |
|
free (e); |
1743 |
|
} |
1744 |
|
} |
1745 |
|
|
1746 |
/****************************************************************************** |
/****************************************************************************** |
1747 |
* |
* |
1748 |
* Protocol for calling a generic fumction |
* Protocol for calling a generic fumction |
2747 |
var_compute_applicable_methods = |
var_compute_applicable_methods = |
2748 |
scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure, |
scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure, |
2749 |
SCM_BOOL_F); |
SCM_BOOL_F); |
2750 |
|
setup_extended_primitive_generics (); |
2751 |
return SCM_UNSPECIFIED; |
return SCM_UNSPECIFIED; |
2752 |
} |
} |
2753 |
#undef FUNC_NAME |
#undef FUNC_NAME |