guile18/libguile/goops.c

   1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008
   2  * Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2.1 of the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  */
  18 \f
  19
  20 /* This software is a derivative work of other copyrighted softwares; the
  21  * copyright notices of these softwares are placed in the file COPYRIGHTS
  22  *
  23  * This file is based upon stklos.c from the STk distribution by
  24  * Erick Gallesio <eg@unice.fr>.
  25  */
  26
  27 #ifdef HAVE_CONFIG_H
  28 # include <config.h>
  29 #endif
  30
  31 #include <stdio.h>
  32 #include <assert.h>
  33
  34 #include "libguile/_scm.h"
  35 #include "libguile/alist.h"
  36 #include "libguile/async.h"
  37 #include "libguile/chars.h"
  38 #include "libguile/debug.h"
  39 #include "libguile/dynl.h"
  40 #include "libguile/dynwind.h"
  41 #include "libguile/eval.h"
  42 #include "libguile/hashtab.h"
  43 #include "libguile/keywords.h"
  44 #include "libguile/macros.h"
  45 #include "libguile/modules.h"
  46 #include "libguile/objects.h"
  47 #include "libguile/ports.h"
  48 #include "libguile/procprop.h"
  49 #include "libguile/random.h"
  50 #include "libguile/root.h"
  51 #include "libguile/smob.h"
  52 #include "libguile/strings.h"
  53 #include "libguile/strports.h"
  54 #include "libguile/vectors.h"
  55 #include "libguile/weaks.h"
  56
  57 #include "libguile/validate.h"
  58 #include "libguile/goops.h"
  59
  60 #define SPEC_OF(x)  SCM_SLOT (x, scm_si_specializers)
  61
  62 #define DEFVAR(v, val) \
  63 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
  64             scm_module_goops); }
  65 /* Temporary hack until we get the new module system */
  66 /*fixme* Should optimize by keeping track of the variable object itself */
  67 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure,  \
  68                                                  (v), SCM_BOOL_F)))
  69
  70 /* Fixme: Should use already interned symbols */
  71
  72 #define CALL_GF1(name, a)       (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
  73                                              a))
  74 #define CALL_GF2(name, a, b)    (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
  75                                              a, b))
  76 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
  77                                              a, b, c))
  78 #define CALL_GF4(name, a, b, c, d)      (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
  79                                              a, b, c, d))
  80
  81 /* Class redefinition protocol:
  82
  83    A class is represented by a heap header h1 which points to a
  84    malloc:ed memory block m1.
  85
  86    When a new version of a class is created, a new header h2 and
  87    memory block m2 are allocated.  The headers h1 and h2 then switch
  88    pointers so that h1 refers to m2 and h2 to m1.  In this way, names
  89    bound to h1 will point to the new class at the same time as h2 will
  90    be a handle which the GC will use to free m1.
  91
  92    The `redefined' slot of m1 will be set to point to h1.  An old
  93    instance will have its class pointer (the CAR of the heap header)
  94    pointing to m1.  The non-immediate `redefined'-slot in m1 indicates
  95    the class modification and the new class pointer can be found via
  96    h1.
  97 */
  98
  99 /* The following definition is located in libguile/objects.h:
 100 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
 101 */
 102
 103 #define TEST_CHANGE_CLASS(obj, class)                                  \
 104         {                                                              \
 105           class = SCM_CLASS_OF (obj);                                  \
 106           if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj)))                 \
 107             {                                                          \
 108               scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
 109               class = SCM_CLASS_OF (obj);                              \
 110             }                                                          \
 111         }
 112
 113 #define NXT_MTHD_METHODS(m)     (SCM_VELTS (m)[1])
 114 #define NXT_MTHD_ARGS(m)        (SCM_VELTS (m)[2])
 115
 116 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
 117 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
 118
 119 static int goops_loaded_p = 0;
 120 static scm_t_rstate *goops_rstate;
 121
 122 static SCM scm_goops_lookup_closure;
 123
 124 /* These variables are filled in by the object system when loaded. */
 125 SCM scm_class_boolean, scm_class_char, scm_class_pair;
 126 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
 127 SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
 128 SCM scm_class_vector, scm_class_null;
 129 SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
 130 SCM scm_class_unknown;
 131 SCM scm_class_top, scm_class_object, scm_class_class;
 132 SCM scm_class_applicable;
 133 SCM scm_class_entity, scm_class_entity_with_setter;
 134 SCM scm_class_generic, scm_class_generic_with_setter;
 135 SCM scm_class_accessor;
 136 SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
 137 SCM scm_class_extended_accessor;
 138 SCM scm_class_method;
 139 SCM scm_class_simple_method, scm_class_accessor_method;
 140 SCM scm_class_procedure_class;
 141 SCM scm_class_operator_class, scm_class_operator_with_setter_class;
 142 SCM scm_class_entity_class;
 143 SCM scm_class_number, scm_class_list;
 144 SCM scm_class_keyword;
 145 SCM scm_class_port, scm_class_input_output_port;
 146 SCM scm_class_input_port, scm_class_output_port;
 147 SCM scm_class_foreign_class, scm_class_foreign_object;
 148 SCM scm_class_foreign_slot;
 149 SCM scm_class_self, scm_class_protected;
 150 SCM scm_class_opaque, scm_class_read_only;
 151 SCM scm_class_protected_opaque, scm_class_protected_read_only;
 152 SCM scm_class_scm;
 153 SCM scm_class_int, scm_class_float, scm_class_double;
 154
 155 SCM *scm_port_class = 0;
 156 SCM *scm_smob_class = 0;
 157
 158 SCM scm_no_applicable_method;
 159
 160 SCM_SYMBOL (scm_sym_define_public, "define-public");
 161
 162 static SCM scm_make_unbound (void);
 163 static SCM scm_unbound_p (SCM obj);
 164 static SCM scm_assert_bound (SCM value, SCM obj);
 165 static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
 166 static SCM scm_sys_goops_loaded (void);
 167
 168 /* This function is used for efficient type dispatch.  */
 169 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 170             (SCM x),
 171             "Return the class of @var{x}.")
 172 #define FUNC_NAME s_scm_class_of
 173 {
 174   switch (SCM_ITAG3 (x))
 175     {
 176     case scm_tc3_int_1:
 177     case scm_tc3_int_2:
 178       return scm_class_integer;
 179
 180     case scm_tc3_imm24:
 181       if (SCM_CHARP (x))
 182         return scm_class_char;
 183       else if (scm_is_bool (x))
 184         return scm_class_boolean;
 185       else if (scm_is_null (x))
 186         return scm_class_null;
 187       else
 188         return scm_class_unknown;
 189
 190     case scm_tc3_cons:
 191       switch (SCM_TYP7 (x))
 192         {
 193         case scm_tcs_cons_nimcar:
 194           return scm_class_pair;
 195         case scm_tcs_closures:
 196           return scm_class_procedure;
 197         case scm_tc7_symbol:
 198           return scm_class_symbol;
 199         case scm_tc7_vector:
 200         case scm_tc7_wvect:
 201           return scm_class_vector;
 202         case scm_tc7_string:
 203           return scm_class_string;
 204         case scm_tc7_number:
 205           switch SCM_TYP16 (x) {
 206           case scm_tc16_big:
 207             return scm_class_integer;
 208           case scm_tc16_real:
 209             return scm_class_real;
 210           case scm_tc16_complex:
 211             return scm_class_complex;
 212           case scm_tc16_fraction:
 213             return scm_class_fraction;
 214           }
 215         case scm_tc7_asubr:
 216         case scm_tc7_subr_0:
 217         case scm_tc7_subr_1:
 218         case scm_tc7_dsubr:
 219         case scm_tc7_cxr:
 220         case scm_tc7_subr_3:
 221         case scm_tc7_subr_2:
 222         case scm_tc7_rpsubr:
 223         case scm_tc7_subr_1o:
 224         case scm_tc7_subr_2o:
 225         case scm_tc7_lsubr_2:
 226         case scm_tc7_lsubr:
 227           if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
 228             return scm_class_primitive_generic;
 229           else
 230             return scm_class_procedure;
 231         case scm_tc7_cclo:
 232           return scm_class_procedure;
 233         case scm_tc7_pws:
 234           return scm_class_procedure_with_setter;
 235
 236         case scm_tc7_smob:
 237           {
 238             scm_t_bits type = SCM_TYP16 (x);
 239             if (type != scm_tc16_port_with_ps)
 240               return scm_smob_class[SCM_TC2SMOBNUM (type)];
 241             x = SCM_PORT_WITH_PS_PORT (x);
 242             /* fall through to ports */
 243           }
 244         case scm_tc7_port:
 245           return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
 246                                  ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
 247                                     ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
 248                                     : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
 249                                  : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
 250         case scm_tcs_struct:
 251           if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
 252             return SCM_CLASS_OF (x);
 253           else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
 254             {
 255               /* Goops object */
 256               if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
 257                 scm_change_object_class (x,
 258                                          SCM_CLASS_OF (x),         /* old */
 259                                          SCM_OBJ_CLASS_REDEF (x)); /* new */
 260               return SCM_CLASS_OF (x);
 261             }
 262           else
 263             {
 264               /* ordinary struct */
 265               SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
 266               if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
 267                 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
 268               else
 269                 {
 270                   SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
 271                   SCM class = scm_make_extended_class (scm_is_true (name)
 272                                                        ? scm_i_symbol_chars (name)
 273                                                        : 0,
 274                                                        SCM_I_OPERATORP (x));
 275                   SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
 276                   return class;
 277                 }
 278             }
 279         default:
 280           if (scm_is_pair (x))
 281             return scm_class_pair;
 282           else
 283             return scm_class_unknown;
 284         }
 285
 286     case scm_tc3_struct:
 287     case scm_tc3_tc7_1:
 288     case scm_tc3_tc7_2:
 289     case scm_tc3_closure:
 290       /* Never reached */
 291       break;
 292     }
 293   return scm_class_unknown;
 294 }
 295 #undef FUNC_NAME
 296
 297 /******************************************************************************
 298  *
 299  * Compute-cpl
 300  *
 301  *   This version doesn't fully handle multiple-inheritance. It serves
 302  *   only for booting classes and will be overloaded in Scheme
 303  *
 304  ******************************************************************************/
 305
 306 static SCM
 307 map (SCM (*proc) (SCM), SCM ls)
 308 {
 309   if (scm_is_null (ls))
 310     return ls;
 311   else
 312     {
 313       SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
 314       SCM h = res;
 315       ls = SCM_CDR (ls);
 316       while (!scm_is_null (ls))
 317         {
 318           SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
 319           h = SCM_CDR (h);
 320           ls = SCM_CDR (ls);
 321         }
 322       return res;
 323     }
 324 }
 325
 326 static SCM
 327 filter_cpl (SCM ls)
 328 {
 329   SCM res = SCM_EOL;
 330   while (!scm_is_null (ls))
 331     {
 332       SCM el = SCM_CAR (ls);
 333       if (scm_is_false (scm_c_memq (el, res)))
 334         res = scm_cons (el, res);
 335       ls = SCM_CDR (ls);
 336     }
 337   return res;
 338 }
 339
 340 static SCM
 341 compute_cpl (SCM class)
 342 {
 343   if (goops_loaded_p)
 344     return CALL_GF1 ("compute-cpl", class);
 345   else
 346     {
 347       SCM supers = SCM_SLOT (class, scm_si_direct_supers);
 348       SCM ls = scm_append (scm_acons (class, supers,
 349                                       map (compute_cpl, supers)));
 350       return scm_reverse_x (filter_cpl (ls), SCM_EOL);
 351     }
 352 }
 353
 354 /******************************************************************************
 355  *
 356  * compute-slots
 357  *
 358  ******************************************************************************/
 359
 360 static SCM
 361 remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
 362 {
 363   SCM tmp;
 364
 365   if (scm_is_null (l))
 366     return res;
 367
 368   tmp = SCM_CAAR (l);
 369   if (!scm_is_symbol (tmp))
 370     scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
 371
 372   if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) {
 373     res                = scm_cons (SCM_CAR (l), res);
 374     slots_already_seen = scm_cons (tmp, slots_already_seen);
 375   }
 376
 377   return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
 378 }
 379
 380 static SCM
 381 build_slots_list (SCM dslots, SCM cpl)
 382 {
 383   register SCM res = dslots;
 384
 385   for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl))
 386     res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl),
 387                                             scm_si_direct_slots),
 388                                   res));
 389
 390   /* res contains a list of slots. Remove slots which appears more than once */
 391   return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL);
 392 }
 393
 394 static SCM
 395 maplist (SCM ls)
 396 {
 397   SCM orig = ls;
 398   while (!scm_is_null (ls))
 399     {
 400       if (!scm_is_pair (SCM_CAR (ls)))
 401         SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
 402       ls = SCM_CDR (ls);
 403     }
 404   return orig;
 405 }
 406
 407
 408 SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
 409             (SCM class),
 410             "Return a list consisting of the names of all slots belonging to\n"
 411             "class @var{class}, i. e. the slots of @var{class} and of all of\n"
 412             "its superclasses.")
 413 #define FUNC_NAME s_scm_sys_compute_slots
 414 {
 415   SCM_VALIDATE_CLASS (1, class);
 416   return build_slots_list (SCM_SLOT (class, scm_si_direct_slots),
 417                            SCM_SLOT (class, scm_si_cpl));
 418 }
 419 #undef FUNC_NAME
 420
 421
 422 /******************************************************************************
 423  *
 424  * compute-getters-n-setters
 425  *
 426  *   This version doesn't handle slot options. It serves only for booting
 427  * classes and will be overloaded in Scheme.
 428  *
 429  ******************************************************************************/
 430
 431 SCM_KEYWORD (k_init_value, "init-value");
 432 SCM_KEYWORD (k_init_thunk, "init-thunk");
 433
 434 static SCM
 435 compute_getters_n_setters (SCM slots)
 436 {
 437   SCM res = SCM_EOL;
 438   SCM *cdrloc = &res;
 439   long i   = 0;
 440
 441   for (  ; !scm_is_null (slots); slots = SCM_CDR (slots))
 442     {
 443       SCM init = SCM_BOOL_F;
 444       SCM options = SCM_CDAR (slots);
 445       if (!scm_is_null (options))
 446         {
 447           init = scm_get_keyword (k_init_value, options, 0);
 448           if (init)
 449             {
 450               init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
 451                                                SCM_EOL,
 452                                                scm_list_2 (scm_sym_quote,
 453                                                            init)),
 454                                    SCM_EOL);
 455             }
 456           else
 457             init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
 458         }
 459       *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots),
 460                                     scm_cons (init,
 461                                               scm_from_int (i++))),
 462                           SCM_EOL);
 463       cdrloc = SCM_CDRLOC (*cdrloc);
 464     }
 465   return res;
 466 }
 467
 468 /******************************************************************************
 469  *
 470  * initialize-object
 471  *
 472  ******************************************************************************/
 473
 474 /*fixme* Manufacture keywords in advance */
 475 SCM
 476 scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr)
 477 {
 478   long i;
 479
 480   for (i = 0; i != len; i += 2)
 481     {
 482       SCM obj = SCM_CAR (l);
 483
 484       if (!scm_is_keyword (obj))
 485         scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
 486       else if (scm_is_eq (obj, key))
 487         return SCM_CADR (l);
 488       else
 489         l = SCM_CDDR (l);
 490     }
 491
 492   return default_value;
 493 }
 494
 495
 496 SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
 497             (SCM key, SCM l, SCM default_value),
 498             "Determine an associated value for the keyword @var{key} from\n"
 499             "the list @var{l}.  The list @var{l} has to consist of an even\n"
 500             "number of elements, where, starting with the first, every\n"
 501             "second element is a keyword, followed by its associated value.\n"
 502             "If @var{l} does not hold a value for @var{key}, the value\n"
 503             "@var{default_value} is returned.")
 504 #define FUNC_NAME s_scm_get_keyword
 505 {
 506   long len;
 507
 508   SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME);
 509   len = scm_ilength (l);
 510   if (len < 0 || len % 2 == 1)
 511     scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l));
 512
 513   return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
 514 }
 515 #undef FUNC_NAME
 516
 517
 518 SCM_KEYWORD (k_init_keyword, "init-keyword");
 519
 520 static SCM get_slot_value (SCM class, SCM obj, SCM slotdef);
 521 static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value);
 522
 523 SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
 524             (SCM obj, SCM initargs),
 525             "Initialize the object @var{obj} with the given arguments\n"
 526             "@var{initargs}.")
 527 #define FUNC_NAME s_scm_sys_initialize_object
 528 {
 529   SCM tmp, get_n_set, slots;
 530   SCM class       = SCM_CLASS_OF (obj);
 531   long n_initargs;
 532
 533   SCM_VALIDATE_INSTANCE (1, obj);
 534   n_initargs = scm_ilength (initargs);
 535   SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
 536
 537   get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
 538   slots     = SCM_SLOT (class, scm_si_slots);
 539
 540   /* See for each slot how it must be initialized */
 541   for (;
 542        !scm_is_null (slots);
 543        get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
 544     {
 545       SCM slot_name  = SCM_CAR (slots);
 546       SCM slot_value = 0;
 547
 548       if (!scm_is_null (SCM_CDR (slot_name)))
 549         {
 550           /* This slot admits (perhaps) to be initialized at creation time */
 551           long n = scm_ilength (SCM_CDR (slot_name));
 552           if (n & 1) /* odd or -1 */
 553             SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
 554                             scm_list_1 (slot_name));
 555           tmp   = scm_i_get_keyword (k_init_keyword,
 556                                      SCM_CDR (slot_name),
 557                                      n,
 558                                      0,
 559                                      FUNC_NAME);
 560           slot_name = SCM_CAR (slot_name);
 561           if (tmp)
 562             {
 563               /* an initarg was provided for this slot */
 564               if (!scm_is_keyword (tmp))
 565                 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
 566                                 scm_list_1 (tmp));
 567               slot_value = scm_i_get_keyword (tmp,
 568                                               initargs,
 569                                               n_initargs,
 570                                               0,
 571                                               FUNC_NAME);
 572             }
 573         }
 574
 575       if (slot_value)
 576         /* set slot to provided value */
 577         set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
 578       else
 579         {
 580           /* set slot to its :init-form if it exists */
 581           tmp = SCM_CADAR (get_n_set);
 582           if (scm_is_true (tmp))
 583             {
 584               slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
 585               if (SCM_GOOPS_UNBOUNDP (slot_value))
 586                 {
 587                   SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp));
 588                   set_slot_value (class,
 589                                   obj,
 590                                   SCM_CAR (get_n_set),
 591                                   scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
 592                 }
 593             }
 594         }
 595     }
 596
 597   return obj;
 598 }
 599 #undef FUNC_NAME
 600
 601 /* NOTE: The following macros are interdependent with code
 602  *       in goops.scm:compute-getters-n-setters
 603  */
 604 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns)       \
 605   (SCM_I_INUMP (SCM_CDDR (gns))                 \
 606    || (scm_is_pair (SCM_CDDR (gns))             \
 607        && scm_is_pair (SCM_CDDDR (gns))         \
 608        && scm_is_pair (SCM_CDDDDR (gns))))
 609 #define SCM_GNS_INDEX(gns)                      \
 610   (SCM_I_INUMP (SCM_CDDR (gns))                 \
 611    ? SCM_I_INUM (SCM_CDDR (gns))                \
 612    : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
 613 #define SCM_GNS_SIZE(gns)                       \
 614   (SCM_I_INUMP (SCM_CDDR (gns))                 \
 615    ? 1                                          \
 616    : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
 617
 618 SCM_KEYWORD (k_class, "class");
 619 SCM_KEYWORD (k_allocation, "allocation");
 620 SCM_KEYWORD (k_instance, "instance");
 621
 622 SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
 623             (SCM class),
 624             "")
 625 #define FUNC_NAME s_scm_sys_prep_layout_x
 626 {
 627   SCM slots, getters_n_setters, nfields;
 628   unsigned long int n, i;
 629   char *s;
 630   SCM layout;
 631
 632   SCM_VALIDATE_INSTANCE (1, class);
 633   slots = SCM_SLOT (class, scm_si_slots);
 634   getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
 635   nfields = SCM_SLOT (class, scm_si_nfields);
 636   if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0)
 637     SCM_MISC_ERROR ("bad value in nfields slot: ~S",
 638                     scm_list_1 (nfields));
 639   n = 2 * SCM_I_INUM (nfields);
 640   if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1
 641       && SCM_SUBCLASSP (class, scm_class_class))
 642     SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
 643                     scm_list_1 (nfields));
 644
 645   layout = scm_i_make_string (n, &s);
 646   i = 0;
 647   while (scm_is_pair (getters_n_setters))
 648     {
 649       if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
 650         {
 651           SCM type;
 652           int len, index, size;
 653           char p, a;
 654
 655           if (i >= n || !scm_is_pair (slots))
 656             goto inconsistent;
 657
 658           /* extract slot type */
 659           len = scm_ilength (SCM_CDAR (slots));
 660           type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
 661                                     len, SCM_BOOL_F, FUNC_NAME);
 662           /* determine slot GC protection and access mode */
 663           if (scm_is_false (type))
 664             {
 665               p = 'p';
 666               a = 'w';
 667             }
 668           else
 669             {
 670               if (!SCM_CLASSP (type))
 671                 SCM_MISC_ERROR ("bad slot class", SCM_EOL);
 672               else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
 673                 {
 674                   if (SCM_SUBCLASSP (type, scm_class_self))
 675                     p = 's';
 676                   else if (SCM_SUBCLASSP (type, scm_class_protected))
 677                     p = 'p';
 678                   else
 679                     p = 'u';
 680
 681                   if (SCM_SUBCLASSP (type, scm_class_opaque))
 682                     a = 'o';
 683                   else if (SCM_SUBCLASSP (type, scm_class_read_only))
 684                     a = 'r';
 685                   else
 686                     a = 'w';
 687                 }
 688               else
 689                 {
 690                   p = 'p';
 691                   a = 'w';
 692                 }
 693             }
 694
 695           index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
 696           if (index != (i >> 1))
 697             goto inconsistent;
 698           size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
 699           while (size)
 700             {
 701               s[i++] = p;
 702               s[i++] = a;
 703               --size;
 704             }
 705         }
 706       slots = SCM_CDR (slots);
 707       getters_n_setters = SCM_CDR (getters_n_setters);
 708     }
 709   if (!scm_is_null (slots))
 710     {
 711     inconsistent:
 712       SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
 713     }
 714   SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
 715   return SCM_UNSPECIFIED;
 716 }
 717 #undef FUNC_NAME
 718
 719 static void prep_hashsets (SCM);
 720
 721 SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
 722             (SCM class, SCM dsupers),
 723             "")
 724 #define FUNC_NAME s_scm_sys_inherit_magic_x
 725 {
 726   SCM ls = dsupers;
 727   long flags = 0;
 728   SCM_VALIDATE_INSTANCE (1, class);
 729   while (!scm_is_null (ls))
 730     {
 731       SCM_ASSERT (scm_is_pair (ls)
 732                   && SCM_INSTANCEP (SCM_CAR (ls)),
 733                   dsupers,
 734                   SCM_ARG2,
 735                   FUNC_NAME);
 736       flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
 737       ls = SCM_CDR (ls);
 738     }
 739   flags &= SCM_CLASSF_INHERIT;
 740   if (flags & SCM_CLASSF_ENTITY)
 741     SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity);
 742   else
 743     {
 744       long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
 745 #if 0
 746       /*
 747        * We could avoid calling scm_gc_malloc in the allocation code
 748        * (in which case the following two lines are needed).  Instead
 749        * we make 0-slot instances non-light, so that the light case
 750        * can be handled without special cases.
 751        */
 752       if (n == 0)
 753         SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0);
 754 #endif
 755       if (n > 0 && !(flags & SCM_CLASSF_METACLASS))
 756         {
 757           /* NOTE: The following depends on scm_struct_i_size. */
 758           flags |= SCM_STRUCTF_LIGHT + n * sizeof (SCM); /* use light representation */
 759           SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
 760         }
 761     }
 762   SCM_SET_CLASS_FLAGS (class, flags);
 763
 764   prep_hashsets (class);
 765
 766   return SCM_UNSPECIFIED;
 767 }
 768 #undef FUNC_NAME
 769
 770 static void
 771 prep_hashsets (SCM class)
 772 {
 773   unsigned int i;
 774
 775   for (i = 0; i < 7; ++i)
 776     SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate));
 777 }
 778
 779 /******************************************************************************/
 780
 781 SCM
 782 scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
 783 {
 784   SCM z, cpl, slots, nfields, g_n_s;
 785
 786   /* Allocate one instance */
 787   z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
 788
 789   /* Initialize its slots */
 790   SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
 791   cpl   = compute_cpl (z);
 792   slots = build_slots_list (maplist (dslots), cpl);
 793   nfields = scm_from_int (scm_ilength (slots));
 794   g_n_s = compute_getters_n_setters (slots);
 795
 796   SCM_SET_SLOT (z, scm_si_name, name);
 797   SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
 798   SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
 799   SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
 800   SCM_SET_SLOT (z, scm_si_cpl, cpl);
 801   SCM_SET_SLOT (z, scm_si_slots, slots);
 802   SCM_SET_SLOT (z, scm_si_nfields, nfields);
 803   SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
 804   SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
 805   SCM_SET_SLOT (z, scm_si_environment,
 806                 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
 807
 808   /* Add this class in the direct-subclasses slot of dsupers */
 809   {
 810     SCM tmp;
 811     for (tmp = dsupers; !scm_is_null (tmp); tmp = SCM_CDR (tmp))
 812       SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses,
 813                     scm_cons (z, SCM_SLOT (SCM_CAR (tmp),
 814                                            scm_si_direct_subclasses)));
 815   }
 816
 817   /* Support for the underlying structs: */
 818   SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class
 819                            ? (SCM_CLASSF_GOOPS_OR_VALID
 820                               | SCM_CLASSF_OPERATOR
 821                               | SCM_CLASSF_ENTITY)
 822                            : class == scm_class_operator_class
 823                            ? SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_OPERATOR
 824                            : SCM_CLASSF_GOOPS_OR_VALID));
 825   return z;
 826 }
 827
 828 SCM
 829 scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
 830 {
 831   SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
 832   scm_sys_inherit_magic_x (z, dsupers);
 833   scm_sys_prep_layout_x (z);
 834   return z;
 835 }
 836
 837 /******************************************************************************/
 838
 839 SCM_SYMBOL (sym_layout, "layout");
 840 SCM_SYMBOL (sym_vcell, "vcell");
 841 SCM_SYMBOL (sym_vtable, "vtable");
 842 SCM_SYMBOL (sym_print, "print");
 843 SCM_SYMBOL (sym_procedure, "procedure");
 844 SCM_SYMBOL (sym_setter, "setter");
 845 SCM_SYMBOL (sym_redefined, "redefined");
 846 SCM_SYMBOL (sym_h0, "h0");
 847 SCM_SYMBOL (sym_h1, "h1");
 848 SCM_SYMBOL (sym_h2, "h2");
 849 SCM_SYMBOL (sym_h3, "h3");
 850 SCM_SYMBOL (sym_h4, "h4");
 851 SCM_SYMBOL (sym_h5, "h5");
 852 SCM_SYMBOL (sym_h6, "h6");
 853 SCM_SYMBOL (sym_h7, "h7");
 854 SCM_SYMBOL (sym_name, "name");
 855 SCM_SYMBOL (sym_direct_supers, "direct-supers");
 856 SCM_SYMBOL (sym_direct_slots, "direct-slots");
 857 SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
 858 SCM_SYMBOL (sym_direct_methods, "direct-methods");
 859 SCM_SYMBOL (sym_cpl, "cpl");
 860 SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class");
 861 SCM_SYMBOL (sym_slots, "slots");
 862 SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
 863 SCM_SYMBOL (sym_keyword_access, "keyword-access");
 864 SCM_SYMBOL (sym_nfields, "nfields");
 865 SCM_SYMBOL (sym_environment, "environment");
 866
 867
 868 static SCM
 869 build_class_class_slots ()
 870 {
 871   return scm_list_n (
 872     scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
 873     scm_list_3 (sym_vtable, k_class, scm_class_self),
 874     scm_list_1 (sym_print),
 875     scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque),
 876     scm_list_3 (sym_setter, k_class, scm_class_protected_opaque),
 877     scm_list_1 (sym_redefined),
 878     scm_list_3 (sym_h0, k_class, scm_class_int),
 879     scm_list_3 (sym_h1, k_class, scm_class_int),
 880     scm_list_3 (sym_h2, k_class, scm_class_int),
 881     scm_list_3 (sym_h3, k_class, scm_class_int),
 882     scm_list_3 (sym_h4, k_class, scm_class_int),
 883     scm_list_3 (sym_h5, k_class, scm_class_int),
 884     scm_list_3 (sym_h6, k_class, scm_class_int),
 885     scm_list_3 (sym_h7, k_class, scm_class_int),
 886     scm_list_1 (sym_name),
 887     scm_list_1 (sym_direct_supers),
 888     scm_list_1 (sym_direct_slots),
 889     scm_list_1 (sym_direct_subclasses),
 890     scm_list_1 (sym_direct_methods),
 891     scm_list_1 (sym_cpl),
 892     scm_list_1 (sym_default_slot_definition_class),
 893     scm_list_1 (sym_slots),
 894     scm_list_1 (sym_getters_n_setters),
 895     scm_list_1 (sym_keyword_access),
 896     scm_list_1 (sym_nfields),
 897     scm_list_1 (sym_environment),
 898     SCM_UNDEFINED);
 899 }
 900
 901 static void
 902 create_basic_classes (void)
 903 {
 904   /* SCM slots_of_class = build_class_class_slots (); */
 905
 906   /**** <scm_class_class> ****/
 907   SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
 908                                    + 2 * scm_vtable_offset_user);
 909   SCM name = scm_from_locale_symbol ("<class>");
 910   scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
 911                                                                   SCM_INUM0,
 912                                                                   SCM_EOL));
 913   SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
 914                                          | SCM_CLASSF_METACLASS));
 915
 916   SCM_SET_SLOT (scm_class_class, scm_si_name, name);
 917   SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL);  /* will be changed */
 918   /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
 919   SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
 920   SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
 921   SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL);  /* will be changed */
 922   /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
 923   SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
 924   /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
 925                    compute_getters_n_setters (slots_of_class)); */
 926   SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
 927   SCM_SET_SLOT (scm_class_class, scm_si_environment,
 928                 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
 929
 930   prep_hashsets (scm_class_class);
 931
 932   DEFVAR(name, scm_class_class);
 933
 934   /**** <scm_class_top> ****/
 935   name = scm_from_locale_symbol ("<top>");
 936   scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
 937                                                     name,
 938                                                     SCM_EOL,
 939                                                     SCM_EOL));
 940
 941   DEFVAR(name, scm_class_top);
 942
 943   /**** <scm_class_object> ****/
 944   name   = scm_from_locale_symbol ("<object>");
 945   scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
 946                                                        name,
 947                                                        scm_list_1 (scm_class_top),
 948                                                        SCM_EOL));
 949
 950   DEFVAR (name, scm_class_object);
 951
 952   /* <top> <object> and <class> were partially initialized. Correct them here */
 953   SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
 954
 955   SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 (scm_class_object));
 956   SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, scm_class_object, scm_class_top));
 957 }
 958
 959 /******************************************************************************/
 960
 961 SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
 962             (SCM obj),
 963             "Return @code{#t} if @var{obj} is an instance.")
 964 #define FUNC_NAME s_scm_instance_p
 965 {
 966   return scm_from_bool (SCM_INSTANCEP (obj));
 967 }
 968 #undef FUNC_NAME
 969
 970
 971 /******************************************************************************
 972  *
 973  * Meta object accessors
 974  *
 975  ******************************************************************************/
 976 SCM_DEFINE (scm_class_name, "class-name",  1, 0, 0,
 977             (SCM obj),
 978             "Return the class name of @var{obj}.")
 979 #define FUNC_NAME s_scm_class_name
 980 {
 981   SCM_VALIDATE_CLASS (1, obj);
 982   return scm_slot_ref (obj, sym_name);
 983 }
 984 #undef FUNC_NAME
 985
 986 SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
 987             (SCM obj),
 988             "Return the direct superclasses of the class @var{obj}.")
 989 #define FUNC_NAME s_scm_class_direct_supers
 990 {
 991   SCM_VALIDATE_CLASS (1, obj);
 992   return scm_slot_ref (obj, sym_direct_supers);
 993 }
 994 #undef FUNC_NAME
 995
 996 SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
 997             (SCM obj),
 998             "Return the direct slots of the class @var{obj}.")
 999 #define FUNC_NAME s_scm_class_direct_slots
