/[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.39.2.2 by ossau, Fri Mar 15 09:23:19 2002 UTC revision 1.39.2.3 by ttn, Tue Apr 23 22:31:53 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 246  remove_duplicate_slots (SCM l, SCM res, Line 246  remove_duplicate_slots (SCM l, SCM res,
246    tmp = SCM_CAAR (l);    tmp = SCM_CAAR (l);
247    if (!SCM_SYMBOLP (tmp))    if (!SCM_SYMBOLP (tmp))
248      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));
249      
250    if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) {    if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) {
251      res                = scm_cons (SCM_CAR (l), res);      res                = scm_cons (SCM_CAR (l), res);
252      slots_already_seen = scm_cons (tmp, slots_already_seen);      slots_already_seen = scm_cons (tmp, slots_already_seen);
253    }    }
254      
255    return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);    return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
256  }  }
257    
# Line 287  SCM_DEFINE (scm_sys_compute_slots, "%com Line 287  SCM_DEFINE (scm_sys_compute_slots, "%com
287              (SCM class),              (SCM class),
288              "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"
289              "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"
290              "its superclasses.")              "its superclasses.")
291  #define FUNC_NAME s_scm_sys_compute_slots  #define FUNC_NAME s_scm_sys_compute_slots
292  {  {
293    SCM_VALIDATE_CLASS (1, class);    SCM_VALIDATE_CLASS (1, class);
# Line 300  SCM_DEFINE (scm_sys_compute_slots, "%com Line 300  SCM_DEFINE (scm_sys_compute_slots, "%com
300  /******************************************************************************  /******************************************************************************
301   *   *
302   * compute-getters-n-setters   * compute-getters-n-setters
303   *     *
304   *   This version doesn't handle slot options. It serves only for booting   *   This version doesn't handle slot options. It serves only for booting
305   * classes and will be overloaded in Scheme.   * classes and will be overloaded in Scheme.
306   *   *
307   ******************************************************************************/   ******************************************************************************/
# Line 405  SCM_DEFINE (scm_sys_initialize_object, " Line 405  SCM_DEFINE (scm_sys_initialize_object, "
405    SCM_VALIDATE_INSTANCE (1, obj);    SCM_VALIDATE_INSTANCE (1, obj);
406    n_initargs = scm_ilength (initargs);    n_initargs = scm_ilength (initargs);
407    SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);    SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
408      
409    get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);    get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
410    slots     = SCM_SLOT (class, scm_si_slots);    slots     = SCM_SLOT (class, scm_si_slots);
411      
412    /* See for each slot how it must be initialized */    /* See for each slot how it must be initialized */
413    for (;    for (;
414         SCM_NNULLP (slots);         SCM_NNULLP (slots);
# Line 416  SCM_DEFINE (scm_sys_initialize_object, " Line 416  SCM_DEFINE (scm_sys_initialize_object, "
416      {      {
417        SCM slot_name  = SCM_CAR (slots);        SCM slot_name  = SCM_CAR (slots);
418        SCM slot_value = 0;        SCM slot_value = 0;
419        
420        if (SCM_NIMP (SCM_CDR (slot_name)))        if (SCM_NIMP (SCM_CDR (slot_name)))
421          {          {
422            /* 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_must_malloc (n, FUNC_NAME) : 0;    s  = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0;
499    for (i = 0; i < n; i += 2)    for (i = 0; i < n; i += 2)
500      {      {
# Line 511  SCM_DEFINE (scm_sys_prep_layout_x, "%pre Line 511  SCM_DEFINE (scm_sys_prep_layout_x, "%pre
511              p = 'p';              p = 'p';
512            else            else
513              p = 'u';              p = 'u';
514              
515            if (SCM_SUBCLASSP (type, scm_class_opaque))            if (SCM_SUBCLASSP (type, scm_class_opaque))
516              a = 'o';              a = 'o';
517            else if (SCM_SUBCLASSP (type, scm_class_read_only))            else if (SCM_SUBCLASSP (type, scm_class_read_only))
# Line 581  SCM_DEFINE (scm_sys_inherit_magic_x, "%i Line 581  SCM_DEFINE (scm_sys_inherit_magic_x, "%i
581    SCM_SET_CLASS_FLAGS (class, flags);    SCM_SET_CLASS_FLAGS (class, flags);
582    
583    prep_hashsets (class);    prep_hashsets (class);
584      
585    return SCM_UNSPECIFIED;    return SCM_UNSPECIFIED;
586  }  }
587  #undef FUNC_NAME  #undef FUNC_NAME
# Line 737  create_basic_classes (void) Line 737  create_basic_classes (void)
737    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 */
738    /* 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); */
739    SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);    SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
740    SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);      SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
741    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 */
742    /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */    /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
743    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 759  create_basic_classes (void) Line 759  create_basic_classes (void)
759                                                      SCM_EOL));                                                      SCM_EOL));
760    
761    DEFVAR(name, scm_class_top);    DEFVAR(name, scm_class_top);
762      
763    /**** <scm_class_object> ****/    /**** <scm_class_object> ****/
764    name   = scm_str2symbol ("<object>");    name   = scm_str2symbol ("<object>");
765    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 789  SCM_DEFINE (scm_instance_p, "instance?", Line 789  SCM_DEFINE (scm_instance_p, "instance?",
789    
790    
791  /******************************************************************************  /******************************************************************************
792   *   *
793   * Meta object accessors   * Meta object accessors
794   *   *
795   ******************************************************************************/   ******************************************************************************/
# Line 1003  SCM_DEFINE (scm_sys_fast_slot_ref, "%fas Line 1003  SCM_DEFINE (scm_sys_fast_slot_ref, "%fas
1003    SCM_VALIDATE_INSTANCE (1, obj);    SCM_VALIDATE_INSTANCE (1, obj);
1004    SCM_VALIDATE_INUM (2, index);    SCM_VALIDATE_INUM (2, index);
1005    i = SCM_INUM (index);    i = SCM_INUM (index);
1006      
1007    SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj));    SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj));
1008    return scm_at_assert_bound_ref (obj, index);    return scm_at_assert_bound_ref (obj, index);
1009  }  }
# Line 1058  get_slot_value (SCM class SCM_UNUSED, SC Line 1058  get_slot_value (SCM class SCM_UNUSED, SC
1058      return SCM_SLOT (obj, SCM_INUM (access));      return SCM_SLOT (obj, SCM_INUM (access));
1059    else    else
1060      {      {
1061        /* We must evaluate (apply (car access) (list obj))        /* We must evaluate (apply (car access) (list obj))
1062         * where (car access) is known to be a closure of arity 1  */         * where (car access) is known to be a closure of arity 1  */
1063        register SCM code, env;        register SCM code, env;
1064    
# Line 1254  SCM_DEFINE (scm_slot_bound_p, "slot-boun Line 1254  SCM_DEFINE (scm_slot_bound_p, "slot-boun
1254  }  }
1255  #undef FUNC_NAME  #undef FUNC_NAME
1256    
1257  SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0,  SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
1258              (SCM obj, SCM slot_name),              (SCM obj, SCM slot_name),
1259              "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}.")
1260  #define FUNC_NAME s_scm_slots_exists_p  #define FUNC_NAME s_scm_slot_exists_p
1261  {  {
1262    SCM class;    SCM class;
1263    
# Line 1283  wrap_init (SCM class, SCM *m, long n) Line 1283  wrap_init (SCM class, SCM *m, long n)
1283  {  {
1284    SCM z;    SCM z;
1285    long i;    long i;
1286      
1287    /* Set all slots to unbound */    /* Set all slots to unbound */
1288    for (i = 0; i < n; i++)    for (i = 0; i < n; i++)
1289      m[i] = SCM_GOOPS_UNBOUND;      m[i] = SCM_GOOPS_UNBOUND;
# Line 1315  SCM_DEFINE (scm_sys_allocate_instance, " Line 1315  SCM_DEFINE (scm_sys_allocate_instance, "
1315        m = (SCM *) scm_must_malloc (n * sizeof (SCM), "instance");        m = (SCM *) scm_must_malloc (n * sizeof (SCM), "instance");
1316        return wrap_init (class, m, n);        return wrap_init (class, m, n);
1317      }      }
1318      
1319    /* Foreign objects */    /* Foreign objects */
1320    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
1321      return scm_make_foreign_object (class, initargs);      return scm_make_foreign_object (class, initargs);
1322    
1323    n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));    n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
1324      
1325    /* Entities */    /* Entities */
1326    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
1327      {      {
# Line 1340  SCM_DEFINE (scm_sys_allocate_instance, " Line 1340  SCM_DEFINE (scm_sys_allocate_instance, "
1340        else        else
1341          return wrap_init (class, m, n);          return wrap_init (class, m, n);
1342      }      }
1343      
1344    /* Class objects */    /* Class objects */
1345    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)    if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
1346      {      {
# Line 1360  SCM_DEFINE (scm_sys_allocate_instance, " Line 1360  SCM_DEFINE (scm_sys_allocate_instance, "
1360    
1361        return z;        return z;
1362      }      }
1363      
1364    /* Non-light instances */    /* Non-light instances */
1365    {    {
1366      m = (SCM *) scm_alloc_struct (n,      m = (SCM *) scm_alloc_struct (n,
# Line 1393  SCM_DEFINE (scm_sys_set_object_setter_x, Line 1393  SCM_DEFINE (scm_sys_set_object_setter_x,
1393  /******************************************************************************  /******************************************************************************
1394   *   *
1395   * %modify-instance (used by change-class to modify in place)   * %modify-instance (used by change-class to modify in place)
1396   *   *
1397   ******************************************************************************/   ******************************************************************************/
1398    
1399  SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,  SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
# Line 1404  SCM_DEFINE (scm_sys_modify_instance, "%m Line 1404  SCM_DEFINE (scm_sys_modify_instance, "%m
1404    SCM_VALIDATE_INSTANCE (1, old);    SCM_VALIDATE_INSTANCE (1, old);
1405    SCM_VALIDATE_INSTANCE (2, new);    SCM_VALIDATE_INSTANCE (2, new);
1406    
1407    /* Exchange the data contained in old and new. We exchange rather than    /* Exchange the data contained in old and new. We exchange rather than
1408     * scratch the old value with new to be correct with GC.     * scratch the old value with new to be correct with GC.
1409     * See "Class redefinition protocol above".     * See "Class redefinition protocol above".
1410     */     */
# Line 1528  scm_change_object_class (SCM obj, SCM ol Line 1528  scm_change_object_class (SCM obj, SCM ol
1528    
1529  /******************************************************************************  /******************************************************************************
1530   *   *
1531   *   GGGG                FFFFF             *   GGGG                FFFFF
1532   *  G                    F       *  G                    F
1533   *  G  GG                FFF       *  G  GG                FFF
1534   *  G   G                F         *  G   G                F
1535   *   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
1536   *   *
1537   * This implementation provides   * This implementation provides
1538   *      - generic functions (with class specializers)   *      - generic functions (with class specializers)
1539   *      - multi-methods   *      - multi-methods
1540   *      - next-method   *      - next-method
1541   *      - 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
1542   *   *
1543   ******************************************************************************/   ******************************************************************************/
# Line 1644  SCM_DEFINE (scm_primitive_generic_generi Line 1644  SCM_DEFINE (scm_primitive_generic_generi
1644  #undef FUNC_NAME  #undef FUNC_NAME
1645    
1646  /******************************************************************************  /******************************************************************************
1647   *   *
1648   * Protocol for calling a generic fumction   * Protocol for calling a generic fumction
1649   * This protocol is roughly equivalent to (parameter are a little bit different   * This protocol is roughly equivalent to (parameter are a little bit different
1650   * for efficiency reasons):   * for efficiency reasons):
1651   *   *
1652   *      + apply-generic (gf args)   *      + apply-generic (gf args)
1653   *              + compute-applicable-methods (gf args ...)   *              + compute-applicable-methods (gf args ...)
1654   *                      + sort-applicable-methods (methods args)   *                      + sort-applicable-methods (methods args)
1655   *              + apply-methods (gf methods args)   *              + apply-methods (gf methods args)
1656   *                                 *
1657   * 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
1658   * method.  Applying a next-method will call apply-next-method which in   * method.  Applying a next-method will call apply-next-method which in
1659   * turn will call  apply again to call effectively the following method.   * turn will call  apply again to call effectively the following method.
1660   *   *
# Line 1672  more_specificp (SCM m1, SCM m2, SCM *tar Line 1672  more_specificp (SCM m1, SCM m2, SCM *tar
1672  {  {
1673    register SCM s1, s2;    register SCM s1, s2;
1674    register long i;    register long i;
1675    /*    /*
1676     * Note:     * Note:
1677     *   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
1678     * 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
1679     *   (M 1)     *   (M 1)
1680     * with     * with
1681     *   (define-method M (a . l) ....)     *   (define-method M (a . l) ....)
1682     *   (define-method M (a) ....)     *   (define-method M (a) ....)
1683     *     *
1684     * we consider that the second method is more specific.     * we consider that the second method is more specific.
1685     *     *
# Line 1693  more_specificp (SCM m1, SCM m2, SCM *tar Line 1693  more_specificp (SCM m1, SCM m2, SCM *tar
1693      if (SCM_NULLP(s2)) return 0;      if (SCM_NULLP(s2)) return 0;
1694      if (SCM_CAR(s1) != SCM_CAR(s2)) {      if (SCM_CAR(s1) != SCM_CAR(s2)) {
1695        register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);        register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
1696          
1697        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)) {
1698          if (cs1 == SCM_CAR(l))          if (cs1 == SCM_CAR(l))
1699            return 1;            return 1;
# Line 1713  scm_i_vector2list (SCM l, long len) Line 1713  scm_i_vector2list (SCM l, long len)
1713  {  {
1714    long j;    long j;
1715    SCM z = scm_c_make_vector (len, SCM_UNDEFINED);    SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
1716      
1717    for (j = 0; j < len; j++, l = SCM_CDR (l)) {    for (j = 0; j < len; j++, l = SCM_CDR (l)) {
1718      SCM_VELTS (z)[j] = SCM_CAR (l);      SCM_VELTS (z)[j] = SCM_CAR (l);
1719    }    }
# Line 1740  sort_applicable_methods (SCM method_list Line 1740  sort_applicable_methods (SCM method_list
1740            method_list = SCM_CDR (method_list);            method_list = SCM_CDR (method_list);
1741          }          }
1742        v = buffer;        v = buffer;
1743      }      }
1744    else    else
1745      {      {
1746        /* Too many elements in method_list to keep everything locally */        /* Too many elements in method_list to keep everything locally */
# Line 1748  sort_applicable_methods (SCM method_list Line 1748  sort_applicable_methods (SCM method_list
1748        v      = SCM_VELTS (vector);        v      = SCM_VELTS (vector);
1749      }      }
1750    
1751    /* 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
1752     * small vectors (which is probably mostly the case when we have to     * small vectors (which is probably mostly the case when we have to
1753     * sort a list of applicable methods).     * sort a list of applicable methods).
1754     */     */
# Line 1780  sort_applicable_methods (SCM method_list Line 1780  sort_applicable_methods (SCM method_list
1780          }          }
1781        return save;        return save;
1782      }      }
1783    /* 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... */
1784    return scm_vector_to_list (vector);    return scm_vector_to_list (vector);
1785  }  }
1786    
# Line 1793  scm_compute_applicable_methods (SCM gf, Line 1793  scm_compute_applicable_methods (SCM gf,
1793    SCM save = args;    SCM save = args;
1794    SCM buffer[BUFFSIZE], *types, *p;    SCM buffer[BUFFSIZE], *types, *p;
1795    SCM tmp;    SCM tmp;
1796    
1797    /* Build the list of arguments types */    /* Build the list of arguments types */
1798    if (len >= BUFFSIZE) {    if (len >= BUFFSIZE) {
1799      tmp   = scm_c_make_vector (len, SCM_UNDEFINED);      tmp   = scm_c_make_vector (len, SCM_UNDEFINED);
# Line 1804  scm_compute_applicable_methods (SCM gf, Line 1804  scm_compute_applicable_methods (SCM gf,
1804    }    }
1805    else    else
1806      types = p = buffer;      types = p = buffer;
1807      
1808    for (  ; SCM_NNULLP (args); args = SCM_CDR (args))    for (  ; SCM_NNULLP (args); args = SCM_CDR (args))
1809      *p++ = scm_class_of (SCM_CAR (args));      *p++ = scm_class_of (SCM_CAR (args));
1810    
1811    /* Build a list of all applicable methods */    /* Build a list of all applicable methods */
1812    for (l = SCM_SLOT (gf, scm_si_methods); SCM_NNULLP (l); l = SCM_CDR (l))    for (l = SCM_SLOT (gf, scm_si_methods); SCM_NNULLP (l); l = SCM_CDR (l))
1813      {      {
# Line 1975  scm_memoize_method (SCM x, SCM args) Line 1975  scm_memoize_method (SCM x, SCM args)
1975   * A simple make (which will be redefined later in Scheme)   * A simple make (which will be redefined later in Scheme)
1976   * This version handles only creation of gf, methods and classes (no instances)   * This version handles only creation of gf, methods and classes (no instances)
1977   *   *
1978   * Since this code will disappear when Goops will be fully booted,   * Since this code will disappear when Goops will be fully booted,
1979   * no precaution is taken to be efficient.   * no precaution is taken to be efficient.
1980   *   *
1981   ******************************************************************************/   ******************************************************************************/
# Line 2034  SCM_DEFINE (scm_make, "make",  0, 0, 1, Line 2034  SCM_DEFINE (scm_make, "make",  0, 0, 1,
2034            || class == scm_class_simple_method            || class == scm_class_simple_method
2035            || class == scm_class_accessor)            || class == scm_class_accessor)
2036          {          {
2037            SCM_SET_SLOT (z, scm_si_generic_function,            SCM_SET_SLOT (z, scm_si_generic_function,
2038              scm_i_get_keyword (k_gf,              scm_i_get_keyword (k_gf,
2039                                 args,                                 args,
2040                                 len - 1,                                 len - 1,
2041                                 SCM_BOOL_F,                                 SCM_BOOL_F,
2042                                 FUNC_NAME));                                 FUNC_NAME));
2043            SCM_SET_SLOT (z, scm_si_specializers,            SCM_SET_SLOT (z, scm_si_specializers,
2044              scm_i_get_keyword (k_specializers,              scm_i_get_keyword (k_specializers,
2045                                 args,                                 args,
2046                                 len - 1,                                 len - 1,
2047                                 SCM_EOL,                                 SCM_EOL,
2048                                 FUNC_NAME));                                 FUNC_NAME));
2049            SCM_SET_SLOT (z, scm_si_procedure,            SCM_SET_SLOT (z, scm_si_procedure,
2050              scm_i_get_keyword (k_procedure,              scm_i_get_keyword (k_procedure,
2051                                 args,                                 args,
2052                                 len - 1,                                 len - 1,
# Line 2057  SCM_DEFINE (scm_make, "make",  0, 0, 1, Line 2057  SCM_DEFINE (scm_make, "make",  0, 0, 1,
2057        else        else
2058          {          {
2059            /* In all the others case, make a new class .... No instance here */            /* In all the others case, make a new class .... No instance here */
2060            SCM_SET_SLOT (z, scm_si_name,            SCM_SET_SLOT (z, scm_si_name,
2061              scm_i_get_keyword (k_name,              scm_i_get_keyword (k_name,
2062                                 args,                                 args,
2063                                 len - 1,                                 len - 1,
2064                                 scm_str2symbol ("???"),                                 scm_str2symbol ("???"),
2065                                 FUNC_NAME));                                 FUNC_NAME));
2066            SCM_SET_SLOT (z, scm_si_direct_supers,            SCM_SET_SLOT (z, scm_si_direct_supers,
2067              scm_i_get_keyword (k_dsupers,              scm_i_get_keyword (k_dsupers,
2068                                 args,                                 args,
2069                                 len - 1,                                 len - 1,
2070                                 SCM_EOL,                                 SCM_EOL,
2071                                 FUNC_NAME));                                 FUNC_NAME));
2072            SCM_SET_SLOT (z, scm_si_direct_slots,            SCM_SET_SLOT (z, scm_si_direct_slots,
2073              scm_i_get_keyword (k_slots,              scm_i_get_keyword (k_slots,
2074                                 args,                                 args,
2075                                 len - 1,                                 len - 1,
# Line 2123  SCM_DEFINE (scm_sys_method_more_specific Line 2123  SCM_DEFINE (scm_sys_method_more_specific
2123    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;
2124  }  }
2125  #undef FUNC_NAME  #undef FUNC_NAME
2126      
2127      
2128    
2129  /******************************************************************************  /******************************************************************************
2130   *   *
2131   * Initializations   * Initializations
2132   *   *
2133   ******************************************************************************/   ******************************************************************************/
2134    
# Line 2137  static void Line 2137  static void
2137  make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)  make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
2138  {  {
2139     SCM tmp = scm_str2symbol (name);     SCM tmp = scm_str2symbol (name);
2140      
2141     *var = scm_permanent_object (scm_basic_make_class (meta,     *var = scm_permanent_object (scm_basic_make_class (meta,
2142                                                        tmp,                                                        tmp,
2143                                                        SCM_CONSP (super)                                                        SCM_CONSP (super)
# Line 2154  static void Line 2154  static void
2154  create_standard_classes (void)  create_standard_classes (void)
2155  {  {
2156    SCM slots;    SCM slots;
2157    SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"),    SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"),
2158                                   scm_str2symbol ("specializers"),                                   scm_str2symbol ("specializers"),
2159                                   scm_str2symbol ("procedure"),                                   scm_str2symbol ("procedure"),
2160                                   scm_str2symbol ("code-table"));                                   scm_str2symbol ("code-table"));
2161    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 2210  create_standard_classes (void) Line 2210  create_standard_classes (void)
2210                 scm_class_class, scm_class_foreign_slot,    SCM_EOL);                 scm_class_class, scm_class_foreign_slot,    SCM_EOL);
2211    
2212    /* Continue initialization of class <class> */    /* Continue initialization of class <class> */
2213      
2214    slots = build_class_class_slots ();    slots = build_class_class_slots ();
2215    SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);    SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
2216    SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);    SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
2217    SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,    SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
2218                  compute_getters_n_setters (slots));                  compute_getters_n_setters (slots));
2219      
2220    make_stdcls (&scm_class_foreign_class, "<foreign-class>",    make_stdcls (&scm_class_foreign_class, "<foreign-class>",
2221                 scm_class_class, scm_class_class,                 scm_class_class, scm_class_class,
2222                 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),                 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
# Line 2260  create_standard_classes (void) Line 2260  create_standard_classes (void)
2260                 SCM_EOL);                 SCM_EOL);
2261  #if 0  #if 0
2262    /* Patch cpl since compute_cpl doesn't support multiple inheritance. */    /* Patch cpl since compute_cpl doesn't support multiple inheritance. */
2263    SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl,    SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl,
2264      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,
2265                                          scm_class_generic),                                          scm_class_generic),
2266                              SCM_SLOT (scm_class_entity_with_setter,                              SCM_SLOT (scm_class_entity_with_setter,
# Line 2368  create_smob_classes (void) Line 2368  create_smob_classes (void)
2368    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real;    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real;
2369    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex;    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex;
2370    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;    scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
2371      
2372    for (i = 0; i < scm_numsmob; ++i)    for (i = 0; i < scm_numsmob; ++i)
2373      if (!scm_smob_class[i])      if (!scm_smob_class[i])
2374        scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i));        scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i));
# Line 2412  create_port_classes (void) Line 2412  create_port_classes (void)
2412  }  }
2413    
2414  static SCM  static SCM
2415  make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,  make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,
2416                     SCM data, SCM prev SCM_UNUSED)                     SCM data, SCM prev SCM_UNUSED)
2417  {  {
2418    if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data)))    if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data)))
# Line 2485  scm_make_class (SCM meta, char *s_name, Line 2485  scm_make_class (SCM meta, char *s_name,
2485        SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);        SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
2486        SCM_SET_CLASS_INSTANCE_SIZE (class, size);        SCM_SET_CLASS_INSTANCE_SIZE (class, size);
2487      }      }
2488      
2489    SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));    SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));
2490    SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);    SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
2491    
# Line 2544  scm_add_slot (SCM class, char *slot_name Line 2544  scm_add_slot (SCM class, char *slot_name
2544                                              k_procedure,                                              k_procedure,
2545                                              setm)));                                              setm)));
2546        DEFVAR (aname, gf);        DEFVAR (aname, gf);
2547          
2548        SCM_SET_SLOT (class, scm_si_slots,        SCM_SET_SLOT (class, scm_si_slots,
2549                      scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),                      scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
2550                                                scm_list_1 (slot))));                                                scm_list_1 (slot))));
# Line 2553  scm_add_slot (SCM class, char *slot_name Line 2553  scm_add_slot (SCM class, char *slot_name
2553                                                scm_list_1 (gns))));                                                scm_list_1 (gns))));
2554      }      }
2555    }    }
2556    {      {
2557      long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));      long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
2558    
2559      SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));      SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
# Line 2650  scm_init_goops_builtins (void) Line 2650  scm_init_goops_builtins (void)
2650    scm_module_goops = scm_current_module ();    scm_module_goops = scm_current_module ();
2651    scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);    scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
2652    
2653    /* Not really necessary right now, but who knows...    /* Not really necessary right now, but who knows...
2654     */     */
2655    scm_permanent_object (scm_module_goops);    scm_permanent_object (scm_module_goops);
2656    scm_permanent_object (scm_goops_lookup_closure);    scm_permanent_object (scm_goops_lookup_closure);

Legend:
Removed from v.1.39.2.2  
changed lines
  Added in v.1.39.2.3

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