/[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.48 by ossau, Fri Mar 15 10:37:40 2002 UTC revision 1.49 by ttn, Mon Apr 22 17:46:06 2002 UTC
# Line 1  Line 1 
1  /* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.  /* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
2   *   *
3   * This program is free software; you can redistribute it and/or modify   * This program is free software; you can redistribute it and/or modify
4   * it under the terms of the GNU General Public License as published by   * it under the terms of the GNU General Public License as published by
5   * the Free Software Foundation; either version 2, or (at your option)   * the Free Software Foundation; either version 2, or (at your option)
6   * any later version.   * any later version.
7   *   *
8   * This program is distributed in the hope that it will be useful,   * This program is distributed in the hope that it will be useful,
9   * but WITHOUT ANY WARRANTY; without even the implied warranty of   * but WITHOUT ANY WARRANTY; without even the implied warranty of
10   * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the   * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11   * GNU General Public License for more details.   * GNU General Public License for more details.
12   *   *
13   * You should have received a copy of the GNU General Public License   * You should have received a copy of the GNU General Public License
14   * along with this software; see the file COPYING.  If not, write to   * along with this software; see the file COPYING.  If not, write to
15   * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,   * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
# Line 247  remove_duplicate_slots (SCM l, SCM res, Line 247  remove_duplicate_slots (SCM l, SCM res,
247    tmp = SCM_CAAR (l);    tmp = SCM_CAAR (l);
248    if (!SCM_SYMBOLP (tmp))    if (!SCM_SYMBOLP (tmp))
249      scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));      scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
250      
251    if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) {    if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) {
252      res                = scm_cons (SCM_CAR (l), res);      res                = scm_cons (SCM_CAR (l), res);
253      slots_already_seen = scm_cons (tmp, slots_already_seen);      slots_already_seen = scm_cons (tmp, slots_already_seen);
254    }    }
255      
256    return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);    return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
257  }  }
258    
# Line 288  SCM_DEFINE (scm_sys_compute_slots, "%com Line 288  SCM_DEFINE (scm_sys_compute_slots, "%com
288              (SCM class),              (SCM class),
289              "Return a list consisting of the names of all slots belonging to\n"              "Return a list consisting of the names of all slots belonging to\n"
290              "class @var{class}, i. e. the slots of @var{class} and of all of\n"              "class @var{class}, i. e. the slots of @var{class} and of all of\n"
291              "its superclasses.")              "its superclasses.")
292  #define FUNC_NAME s_scm_sys_compute_slots  #define FUNC_NAME s_scm_sys_compute_slots
293  {  {
294    SCM_VALIDATE_CLASS (1, class);    SCM_VALIDATE_CLASS (1, class);
# Line 301  SCM_DEFINE (scm_sys_compute_slots, "%com Line 301  SCM_DEFINE (scm_sys_compute_slots, "%com
301  /******************************************************************************  /******************************************************************************
302   *   *
303   * compute-getters-n-setters   * compute-getters-n-setters
304   *     *
305   *   This version doesn't handle slot options. It serves only for booting   *   This version doesn't handle slot options. It serves only for booting
306   * classes and will be overloaded in Scheme.   * classes and will be overloaded in Scheme.
307   *   *
308   ******************************************************************************/   ******************************************************************************/
# Line 406  SCM_DEFINE (scm_sys_initialize_object, " Line 406  SCM_DEFINE (scm_sys_initialize_object, "
406    SCM_VALIDATE_INSTANCE (1, obj);    SCM_VALIDATE_INSTANCE (1, obj);
407    n_initargs = scm_ilength (initargs);    n_initargs = scm_ilength (initargs);
408    SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);    SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
409      
410    get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);    get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
411    slots     = SCM_SLOT (class, scm_si_slots);    slots     = SCM_SLOT (class, scm_si_slots);
412      
413    /* See for each slot how it must be initialized */    /* See for each slot how it must be initialized */
414    for (;    for (;
415         !SCM_NULLP (slots);         !SCM_NULLP (slots);
# Line 417  SCM_DEFINE (scm_sys_initialize_object, " Line 417  SCM_DEFINE (scm_sys_initialize_object, "
417      {      {
418        SCM slot_name  = SCM_CAR (slots);        SCM slot_name  = SCM_CAR (slots);
419        SCM slot_value = 0;        SCM slot_value = 0;
420        
421        if (!SCM_NULLP (SCM_CDR (slot_name)))        if (!SCM_NULLP (SCM_CDR (slot_name)))
422          {          {
423            /* This slot admits (perhaps) to be initialized at creation time */            /* This slot admits (perhaps) to be initialized at creation time */
# Line 466  SCM_DEFINE (scm_sys_initialize_object, " Line 466  SCM_DEFINE (scm_sys_initialize_object, "
466              }              }
467          }          }
468      }      }
469      
470    return obj;    return obj;
471  }  }
472  #undef FUNC_NAME  #undef FUNC_NAME
# Line 494  SCM_DEFINE (scm_sys_prep_layout_x, "%pre Line 494  SCM_DEFINE (scm_sys_prep_layout_x, "%pre
494        && SCM_SUBCLASSP (class, scm_class_class))        && SCM_SUBCLASSP (class, scm_class_class))
495      SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",      SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
496                      scm_list_1 (nfields));                      scm_list_1 (nfields));
497      
498    s = n > 0 ? scm_malloc (n) : 0;    s = n > 0 ? scm_malloc (n) : 0;
499    for (i = 0; i < n; i += 2)    for (i = 0; i < n; i += 2)
500      {      {
# Line 595  SCM_DEFINE (scm_sys_inherit_magic_x, "%i Line 595  SCM_DEFINE (scm_sys_inherit_magic_x, "%i
595    SCM_SET_CLASS_FLAGS (class, flags);    SCM_SET_CLASS_FLAGS (class, flags);
596    
597    prep_hashsets (class);    prep_hashsets (class);
598      
599    return SCM_UNSPECIFIED;    return SCM_UNSPECIFIED;
600  }  }
601  #undef FUNC_NAME  #undef FUNC_NAME
# Line 753  create_basic_classes (void) Line 753  create_basic_classes (void)
753    SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL);  /* will be changed */    SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL);  /* will be changed */
754    /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */    /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
755    SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);    SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
756    SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);      SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
757    SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL);  /* will be changed */    SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL);  /* will be changed */
758    /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */    /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
759    SCM_SET_SLOT (scm_class_class, scm_si_nfields, SCM_MAKINUM (SCM_N_CLASS_SLOTS));    SCM_SET_SLOT (scm_class_class, scm_si_nfields, SCM_MAKINUM (SCM_N_CLASS_SLOTS));
# Line 775  create_basic_classes (void) Line 775  create_basic_classes (void)
775                                                      SCM_EOL));                                                      SCM_EOL));
776    
777    DEFVAR(name, scm_class_top);    DEFVAR(name, scm_class_top);
778      
779    /**** <scm_class_object> ****/    /**** <scm_class_object> ****/
780    name   = scm_str2symbol ("<object>");    name   = scm_str2symbol ("<object>");
781    scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,    scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
# Line 805  SCM_DEFINE (scm_instance_p, "instance?", Line 805  SCM_DEFINE (scm_instance_p, "instance?",
805    
806    
807  /******************************************************************************  /******************************************************************************
808   *   *
809   * Meta object accessors   * Meta object accessors
810   *   *
811   ******************************************************************************/   ******************************************************************************/
# Line 1077  get_slot_value (SCM class SCM_UNUSED, SC Line 1077  get_slot_value (SCM class SCM_UNUSED, SC
1077      return SCM_SLOT (obj, SCM_INUM (access));      return SCM_SLOT (obj, SCM_INUM (access));
1078    else    else
1079      {      {
1080        /* We must evaluate (apply (car access) (list obj))        /* We must evaluate (apply (car access) (list obj))
1081         * where (car access) is known to be a closure of arity 1  */         * where (car access) is known to be a closure of arity 1  */
1082        register SCM code, env;        register SCM code, env;
1083    
# Line 1273  SCM_DEFINE (scm_slot_bound_p, "slot-boun Line 1273  SCM_DEFINE (scm_slot_bound_p, "slot-boun
1273  }  }
1274  #undef FUNC_NAME  #undef FUNC_NAME
1275    
1276  SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0,  SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
1277              (SCM obj, SCM slot_name),              (SCM obj, SCM slot_name),
1278              "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")              "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1279  #define FUNC_NAME s_scm_slots_exists_p  #define FUNC_NAME s_scm_slot_exists_p
1280  {  {
1281    SCM class;    SCM class;
1282    
# Line 1301  static SCM Line 1301  static SCM
1301  wrap_init (SCM class, SCM *m, long n)  wrap_init (SCM class, SCM *m, long n)
1302  {  {
1303    long i;    long i;
1304      
1305    /* Set all slots to unbound */    /* Set all slots to unbound */
1306    for (i = 0; i < n; i++)    for (i = 0; i < n; i++)
1307      m[i] = SCM_GOOPS_UNBOUND;      m[i] = SCM_GOOPS_UNBOUND;
# Line 1329  SCM_DEFINE (scm_sys_allocate_instance, " Line 1329  SCM_DEFINE (scm_sys_allocate_instance, "
1329        m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");        m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
1330        return wrap_init (class, m, n);        return wrap_init (class, m, n);
1331      }      }
1332      
1333    /* Foreign objects */    /* Foreign objects */
1334    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
1335      return scm_make_foreign_object (class, initargs);      return scm_make_foreign_object (class, initargs);
1336    
1337    n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));    n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
1338      
1339    /* Entities */    /* Entities */
1340    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
1341      {      {
# Line 1353  SCM_DEFINE (scm_sys_allocate_instance, " Line 1353  SCM_DEFINE (scm_sys_allocate_instance, "
1353        else        else
1354          return wrap_init (class, m, n);          return wrap_init (class, m, n);
1355      }      }
1356      
1357    /* Class objects */    /* Class objects */
1358    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
1359      {      {
# Line 1373  SCM_DEFINE (scm_sys_allocate_instance, " Line 1373  SCM_DEFINE (scm_sys_allocate_instance, "
1373    
1374        return z;        return z;
1375      }      }
1376      
1377    /* Non-light instances */    /* Non-light instances */
1378    {    {
1379      m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");      m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
# Line 1404  SCM_DEFINE (scm_sys_set_object_setter_x, Line 1404  SCM_DEFINE (scm_sys_set_object_setter_x,
1404  /******************************************************************************  /******************************************************************************
1405   *   *
1406   * %modify-instance (used by change-class to modify in place)   * %modify-instance (used by change-class to modify in place)
1407   *   *
1408   ******************************************************************************/   ******************************************************************************/
1409    
1410  SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,  SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
# Line 1415  SCM_DEFINE (scm_sys_modify_instance, "%m Line 1415  SCM_DEFINE (scm_sys_modify_instance, "%m
1415    SCM_VALIDATE_INSTANCE (1, old);    SCM_VALIDATE_INSTANCE (1, old);
1416    SCM_VALIDATE_INSTANCE (2, new);    SCM_VALIDATE_INSTANCE (2, new);
1417    
1418    /* Exchange the data contained in old and new. We exchange rather than    /* Exchange the data contained in old and new. We exchange rather than
1419     * scratch the old value with new to be correct with GC.     * scratch the old value with new to be correct with GC.
1420     * See "Class redefinition protocol above".     * See "Class redefinition protocol above".
1421     */     */
# Line 1528  SCM_SYMBOL (scm_sym_change_class, "chang Line 1528  SCM_SYMBOL (scm_sym_change_class, "chang
1528  static SCM  static SCM
1529  purgatory (void *args)  purgatory (void *args)
1530  {  {
1531    return scm_apply_0 (GETVAR (scm_sym_change_class),    return scm_apply_0 (GETVAR (scm_sym_change_class),
1532                        SCM_PACK ((scm_t_bits) args));                        SCM_PACK ((scm_t_bits) args));
1533  }  }
1534    
# Line 1543  scm_change_object_class (SCM obj, SCM ol Line 1543  scm_change_object_class (SCM obj, SCM ol
1543    
1544  /******************************************************************************  /******************************************************************************
1545   *   *
1546   *   GGGG                FFFFF             *   GGGG                FFFFF
1547   *  G                    F       *  G                    F
1548   *  G  GG                FFF       *  G  GG                FFF
1549   *  G   G                F         *  G   G                F
1550   *   GGG  E N E R I C    F    U N C T I O N S   *   GGG  E N E R I C    F    U N C T I O N S
1551   *   *
1552   * This implementation provides   * This implementation provides
1553   *      - generic functions (with class specializers)   *      - generic functions (with class specializers)
1554   *      - multi-methods   *      - multi-methods
1555   *      - next-method   *      - next-method
1556   *      - a hard-coded MOP for standard gf, which can be overloaded for non-std gf   *      - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1557   *   *
1558   ******************************************************************************/   ******************************************************************************/
# Line 1660  SCM_DEFINE (scm_primitive_generic_generi Line 1660  SCM_DEFINE (scm_primitive_generic_generi
1660  #undef FUNC_NAME  #undef FUNC_NAME
1661    
1662  /******************************************************************************  /******************************************************************************
1663   *   *
1664   * Protocol for calling a generic fumction   * Protocol for calling a generic fumction
1665   * This protocol is roughly equivalent to (parameter are a little bit different   * This protocol is roughly equivalent to (parameter are a little bit different
1666   * for efficiency reasons):   * for efficiency reasons):
1667   *   *
1668   *      + apply-generic (gf args)   *      + apply-generic (gf args)
1669   *              + compute-applicable-methods (gf args ...)   *              + compute-applicable-methods (gf args ...)
1670   *                      + sort-applicable-methods (methods args)   *                      + sort-applicable-methods (methods args)
1671   *              + apply-methods (gf methods args)   *              + apply-methods (gf methods args)
1672   *                                 *
1673   * apply-methods calls make-next-method to build the "continuation" of a a   * apply-methods calls make-next-method to build the "continuation" of a a
1674   * method.  Applying a next-method will call apply-next-method which in   * method.  Applying a next-method will call apply-next-method which in
1675   * turn will call  apply again to call effectively the following method.   * turn will call  apply again to call effectively the following method.
1676   *   *
# Line 1688  more_specificp (SCM m1, SCM m2, SCM *tar Line 1688  more_specificp (SCM m1, SCM m2, SCM *tar
1688  {  {
1689    register SCM s1, s2;    register SCM s1, s2;
1690    register long i;    register long i;
1691    /*    /*
1692     * Note:     * Note:
1693     *   m1 and m2 can have != length (i.e. one can be one element longer than the     *   m1 and m2 can have != length (i.e. one can be one element longer than the
1694     * other when we have a dotted parameter list). For instance, with the call     * other when we have a dotted parameter list). For instance, with the call
1695     *   (M 1)     *   (M 1)
1696     * with     * with
1697     *   (define-method M (a . l) ....)     *   (define-method M (a . l) ....)
1698     *   (define-method M (a) ....)     *   (define-method M (a) ....)
1699     *     *
1700     * we consider that the second method is more specific.     * we consider that the second method is more specific.
1701     *     *
# Line 1709  more_specificp (SCM m1, SCM m2, SCM *tar Line 1709  more_specificp (SCM m1, SCM m2, SCM *tar
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)) {
1711        register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);        register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
1712          
1713        for (l = SCM_SLOT (targs[i], scm_si_cpl);   ; l = SCM_CDR(l)) {        for (l = SCM_SLOT (targs[i], scm_si_cpl);   ; l = SCM_CDR(l)) {
1714          if (cs1 == SCM_CAR(l))          if (cs1 == SCM_CAR(l))
1715            return 1;            return 1;
# Line 1729  scm_i_vector2list (SCM l, long len) Line 1729  scm_i_vector2list (SCM l, long len)
1729  {  {
1730    long j;    long j;
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_VELTS (z)[j] = SCM_CAR (l);
1735    }    }
# Line 1756  sort_applicable_methods (SCM method_list Line 1756  sort_applicable_methods (SCM method_list
1756            method_list = SCM_CDR (method_list);            method_list = SCM_CDR (method_list);
1757          }          }
1758        v = buffer;        v = buffer;
1759      }      }
1760    else    else
1761      {      {
1762        /* Too many elements in method_list to keep everything locally */        /* Too many elements in method_list to keep everything locally */
# Line 1764  sort_applicable_methods (SCM method_list Line 1764  sort_applicable_methods (SCM method_list
1764        v      = SCM_VELTS (vector);        v      = SCM_VELTS (vector);
1765      }      }
1766    
1767    /* 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
1768     * small vectors (which is probably mostly the case when we have to     * small vectors (which is probably mostly the case when we have to
1769     * sort a list of applicable methods).     * sort a list of applicable methods).
1770     */     */
# Line 1796  sort_applicable_methods (SCM method_list Line 1796  sort_applicable_methods (SCM method_list
1796          }          }
1797        return save;        return save;
1798      }      }
1799    /* If we are here, that's that we did it the hard way... */    /* If we are here, that's that we did it the hard way... */
1800    return scm_vector_to_list (vector);    return scm_vector_to_list (vector);
1801  }  }
1802    
# Line 1809  scm_compute_applicable_methods (SCM gf, Line 1809  scm_compute_applicable_methods (SCM gf,
1809    SCM save = args;    SCM save = args;
1810    SCM buffer[BUFFSIZE], *types, *p;    SCM buffer[BUFFSIZE], *types, *p;
1811    SCM tmp;    SCM tmp;
1812    
1813    /* Build the list of arguments types */    /* Build the list of arguments types */
1814    if (len >= BUFFSIZE) {    if (len >= BUFFSIZE) {
1815      tmp   = scm_c_make_vector (len, SCM_UNDEFINED);      tmp   = scm_c_make_vector (len, SCM_UNDEFINED);
# Line 1820  scm_compute_applicable_methods (SCM gf, Line 1820  scm_compute_applicable_methods (SCM gf,
1820    }    }
1821    else    else
1822      types = p = buffer;      types = p = buffer;
1823      
1824    for (  ; !SCM_NULLP (args); args = SCM_CDR (args))    for (  ; !SCM_NULLP (args); args = SCM_CDR (args))
1825      *p++ = scm_class_of (SCM_CAR (args));      *p++ = scm_class_of (SCM_CAR (args));
1826    
1827    /* Build a list of all applicable methods */    /* Build a list of all applicable methods */
1828    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))
1829      {      {
# Line 1992  scm_memoize_method (SCM x, SCM args) Line 1992  scm_memoize_method (SCM x, SCM args)
1992   * A simple make (which will be redefined later in Scheme)   * A simple make (which will be redefined later in Scheme)
1993   * This version handles only creation of gf, methods and classes (no instances)   * This version handles only creation of gf, methods and classes (no instances)
1994   *   *
1995   * Since this code will disappear when Goops will be fully booted,   * Since this code will disappear when Goops will be fully booted,
1996   * no precaution is taken to be efficient.   * no precaution is taken to be efficient.
1997   *   *
1998   ******************************************************************************/   ******************************************************************************/
# Line 2051  SCM_DEFINE (scm_make, "make",  0, 0, 1, Line 2051  SCM_DEFINE (scm_make, "make",  0, 0, 1,
2051            || class == scm_class_simple_method            || class == scm_class_simple_method
2052            || class == scm_class_accessor)            || class == scm_class_accessor)
2053          {          {
2054            SCM_SET_SLOT (z, scm_si_generic_function,            SCM_SET_SLOT (z, scm_si_generic_function,
2055              scm_i_get_keyword (k_gf,              scm_i_get_keyword (k_gf,
2056                                 args,                                 args,
2057                                 len - 1,                                 len - 1,
2058                                 SCM_BOOL_F,                                 SCM_BOOL_F,
2059                                 FUNC_NAME));                                 FUNC_NAME));
2060            SCM_SET_SLOT (z, scm_si_specializers,            SCM_SET_SLOT (z, scm_si_specializers,
2061              scm_i_get_keyword (k_specializers,              scm_i_get_keyword (k_specializers,
2062                                 args,                                 args,
2063                                 len - 1,                                 len - 1,
2064                                 SCM_EOL,                                 SCM_EOL,
2065                                 FUNC_NAME));                                 FUNC_NAME));
2066            SCM_SET_SLOT (z, scm_si_procedure,            SCM_SET_SLOT (z, scm_si_procedure,
2067              scm_i_get_keyword (k_procedure,              scm_i_get_keyword (k_procedure,
2068                                 args,                                 args,
2069                                 len - 1,                                 len - 1,
# Line 2074  SCM_DEFINE (scm_make, "make",  0, 0, 1, Line 2074  SCM_DEFINE (scm_make, "make",  0, 0, 1,
2074        else        else
2075          {          {
2076            /* In all the others case, make a new class .... No instance here */            /* In all the others case, make a new class .... No instance here */
2077            SCM_SET_SLOT (z, scm_si_name,            SCM_SET_SLOT (z, scm_si_name,
2078              scm_i_get_keyword (k_name,              scm_i_get_keyword (k_name,
2079                                 args,                                 args,
2080                                 len - 1,                                 len - 1,
2081                                 scm_str2symbol ("???"),                                 scm_str2symbol ("???"),
2082                                 FUNC_NAME));                                 FUNC_NAME));
2083            SCM_SET_SLOT (z, scm_si_direct_supers,            SCM_SET_SLOT (z, scm_si_direct_supers,
2084              scm_i_get_keyword (k_dsupers,              scm_i_get_keyword (k_dsupers,
2085                                 args,                                 args,
2086                                 len - 1,                                 len - 1,
2087                                 SCM_EOL,                                 SCM_EOL,
2088                                 FUNC_NAME));                                 FUNC_NAME));
2089            SCM_SET_SLOT (z, scm_si_direct_slots,            SCM_SET_SLOT (z, scm_si_direct_slots,
2090              scm_i_get_keyword (k_slots,              scm_i_get_keyword (k_slots,
2091                                 args,                                 args,
2092                                 len - 1,                                 len - 1,
# Line 2140  SCM_DEFINE (scm_sys_method_more_specific Line 2140  SCM_DEFINE (scm_sys_method_more_specific
2140    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;
2141  }  }
2142  #undef FUNC_NAME  #undef FUNC_NAME
2143      
2144      
2145    
2146  /******************************************************************************  /******************************************************************************
2147   *   *
2148   * Initializations   * Initializations
2149   *   *
2150   ******************************************************************************/   ******************************************************************************/
2151    
# Line 2154  static void Line 2154  static void
2154  make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)  make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
2155  {  {
2156     SCM tmp = scm_str2symbol (name);     SCM tmp = scm_str2symbol (name);
2157      
2158     *var = scm_permanent_object (scm_basic_make_class (meta,     *var = scm_permanent_object (scm_basic_make_class (meta,
2159                                                        tmp,                                                        tmp,
2160                                                        SCM_CONSP (super)                                                        SCM_CONSP (super)
# Line 2171  static void Line 2171  static void
2171  create_standard_classes (void)  create_standard_classes (void)
2172  {  {
2173    SCM slots;    SCM slots;
2174    SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"),    SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"),
2175                                   scm_str2symbol ("specializers"),                                   scm_str2symbol ("specializers"),
2176                                   sym_procedure,                                   sym_procedure,
2177                                   scm_str2symbol ("code-table"));                                   scm_str2symbol ("code-table"));
2178    SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),    SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
# Line 2227  create_standard_classes (void) Line 2227  create_standard_classes (void)
2227                 scm_class_class, scm_class_foreign_slot,    SCM_EOL);                 scm_class_class, scm_class_foreign_slot,    SCM_EOL);
2228    
2229    /* Continue initialization of class <class> */    /* Continue initialization of class <class> */
2230      
2231    slots = build_class_class_slots ();    slots = build_class_class_slots ();
2232    SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);    SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
2233    SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);    SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
2234    SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,    SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
2235                  compute_getters_n_setters (slots));                  compute_getters_n_setters (slots));
2236      
2237    make_stdcls (&scm_class_foreign_class, "<foreign-class>",    make_stdcls (&scm_class_foreign_class, "<foreign-class>",
2238                 scm_class_class, scm_class_class,                 scm_class_class, scm_class_class,
2239                 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),                 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
# Line 2277  create_standard_classes (void) Line 2277  create_standard_classes (void)
2277                 SCM_EOL);                 SCM_EOL);
2278  #if 0  #if 0
2279    /* Patch cpl since compute_cpl doesn't support multiple inheritance. */    /* Patch cpl since compute_cpl doesn't support multiple inheritance. */
2280    SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl,    SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl,
2281      scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter,      scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter,
2282                                          scm_class_generic),                                          scm_class_generic),
2283                              SCM_SLOT (scm_class_entity_with_setter,                              SCM_SLOT (scm_class_entity_with_setter,
# Line 2385  create_smob_classes (void) Line 2385  create_smob_classes (void)
2385    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real;    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real;
2386    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex;    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex;
2387    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
2388      
2389    for (i = 0; i < scm_numsmob; ++i)    for (i = 0; i < scm_numsmob; ++i)
2390      if (!scm_smob_class[i])      if (!scm_smob_class[i])
2391        scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i));        scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i));
# Line 2429  create_port_classes (void) Line 2429  create_port_classes (void)
2429  }  }
2430    
2431  static SCM  static SCM
2432  make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,  make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,
2433                     SCM data, SCM prev SCM_UNUSED)                     SCM data, SCM prev SCM_UNUSED)
2434  {  {
2435    if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data)))    if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data)))
# Line 2502  scm_make_class (SCM meta, char *s_name, Line 2502  scm_make_class (SCM meta, char *s_name,
2502        SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);        SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
2503        SCM_SET_CLASS_INSTANCE_SIZE (class, size);        SCM_SET_CLASS_INSTANCE_SIZE (class, size);
2504      }      }
2505      
2506    SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));    SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));
2507    SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);    SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
2508    
# Line 2561  scm_add_slot (SCM class, char *slot_name Line 2561  scm_add_slot (SCM class, char *slot_name
2561                                              k_procedure,                                              k_procedure,
2562                                              setm)));                                              setm)));
2563        DEFVAR (aname, gf);        DEFVAR (aname, gf);
2564          
2565        SCM_SET_SLOT (class, scm_si_slots,        SCM_SET_SLOT (class, scm_si_slots,
2566                      scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),                      scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
2567                                                scm_list_1 (slot))));                                                scm_list_1 (slot))));
# Line 2570  scm_add_slot (SCM class, char *slot_name Line 2570  scm_add_slot (SCM class, char *slot_name
2570                                                scm_list_1 (gns))));                                                scm_list_1 (gns))));
2571      }      }
2572    }    }
2573    {      {
2574      long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));      long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
2575    
2576      SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));      SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
# Line 2664  scm_init_goops_builtins (void) Line 2664  scm_init_goops_builtins (void)
2664    scm_module_goops = scm_current_module ();    scm_module_goops = scm_current_module ();
2665    scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);    scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
2666    
2667    /* Not really necessary right now, but who knows...    /* Not really necessary right now, but who knows...
2668     */     */
2669    scm_permanent_object (scm_module_goops);    scm_permanent_object (scm_module_goops);
2670    scm_permanent_object (scm_goops_lookup_closure);    scm_permanent_object (scm_goops_lookup_closure);

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

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