/[guile]/guile/guile-core/libguile/goops.c
ViewVC logotype

Diff of /guile/guile-core/libguile/goops.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.49 by ttn, Mon Apr 22 17:46:06 2002 UTC revision 1.50 by xxhanwen, Sat Jul 20 14:08:33 2002 UTC
# Line 75  Line 75 
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 */
# Line 84  Line 84 
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:
# Line 1684  applicablep (SCM actual, SCM formal) Line 1684  applicablep (SCM actual, SCM formal)
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;
# Line 1704  more_specificp (SCM m1, SCM m2, SCM *tar Line 1704  more_specificp (SCM m1, SCM m2, SCM *tar
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)) {
# Line 1731  scm_i_vector2list (SCM l, long len) Line 1731  scm_i_vector2list (SCM l, long len)
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;
# Line 1761  sort_applicable_methods (SCM method_list Line 1761  sort_applicable_methods (SCM method_list
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
# Line 1807  scm_compute_applicable_methods (SCM gf, Line 1813  scm_compute_applicable_methods (SCM gf,
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) {
# Line 1816  scm_compute_applicable_methods (SCM gf, Line 1824  scm_compute_applicable_methods (SCM gf,
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      {      {
# Line 1857  scm_compute_applicable_methods (SCM gf, Line 1871  scm_compute_applicable_methods (SCM gf,
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));
# Line 2135  SCM_DEFINE (scm_sys_method_more_specific Line 2151  SCM_DEFINE (scm_sys_method_more_specific
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  }  }

Legend:
Removed from v.1.49  
changed lines
  Added in v.1.50

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26