libguile/goops.c

   1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
   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 License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * 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
  17  * 02110-1301 USA
  18  */
  19 \f
  20
  21 /* This software is a derivative work of other copyrighted softwares; the
  22  * copyright notices of these softwares are placed in the file COPYRIGHTS
  23  *
  24  * This file is based upon stklos.c from the STk distribution by
  25  * Erick Gallesio <eg@unice.fr>.
  26  */
  27
  28 #ifdef HAVE_CONFIG_H
  29 # include <config.h>
  30 #endif
  31
  32 #include "libguile/_scm.h"
  33 #include "libguile/async.h"
  34 #include "libguile/chars.h"
  35 #include "libguile/dynwind.h"
  36 #include "libguile/eval.h"
  37 #include "libguile/gsubr.h"
  38 #include "libguile/hashtab.h"
  39 #include "libguile/keywords.h"
  40 #include "libguile/macros.h"
  41 #include "libguile/modules.h"
  42 #include "libguile/ports.h"
  43 #include "libguile/procprop.h"
  44 #include "libguile/programs.h"
  45 #include "libguile/smob.h"
  46 #include "libguile/strings.h"
  47 #include "libguile/strports.h"
  48 #include "libguile/vectors.h"
  49
  50 #include "libguile/validate.h"
  51 #include "libguile/goops.h"
  52
  53 /* Port classes */
  54 #define SCM_IN_PCLASS_INDEX       0
  55 #define SCM_OUT_PCLASS_INDEX      SCM_I_MAX_PORT_TYPE_COUNT
  56 #define SCM_INOUT_PCLASS_INDEX    (2 * SCM_I_MAX_PORT_TYPE_COUNT)
  57
  58 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
  59 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
  60
  61 /* Objects have identity, so references to classes and instances are by
  62    value, not by reference.  Redefinition of a class or modification of
  63    an instance causes in-place update; you can think of GOOPS as
  64    building in its own indirection, and for that reason referring to
  65    GOOPS values by variable reference is unnecessary.
  66
  67    References to ordinary procedures is by reference (by variable),
  68    though, as in the rest of Guile.  */
  69
  70 static int goops_loaded_p = 0;
  71
  72 static SCM var_make_standard_class = SCM_BOOL_F;
  73 static SCM var_change_class = SCM_BOOL_F;
  74 static SCM var_make = SCM_BOOL_F;
  75 static SCM var_class_name = SCM_BOOL_F;
  76 static SCM var_class_direct_supers = SCM_BOOL_F;
  77 static SCM var_class_direct_slots = SCM_BOOL_F;
  78 static SCM var_class_direct_subclasses = SCM_BOOL_F;
  79 static SCM var_class_direct_methods = SCM_BOOL_F;
  80 static SCM var_class_precedence_list = SCM_BOOL_F;
  81 static SCM var_class_slots = SCM_BOOL_F;
  82
  83 static SCM var_generic_function_methods = SCM_BOOL_F;
  84 static SCM var_method_generic_function = SCM_BOOL_F;
  85 static SCM var_method_specializers = SCM_BOOL_F;
  86 static SCM var_method_procedure = SCM_BOOL_F;
  87
  88 static SCM var_slot_ref_using_class = SCM_BOOL_F;
  89 static SCM var_slot_set_using_class_x = SCM_BOOL_F;
  90 static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
  91 static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
  92
  93 static SCM var_slot_ref = SCM_BOOL_F;
  94 static SCM var_slot_set_x = SCM_BOOL_F;
  95 static SCM var_slot_bound_p = SCM_BOOL_F;
  96 static SCM var_slot_exists_p = SCM_BOOL_F;
  97
  98 /* These variables are filled in by the object system when loaded. */
  99 static SCM class_boolean, class_char, class_pair;
 100 static SCM class_procedure, class_string, class_symbol;
 101 static SCM class_primitive_generic;
 102 static SCM class_vector, class_null;
 103 static SCM class_integer, class_real, class_complex, class_fraction;
 104 static SCM class_unknown;
 105 static SCM class_top, class_object, class_class;
 106 static SCM class_applicable;
 107 static SCM class_applicable_struct, class_applicable_struct_with_setter;
 108 static SCM class_generic, class_generic_with_setter;
 109 static SCM class_accessor;
 110 static SCM class_extended_generic, class_extended_generic_with_setter;
 111 static SCM class_extended_accessor;
 112 static SCM class_method;
 113 static SCM class_accessor_method;
 114 static SCM class_procedure_class;
 115 static SCM class_applicable_struct_class;
 116 static SCM class_applicable_struct_with_setter_class;
 117 static SCM class_number, class_list;
 118 static SCM class_keyword;
 119 static SCM class_port, class_input_output_port;
 120 static SCM class_input_port, class_output_port;
 121 static SCM class_foreign_slot;
 122 static SCM class_self, class_protected;
 123 static SCM class_hidden, class_opaque, class_read_only;
 124 static SCM class_protected_hidden, class_protected_opaque, class_protected_read_only;
 125 static SCM class_scm;
 126 static SCM class_int, class_float, class_double;
 127
 128 static SCM class_foreign;
 129 static SCM class_hashtable;
 130 static SCM class_fluid;
 131 static SCM class_dynamic_state;
 132 static SCM class_frame;
 133 static SCM class_vm_cont;
 134 static SCM class_bytevector;
 135 static SCM class_uvec;
 136 static SCM class_array;
 137 static SCM class_bitvector;
 138
 139 static SCM vtable_class_map = SCM_BOOL_F;
 140
 141 /* Port classes.  Allocate 3 times the maximum number of port types so that
 142    input ports, output ports, and in/out ports can be stored at different
 143    offsets.  See `SCM_IN_PCLASS_INDEX' et al.  */
 144 SCM scm_i_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT];
 145
 146 /* SMOB classes.  */
 147 SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
 148
 149 static SCM scm_make_unbound (void);
 150 static SCM scm_unbound_p (SCM obj);
 151 static SCM scm_class_p (SCM obj);
 152 static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable,
 153                                                       SCM setter);
 154 static SCM scm_sys_make_root_class (SCM name, SCM dslots,
 155                                     SCM getters_n_setters);
 156 static SCM scm_sys_init_layout_x (SCM class, SCM layout);
 157 static SCM scm_sys_goops_early_init (void);
 158 static SCM scm_sys_goops_loaded (void);
 159
 160
 161 /* This function is used for efficient type dispatch.  */
 162 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 163             (SCM x),
 164             "Return the class of @var{x}.")
 165 #define FUNC_NAME s_scm_class_of
 166 {
 167   switch (SCM_ITAG3 (x))
 168     {
 169     case scm_tc3_int_1:
 170     case scm_tc3_int_2:
 171       return class_integer;
 172
 173     case scm_tc3_imm24:
 174       if (SCM_CHARP (x))
 175         return class_char;
 176       else if (scm_is_bool (x))
 177         return class_boolean;
 178       else if (scm_is_null (x))
 179         return class_null;
 180       else
 181         return class_unknown;
 182
 183     case scm_tc3_cons:
 184       switch (SCM_TYP7 (x))
 185         {
 186         case scm_tcs_cons_nimcar:
 187           return class_pair;
 188         case scm_tc7_symbol:
 189           return class_symbol;
 190         case scm_tc7_vector:
 191         case scm_tc7_wvect:
 192           return class_vector;
 193         case scm_tc7_pointer:
 194           return class_foreign;
 195         case scm_tc7_hashtable:
 196           return class_hashtable;
 197         case scm_tc7_fluid:
 198           return class_fluid;
 199         case scm_tc7_dynamic_state:
 200           return class_dynamic_state;
 201         case scm_tc7_frame:
 202           return class_frame;
 203         case scm_tc7_keyword:
 204           return class_keyword;
 205         case scm_tc7_vm_cont:
 206           return class_vm_cont;
 207         case scm_tc7_bytevector:
 208           if (SCM_BYTEVECTOR_ELEMENT_TYPE (x) == SCM_ARRAY_ELEMENT_TYPE_VU8)
 209             return class_bytevector;
 210           else
 211             return class_uvec;
 212         case scm_tc7_array:
 213           return class_array;
 214         case scm_tc7_bitvector:
 215           return class_bitvector;
 216         case scm_tc7_string:
 217           return class_string;
 218         case scm_tc7_number:
 219           switch SCM_TYP16 (x) {
 220           case scm_tc16_big:
 221             return class_integer;
 222           case scm_tc16_real:
 223             return class_real;
 224           case scm_tc16_complex:
 225             return class_complex;
 226           case scm_tc16_fraction:
 227             return class_fraction;
 228           }
 229         case scm_tc7_program:
 230           if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
 231               && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
 232             return class_primitive_generic;
 233           else
 234             return class_procedure;
 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_i_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_i_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             return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
 264         default:
 265           if (scm_is_pair (x))
 266             return class_pair;
 267           else
 268             return class_unknown;
 269         }
 270
 271     case scm_tc3_struct:
 272     case scm_tc3_tc7_1:
 273     case scm_tc3_tc7_2:
 274       /* case scm_tc3_unused: */
 275       /* Never reached */
 276       break;
 277     }
 278   return class_unknown;
 279 }
 280 #undef FUNC_NAME
 281
 282 /******************************************************************************
 283  *
 284  * initialize-object
 285  *
 286  ******************************************************************************/
 287
 288 /*fixme* Manufacture keywords in advance */
 289 SCM
 290 scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr)
 291 {
 292   long i;
 293
 294   for (i = 0; i != len; i += 2)
 295     {
 296       SCM obj = SCM_CAR (l);
 297
 298       if (!scm_is_keyword (obj))
 299         scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
 300       else if (scm_is_eq (obj, key))
 301         return SCM_CADR (l);
 302       else
 303         l = SCM_CDDR (l);
 304     }
 305
 306   return default_value;
 307 }
 308
 309
 310 SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
 311             (SCM key, SCM l, SCM default_value),
 312             "Determine an associated value for the keyword @var{key} from\n"
 313             "the list @var{l}.  The list @var{l} has to consist of an even\n"
 314             "number of elements, where, starting with the first, every\n"
 315             "second element is a keyword, followed by its associated value.\n"
 316             "If @var{l} does not hold a value for @var{key}, the value\n"
 317             "@var{default_value} is returned.")
 318 #define FUNC_NAME s_scm_get_keyword
 319 {
 320   long len;
 321
 322   SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME);
 323   len = scm_ilength (l);
 324   if (len < 0 || len % 2 == 1)
 325     scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l));
 326
 327   return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
 328 }
 329 #undef FUNC_NAME
 330
 331
 332 SCM_KEYWORD (k_init_keyword, "init-keyword");
 333
 334
 335 SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
 336             (SCM obj, SCM initargs),
 337             "Initialize the object @var{obj} with the given arguments\n"
 338             "@var{initargs}.")
 339 #define FUNC_NAME s_scm_sys_initialize_object
 340 {
 341   SCM tmp, get_n_set, slots;
 342   SCM class       = SCM_CLASS_OF (obj);
 343   long n_initargs;
 344
 345   SCM_VALIDATE_INSTANCE (1, obj);
 346   n_initargs = scm_ilength (initargs);
 347   SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
 348
 349   get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
 350   slots     = SCM_SLOT (class, scm_si_slots);
 351
 352   /* See for each slot how it must be initialized */
 353   for (;
 354        !scm_is_null (slots);
 355        get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
 356     {
 357       SCM slot_name  = SCM_CAR (slots);
 358       SCM slot_value = SCM_GOOPS_UNBOUND;
 359
 360       if (!scm_is_null (SCM_CDR (slot_name)))
 361         {
 362           /* This slot admits (perhaps) to be initialized at creation time */
 363           long n = scm_ilength (SCM_CDR (slot_name));
 364           if (n & 1) /* odd or -1 */
 365             SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
 366                             scm_list_1 (slot_name));
 367           tmp   = scm_i_get_keyword (k_init_keyword,
 368                                      SCM_CDR (slot_name),
 369                                      n,
 370                                      SCM_PACK (0),
 371                                      FUNC_NAME);
 372           slot_name = SCM_CAR (slot_name);
 373           if (SCM_UNPACK (tmp))
 374             {
 375               /* an initarg was provided for this slot */
 376               if (!scm_is_keyword (tmp))
 377                 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
 378                                 scm_list_1 (tmp));
 379               slot_value = scm_i_get_keyword (tmp,
 380                                               initargs,
 381                                               n_initargs,
 382                                               SCM_GOOPS_UNBOUND,
 383                                               FUNC_NAME);
 384             }
 385         }
 386
 387       if (!SCM_GOOPS_UNBOUNDP (slot_value))
 388         /* set slot to provided value */
 389         scm_slot_set_x (obj, slot_name, slot_value);
 390       else
 391         {
 392           /* set slot to its :init-form if it exists */
 393           tmp = SCM_CADAR (get_n_set);
 394           if (scm_is_true (tmp))
 395             scm_slot_set_x (obj, slot_name, scm_call_0 (tmp));
 396         }
 397     }
 398
 399   return obj;
 400 }
 401 #undef FUNC_NAME
 402
 403 SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
 404             (SCM class, SCM layout),
 405             "")
 406 #define FUNC_NAME s_scm_sys_init_layout_x
 407 {
 408   SCM_VALIDATE_INSTANCE (1, class);
 409   SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME);
 410   SCM_VALIDATE_STRING (2, layout);
 411
 412   SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
 413   return SCM_UNSPECIFIED;
 414 }
 415 #undef FUNC_NAME
 416
 417 SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
 418             (SCM class, SCM dsupers),
 419             "")
 420 #define FUNC_NAME s_scm_sys_inherit_magic_x
 421 {
 422   SCM_VALIDATE_INSTANCE (1, class);
 423   scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
 424   SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
 425
 426   return SCM_UNSPECIFIED;
 427 }
 428 #undef FUNC_NAME
 429
 430 /******************************************************************************/
 431
 432 SCM
 433 scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
 434 {
 435   return scm_call_4 (scm_variable_ref (var_make_standard_class),
 436                      meta, name, dsupers, dslots);
 437 }
 438
 439 /******************************************************************************/
 440
 441 SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 3, 0, 0,
 442             (SCM name, SCM dslots, SCM getters_n_setters),
 443             "")
 444 #define FUNC_NAME s_scm_sys_make_root_class
 445 {
 446   SCM cs, z;
 447
 448   cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
 449   z = scm_i_make_vtable_vtable (cs);
 450   SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID
 451                            | SCM_CLASSF_METACLASS));
 452
 453   SCM_SET_SLOT (z, scm_vtable_index_name, name);
 454   SCM_SET_SLOT (z, scm_si_direct_supers, SCM_EOL);  /* will be changed */
 455   SCM_SET_SLOT (z, scm_si_direct_slots, dslots); /* will be changed */
 456   SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
 457   SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
 458   SCM_SET_SLOT (z, scm_si_cpl, SCM_EOL);  /* will be changed */
 459   SCM_SET_SLOT (z, scm_si_slots, dslots); /* will be changed */
 460   SCM_SET_SLOT (z, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
 461   SCM_SET_SLOT (z, scm_si_getters_n_setters, getters_n_setters); /* will be changed */
 462   SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
 463
 464   return z;
 465 }
 466 #undef FUNC_NAME
 467
 468 /******************************************************************************/
 469
 470 SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
 471             (SCM obj),
 472             "Return @code{#t} if @var{obj} is an instance.")
 473 #define FUNC_NAME s_scm_instance_p
 474 {
 475   return scm_from_bool (SCM_INSTANCEP (obj));
 476 }
 477 #undef FUNC_NAME
 478
 479 SCM_DEFINE (scm_class_p, "class?", 1, 0, 0,
 480             (SCM obj),
 481             "Return @code{#t} if @var{obj} is a class.")
 482 #define FUNC_NAME s_scm_class_p
 483 {
 484   return scm_from_bool (SCM_CLASSP (obj));
 485 }
 486 #undef FUNC_NAME
 487
 488 int
 489 scm_is_generic (SCM x)
 490 {
 491   return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_generic);
 492 }
 493
 494 int
 495 scm_is_method (SCM x)
 496 {
 497   return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method);
 498 }
 499
 500 /******************************************************************************
 501  *
 502  * Meta object accessors
 503  *
 504  ******************************************************************************/
 505
 506 SCM
 507 scm_class_name (SCM obj)
 508 {
 509   return scm_call_1 (scm_variable_ref (var_class_name), obj);
 510 }
 511
 512 SCM
 513 scm_class_direct_supers (SCM obj)
 514 {
 515   return scm_call_1 (scm_variable_ref (var_class_direct_supers), obj);
 516 }
 517
 518 SCM
 519 scm_class_direct_slots (SCM obj)
 520 {
 521   return scm_call_1 (scm_variable_ref (var_class_direct_slots), obj);
 522 }
 523
 524 SCM
 525 scm_class_direct_subclasses (SCM obj)
 526 {
 527   return scm_call_1 (scm_variable_ref (var_class_direct_subclasses), obj);
 528 }
 529
 530 SCM
 531 scm_class_direct_methods (SCM obj)
 532 {
 533   return scm_call_1 (scm_variable_ref (var_class_direct_methods), obj);
 534 }
 535
 536 SCM
 537 scm_class_precedence_list (SCM obj)
 538 {
 539   return scm_call_1 (scm_variable_ref (var_class_precedence_list), obj);
 540 }
 541
 542 SCM
 543 scm_class_slots (SCM obj)
 544 {
 545   return scm_call_1 (scm_variable_ref (var_class_slots), obj);
 546 }
 547
 548 SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
 549             (SCM obj),
 550             "Return the name of the generic function @var{obj}.")
 551 #define FUNC_NAME s_scm_generic_function_name
 552 {
 553   SCM_VALIDATE_GENERIC (1, obj);
 554   return scm_procedure_property (obj, scm_sym_name);
 555 }
 556 #undef FUNC_NAME
 557
 558 SCM
 559 scm_generic_function_methods (SCM obj)
 560 {
 561   return scm_call_1 (scm_variable_ref (var_generic_function_methods), obj);
 562 }
 563
 564 SCM
 565 scm_method_generic_function (SCM obj)
 566 {
 567   return scm_call_1 (scm_variable_ref (var_method_generic_function), obj);
 568 }
 569
 570 SCM
 571 scm_method_specializers (SCM obj)
 572 {
 573   return scm_call_1 (scm_variable_ref (var_method_specializers), obj);
 574 }
 575
 576 SCM
 577 scm_method_procedure (SCM obj)
 578 {
 579   return scm_call_1 (scm_variable_ref (var_method_procedure), obj);
 580 }
 581
 582 /******************************************************************************
 583  *
 584  * S l o t   a c c e s s
 585  *
 586  ******************************************************************************/
 587
 588 SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
 589             (),
 590             "Return the unbound value.")
 591 #define FUNC_NAME s_scm_make_unbound
 592 {
 593   return SCM_GOOPS_UNBOUND;
 594 }
 595 #undef FUNC_NAME
 596
 597 SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
 598             (SCM obj),
 599             "Return @code{#t} if @var{obj} is unbound.")
 600 #define FUNC_NAME s_scm_unbound_p
 601 {
 602   return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
 603 }
 604 #undef FUNC_NAME
 605
 606
 607 \f
 608
 609 SCM
 610 scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
 611 {
 612   return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
 613                      class, obj, slot_name);
 614 }
 615
 616 SCM
 617 scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
 618 {
 619   return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
 620                      class, obj, slot_name, value);
 621 }
 622
 623 SCM
 624 scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
 625 {
 626   return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
 627                      class, obj, slot_name);
 628 }
 629
 630 SCM
 631 scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
 632 {
 633   return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
 634                      class, obj, slot_name);
 635 }
 636
 637 SCM
 638 scm_slot_ref (SCM obj, SCM slot_name)
 639 {
 640   return scm_call_2 (scm_variable_ref (var_slot_ref), obj, slot_name);
 641 }
 642
 643 SCM
 644 scm_slot_set_x (SCM obj, SCM slot_name, SCM value)
 645 {
 646   return scm_call_3 (scm_variable_ref (var_slot_set_x), obj, slot_name, value);
 647 }
 648
 649 SCM
 650 scm_slot_bound_p (SCM obj, SCM slot_name)
 651 {
 652   return scm_call_2 (scm_variable_ref (var_slot_bound_p), obj, slot_name);
 653 }
 654
 655 SCM
 656 scm_slot_exists_p (SCM obj, SCM slot_name)
 657 {
 658   return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name);
 659 }
 660
 661
 662 /******************************************************************************
 663  *
 664  * %allocate-instance (the low level instance allocation primitive)
 665  *
 666  ******************************************************************************/
 667
 668 SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
 669             (SCM class, SCM initargs),
 670             "Create a new instance of class @var{class} and initialize it\n"
 671             "from the arguments @var{initargs}.")
 672 #define FUNC_NAME s_scm_sys_allocate_instance
 673 {
 674   SCM obj;
 675   scm_t_signed_bits n, i;
 676   SCM layout;
 677
 678   SCM_VALIDATE_CLASS (1, class);
 679
 680   /* FIXME: duplicates some of scm_make_struct. */
 681
 682   n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
 683   obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n);
 684
 685   layout = SCM_VTABLE_LAYOUT (class);
 686
 687   /* Set all SCM-holding slots to unbound */
 688   for (i = 0; i < n; i++)
 689     {
 690       scm_t_wchar c = scm_i_symbol_ref (layout, i*2);
 691       if (c == 'p')
 692         SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND);
 693       else if (c == 's')
 694         SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj);
 695       else
 696         SCM_STRUCT_DATA (obj)[i] = 0;
 697     }
 698
 699   return obj;
 700 }
 701 #undef FUNC_NAME
 702
 703 /******************************************************************************
 704  *
 705  * %modify-instance (used by change-class to modify in place)
 706  *
 707  ******************************************************************************/
 708
 709 SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
 710             (SCM old, SCM new),
 711             "")
 712 #define FUNC_NAME s_scm_sys_modify_instance
 713 {
 714   SCM_VALIDATE_INSTANCE (1, old);
 715   SCM_VALIDATE_INSTANCE (2, new);
 716
 717   /* Exchange the data contained in old and new. We exchange rather than
 718    * scratch the old value with new to be correct with GC.
 719    * See "Class redefinition protocol above".
 720    */
 721   SCM_CRITICAL_SECTION_START;
 722   {
 723     scm_t_bits word0, word1;
 724     word0 = SCM_CELL_WORD_0 (old);
 725     word1 = SCM_CELL_WORD_1 (old);
 726     SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
 727     SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
 728     SCM_SET_CELL_WORD_0 (new, word0);
 729     SCM_SET_CELL_WORD_1 (new, word1);
 730   }
 731   SCM_CRITICAL_SECTION_END;
 732   return SCM_UNSPECIFIED;
 733 }
 734 #undef FUNC_NAME
 735
 736 SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
 737             (SCM old, SCM new),
 738             "")
 739 #define FUNC_NAME s_scm_sys_modify_class
 740 {
 741   SCM_VALIDATE_CLASS (1, old);
 742   SCM_VALIDATE_CLASS (2, new);
 743
 744   SCM_CRITICAL_SECTION_START;
 745   {
 746     scm_t_bits word0, word1;
 747     word0 = SCM_CELL_WORD_0 (old);
 748     word1 = SCM_CELL_WORD_1 (old);
 749     SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
 750     SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
 751     SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
 752     SCM_SET_CELL_WORD_0 (new, word0);
 753     SCM_SET_CELL_WORD_1 (new, word1);
 754     SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
 755   }
 756   SCM_CRITICAL_SECTION_END;
 757   return SCM_UNSPECIFIED;
 758 }
 759 #undef FUNC_NAME
 760
 761 SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
 762             (SCM class),
 763             "")
 764 #define FUNC_NAME s_scm_sys_invalidate_class
 765 {
 766   SCM_VALIDATE_CLASS (1, class);
 767   SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
 768   return SCM_UNSPECIFIED;
 769 }
 770 #undef FUNC_NAME
 771
 772 /* When instances change class, they finally get a new body, but
 773  * before that, they go through purgatory in hell.  Odd as it may
 774  * seem, this data structure saves us from eternal suffering in
 775  * infinite recursions.
 776  */
 777
 778 static scm_t_bits **hell;
 779 static long n_hell = 1;         /* one place for the evil one himself */
 780 static long hell_size = 4;
 781 static SCM hell_mutex;
 782
 783 static long
 784 burnin (SCM o)
 785 {
 786   long i;
 787   for (i = 1; i < n_hell; ++i)
 788     if (SCM_STRUCT_DATA (o) == hell[i])
 789       return i;
 790   return 0;
 791 }
 792
 793 static void
 794 go_to_hell (void *o)
 795 {
 796   SCM obj = *(SCM*)o;
 797   scm_lock_mutex (hell_mutex);
 798   if (n_hell >= hell_size)
 799     {
 800       hell_size *= 2;
 801       hell = scm_realloc (hell, hell_size * sizeof(*hell));
 802     }
 803   hell[n_hell++] = SCM_STRUCT_DATA (obj);
 804   scm_unlock_mutex (hell_mutex);
 805 }
 806
 807 static void
 808 go_to_heaven (void *o)
 809 {
 810   SCM obj = *(SCM*)o;
 811   scm_lock_mutex (hell_mutex);
 812   hell[burnin (obj)] = hell[--n_hell];
 813   scm_unlock_mutex (hell_mutex);
 814 }
 815
 816
 817 static SCM
 818 purgatory (SCM obj, SCM new_class)
 819 {
 820   return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
 821 }
 822
 823 /* This function calls the generic function change-class for all
 824  * instances which aren't currently undergoing class change.
 825  */
 826
 827 void
 828 scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
 829 {
 830   if (!burnin (obj))
 831     {
 832       scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 833       scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY);
 834       scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY);
 835       purgatory (obj, new_class);
 836       scm_dynwind_end ();
 837     }
 838 }
 839
 840 /******************************************************************************
 841  *
 842  *   GGGG                FFFFF
 843  *  G                    F
 844  *  G  GG                FFF
 845  *  G   G                F
 846  *   GGG  E N E R I C    F    U N C T I O N S
 847  *
 848  * This implementation provides
 849  *      - generic functions (with class specializers)
 850  *      - multi-methods
 851  *      - next-method
 852  *      - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
 853  *
 854  ******************************************************************************/
 855
 856 SCM_KEYWORD (k_name, "name");
 857 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
 858
 859 SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
 860             (SCM proc),
 861             "")
 862 #define FUNC_NAME s_scm_generic_capability_p
 863 {
 864   SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
 865               proc, SCM_ARG1, FUNC_NAME);
 866   return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F);
 867 }
 868 #undef FUNC_NAME
 869
 870 SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
 871             (SCM subrs),
 872             "")
 873 #define FUNC_NAME s_scm_enable_primitive_generic_x
 874 {
 875   SCM_VALIDATE_REST_ARGUMENT (subrs);
 876   while (!scm_is_null (subrs))
 877     {
 878       SCM subr = SCM_CAR (subrs);
 879       SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
 880       SCM_SET_SUBR_GENERIC (subr,
 881                             scm_make (scm_list_3 (class_generic,
 882                                                   k_name,
 883                                                   SCM_SUBR_NAME (subr))));
 884       subrs = SCM_CDR (subrs);
 885     }
 886   return SCM_UNSPECIFIED;
 887 }
 888 #undef FUNC_NAME
 889
 890 SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
 891             (SCM subr, SCM generic),
 892             "")
 893 #define FUNC_NAME s_scm_set_primitive_generic_x
 894 {
 895   SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
 896   SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
 897   SCM_SET_SUBR_GENERIC (subr, generic);
 898   return SCM_UNSPECIFIED;
 899 }
 900 #undef FUNC_NAME
 901
 902 SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
 903             (SCM subr),
 904             "")
 905 #define FUNC_NAME s_scm_primitive_generic_generic
 906 {
 907   if (SCM_PRIMITIVE_GENERIC_P (subr))
 908     {
 909       if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr)))
 910         scm_enable_primitive_generic_x (scm_list_1 (subr));
 911       return *SCM_SUBR_GENERIC (subr);
 912     }
 913   SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
 914 }
 915 #undef FUNC_NAME
 916
 917 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
 918  * assumed that 'gf' is zero if uninitialized.  It would be cleaner if
 919  * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
 920  */
 921
 922 SCM
 923 scm_wta_dispatch_0 (SCM gf, const char *subr)
 924 {
 925   if (!SCM_UNPACK (gf))
 926     scm_error_num_args_subr (subr);
 927
 928   return scm_call_0 (gf);
 929 }
 930
 931 SCM
 932 scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr)
 933 {
 934   if (!SCM_UNPACK (gf))
 935     scm_wrong_type_arg (subr, pos, a1);
 936
 937   return scm_call_1 (gf, a1);
 938 }
 939
 940 SCM
 941 scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr)
 942 {
 943   if (!SCM_UNPACK (gf))
 944     scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
 945
 946   return scm_call_2 (gf, a1, a2);
 947 }
 948
 949 SCM
 950 scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
 951 {
 952   if (!SCM_UNPACK (gf))
 953     scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos)));
 954
 955   return scm_apply_0 (gf, args);
 956 }
 957
 958 /******************************************************************************
 959  *
 960  * Protocol for calling a generic fumction
 961  * This protocol is roughly equivalent to (parameter are a little bit different
 962  * for efficiency reasons):
 963  *
 964  *      + apply-generic (gf args)
 965  *              + compute-applicable-methods (gf args ...)
 966  *                      + sort-applicable-methods (methods args)
 967  *              + apply-methods (gf methods args)
 968  *
 969  * apply-methods calls make-next-method to build the "continuation" of a a
 970  * method.  Applying a next-method will call apply-next-method which in
 971  * turn will call  apply again to call effectively the following method.
 972  *
 973  ******************************************************************************/
 974
 975 SCM_DEFINE (scm_make, "make",  0, 0, 1,
 976             (SCM args),
 977             "Make a new object.  @var{args} must contain the class and\n"
 978             "all necessary initialization information.")
 979 #define FUNC_NAME s_scm_make
 980 {
 981   return scm_apply_0 (scm_variable_ref (var_make), args);
 982 }
 983 #undef FUNC_NAME
 984
 985
 986 /**********************************************************************
 987  *
 988  * Smob classes
 989  *
 990  **********************************************************************/
 991
 992 static SCM
 993 make_class_name (const char *prefix, const char *type_name, const char *suffix)
 994 {
 995   if (!type_name)
 996     type_name = "";
 997   return scm_string_to_symbol (scm_string_append
 998                                (scm_list_3 (scm_from_utf8_string (prefix),
 999                                             scm_from_utf8_string (type_name),
1000                                             scm_from_utf8_string (suffix))));
1001 }
1002
1003 SCM
1004 scm_make_extended_class (char const *type_name, int applicablep)
1005 {
1006   SCM name, meta, supers;
1007
1008   name = make_class_name ("<", type_name, ">");
1009   meta = class_class;
1010
1011   if (applicablep)
1012     supers = scm_list_1 (class_applicable);
1013   else
1014     supers = scm_list_1 (class_top);
1015
1016   return scm_make_standard_class (meta, name, supers, SCM_EOL);
1017 }
1018
1019 void
1020 scm_i_inherit_applicable (SCM c)
1021 {
1022   if (!SCM_SUBCLASSP (c, class_applicable))
1023     {
1024       SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
1025       SCM cpl = SCM_SLOT (c, scm_si_cpl);
1026       /* patch class_applicable into direct-supers */
1027       SCM top = scm_c_memq (class_top, dsupers);
1028       if (scm_is_false (top))
1029         dsupers = scm_append (scm_list_2 (dsupers,
1030                                           scm_list_1 (class_applicable)));
1031       else
1032         {
1033           SCM_SETCAR (top, class_applicable);
1034           SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
1035         }
1036       SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
1037       /* patch class_applicable into cpl */
1038       top = scm_c_memq (class_top, cpl);
1039       if (scm_is_false (top))
1040         abort ();
1041       else
1042         {
1043           SCM_SETCAR (top, class_applicable);
1044           SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
1045         }
1046       /* add class to direct-subclasses of class_applicable */
1047       SCM_SET_SLOT (class_applicable,
1048                     scm_si_direct_subclasses,
1049                     scm_cons (c, SCM_SLOT (class_applicable,
1050                                            scm_si_direct_subclasses)));
1051     }
1052 }
1053
1054 static void
1055 create_smob_classes (void)
1056 {
1057   long i;
1058
1059   for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
1060     scm_i_smob_class[i] = SCM_BOOL_F;
1061
1062   for (i = 0; i < scm_numsmob; ++i)
1063     if (scm_is_false (scm_i_smob_class[i]))
1064       scm_i_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
1065                                                      scm_smobs[i].apply != 0);
1066 }
1067
1068 void
1069 scm_make_port_classes (long ptobnum, char *type_name)
1070 {
1071   SCM name, meta, super, supers;
1072
1073   meta = class_class;
1074
1075   name = make_class_name ("<", type_name, "-port>");
1076   supers = scm_list_1 (class_port);
1077   super = scm_make_standard_class (meta, name, supers, SCM_EOL);
1078
1079   name = make_class_name ("<", type_name, "-input-port>");
1080   supers = scm_list_2 (super, class_input_port);
1081   scm_i_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
1082     = scm_make_standard_class (meta, name, supers, SCM_EOL);
1083
1084   name = make_class_name ("<", type_name, "-output-port>");
1085   supers = scm_list_2 (super, class_output_port);
1086   scm_i_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
1087     = scm_make_standard_class (meta, name, supers, SCM_EOL);
1088
1089   name = make_class_name ("<", type_name, "-input-output-port>");
1090   supers = scm_list_2 (super, class_input_output_port);
1091   scm_i_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
1092     = scm_make_standard_class (meta, name, supers, SCM_EOL);
1093 }
1094
1095 static void
1096 create_port_classes (void)
1097 {
1098   long i;
1099
1100   for (i = scm_c_num_port_types () - 1; i >= 0; i--)
1101     scm_make_port_classes (i, SCM_PTOBNAME (i));
1102 }
1103
1104 SCM
1105 scm_i_define_class_for_vtable (SCM vtable)
1106 {
1107   SCM class;
1108
1109   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
1110   if (scm_is_false (vtable_class_map))
1111     vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
1112   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
1113
1114   if (scm_is_false (scm_struct_vtable_p (vtable)))
1115     abort ();
1116
1117   class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
1118
1119   if (scm_is_false (class))
1120     {
1121       if (SCM_UNPACK (class_class))
1122         {
1123           SCM name, meta, supers;
1124
1125           name = SCM_VTABLE_NAME (vtable);
1126           if (scm_is_symbol (name))
1127             name = scm_string_to_symbol
1128               (scm_string_append
1129                (scm_list_3 (scm_from_latin1_string ("<"),
1130                             scm_symbol_to_string (name),
1131                             scm_from_latin1_string (">"))));
1132           else
1133             name = scm_from_latin1_symbol ("<>");
1134
1135           if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER))
1136             {
1137               meta = class_applicable_struct_with_setter_class;
1138               supers = scm_list_1 (class_applicable_struct_with_setter);
1139             }
1140           else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable,
1141                                                   SCM_VTABLE_FLAG_APPLICABLE))
1142             {
1143               meta = class_applicable_struct_class;
1144               supers = scm_list_1 (class_applicable_struct);
1145             }
1146           else
1147             {
1148               meta = class_class;
1149               supers = scm_list_1 (class_top);
1150             }
1151
1152           return scm_make_standard_class (meta, name, supers, SCM_EOL);
1153         }
1154       else
1155         /* `create_struct_classes' will fill this in later.  */
1156         class = SCM_BOOL_F;
1157
1158       /* Don't worry about races.  This only happens when creating a
1159          vtable, which happens by definition in one thread.  */
1160       scm_weak_table_putq_x (vtable_class_map, vtable, class);
1161     }
1162
1163   return class;
1164 }
1165
1166 static SCM
1167 make_struct_class (void *closure SCM_UNUSED,
1168                    SCM vtable, SCM data, SCM prev SCM_UNUSED)
1169 {
1170   if (scm_is_false (data))
1171     scm_i_define_class_for_vtable (vtable);
1172   return SCM_UNSPECIFIED;
1173 }
1174
1175 static void
1176 create_struct_classes (void)
1177 {
1178   /* FIXME: take the vtable_class_map while initializing goops?  */
1179   scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
1180                           vtable_class_map);
1181 }
1182
1183 /**********************************************************************
1184  *
1185  * C interface
1186  *
1187  **********************************************************************/
1188
1189 void
1190 scm_load_goops ()
1191 {
1192   if (!goops_loaded_p)
1193     scm_c_resolve_module ("oop goops");
1194 }
1195
1196
1197 SCM_KEYWORD (k_setter, "setter");
1198
1199 SCM
1200 scm_ensure_accessor (SCM name)
1201 {
1202   SCM var, gf;
1203
1204   var = scm_module_variable (scm_current_module (), name);
1205   if (SCM_VARIABLEP (var) && !SCM_UNBNDP (SCM_VARIABLE_REF (var)))
1206     gf = SCM_VARIABLE_REF (var);
1207   else
1208     gf = SCM_BOOL_F;
1209
1210   if (!SCM_IS_A_P (gf, class_accessor))
1211     {
1212       gf = scm_make (scm_list_3 (class_generic, k_name, name));
1213       gf = scm_make (scm_list_5 (class_accessor,
1214                                  k_name, name, k_setter, gf));
1215     }
1216
1217   return gf;
1218 }
1219
1220 /*
1221  * Initialization
1222  */
1223
1224 SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0,
1225             (SCM applicable, SCM setter),
1226             "")
1227 #define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x
1228 {
1229   SCM_VALIDATE_CLASS (1, applicable);
1230   SCM_VALIDATE_CLASS (2, setter);
1231   SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
1232   SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE);
1233   return SCM_UNSPECIFIED;
1234 }
1235 #undef FUNC_NAME
1236
1237 SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
1238             (),
1239             "")
1240 #define FUNC_NAME s_scm_sys_goops_early_init
1241 {
1242   var_make_standard_class = scm_c_lookup ("make-standard-class");
1243   var_make = scm_c_lookup ("make");
1244
1245   var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
1246   var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
1247   var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
1248   var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
1249
1250   var_slot_ref = scm_c_lookup ("slot-ref");
1251   var_slot_set_x = scm_c_lookup ("slot-set!");
1252   var_slot_bound_p = scm_c_lookup ("slot-bound?");
1253   var_slot_exists_p = scm_c_lookup ("slot-exists?");
1254
1255   class_class = scm_variable_ref (scm_c_lookup ("<class>"));
1256   class_top = scm_variable_ref (scm_c_lookup ("<top>"));
1257   class_object = scm_variable_ref (scm_c_lookup ("<object>"));
1258
1259   class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
1260   class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
1261   class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
1262   class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
1263   class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
1264   class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
1265   class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
1266   class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
1267   class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
1268   class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
1269   class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
1270   class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
1271   class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
1272
1273   /* Applicables */
1274   class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
1275   class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
1276   class_applicable_struct_with_setter_class =
1277     scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>"));
1278
1279   class_method = scm_variable_ref (scm_c_lookup ("<method>"));
1280   class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
1281   class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
1282   class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
1283   class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
1284   class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
1285   class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
1286   class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
1287   class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
1288   class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
1289   class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
1290
1291   /* Primitive types classes */
1292   class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
1293   class_char = scm_variable_ref (scm_c_lookup ("<char>"));
1294   class_list = scm_variable_ref (scm_c_lookup ("<list>"));
1295   class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
1296   class_null = scm_variable_ref (scm_c_lookup ("<null>"));
1297   class_string = scm_variable_ref (scm_c_lookup ("<string>"));
1298   class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
1299   class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
1300   class_foreign = scm_variable_ref (scm_c_lookup ("<foreign>"));
1301   class_hashtable = scm_variable_ref (scm_c_lookup ("<hashtable>"));
1302   class_fluid = scm_variable_ref (scm_c_lookup ("<fluid>"));
1303   class_dynamic_state = scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
1304   class_frame = scm_variable_ref (scm_c_lookup ("<frame>"));
1305   class_vm_cont = scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
1306   class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
1307   class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
1308   class_array = scm_variable_ref (scm_c_lookup ("<array>"));
1309   class_bitvector = scm_variable_ref (scm_c_lookup ("<bitvector>"));
1310   class_number = scm_variable_ref (scm_c_lookup ("<number>"));
1311   class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
1312   class_real = scm_variable_ref (scm_c_lookup ("<real>"));
1313   class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
1314   class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
1315   class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
1316   class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
1317   class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
1318   class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
1319   class_port = scm_variable_ref (scm_c_lookup ("<port>"));
1320   class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
1321   class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
1322   class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
1323
1324   create_smob_classes ();
1325   create_struct_classes ();
1326   create_port_classes ();
1327
1328   return SCM_UNSPECIFIED;
1329 }
1330 #undef FUNC_NAME
1331
1332 SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
1333             (),
1334             "Announce that GOOPS is loaded and perform initialization\n"
1335             "on the C level which depends on the loaded GOOPS modules.")
1336 #define FUNC_NAME s_scm_sys_goops_loaded
1337 {
1338   goops_loaded_p = 1;
1339   var_class_name = scm_c_lookup ("class-name");
1340   var_class_direct_supers = scm_c_lookup ("class-direct-supers");
1341   var_class_direct_slots = scm_c_lookup ("class-direct-slots");
1342   var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses");
1343   var_class_direct_methods = scm_c_lookup ("class-direct-methods");
1344   var_class_precedence_list = scm_c_lookup ("class-precedence-list");
1345   var_class_slots = scm_c_lookup ("class-slots");
1346
1347   var_generic_function_methods = scm_c_lookup ("generic-function-methods");
1348   var_method_generic_function = scm_c_lookup ("method-generic-function");
1349   var_method_specializers = scm_c_lookup ("method-specializers");
1350   var_method_procedure = scm_c_lookup ("method-procedure");
1351
1352   var_change_class = scm_c_lookup ("change-class");
1353
1354 #if (SCM_ENABLE_DEPRECATED == 1)
1355   scm_init_deprecated_goops ();
1356 #endif
1357
1358   return SCM_UNSPECIFIED;
1359 }
1360 #undef FUNC_NAME
1361
1362 SCM scm_module_goops;
1363
1364 static void
1365 scm_init_goops_builtins (void *unused)
1366 {
1367   scm_module_goops = scm_current_module ();
1368
1369   hell = scm_calloc (hell_size * sizeof (*hell));
1370   hell_mutex = scm_make_mutex ();
1371
1372 #include "libguile/goops.x"
1373 }
1374
1375 void
1376 scm_init_goops ()
1377 {
1378   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1379                             "scm_init_goops_builtins", scm_init_goops_builtins,
1380                             NULL);
1381 }
1382
1383 /*
1384   Local Variables:
1385   c-file-style: "gnu"
1386   End:
1387 */