1000 {
1001   SCM_VALIDATE_CLASS (1, obj);
1002   return scm_slot_ref (obj, sym_direct_slots);
1003 }
1004 #undef FUNC_NAME
1005
1006 SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
1007             (SCM obj),
1008             "Return the direct subclasses of the class @var{obj}.")
1009 #define FUNC_NAME s_scm_class_direct_subclasses
1010 {
1011   SCM_VALIDATE_CLASS (1, obj);
1012   return scm_slot_ref(obj, sym_direct_subclasses);
1013 }
1014 #undef FUNC_NAME
1015
1016 SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
1017             (SCM obj),
1018             "Return the direct methods of the class @var{obj}")
1019 #define FUNC_NAME s_scm_class_direct_methods
1020 {
1021   SCM_VALIDATE_CLASS (1, obj);
1022   return scm_slot_ref (obj, sym_direct_methods);
1023 }
1024 #undef FUNC_NAME
1025
1026 SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
1027             (SCM obj),
1028             "Return the class precedence list of the class @var{obj}.")
1029 #define FUNC_NAME s_scm_class_precedence_list
1030 {
1031   SCM_VALIDATE_CLASS (1, obj);
1032   return scm_slot_ref (obj, sym_cpl);
1033 }
1034 #undef FUNC_NAME
1035
1036 SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
1037             (SCM obj),
1038             "Return the slot list of the class @var{obj}.")
1039 #define FUNC_NAME s_scm_class_slots
1040 {
1041   SCM_VALIDATE_CLASS (1, obj);
1042   return scm_slot_ref (obj, sym_slots);
1043 }
1044 #undef FUNC_NAME
1045
1046 SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
1047             (SCM obj),
1048             "Return the environment of the class @var{obj}.")
1049 #define FUNC_NAME s_scm_class_environment
1050 {
1051   SCM_VALIDATE_CLASS (1, obj);
1052   return scm_slot_ref(obj, sym_environment);
1053 }
1054 #undef FUNC_NAME
1055
1056
1057 SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
1058             (SCM obj),
1059             "Return the name of the generic function @var{obj}.")
1060 #define FUNC_NAME s_scm_generic_function_name
1061 {
1062   SCM_VALIDATE_GENERIC (1, obj);
1063   return scm_procedure_property (obj, scm_sym_name);
1064 }
1065 #undef FUNC_NAME
1066
1067 SCM_SYMBOL (sym_methods, "methods");
1068 SCM_SYMBOL (sym_extended_by, "extended-by");
1069 SCM_SYMBOL (sym_extends, "extends");
1070
1071 static
1072 SCM fold_downward_gf_methods (SCM method_lists, SCM gf)
1073 {
1074   SCM gfs = scm_slot_ref (gf, sym_extended_by);
1075   method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
1076   while (!scm_is_null (gfs))
1077     {
1078       method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
1079       gfs = SCM_CDR (gfs);
1080     }
1081   return method_lists;
1082 }
1083
1084 static
1085 SCM fold_upward_gf_methods (SCM method_lists, SCM gf)
1086 {
1087   if (SCM_IS_A_P (gf, scm_class_extended_generic))
1088     {
1089       SCM gfs = scm_slot_ref (gf, sym_extends);
1090       while (!scm_is_null (gfs))
1091         {
1092           SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
1093           method_lists = fold_upward_gf_methods (scm_cons (methods,
1094                                                            method_lists),
1095                                                  SCM_CAR (gfs));
1096           gfs = SCM_CDR (gfs);
1097         }
1098     }
1099   return method_lists;
1100 }
1101
1102 SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
1103             (SCM obj),
1104             "Return the methods of the generic function @var{obj}.")
1105 #define FUNC_NAME s_scm_generic_function_methods
1106 {
1107   SCM methods;
1108   SCM_VALIDATE_GENERIC (1, obj);
1109   methods = fold_upward_gf_methods (SCM_EOL, obj);
1110   methods = fold_downward_gf_methods (methods, obj);
1111   return scm_append (methods);
1112 }
1113 #undef FUNC_NAME
1114
1115 SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
1116             (SCM obj),
1117             "Return the generic function for the method @var{obj}.")
1118 #define FUNC_NAME s_scm_method_generic_function
1119 {
1120   SCM_VALIDATE_METHOD (1, obj);
1121   return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function"));
1122 }
1123 #undef FUNC_NAME
1124
1125 SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0,
1126             (SCM obj),
1127             "Return specializers of the method @var{obj}.")
1128 #define FUNC_NAME s_scm_method_specializers
1129 {
1130   SCM_VALIDATE_METHOD (1, obj);
1131   return scm_slot_ref (obj, scm_from_locale_symbol ("specializers"));
1132 }
1133 #undef FUNC_NAME
1134
1135 SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
1136             (SCM obj),
1137             "Return the procedure of the method @var{obj}.")
1138 #define FUNC_NAME s_scm_method_procedure
1139 {
1140   SCM_VALIDATE_METHOD (1, obj);
1141   return scm_slot_ref (obj, sym_procedure);
1142 }
1143 #undef FUNC_NAME
1144
1145 SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
1146             (SCM obj),
1147             "Return the slot definition of the accessor @var{obj}.")
1148 #define FUNC_NAME s_scm_accessor_method_slot_definition
1149 {
1150   SCM_VALIDATE_ACCESSOR (1, obj);
1151   return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
1152 }
1153 #undef FUNC_NAME
1154
1155 SCM_DEFINE (scm_sys_tag_body, "%tag-body", 1, 0, 0,
1156             (SCM body),
1157             "Internal GOOPS magic---don't use this function!")
1158 #define FUNC_NAME s_scm_sys_tag_body
1159 {
1160   return scm_cons (SCM_IM_LAMBDA, body);
1161 }
1162 #undef FUNC_NAME
1163
1164 /******************************************************************************
1165  *
1166  * S l o t   a c c e s s
1167  *
1168  ******************************************************************************/
1169
1170 SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
1171             (),
1172             "Return the unbound value.")
1173 #define FUNC_NAME s_scm_make_unbound
1174 {
1175   return SCM_GOOPS_UNBOUND;
1176 }
1177 #undef FUNC_NAME
1178
1179 SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
1180             (SCM obj),
1181             "Return @code{#t} if @var{obj} is unbound.")
1182 #define FUNC_NAME s_scm_unbound_p
1183 {
1184   return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
1185 }
1186 #undef FUNC_NAME
1187
1188 SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0,
1189             (SCM value, SCM obj),
1190             "Return @var{value} if it is bound, and invoke the\n"
1191             "@var{slot-unbound} method of @var{obj} if it is not.")
1192 #define FUNC_NAME s_scm_assert_bound
1193 {
1194   if (SCM_GOOPS_UNBOUNDP (value))
1195     return CALL_GF1 ("slot-unbound", obj);
1196   return value;
1197 }
1198 #undef FUNC_NAME
1199
1200 SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0,
1201             (SCM obj, SCM index),
1202             "Like @code{assert-bound}, but use @var{index} for accessing\n"
1203             "the value from @var{obj}.")
1204 #define FUNC_NAME s_scm_at_assert_bound_ref
1205 {
1206   SCM value = SCM_SLOT (obj, scm_to_int (index));
1207   if (SCM_GOOPS_UNBOUNDP (value))
1208     return CALL_GF1 ("slot-unbound", obj);
1209   return value;
1210 }
1211 #undef FUNC_NAME
1212
1213 SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
1214             (SCM obj, SCM index),
1215             "Return the slot value with index @var{index} from @var{obj}.")
1216 #define FUNC_NAME s_scm_sys_fast_slot_ref
1217 {
1218   unsigned long int i;
1219
1220   SCM_VALIDATE_INSTANCE (1, obj);
1221   i = scm_to_unsigned_integer (index, 0,
1222                                SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
1223                                                      scm_si_nfields))
1224                                - 1);
1225   return SCM_SLOT (obj, i);
1226 }
1227 #undef FUNC_NAME
1228
1229 SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
1230             (SCM obj, SCM index, SCM value),
1231             "Set the slot with index @var{index} in @var{obj} to\n"
1232             "@var{value}.")
1233 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1234 {
1235   unsigned long int i;
1236
1237   SCM_VALIDATE_INSTANCE (1, obj);
1238   i = scm_to_unsigned_integer (index, 0,
1239                                SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
1240                                                      scm_si_nfields))
1241                                - 1);
1242
1243   SCM_SET_SLOT (obj, i, value);
1244
1245   return SCM_UNSPECIFIED;
1246 }
1247 #undef FUNC_NAME
1248
1249
1250 SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
1251 SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
1252
1253
1254 /** Utilities **/
1255
1256 /* In the future, this function will return the effective slot
1257  * definition associated with SLOT_NAME.  Now it just returns some of
1258  * the information which will be stored in the effective slot
1259  * definition.
1260  */
1261
1262 static SCM
1263 slot_definition_using_name (SCM class, SCM slot_name)
1264 {
1265   register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
1266   for (; !scm_is_null (slots); slots = SCM_CDR (slots))
1267     if (SCM_CAAR (slots) == slot_name)
1268       return SCM_CAR (slots);
1269   return SCM_BOOL_F;
1270 }
1271
1272 static SCM
1273 get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
1274 #define FUNC_NAME "%get-slot-value"
1275 {
1276   SCM access = SCM_CDDR (slotdef);
1277   /* Two cases here:
1278    *    - access is an integer (the offset of this slot in the slots vector)
1279    *    - otherwise (car access) is the getter function to apply
1280    *
1281    * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1282    * we can just assume fixnums here.
1283    */
1284   if (SCM_I_INUMP (access))
1285     /* Don't poke at the slots directly, because scm_struct_ref handles the
1286        access bits for us. */
1287     return scm_struct_ref (obj, access);
1288   else
1289     {
1290       /* We must evaluate (apply (car access) (list obj))
1291        * where (car access) is known to be a closure of arity 1  */
1292       register SCM code, env;
1293
1294       code = SCM_CAR (access);
1295       if (!SCM_CLOSUREP (code))
1296         return SCM_SUBRF (code) (obj);
1297       env  = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
1298                              scm_list_1 (obj),
1299                              SCM_ENV (code));
1300       /* Evaluate the closure body */
1301       return scm_eval_body (SCM_CLOSURE_BODY (code), env);
1302     }
1303 }
1304 #undef FUNC_NAME
1305
1306 static SCM
1307 get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
1308 {
1309   SCM slotdef = slot_definition_using_name (class, slot_name);
1310   if (scm_is_true (slotdef))
1311     return get_slot_value (class, obj, slotdef);
1312   else
1313     return CALL_GF3 ("slot-missing", class, obj, slot_name);
1314 }
1315
1316 static SCM
1317 set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
1318 #define FUNC_NAME "%set-slot-value"
1319 {
1320   SCM access = SCM_CDDR (slotdef);
1321   /* Two cases here:
1322    *    - access is an integer (the offset of this slot in the slots vector)
1323    *    - otherwise (cadr access) is the setter function to apply
1324    *
1325    * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1326    * we can just assume fixnums here.
1327    */
1328   if (SCM_I_INUMP (access))
1329     /* obey permissions bits via going through struct-set! */
1330     scm_struct_set_x (obj, access, value);
1331   else
1332     {
1333       /* We must evaluate (apply (cadr l) (list obj value))
1334        * where (cadr l) is known to be a closure of arity 2  */
1335       register SCM code, env;
1336
1337       code = SCM_CADR (access);
1338       if (!SCM_CLOSUREP (code))
1339         SCM_SUBRF (code) (obj, value);
1340       else
1341         {
1342           env  = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
1343                                  scm_list_2 (obj, value),
1344                                  SCM_ENV (code));
1345           /* Evaluate the closure body */
1346           scm_eval_body (SCM_CLOSURE_BODY (code), env);
1347         }
1348     }
1349   return SCM_UNSPECIFIED;
1350 }
1351 #undef FUNC_NAME
1352
1353 static SCM
1354 set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
1355 {
1356   SCM slotdef = slot_definition_using_name (class, slot_name);
1357   if (scm_is_true (slotdef))
1358     return set_slot_value (class, obj, slotdef, value);
1359   else
1360     return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
1361 }
1362
1363 static SCM
1364 test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name)
1365 {
1366   register SCM l;
1367
1368   for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l))
1369     if (scm_is_eq (SCM_CAAR (l), slot_name))
1370       return SCM_BOOL_T;
1371
1372   return SCM_BOOL_F;
1373 }
1374
1375                 /* ======================================== */
1376
1377 SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0,
1378             (SCM class, SCM obj, SCM slot_name),
1379             "")
1380 #define FUNC_NAME s_scm_slot_ref_using_class
1381 {
1382   SCM res;
1383
1384   SCM_VALIDATE_CLASS (1, class);
1385   SCM_VALIDATE_INSTANCE (2, obj);
1386   SCM_VALIDATE_SYMBOL (3, slot_name);
1387
1388   res = get_slot_value_using_name (class, obj, slot_name);
1389   if (SCM_GOOPS_UNBOUNDP (res))
1390     return CALL_GF3 ("slot-unbound", class, obj, slot_name);
1391   return res;
1392 }
1393 #undef FUNC_NAME
1394
1395
1396 SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0,
1397             (SCM class, SCM obj, SCM slot_name, SCM value),
1398             "")
1399 #define FUNC_NAME s_scm_slot_set_using_class_x
1400 {
1401   SCM_VALIDATE_CLASS (1, class);
1402   SCM_VALIDATE_INSTANCE (2, obj);
1403   SCM_VALIDATE_SYMBOL (3, slot_name);
1404
1405   return set_slot_value_using_name (class, obj, slot_name, value);
1406 }
1407 #undef FUNC_NAME
1408
1409
1410 SCM_DEFINE (scm_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0,
1411             (SCM class, SCM obj, SCM slot_name),
1412             "")
1413 #define FUNC_NAME s_scm_slot_bound_using_class_p
1414 {
1415   SCM_VALIDATE_CLASS (1, class);
1416   SCM_VALIDATE_INSTANCE (2, obj);
1417   SCM_VALIDATE_SYMBOL (3, slot_name);
1418
1419   return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, slot_name))
1420           ? SCM_BOOL_F
1421           : SCM_BOOL_T);
1422 }
1423 #undef FUNC_NAME
1424
1425 SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0,
1426             (SCM class, SCM obj, SCM slot_name),
1427             "")
1428 #define FUNC_NAME s_scm_slot_exists_using_class_p
1429 {
1430   SCM_VALIDATE_CLASS (1, class);
1431   SCM_VALIDATE_INSTANCE (2, obj);
1432   SCM_VALIDATE_SYMBOL (3, slot_name);
1433   return test_slot_existence (class, obj, slot_name);
1434 }
1435 #undef FUNC_NAME
1436
1437
1438                 /* ======================================== */
1439
1440 SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
1441             (SCM obj, SCM slot_name),
1442             "Return the value from @var{obj}'s slot with the name\n"
1443             "@var{slot_name}.")
1444 #define FUNC_NAME s_scm_slot_ref
1445 {
1446   SCM res, class;
1447
1448   SCM_VALIDATE_INSTANCE (1, obj);
1449   TEST_CHANGE_CLASS (obj, class);
1450
1451   res = get_slot_value_using_name (class, obj, slot_name);
1452   if (SCM_GOOPS_UNBOUNDP (res))
1453     return CALL_GF3 ("slot-unbound", class, obj, slot_name);
1454   return res;
1455 }
1456 #undef FUNC_NAME
1457
1458 SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
1459             (SCM obj, SCM slot_name, SCM value),
1460             "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1461 #define FUNC_NAME s_scm_slot_set_x
1462 {
1463   SCM class;
1464
1465   SCM_VALIDATE_INSTANCE (1, obj);
1466   TEST_CHANGE_CLASS(obj, class);
1467
1468   return set_slot_value_using_name (class, obj, slot_name, value);
1469 }
1470 #undef FUNC_NAME
1471
1472 const char *scm_s_slot_set_x = s_scm_slot_set_x;
1473
1474 SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
1475             (SCM obj, SCM slot_name),
1476             "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1477             "is bound.")
1478 #define FUNC_NAME s_scm_slot_bound_p
1479 {
1480   SCM class;
1481
1482   SCM_VALIDATE_INSTANCE (1, obj);
1483   TEST_CHANGE_CLASS(obj, class);
1484
1485   return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1486                                                          obj,
1487                                                          slot_name))
1488           ? SCM_BOOL_F
1489           : SCM_BOOL_T);
1490 }
1491 #undef FUNC_NAME
1492
1493 SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
1494             (SCM obj, SCM slot_name),
1495             "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1496 #define FUNC_NAME s_scm_slot_exists_p
1497 {
1498   SCM class;
1499
1500   SCM_VALIDATE_INSTANCE (1, obj);
1501   SCM_VALIDATE_SYMBOL (2, slot_name);
1502   TEST_CHANGE_CLASS (obj, class);
1503
1504   return test_slot_existence (class, obj, slot_name);
1505 }
1506 #undef FUNC_NAME
1507
1508
1509 /******************************************************************************
1510  *
1511  * %allocate-instance (the low level instance allocation primitive)
1512  *
1513  ******************************************************************************/
1514
1515 static void clear_method_cache (SCM);
1516
1517 static SCM
1518 wrap_init (SCM class, SCM *m, long n)
1519 {
1520   long i;
1521   scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
1522   const char *layout = scm_i_symbol_chars (SCM_PACK (slayout));
1523
1524   /* Set all SCM-holding slots to unbound */
1525   for (i = 0; i < n; i++)
1526     if (layout[i*2] == 'p')
1527       m[i] = SCM_GOOPS_UNBOUND;
1528     else
1529       m[i] = 0;
1530
1531   return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
1532                            | scm_tc3_struct),
1533                           (scm_t_bits) m, 0, 0);
1534 }
1535
1536 SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
1537             (SCM class, SCM initargs),
1538             "Create a new instance of class @var{class} and initialize it\n"
1539             "from the arguments @var{initargs}.")
1540 #define FUNC_NAME s_scm_sys_allocate_instance
1541 {
1542   SCM *m;
1543   long n;
1544
1545   SCM_VALIDATE_CLASS (1, class);
1546
1547   /* Most instances */
1548   if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
1549     {
1550       n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
1551       m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
1552       return wrap_init (class, m, n);
1553     }
1554
1555   /* Foreign objects */
1556   if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
1557     return scm_make_foreign_object (class, initargs);
1558
1559   n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
1560
1561   /* Entities */
1562   if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
1563     {
1564       m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
1565                                     "entity struct");
1566       m[scm_struct_i_setter] = SCM_BOOL_F;
1567       m[scm_struct_i_procedure] = SCM_BOOL_F;
1568       /* Generic functions */
1569       if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
1570         {
1571           SCM gf = wrap_init (class, m, n);
1572           clear_method_cache (gf);
1573           return gf;
1574         }
1575       else
1576         return wrap_init (class, m, n);
1577     }
1578
1579   /* Class objects */
1580   if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
1581     {
1582       long i;
1583
1584       /* allocate class object */
1585       SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
1586
1587       SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND);
1588       for (i = scm_si_goops_fields; i < n; i++)
1589         SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
1590
1591       if (SCM_SUBCLASSP (class, scm_class_entity_class))
1592         SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
1593       else if (SCM_SUBCLASSP (class, scm_class_operator_class))
1594         SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR);
1595
1596       return z;
1597     }
1598
1599   /* Non-light instances */
1600   {
1601     m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
1602     return wrap_init (class, m, n);
1603   }
1604 }
1605 #undef FUNC_NAME
1606
1607 SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
1608             (SCM obj, SCM setter),
1609             "")
1610 #define FUNC_NAME s_scm_sys_set_object_setter_x
1611 {
1612   SCM_ASSERT (SCM_STRUCTP (obj)
1613               && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
1614                   || SCM_I_ENTITYP (obj)),
1615               obj,
1616               SCM_ARG1,
1617               FUNC_NAME);
1618   if (SCM_I_ENTITYP (obj))
1619     SCM_SET_ENTITY_SETTER (obj, setter);
1620   else
1621     SCM_OPERATOR_CLASS (obj)->setter = setter;
1622   return SCM_UNSPECIFIED;
1623 }
1624 #undef FUNC_NAME
1625
1626 /******************************************************************************
1627  *
1628  * %modify-instance (used by change-class to modify in place)
1629  *
1630  ******************************************************************************/
1631
1632 SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
1633             (SCM old, SCM new),
1634             "")
1635 #define FUNC_NAME s_scm_sys_modify_instance
1636 {
1637   SCM_VALIDATE_INSTANCE (1, old);
1638   SCM_VALIDATE_INSTANCE (2, new);
1639
1640   /* Exchange the data contained in old and new. We exchange rather than
1641    * scratch the old value with new to be correct with GC.
1642    * See "Class redefinition protocol above".
1643    */
1644   SCM_CRITICAL_SECTION_START;
1645   {
1646     SCM car = SCM_CAR (old);
1647     SCM cdr = SCM_CDR (old);
1648     SCM_SETCAR (old, SCM_CAR (new));
1649     SCM_SETCDR (old, SCM_CDR (new));
1650     SCM_SETCAR (new, car);
1651     SCM_SETCDR (new, cdr);
1652   }
1653   SCM_CRITICAL_SECTION_END;
1654   return SCM_UNSPECIFIED;
1655 }
1656 #undef FUNC_NAME
1657
1658 SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
1659             (SCM old, SCM new),
1660             "")
1661 #define FUNC_NAME s_scm_sys_modify_class
1662 {
1663   SCM_VALIDATE_CLASS (1, old);
1664   SCM_VALIDATE_CLASS (2, new);
1665
1666   SCM_CRITICAL_SECTION_START;
1667   {
1668     SCM car = SCM_CAR (old);
1669     SCM cdr = SCM_CDR (old);
1670     SCM_SETCAR (old, SCM_CAR (new));
1671     SCM_SETCDR (old, SCM_CDR (new));
1672     SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
1673     SCM_SETCAR (new, car);
1674     SCM_SETCDR (new, cdr);
1675     SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
1676   }
1677   SCM_CRITICAL_SECTION_END;
1678   return SCM_UNSPECIFIED;
1679 }
1680 #undef FUNC_NAME
1681
1682 SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
1683             (SCM class),
1684             "")
1685 #define FUNC_NAME s_scm_sys_invalidate_class
1686 {
1687   SCM_VALIDATE_CLASS (1, class);
1688   SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
1689   return SCM_UNSPECIFIED;
1690 }
1691 #undef FUNC_NAME
1692
1693 /* When instances change class, they finally get a new body, but
1694  * before that, they go through purgatory in hell.  Odd as it may
1695  * seem, this data structure saves us from eternal suffering in
1696  * infinite recursions.
1697  */
1698
1699 static scm_t_bits **hell;
1700 static long n_hell = 1;         /* one place for the evil one himself */
1701 static long hell_size = 4;
1702 static SCM hell_mutex;
1703
1704 static long
1705 burnin (SCM o)
1706 {
1707   long i;
1708   for (i = 1; i < n_hell; ++i)
1709     if (SCM_STRUCT_DATA (o) == hell[i])
1710       return i;
1711   return 0;
1712 }
1713
1714 static void
1715 go_to_hell (void *o)
1716 {
1717   SCM obj = SCM_PACK ((scm_t_bits) o);
1718   scm_lock_mutex (hell_mutex);
1719   if (n_hell >= hell_size)
1720     {
1721       hell_size *= 2;
1722       hell = scm_realloc (hell, hell_size * sizeof(*hell));
1723     }
1724   hell[n_hell++] = SCM_STRUCT_DATA (obj);
1725   scm_unlock_mutex (hell_mutex);
1726 }
1727
1728 static void
1729 go_to_heaven (void *o)
1730 {
1731   scm_lock_mutex (hell_mutex);
1732   hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell];
1733   scm_unlock_mutex (hell_mutex);
1734 }
1735
1736
1737 SCM_SYMBOL (scm_sym_change_class, "change-class");
1738
1739 static SCM
1740 purgatory (void *args)
1741 {
1742   return scm_apply_0 (GETVAR (scm_sym_change_class),
1743                       SCM_PACK ((scm_t_bits) args));
1744 }
1745
1746 /* This function calls the generic function change-class for all
1747  * instances which aren't currently undergoing class change.
1748  */
1749
1750 void
1751 scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
1752 {
1753   if (!burnin (obj))
1754     scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven,
1755                                (void *) SCM_UNPACK (scm_list_2 (obj, new_class)),
1756                                (void *) SCM_UNPACK (obj));
1757 }
1758
1759 /******************************************************************************
1760  *
1761  *   GGGG                FFFFF
1762  *  G                    F
1763  *  G  GG                FFF
1764  *  G   G                F
1765  *   GGG  E N E R I C    F    U N C T I O N S
1766  *
1767  * This implementation provides
1768  *      - generic functions (with class specializers)
1769  *      - multi-methods
1770  *      - next-method
1771  *      - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1772  *
1773  ******************************************************************************/
1774
1775 SCM_KEYWORD (k_name, "name");
1776
1777 SCM_SYMBOL (sym_no_method, "no-method");
1778
1779 static SCM list_of_no_method;
1780
1781 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
1782
1783
1784 SCM
1785 scm_make_method_cache (SCM gf)
1786 {
1787   return scm_list_5 (SCM_IM_DISPATCH,
1788                      scm_sym_args,
1789                      scm_from_int (1),
1790                      scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
1791                                         list_of_no_method),
1792                      gf);
1793 }
1794
1795 static void
1796 clear_method_cache (SCM gf)
1797 {
1798   SCM cache = scm_make_method_cache (gf);
1799   SCM_SET_ENTITY_PROCEDURE (gf, cache);
1800   SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F);
1801 }
1802
1803 SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
1804             (SCM gf),
1805             "")
1806 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1807 {
1808   SCM used_by;
1809   SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
1810   used_by = SCM_SLOT (gf, scm_si_used_by);
1811   if (scm_is_true (used_by))
1812     {
1813       SCM methods = SCM_SLOT (gf, scm_si_methods);
1814       for (; scm_is_pair (used_by); used_by = SCM_CDR (used_by))
1815         scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
1816       clear_method_cache (gf);
1817       for (; scm_is_pair (methods); methods = SCM_CDR (methods))
1818         SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
1819     }
1820   {
1821     SCM n = SCM_SLOT (gf, scm_si_n_specialized);
1822     /* The sign of n is a flag indicating rest args. */
1823     SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), n);
1824   }
1825   return SCM_UNSPECIFIED;
1826 }
1827 #undef FUNC_NAME
1828
1829 SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
1830             (SCM proc),
1831             "")
1832 #define FUNC_NAME s_scm_generic_capability_p
1833 {
1834   SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
1835               proc, SCM_ARG1, FUNC_NAME);
1836   return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
1837           ? SCM_BOOL_T
1838           : SCM_BOOL_F);
1839 }
1840 #undef FUNC_NAME
1841
1842 SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
1843             (SCM subrs),
1844             "")
1845 #define FUNC_NAME s_scm_enable_primitive_generic_x
1846 {
1847   SCM_VALIDATE_REST_ARGUMENT (subrs);
1848   while (!scm_is_null (subrs))
1849     {
1850       SCM subr = SCM_CAR (subrs);
1851       SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
1852                   subr, SCM_ARGn, FUNC_NAME);
1853       *SCM_SUBR_GENERIC (subr)
1854         = scm_make (scm_list_3 (scm_class_generic,
1855                                 k_name,
1856                                 SCM_SNAME (subr)));
1857       subrs = SCM_CDR (subrs);
1858     }
1859   return SCM_UNSPECIFIED;
1860 }
1861 #undef FUNC_NAME
1862
1863 SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
1864             (SCM subr),
1865             "")
1866 #define FUNC_NAME s_scm_primitive_generic_generic
1867 {
1868   if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
1869     {
1870       if (!*SCM_SUBR_GENERIC (subr))
1871         scm_enable_primitive_generic_x (scm_list_1 (subr));
1872       return *SCM_SUBR_GENERIC (subr);
1873     }
1874   SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
1875 }
1876 #undef FUNC_NAME
1877
1878 typedef struct t_extension {
1879   struct t_extension *next;
1880   SCM extended;
1881   SCM extension;
1882 } t_extension;
1883
1884 static t_extension *extensions = 0;
1885
1886 SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
1887
1888 void
1889 scm_c_extend_primitive_generic (SCM extended, SCM extension)
1890 {
1891   if (goops_loaded_p)
1892     {
1893       SCM gf, gext;
1894       if (!*SCM_SUBR_GENERIC (extended))
1895         scm_enable_primitive_generic_x (scm_list_1 (extended));
1896       gf = *SCM_SUBR_GENERIC (extended);
1897       gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
1898                          gf,
1899                          SCM_SNAME (extension));
1900       *SCM_SUBR_GENERIC (extension) = gext;
1901     }
1902   else
1903     {
1904       t_extension *e = scm_malloc (sizeof (t_extension));
1905       t_extension **loc = &extensions;
1906       /* Make sure that extensions are placed before their own
1907        * extensions in the extensions list.  O(N^2) algorithm, but
1908        * extensions of primitive generics are rare.
1909        */
1910       while (*loc && extension != (*loc)->extended)
1911         loc = &(*loc)->next;
1912       e->next = *loc;
1913       e->extended = extended;
1914       e->extension = extension;
1915       *loc = e;
1916     }
1917 }
1918
1919 static void
1920 setup_extended_primitive_generics ()
1921 {
1922   while (extensions)
1923     {
1924       t_extension *e = extensions;
1925       scm_c_extend_primitive_generic (e->extended, e->extension);
1926       extensions = e->next;
1927       free (e);
1928     }
1929 }
1930
1931 /******************************************************************************
1932  *
1933  * Protocol for calling a generic fumction
1934  * This protocol is roughly equivalent to (parameter are a little bit different
1935  * for efficiency reasons):
1936  *
1937  *      + apply-generic (gf args)
1938  *              + compute-applicable-methods (gf args ...)
1939  *                      + sort-applicable-methods (methods args)
1940  *              + apply-methods (gf methods args)
1941  *
1942  * apply-methods calls make-next-method to build the "continuation" of a a
1943  * method.  Applying a next-method will call apply-next-method which in
1944  * turn will call  apply again to call effectively the following method.
1945  *
1946  ******************************************************************************/
1947
1948 static int
1949 applicablep (SCM actual, SCM formal)
1950 {
1951   /* We already know that the cpl is well formed. */
1952   return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
1953 }
1954
1955 static int
1956 more_specificp (SCM m1, SCM m2, SCM const *targs)
1957 {
1958   register SCM s1, s2;
1959   register long i;
1960   /*
1961    * Note:
1962    *   m1 and m2 can have != length (i.e. one can be one element longer than the
1963    * other when we have a dotted parameter list). For instance, with the call
1964    *   (M 1)
1965    * with
1966    *   (define-method M (a . l) ....)
1967    *   (define-method M (a) ....)
1968    *
1969    * we consider that the second method is more specific.
1970    *
1971    * BTW, targs is an array of types. We don't need it's size since
1972    * we already know that m1 and m2 are applicable (no risk to go past
1973    * the end of this array).
1974    *
1975    */
1976   for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
1977     if (scm_is_null(s1)) return 1;
1978     if (scm_is_null(s2)) return 0;
1979     if (SCM_CAR(s1) != SCM_CAR(s2)) {
1980       register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
1981
1982       for (l = SCM_SLOT (targs[i], scm_si_cpl);   ; l = SCM_CDR(l)) {
1983         if (cs1 == SCM_CAR(l))
1984           return 1;
1985         if (cs2 == SCM_CAR(l))
1986           return 0;
1987       }
1988       return 0;/* should not occur! */
1989     }
1990   }
1991   return 0; /* should not occur! */
1992 }
1993
1994 #define BUFFSIZE 32             /* big enough for most uses */
1995
1996 static SCM
1997 scm_i_vector2list (SCM l, long len)
1998 {
1999   long j;
2000   SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
2001
2002   for (j = 0; j < len; j++, l = SCM_CDR (l)) {
2003     SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
2004   }
2005   return z;
2006 }
2007
2008 static SCM
2009 sort_applicable_methods (SCM method_list, long size, SCM const *targs)
2010 {
2011   long i, j, incr;
2012   SCM *v, vector = SCM_EOL;
2013   SCM buffer[BUFFSIZE];
2014   SCM save = method_list;
2015   scm_t_array_handle handle;
2016
2017   /* For reasonably sized method_lists we can try to avoid all the
2018    * consing and reorder the list in place...
2019    * This idea is due to David McClain <Dave_McClain@msn.com>
2020    */
2021   if (size <= BUFFSIZE)
2022     {
2023       for (i = 0;  i < size; i++)
2024         {
2025           buffer[i]   = SCM_CAR (method_list);
2026           method_list = SCM_CDR (method_list);
2027         }
2028       v = buffer;
2029     }
2030   else
2031     {
2032       /* Too many elements in method_list to keep everything locally */
2033       vector = scm_i_vector2list (save, size);
2034       v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
2035     }
2036
2037   /* Use a simple shell sort since it is generally faster than qsort on
2038    * small vectors (which is probably mostly the case when we have to
2039    * sort a list of applicable methods).
2040    */
2041   for (incr = size / 2; incr; incr /= 2)
2042     {
2043       for (i = incr; i < size; i++)
2044         {
2045           for (j = i - incr; j >= 0; j -= incr)
2046             {
2047               if (more_specificp (v[j], v[j+incr], targs))
2048                 break;
2049               else
2050                 {
2051                   SCM tmp = v[j + incr];
2052                   v[j + incr] = v[j];
2053                   v[j] = tmp;
2054                 }
2055             }
2056         }
2057     }
2058
2059   if (size <= BUFFSIZE)
2060     {
2061       /* We did it in locally, so restore the original list (reordered) in-place */
2062       for (i = 0, method_list = save; i < size; i++, v++)
2063         {
2064           SCM_SETCAR (method_list, *v);
2065           method_list = SCM_CDR (method_list);
2066         }
2067       return save;
2068     }
2069
2070   /* If we are here, that's that we did it the hard way... */
2071   scm_array_handle_release (&handle);
2072   return scm_vector_to_list (vector);
2073 }
2074
2075 SCM
2076 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
2077 {
2078   register long i;
2079   long count = 0;
2080   SCM l, fl, applicable = SCM_EOL;
2081   SCM save = args;
2082   SCM buffer[BUFFSIZE];
2083   SCM const *types;
2084   SCM *p;
2085   SCM tmp = SCM_EOL;
2086   scm_t_array_handle handle;
2087
2088   /* Build the list of arguments types */
2089   if (len >= BUFFSIZE)
2090     {
2091       tmp = scm_c_make_vector (len, SCM_UNDEFINED);
2092       types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
2093
2094     /*
2095       note that we don't have to work to reset the generation
2096       count. TMP is a new vector anyway, and it is found
2097       conservatively.
2098     */
2099     }
2100   else
2101     types = p = buffer;
2102
2103   for (  ; !scm_is_null (args); args = SCM_CDR (args))
2104     *p++ = scm_class_of (SCM_CAR (args));
2105
2106   /* Build a list of all applicable methods */
2107   for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
2108     {
2109       fl = SPEC_OF (SCM_CAR (l));
2110       /* Only accept accessors which match exactly in first arg. */
2111       if (SCM_ACCESSORP (SCM_CAR (l))
2112           && (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
2113         continue;
2114       for (i = 0; ; i++, fl = SCM_CDR (fl))
2115         {
2116           if (SCM_INSTANCEP (fl)
2117               /* We have a dotted argument list */
2118               || (i >= len && scm_is_null (fl)))
2119             {   /* both list exhausted */
2120               applicable = scm_cons (SCM_CAR (l), applicable);
2121               count     += 1;
2122               break;
2123             }
2124           if (i >= len
2125               || scm_is_null (fl)
2126               || !applicablep (types[i], SCM_CAR (fl)))
2127             break;
2128         }
2129     }
2130
2131   if (len >= BUFFSIZE)
2132       scm_array_handle_release (&handle);
2133
2134   if (count == 0)
2135     {
2136       if (find_method_p)
2137         return SCM_BOOL_F;
2138       CALL_GF2 ("no-applicable-method", gf, save);
2139       /* if we are here, it's because no-applicable-method hasn't signaled an error */
2140       return SCM_BOOL_F;
2141     }
2142
2143   return (count == 1
2144           ? applicable
2145           : sort_applicable_methods (applicable, count, types));
2146 }
2147
2148 #if 0
2149 SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods);
2150 #endif
2151
2152 static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods";
2153
2154 SCM
2155 scm_sys_compute_applicable_methods (SCM gf, SCM args)
2156 #define FUNC_NAME s_sys_compute_applicable_methods
2157 {
2158   long n;
2159   SCM_VALIDATE_GENERIC (1, gf);
2160   n = scm_ilength (args);
2161   SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
2162   return scm_compute_applicable_methods (gf, args, n, 1);
2163 }
2164 #undef FUNC_NAME
2165
2166 SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
2167 SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
2168
2169 static void
2170 lock_cache_mutex (void *m)
2171 {
2172   SCM mutex = SCM_PACK ((scm_t_bits) m);
2173   scm_lock_mutex (mutex);
2174 }
2175
2176 static void
2177 unlock_cache_mutex (void *m)
2178 {
2179   SCM mutex = SCM_PACK ((scm_t_bits) m);
2180   scm_unlock_mutex (mutex);
2181 }
2182
2183 static SCM
2184 call_memoize_method (void *a)
2185 {
2186   SCM args = SCM_PACK ((scm_t_bits) a);
2187   SCM gf = SCM_CAR (args);
2188   SCM x = SCM_CADR (args);
2189   /* First check if another thread has inserted a method between
2190    * the cache miss and locking the mutex.
2191    */
2192   SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
2193   if (scm_is_true (cmethod))
2194     return cmethod;
2195   /*fixme* Use scm_apply */
2196   return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
2197 }
2198
2199 SCM
2200 scm_memoize_method (SCM x, SCM args)
2201 {
2202   SCM gf = SCM_CAR (scm_last_pair (x));
2203   return scm_internal_dynamic_wind (
2204     lock_cache_mutex,
2205     call_memoize_method,
2206     unlock_cache_mutex,
2207     (void *) SCM_UNPACK (scm_cons2 (gf, x, args)),
2208     (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex)));
2209 }
2210
2211 /******************************************************************************
2212  *
2213  * A simple make (which will be redefined later in Scheme)
2214  * This version handles only creation of gf, methods and classes (no instances)
2215  *
2216  * Since this code will disappear when Goops will be fully booted,
2217  * no precaution is taken to be efficient.
2218  *
2219  ******************************************************************************/
2220
2221 SCM_KEYWORD (k_setter,          "setter");
2222 SCM_KEYWORD (k_specializers,    "specializers");
2223 SCM_KEYWORD (k_procedure,       "procedure");
2224 SCM_KEYWORD (k_dsupers,         "dsupers");
2225 SCM_KEYWORD (k_slots,           "slots");
2226 SCM_KEYWORD (k_gf,              "generic-function");
2227
2228 SCM_DEFINE (scm_make, "make",  0, 0, 1,
2229             (SCM args),
2230             "Make a new object.  @var{args} must contain the class and\n"
2231             "all necessary initialization information.")
2232 #define FUNC_NAME s_scm_make
2233 {
2234   SCM class, z;
2235   long len = scm_ilength (args);
2236
2237   if (len <= 0 || (len & 1) == 0)
2238     SCM_WRONG_NUM_ARGS ();
2239
2240   class = SCM_CAR(args);
2241   args  = SCM_CDR(args);
2242
2243   if (class == scm_class_generic || class == scm_class_accessor)
2244     {
2245       z = scm_make_struct (class, SCM_INUM0,
2246                            scm_list_5 (SCM_EOL,
2247                                        SCM_INUM0,
2248                                        SCM_BOOL_F,
2249                                        scm_make_mutex (),
2250                                        SCM_EOL));
2251       scm_set_procedure_property_x (z, scm_sym_name,
2252                                     scm_get_keyword (k_name,
2253                                                      args,
2254                                                      SCM_BOOL_F));
2255       clear_method_cache (z);
2256       if (class == scm_class_accessor)
2257         {
2258           SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
2259           if (scm_is_true (setter))
2260             scm_sys_set_object_setter_x (z, setter);
2261         }
2262     }
2263   else
2264     {
2265       z = scm_sys_allocate_instance (class, args);
2266
2267       if (class == scm_class_method
2268           || class == scm_class_simple_method
2269           || class == scm_class_accessor_method)
2270         {
2271           SCM_SET_SLOT (z, scm_si_generic_function,
2272             scm_i_get_keyword (k_gf,
2273                                args,
2274                                len - 1,
2275                                SCM_BOOL_F,
2276                                FUNC_NAME));
2277           SCM_SET_SLOT (z, scm_si_specializers,
2278             scm_i_get_keyword (k_specializers,
2279                                args,
2280                                len - 1,
2281                                SCM_EOL,
2282                                FUNC_NAME));
2283           SCM_SET_SLOT (z, scm_si_procedure,
2284             scm_i_get_keyword (k_procedure,
2285                                args,
2286                                len - 1,
2287                                SCM_EOL,
2288                                FUNC_NAME));
2289           SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
2290         }
2291       else
2292         {
2293           /* In all the others case, make a new class .... No instance here */
2294           SCM_SET_SLOT (z, scm_si_name,
2295             scm_i_get_keyword (k_name,
2296                                args,
2297                                len - 1,
2298                                scm_from_locale_symbol ("???"),
2299                                FUNC_NAME));
2300           SCM_SET_SLOT (z, scm_si_direct_supers,
2301             scm_i_get_keyword (k_dsupers,
2302                                args,
2303                                len - 1,
2304                                SCM_EOL,
2305                                FUNC_NAME));
2306           SCM_SET_SLOT (z, scm_si_direct_slots,
2307             scm_i_get_keyword (k_slots,
2308                                args,
2309                                len - 1,
2310                                SCM_EOL,
2311                                FUNC_NAME));
2312         }
2313     }
2314   return z;
2315 }
2316 #undef FUNC_NAME
2317
2318 SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
2319             (SCM l),
2320             "")
2321 #define FUNC_NAME s_scm_find_method
2322 {
2323   SCM gf;
2324   long len = scm_ilength (l);
2325
2326   if (len == 0)
2327     SCM_WRONG_NUM_ARGS ();
2328
2329   gf = SCM_CAR(l); l = SCM_CDR(l);
2330   SCM_VALIDATE_GENERIC (1, gf);
2331   if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
2332     SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
2333
2334   return scm_compute_applicable_methods (gf, l, len - 1, 1);
2335 }
2336 #undef FUNC_NAME
2337
2338 SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
2339             (SCM m1, SCM m2, SCM targs),
2340             "Return true if method @var{m1} is more specific than @var{m2} "
2341             "given the argument types (classes) listed in @var{targs}.")
2342 #define FUNC_NAME s_scm_sys_method_more_specific_p
2343 {
2344   SCM l, v, result;
2345   SCM *v_elts;
2346   long i, len, m1_specs, m2_specs;
2347   scm_t_array_handle handle;
2348
2349   SCM_VALIDATE_METHOD (1, m1);
2350   SCM_VALIDATE_METHOD (2, m2);
2351
2352   len = scm_ilength (targs);
2353   m1_specs = scm_ilength (SPEC_OF (m1));
2354   m2_specs = scm_ilength (SPEC_OF (m2));
2355   SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
2356               targs, SCM_ARG3, FUNC_NAME);
2357
2358   /* Verify that all the arguments of TARGS are classes and place them
2359      in a vector.  */
2360
2361   v = scm_c_make_vector (len, SCM_EOL);
2362   v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
2363
2364   for (i = 0, l = targs;
2365        i < len && scm_is_pair (l);
2366        i++, l = SCM_CDR (l))
2367     {
2368       SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
2369       v_elts[i] = SCM_CAR (l);
2370     }
2371   result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;
2372
2373   scm_array_handle_release (&handle);
2374
2375   return result;
2376 }
2377 #undef FUNC_NAME
2378
2379
2380
2381 /******************************************************************************
2382  *
2383  * Initializations
2384  *
2385  ******************************************************************************/
2386
2387 static void
2388 fix_cpl (SCM c, SCM before, SCM after)
2389 {
2390   SCM cpl = SCM_SLOT (c, scm_si_cpl);
2391   SCM ls = scm_c_memq (after, cpl);
2392   SCM tail = scm_delq1_x (before, SCM_CDR (ls));
2393   if (scm_is_false (ls))
2394     /* if this condition occurs, fix_cpl should not be applied this way */
2395     abort ();
2396   SCM_SETCAR (ls, before);
2397   SCM_SETCDR (ls, scm_cons (after, tail));
2398   {
2399     SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
2400     SCM slots = build_slots_list (maplist (dslots), cpl);
2401     SCM g_n_s = compute_getters_n_setters (slots);
2402     SCM_SET_SLOT (c, scm_si_slots, slots);
2403     SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
2404   }
2405 }
2406
2407
2408 static void
2409 make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
2410 {
2411    SCM tmp = scm_from_locale_symbol (name);
2412
2413    *var = scm_permanent_object (scm_basic_make_class (meta,
2414                                                       tmp,
2415                                                       scm_is_pair (super)
2416                                                       ? super
2417                                                       : scm_list_1 (super),
2418                                                       slots));
2419    DEFVAR(tmp, *var);
2420 }
2421
2422
2423 SCM_KEYWORD (k_slot_definition, "slot-definition");
2424
2425 static void
2426 create_standard_classes (void)
2427 {
2428   SCM slots;
2429   SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
2430                                  scm_from_locale_symbol ("specializers"),
2431                                  sym_procedure,
2432                                  scm_from_locale_symbol ("code-table"));
2433   SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2434                                               k_init_keyword,
2435                                               k_slot_definition));
2436   SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2437   SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2438                                                 SCM_EOL,
2439                                                 mutex_slot),
2440                                     SCM_EOL);
2441   SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"),
2442                              scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2443                                          k_init_value,
2444                                          SCM_INUM0),
2445                              scm_list_3 (scm_from_locale_symbol ("used-by"),
2446                                          k_init_value,
2447                                          SCM_BOOL_F),
2448                              scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2449                                          k_init_thunk,
2450                                          mutex_closure),
2451                              scm_list_3 (scm_from_locale_symbol ("extended-by"),
2452                                          k_init_value,
2453                                          SCM_EOL));
2454   SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2455                                           k_init_value,
2456                                           SCM_EOL));
2457   /* Foreign class slot classes */
2458   make_stdcls (&scm_class_foreign_slot,    "<foreign-slot>",
2459                scm_class_class, scm_class_top,             SCM_EOL);
2460   make_stdcls (&scm_class_protected,       "<protected-slot>",
2461                scm_class_class, scm_class_foreign_slot,    SCM_EOL);
2462   make_stdcls (&scm_class_opaque,          "<opaque-slot>",
2463                scm_class_class, scm_class_foreign_slot,    SCM_EOL);
2464   make_stdcls (&scm_class_read_only,       "<read-only-slot>",
2465                scm_class_class, scm_class_foreign_slot,    SCM_EOL);
2466   make_stdcls (&scm_class_self,            "<self-slot>",
2467                scm_class_class,
2468                scm_class_read_only,
2469                SCM_EOL);
2470   make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
2471                scm_class_class,
2472                scm_list_2 (scm_class_protected, scm_class_opaque),
2473                SCM_EOL);
2474   make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
2475                scm_class_class,
2476                scm_list_2 (scm_class_protected, scm_class_read_only),
2477                SCM_EOL);
2478   make_stdcls (&scm_class_scm,             "<scm-slot>",
2479                scm_class_class, scm_class_protected, SCM_EOL);
2480   make_stdcls (&scm_class_int,             "<int-slot>",
2481                scm_class_class, scm_class_foreign_slot,    SCM_EOL);
2482   make_stdcls (&scm_class_float,           "<float-slot>",
2483                scm_class_class, scm_class_foreign_slot,    SCM_EOL);
2484   make_stdcls (&scm_class_double,          "<double-slot>",
2485                scm_class_class, scm_class_foreign_slot,    SCM_EOL);
2486
2487   /* Continue initialization of class <class> */
2488
2489   slots = build_class_class_slots ();
2490   SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
2491   SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
2492   SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
2493                 compute_getters_n_setters (slots));
2494
2495   make_stdcls (&scm_class_foreign_class, "<foreign-class>",
2496                scm_class_class, scm_class_class,
2497                scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2498                                        k_class,
2499                                        scm_class_opaque),
2500                            scm_list_3 (scm_from_locale_symbol ("destructor"),
2501                                        k_class,
2502                                        scm_class_opaque)));
2503   make_stdcls (&scm_class_foreign_object,  "<foreign-object>",
2504                scm_class_foreign_class, scm_class_object,   SCM_EOL);
2505   SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
2506
2507   /* scm_class_generic functions classes */
2508   make_stdcls (&scm_class_procedure_class, "<procedure-class>",
2509                scm_class_class, scm_class_class, SCM_EOL);
2510   make_stdcls (&scm_class_entity_class,    "<entity-class>",
2511                scm_class_class, scm_class_procedure_class, SCM_EOL);
2512   make_stdcls (&scm_class_operator_class,  "<operator-class>",
2513                scm_class_class, scm_class_procedure_class, SCM_EOL);
2514   make_stdcls (&scm_class_operator_with_setter_class,
2515                "<operator-with-setter-class>",
2516                scm_class_class, scm_class_operator_class, SCM_EOL);
2517   make_stdcls (&scm_class_method,          "<method>",
2518                scm_class_class, scm_class_object,          method_slots);
2519   make_stdcls (&scm_class_simple_method,   "<simple-method>",
2520                scm_class_class, scm_class_method,          SCM_EOL);
2521   SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
2522   make_stdcls (&scm_class_accessor_method, "<accessor-method>",
2523                scm_class_class, scm_class_simple_method,   amethod_slots);
2524   SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
2525   make_stdcls (&scm_class_applicable,      "<applicable>",
2526                scm_class_class, scm_class_top, SCM_EOL);
2527   make_stdcls (&scm_class_entity,          "<entity>",
2528                scm_class_entity_class,
2529                scm_list_2 (scm_class_object, scm_class_applicable),
2530                SCM_EOL);
2531   make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
2532                scm_class_entity_class, scm_class_entity,   SCM_EOL);
2533   make_stdcls (&scm_class_generic,         "<generic>",
2534                scm_class_entity_class, scm_class_entity,   gf_slots);
2535   SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
2536   make_stdcls (&scm_class_extended_generic, "<extended-generic>",
2537                scm_class_entity_class, scm_class_generic, egf_slots);
2538   SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
2539   make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
2540                scm_class_entity_class,
2541                scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
2542                SCM_EOL);
2543   SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
2544   make_stdcls (&scm_class_accessor,        "<accessor>",
2545                scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
2546   SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
2547   make_stdcls (&scm_class_extended_generic_with_setter,
2548                "<extended-generic-with-setter>",
2549                scm_class_entity_class,
2550                scm_list_2 (scm_class_generic_with_setter,
2551                            scm_class_extended_generic),
2552                SCM_EOL);
2553   SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
2554                        SCM_CLASSF_PURE_GENERIC);
2555   make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
2556                scm_class_entity_class,
2557                scm_list_2 (scm_class_accessor,
2558                            scm_class_extended_generic_with_setter),
2559                SCM_EOL);
2560   fix_cpl (scm_class_extended_accessor,
2561            scm_class_extended_generic, scm_class_generic);
2562   SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
2563
2564   /* Primitive types classes */
2565   make_stdcls (&scm_class_boolean,         "<boolean>",
2566                scm_class_class, scm_class_top,             SCM_EOL);
2567   make_stdcls (&scm_class_char,            "<char>",
2568                scm_class_class, scm_class_top,             SCM_EOL);
2569   make_stdcls (&scm_class_list,            "<list>",
2570                scm_class_class, scm_class_top,             SCM_EOL);
2571   make_stdcls (&scm_class_pair,            "<pair>",
2572                scm_class_class, scm_class_list,            SCM_EOL);
2573   make_stdcls (&scm_class_null,            "<null>",
2574                scm_class_class, scm_class_list,            SCM_EOL);
2575   make_stdcls (&scm_class_string,          "<string>",
2576                scm_class_class, scm_class_top,             SCM_EOL);
2577   make_stdcls (&scm_class_symbol,          "<symbol>",
2578                scm_class_class, scm_class_top,             SCM_EOL);
2579   make_stdcls (&scm_class_vector,          "<vector>",
2580                scm_class_class, scm_class_top,             SCM_EOL);
2581   make_stdcls (&scm_class_number,          "<number>",
2582                scm_class_class, scm_class_top,             SCM_EOL);
2583   make_stdcls (&scm_class_complex,         "<complex>",
2584                scm_class_class, scm_class_number,          SCM_EOL);
2585   make_stdcls (&scm_class_real,            "<real>",
2586                scm_class_class, scm_class_complex,         SCM_EOL);
2587   make_stdcls (&scm_class_integer,         "<integer>",
2588                scm_class_class, scm_class_real,            SCM_EOL);
2589   make_stdcls (&scm_class_fraction,        "<fraction>",
2590                scm_class_class, scm_class_real,            SCM_EOL);
2591   make_stdcls (&scm_class_keyword,         "<keyword>",
2592                scm_class_class, scm_class_top,             SCM_EOL);
2593   make_stdcls (&scm_class_unknown,         "<unknown>",
2594                scm_class_class, scm_class_top,             SCM_EOL);
2595   make_stdcls (&scm_class_procedure,       "<procedure>",
2596                scm_class_procedure_class, scm_class_applicable, SCM_EOL);
2597   make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
2598                scm_class_procedure_class, scm_class_procedure, SCM_EOL);
2599   make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
2600                scm_class_procedure_class, scm_class_procedure, SCM_EOL);
2601   make_stdcls (&scm_class_port,            "<port>",
2602                scm_class_class, scm_class_top,             SCM_EOL);
2603   make_stdcls (&scm_class_input_port,      "<input-port>",
2604                scm_class_class, scm_class_port,            SCM_EOL);
2605   make_stdcls (&scm_class_output_port,     "<output-port>",
2606                scm_class_class, scm_class_port,            SCM_EOL);
2607   make_stdcls (&scm_class_input_output_port, "<input-output-port>",
2608                scm_class_class,
2609                scm_list_2 (scm_class_input_port, scm_class_output_port),
2610                SCM_EOL);
2611 }
2612
2613 /**********************************************************************
2614  *
2615  * Smob classes
2616  *
2617  **********************************************************************/
2618
2619 static SCM
2620 make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
2621 {
2622   SCM class, name;
2623   if (type_name)
2624     {
2625       char buffer[100];
2626       sprintf (buffer, template, type_name);
2627       name = scm_from_locale_symbol (buffer);
2628     }
2629   else
2630     name = SCM_GOOPS_UNBOUND;
2631
2632   class = scm_permanent_object (scm_basic_make_class (applicablep
2633                                                       ? scm_class_procedure_class
2634                                                       : scm_class_class,
2635                                                       name,
2636                                                       supers,
2637                                                       SCM_EOL));
2638
2639   /* Only define name if doesn't already exist. */
2640   if (!SCM_GOOPS_UNBOUNDP (name)
2641       && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
2642     DEFVAR (name, class);
2643   return class;
2644 }
2645
2646 SCM
2647 scm_make_extended_class (char const *type_name, int applicablep)
2648 {
2649   return make_class_from_template ("<%s>",
2650                                    type_name,
2651                                    scm_list_1 (applicablep
2652                                                ? scm_class_applicable
2653                                                : scm_class_top),
2654                                    applicablep);
2655 }
2656
2657 void
2658 scm_i_inherit_applicable (SCM c)
2659 {
2660   if (!SCM_SUBCLASSP (c, scm_class_applicable))
2661     {
2662       SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
2663       SCM cpl = SCM_SLOT (c, scm_si_cpl);
2664       /* patch scm_class_applicable into direct-supers */
2665       SCM top = scm_c_memq (scm_class_top, dsupers);
2666       if (scm_is_false (top))
2667         dsupers = scm_append (scm_list_2 (dsupers,
2668                                           scm_list_1 (scm_class_applicable)));
2669       else
2670         {
2671           SCM_SETCAR (top, scm_class_applicable);
2672           SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
2673         }
2674       SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
2675       /* patch scm_class_applicable into cpl */
2676       top = scm_c_memq (scm_class_top, cpl);
2677       if (scm_is_false (top))
2678         abort ();
2679       else
2680         {
2681           SCM_SETCAR (top, scm_class_applicable);
2682           SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
2683         }
2684       /* add class to direct-subclasses of scm_class_applicable */
2685       SCM_SET_SLOT (scm_class_applicable,
2686                     scm_si_direct_subclasses,
2687                     scm_cons (c, SCM_SLOT (scm_class_applicable,
2688                                            scm_si_direct_subclasses)));
2689     }
2690 }
2691
2692 static void
2693 create_smob_classes (void)
2694 {
2695   long i;
2696
2697   scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
2698   for (i = 0; i < 255; ++i)
2699     scm_smob_class[i] = 0;
2700
2701   scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
2702
2703   for (i = 0; i < scm_numsmob; ++i)
2704     if (!scm_smob_class[i])
2705       scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
2706                                                    scm_smobs[i].apply != 0);
2707 }
2708
2709 void
2710 scm_make_port_classes (long ptobnum, char *type_name)
2711 {
2712   SCM c, class = make_class_from_template ("<%s-port>",
2713                                            type_name,
2714                                            scm_list_1 (scm_class_port),
2715                                            0);
2716   scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
2717     = make_class_from_template ("<%s-input-port>",
2718                                 type_name,
2719                                 scm_list_2 (class, scm_class_input_port),
2720                                 0);
2721   scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
2722     = make_class_from_template ("<%s-output-port>",
2723                                 type_name,
2724                                 scm_list_2 (class, scm_class_output_port),
2725                                 0);
2726   scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
2727     = c
2728     = make_class_from_template ("<%s-input-output-port>",
2729                                 type_name,
2730                                 scm_list_2 (class, scm_class_input_output_port),
2731                                 0);
2732   /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2733   SCM_SET_SLOT (c, scm_si_cpl,
2734                 scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
2735 }
2736
2737 static void
2738 create_port_classes (void)
2739 {
2740   long i;
2741
2742   scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM));
2743   for (i = 0; i < 3 * 256; ++i)
2744     scm_port_class[i] = 0;
2745
2746   for (i = 0; i < scm_numptob; ++i)
2747     scm_make_port_classes (i, SCM_PTOBNAME (i));
2748 }
2749
2750 static SCM
2751 make_struct_class (void *closure SCM_UNUSED,
2752                    SCM vtable, SCM data, SCM prev SCM_UNUSED)
2753 {
2754   if (scm_is_true (SCM_STRUCT_TABLE_NAME (data)))
2755     SCM_SET_STRUCT_TABLE_CLASS (data,
2756                                 scm_make_extended_class
2757                                 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)),
2758                                  SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
2759   return SCM_UNSPECIFIED;
2760 }
2761
2762 static void
2763 create_struct_classes (void)
2764 {
2765   scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
2766 }
2767
2768 /**********************************************************************
2769  *
2770  * C interface
2771  *
2772  **********************************************************************/
2773
2774 void
2775 scm_load_goops ()
2776 {
2777   if (!goops_loaded_p)
2778     scm_c_resolve_module ("oop goops");
2779 }
2780
2781
2782 SCM
2783 scm_make_foreign_object (SCM class, SCM initargs)
2784 #define FUNC_NAME s_scm_make
2785 {
2786   void * (*constructor) (SCM)
2787     = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor);
2788   if (constructor == 0)
2789     SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2790   return scm_wrap_object (class, constructor (initargs));
2791 }
2792 #undef FUNC_NAME
2793
2794
2795 static size_t
2796 scm_free_foreign_object (SCM *class, SCM *data)
2797 {
2798   size_t (*destructor) (void *)
2799     = (size_t (*) (void *)) class[scm_si_destructor];
2800   return destructor (data);
2801 }
2802
2803 SCM
2804 scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
2805                 void * (*constructor) (SCM initargs),
2806                 size_t (*destructor) (void *))
2807 {
2808   SCM name, class;
2809   name = scm_from_locale_symbol (s_name);
2810   if (scm_is_null (supers))
2811     supers = scm_list_1 (scm_class_foreign_object);
2812   class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
2813   scm_sys_inherit_magic_x (class, supers);
2814
2815   if (destructor != 0)
2816     {
2817       SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
2818       SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
2819     }
2820   else if (size > 0)
2821     {
2822       SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
2823       SCM_SET_CLASS_INSTANCE_SIZE (class, size);
2824     }
2825
2826   SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
2827   SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
2828
2829   return class;
2830 }
2831
2832 SCM_SYMBOL (sym_o, "o");
2833 SCM_SYMBOL (sym_x, "x");
2834
2835 SCM_KEYWORD (k_accessor, "accessor");
2836 SCM_KEYWORD (k_getter, "getter");
2837
2838 static SCM
2839 default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
2840 {
2841   scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
2842   return 0;
2843 }
2844
2845 void
2846 scm_add_slot (SCM class, char *slot_name, SCM slot_class,
2847               SCM (*getter) (SCM obj),
2848               SCM (*setter) (SCM obj, SCM x),
2849               char *accessor_name)
2850 {
2851   {
2852     SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter);
2853     SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2,
2854                                setter ? setter : default_setter);
2855
2856     /* Dirk:FIXME:: The following two expressions make use of the fact that
2857      * the memoizer will accept a subr-object in the place of a function.
2858      * This is not guaranteed to stay this way.  */
2859     SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2860                                          scm_list_1 (sym_o),
2861                                          scm_list_2 (get, sym_o)),
2862                              SCM_EOL);
2863     SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2864                                          scm_list_2 (sym_o, sym_x),
2865                                          scm_list_3 (set, sym_o, sym_x)),
2866                              SCM_EOL);
2867
2868     {
2869       SCM name = scm_from_locale_symbol (slot_name);
2870       SCM aname = scm_from_locale_symbol (accessor_name);
2871       SCM gf = scm_ensure_accessor (aname);
2872       SCM slot = scm_list_5 (name,
2873                              k_class,
2874                              slot_class,
2875                              setter ? k_accessor : k_getter,
2876                              gf);
2877       scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
2878                                                 k_specializers,
2879                                                 scm_list_1 (class),
2880                                                 k_procedure,
2881                                                 getm)));
2882       scm_add_method (scm_setter (gf),
2883                       scm_make (scm_list_5 (scm_class_accessor_method,
2884                                             k_specializers,
2885                                             scm_list_2 (class, scm_class_top),
2886                                             k_procedure,
2887                                             setm)));
2888       DEFVAR (aname, gf);
2889
2890       SCM_SET_SLOT (class, scm_si_slots,
2891                     scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
2892                                               scm_list_1 (slot))));
2893       {
2894         SCM n = SCM_SLOT (class, scm_si_nfields);
2895         SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
2896                               SCM_UNDEFINED);
2897         SCM_SET_SLOT (class, scm_si_getters_n_setters,
2898                       scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
2899                                                 scm_list_1 (gns))));
2900         SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1)));
2901       }
2902     }
2903   }
2904 }
2905
2906 SCM
2907 scm_wrap_object (SCM class, void *data)
2908 {
2909   return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
2910                           (scm_t_bits) data,
2911                           0, 0);
2912 }
2913
2914 SCM scm_components;
2915
2916 SCM
2917 scm_wrap_component (SCM class, SCM container, void *data)
2918 {
2919   SCM obj = scm_wrap_object (class, data);
2920   SCM handle = scm_hash_fn_create_handle_x (scm_components,
2921                                             obj,
2922                                             SCM_BOOL_F,
2923                                             scm_struct_ihashq,
2924                                             scm_sloppy_assq,
2925                                             0);
2926   SCM_SETCDR (handle, container);
2927   return obj;
2928 }
2929
2930 SCM
2931 scm_ensure_accessor (SCM name)
2932 {
2933   SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
2934   if (!SCM_IS_A_P (gf, scm_class_accessor))
2935     {
2936       gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
2937       gf = scm_make (scm_list_5 (scm_class_accessor,
2938                                  k_name, name, k_setter, gf));
2939     }
2940   return gf;
2941 }
2942
2943 SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!");
2944
2945 void
2946 scm_add_method (SCM gf, SCM m)
2947 {
2948   scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops);
2949 }
2950
2951 #ifdef GUILE_DEBUG
2952 /*
2953  * Debugging utilities
2954  */
2955
2956 SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0,
2957             (SCM obj),
2958             "Return @code{#t} if @var{obj} is a pure generic.")
2959 #define FUNC_NAME s_scm_pure_generic_p
2960 {
2961   return scm_from_bool (SCM_PUREGENERICP (obj));
2962 }
2963 #undef FUNC_NAME
2964
2965 #endif /* GUILE_DEBUG */
2966
2967 /*
2968  * Initialization
2969  */
2970
2971 SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
2972             (),
2973             "Announce that GOOPS is loaded and perform initialization\n"
2974             "on the C level which depends on the loaded GOOPS modules.")
2975 #define FUNC_NAME s_scm_sys_goops_loaded
2976 {
2977   goops_loaded_p = 1;
2978   var_compute_applicable_methods =
2979     scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
2980                  SCM_BOOL_F);
2981   setup_extended_primitive_generics ();
2982   return SCM_UNSPECIFIED;
2983 }
2984 #undef FUNC_NAME
2985
2986 SCM scm_module_goops;
2987
2988 SCM
2989 scm_init_goops_builtins (void)
2990 {
2991   scm_module_goops = scm_current_module ();
2992   scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
2993
2994   /* Not really necessary right now, but who knows...
2995    */
2996   scm_permanent_object (scm_module_goops);
2997   scm_permanent_object (scm_goops_lookup_closure);
2998
2999   scm_components = scm_permanent_object (scm_make_weak_key_hash_table
3000                                          (scm_from_int (37)));
3001
3002   goops_rstate = scm_c_make_rstate ("GOOPS", 5);
3003
3004 #include "libguile/goops.x"
3005
3006   list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
3007
3008   hell = scm_calloc (hell_size * sizeof (*hell));
3009   hell_mutex = scm_permanent_object (scm_make_mutex ());
3010
3011   create_basic_classes ();
3012   create_standard_classes ();
3013   create_smob_classes ();
3014   create_struct_classes ();
3015   create_port_classes ();
3016
3017   {
3018     SCM name = scm_from_locale_symbol ("no-applicable-method");
3019     scm_no_applicable_method
3020       = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic,
3021                                                     k_name,
3022                                                     name)));
3023     DEFVAR (name, scm_no_applicable_method);
3024   }
3025
3026   return SCM_UNSPECIFIED;
3027 }
3028
3029 void
3030 scm_init_goops ()
3031 {
3032   scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3033                       scm_init_goops_builtins);
3034 }
3035
3036 /*
3037   Local Variables:
3038   c-file-style: "gnu"
3039   End:
3040 */