75 |
|
|
76 |
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) |
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) |
77 |
|
|
78 |
#define DEFVAR(v,val) \ |
#define DEFVAR(v, val) \ |
79 |
{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \ |
{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \ |
80 |
scm_module_goops); } |
scm_module_goops); } |
81 |
/* Temporary hack until we get the new module system */ |
/* Temporary hack until we get the new module system */ |
84 |
(v), SCM_BOOL_F))) |
(v), SCM_BOOL_F))) |
85 |
|
|
86 |
/* Fixme: Should use already interned symbols */ |
/* Fixme: Should use already interned symbols */ |
87 |
#define CALL_GF1(name,a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \ |
#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \ |
88 |
a)) |
a)) |
89 |
#define CALL_GF2(name,a,b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \ |
#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \ |
90 |
a, b)) |
a, b)) |
91 |
#define CALL_GF3(name,a,b,c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \ |
#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \ |
92 |
a, b, c)) |
a, b, c)) |
93 |
#define CALL_GF4(name,a,b,c,d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \ |
#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \ |
94 |
a, b, c, d)) |
a, b, c, d)) |
95 |
|
|
96 |
/* Class redefinition protocol: |
/* Class redefinition protocol: |
1684 |
} |
} |
1685 |
|
|
1686 |
static int |
static int |
1687 |
more_specificp (SCM m1, SCM m2, SCM *targs) |
more_specificp (SCM m1, SCM m2, SCM const *targs) |
1688 |
{ |
{ |
1689 |
register SCM s1, s2; |
register SCM s1, s2; |
1690 |
register long i; |
register long i; |
1704 |
* the end of this array). |
* the end of this array). |
1705 |
* |
* |
1706 |
*/ |
*/ |
1707 |
for (i=0,s1=SPEC_OF(m1),s2=SPEC_OF(m2); ; i++,s1=SCM_CDR(s1),s2=SCM_CDR(s2)) { |
for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) { |
1708 |
if (SCM_NULLP(s1)) return 1; |
if (SCM_NULLP(s1)) return 1; |
1709 |
if (SCM_NULLP(s2)) return 0; |
if (SCM_NULLP(s2)) return 0; |
1710 |
if (SCM_CAR(s1) != SCM_CAR(s2)) { |
if (SCM_CAR(s1) != SCM_CAR(s2)) { |
1731 |
SCM z = scm_c_make_vector (len, SCM_UNDEFINED); |
SCM z = scm_c_make_vector (len, SCM_UNDEFINED); |
1732 |
|
|
1733 |
for (j = 0; j < len; j++, l = SCM_CDR (l)) { |
for (j = 0; j < len; j++, l = SCM_CDR (l)) { |
1734 |
SCM_VELTS (z)[j] = SCM_CAR (l); |
SCM_VECTOR_SET (z, j, SCM_CAR (l)); |
1735 |
} |
} |
1736 |
return z; |
return z; |
1737 |
} |
} |
1738 |
|
|
1739 |
static SCM |
static SCM |
1740 |
sort_applicable_methods (SCM method_list, long size, SCM *targs) |
sort_applicable_methods (SCM method_list, long size, SCM const *targs) |
1741 |
{ |
{ |
1742 |
long i, j, incr; |
long i, j, incr; |
1743 |
SCM *v, vector = SCM_EOL; |
SCM *v, vector = SCM_EOL; |
1761 |
{ |
{ |
1762 |
/* Too many elements in method_list to keep everything locally */ |
/* Too many elements in method_list to keep everything locally */ |
1763 |
vector = scm_i_vector2list (save, size); |
vector = scm_i_vector2list (save, size); |
1764 |
v = SCM_VELTS (vector); |
|
1765 |
|
/* |
1766 |
|
This is a new vector. Don't worry about the write barrier. |
1767 |
|
We're not allocating elements in this routine, so this should |
1768 |
|
pose no problem. |
1769 |
|
*/ |
1770 |
|
v = SCM_WRITABLE_VELTS (vector); |
1771 |
} |
} |
1772 |
|
|
1773 |
/* Use a simple shell sort since it is generally faster than qsort on |
/* Use a simple shell sort since it is generally faster than qsort on |
1813 |
long count = 0; |
long count = 0; |
1814 |
SCM l, fl, applicable = SCM_EOL; |
SCM l, fl, applicable = SCM_EOL; |
1815 |
SCM save = args; |
SCM save = args; |
1816 |
SCM buffer[BUFFSIZE], *types, *p; |
SCM buffer[BUFFSIZE]; |
1817 |
SCM tmp; |
SCM const *types; |
1818 |
|
SCM *p; |
1819 |
|
SCM tmp = SCM_EOL; |
1820 |
|
|
1821 |
/* Build the list of arguments types */ |
/* Build the list of arguments types */ |
1822 |
if (len >= BUFFSIZE) { |
if (len >= BUFFSIZE) { |
1824 |
/* NOTE: Using pointers to malloced memory won't work if we |
/* NOTE: Using pointers to malloced memory won't work if we |
1825 |
1. have preemtive threading, and, |
1. have preemtive threading, and, |
1826 |
2. have a GC which moves objects. */ |
2. have a GC which moves objects. */ |
1827 |
types = p = SCM_VELTS(tmp); |
types = p = SCM_WRITABLE_VELTS(tmp); |
1828 |
|
|
1829 |
|
/* |
1830 |
|
note that we don't have to work to reset the generation |
1831 |
|
count. TMP is a new vector anyway, and it is found |
1832 |
|
conservatively. |
1833 |
|
*/ |
1834 |
} |
} |
1835 |
else |
else |
1836 |
types = p = buffer; |
types = p = buffer; |
1837 |
|
|
1838 |
for ( ; !SCM_NULLP (args); args = SCM_CDR (args)) |
for ( ; !SCM_NULLP (args); args = SCM_CDR (args)) |
1839 |
*p++ = scm_class_of (SCM_CAR (args)); |
*p++ = scm_class_of (SCM_CAR (args)); |
1840 |
|
|
1841 |
/* Build a list of all applicable methods */ |
/* Build a list of all applicable methods */ |
1842 |
for (l = SCM_SLOT (gf, scm_si_methods); !SCM_NULLP (l); l = SCM_CDR (l)) |
for (l = SCM_SLOT (gf, scm_si_methods); !SCM_NULLP (l); l = SCM_CDR (l)) |
1843 |
{ |
{ |
1871 |
/* if we are here, it's because no-applicable-method hasn't signaled an error */ |
/* if we are here, it's because no-applicable-method hasn't signaled an error */ |
1872 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
1873 |
} |
} |
1874 |
|
|
1875 |
|
scm_remember_upto_here (tmp); |
1876 |
return (count == 1 |
return (count == 1 |
1877 |
? applicable |
? applicable |
1878 |
: sort_applicable_methods (applicable, count, types)); |
: sort_applicable_methods (applicable, count, types)); |
2151 |
|
|
2152 |
for (i = 0, l = targs; !SCM_NULLP (l); i++, l = SCM_CDR (l)) { |
for (i = 0, l = targs; !SCM_NULLP (l); i++, l = SCM_CDR (l)) { |
2153 |
SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME); |
SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME); |
2154 |
SCM_VELTS(v)[i] = SCM_CAR(l); |
SCM_VECTOR_SET (v, i, SCM_CAR(l)); |
2155 |
} |
} |
2156 |
return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F; |
return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F; |
2157 |
} |
} |