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 SCM_KEYWORD (k_name, "name");
  71 SCM_KEYWORD (k_setter, "setter");
  72 SCM_SYMBOL (sym_redefined, "redefined");
  73 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
  74
  75 static int goops_loaded_p = 0;
  76
  77 static SCM var_make_standard_class = SCM_BOOL_F;
  78 static SCM var_change_class = SCM_BOOL_F;
  79 static SCM var_make = SCM_BOOL_F;
  80 static SCM var_inherit_applicable = SCM_BOOL_F;
  81 static SCM var_class_name = SCM_BOOL_F;
  82 static SCM var_class_direct_supers = SCM_BOOL_F;
  83 static SCM var_class_direct_slots = SCM_BOOL_F;
  84 static SCM var_class_direct_subclasses = SCM_BOOL_F;
  85 static SCM var_class_direct_methods = SCM_BOOL_F;
  86 static SCM var_class_precedence_list = SCM_BOOL_F;
  87 static SCM var_class_slots = SCM_BOOL_F;
  88
  89 static SCM var_generic_function_methods = SCM_BOOL_F;
  90 static SCM var_method_generic_function = SCM_BOOL_F;
  91 static SCM var_method_specializers = SCM_BOOL_F;
  92 static SCM var_method_procedure = SCM_BOOL_F;
  93
  94 static SCM var_slot_ref_using_class = SCM_BOOL_F;
  95 static SCM var_slot_set_using_class_x = SCM_BOOL_F;
  96 static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
  97 static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
  98
  99 static SCM var_slot_ref = SCM_BOOL_F;
 100 static SCM var_slot_set_x = SCM_BOOL_F;
 101 static SCM var_slot_bound_p = SCM_BOOL_F;
 102 static SCM var_slot_exists_p = SCM_BOOL_F;
 103
 104 /* These variables are filled in by the object system when loaded. */
 105 static SCM class_boolean, class_char, class_pair;
 106 static SCM class_procedure, class_string, class_symbol;
 107 static SCM class_primitive_generic;
 108 static SCM class_vector, class_null;
 109 static SCM class_integer, class_real, class_complex, class_fraction;
 110 static SCM class_unknown;
 111 static SCM class_top, class_object, class_class;
 112 static SCM class_applicable;
 113 static SCM class_applicable_struct, class_applicable_struct_with_setter;
 114 static SCM class_generic, class_generic_with_setter;
 115 static SCM class_accessor;
 116 static SCM class_extended_generic, class_extended_generic_with_setter;
 117 static SCM class_extended_accessor;
 118 static SCM class_method;
 119 static SCM class_accessor_method;
 120 static SCM class_procedure_class;
 121 static SCM class_applicable_struct_class;
 122 static SCM class_applicable_struct_with_setter_class;
 123 static SCM class_number, class_list;
 124 static SCM class_keyword;
 125 static SCM class_port, class_input_output_port;
 126 static SCM class_input_port, class_output_port;
 127 static SCM class_foreign_slot;
 128 static SCM class_self, class_protected;
 129 static SCM class_hidden, class_opaque, class_read_only;
 130 static SCM class_protected_hidden, class_protected_opaque, class_protected_read_only;
 131 static SCM class_scm;
 132 static SCM class_int, class_float, class_double;
 133
 134 static SCM class_foreign;
 135 static SCM class_hashtable;
 136 static SCM class_fluid;
 137 static SCM class_dynamic_state;
 138 static SCM class_frame;
 139 static SCM class_vm_cont;
 140 static SCM class_bytevector;
 141 static SCM class_uvec;
 142 static SCM class_array;
 143 static SCM class_bitvector;
 144
 145 static SCM vtable_class_map = SCM_BOOL_F;
 146
 147 /* Port classes.  Allocate 3 times the maximum number of port types so that
 148    input ports, output ports, and in/out ports can be stored at different
 149    offsets.  See `SCM_IN_PCLASS_INDEX' et al.  */
 150 SCM scm_i_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT];
 151
 152 /* SMOB classes.  */
 153 SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
 154
 155 SCM scm_module_goops;
 156
 157 static SCM scm_make_unbound (void);
 158 static SCM scm_unbound_p (SCM obj);
 159 static SCM scm_class_p (SCM obj);
 160 static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable,
 161                                                       SCM setter);
 162 static SCM scm_sys_make_root_class (SCM layout);
 163 static SCM scm_sys_init_layout_x (SCM class, SCM layout);
 164 static SCM scm_sys_clear_fields_x (SCM obj);
 165 static SCM scm_sys_goops_early_init (void);
 166 static SCM scm_sys_goops_loaded (void);
 167
 168
 169 \f
 170
 171 SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0,
 172             (SCM layout),
 173             "")
 174 #define FUNC_NAME s_scm_sys_make_root_class
 175 {
 176   SCM z;
 177
 178   z = scm_i_make_vtable_vtable (layout);
 179   SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS));
 180
 181   return z;
 182 }
 183 #undef FUNC_NAME
 184
 185 SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0,
 186             (SCM applicable, SCM setter),
 187             "")
 188 #define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x
 189 {
 190   SCM_VALIDATE_CLASS (1, applicable);
 191   SCM_VALIDATE_CLASS (2, setter);
 192   SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
 193   SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE);
 194   return SCM_UNSPECIFIED;
 195 }
 196 #undef FUNC_NAME
 197
 198 SCM
 199 scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
 200 {
 201   return scm_call_4 (scm_variable_ref (var_make_standard_class),
 202                      meta, name, dsupers, dslots);
 203 }
 204
 205 SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
 206             (SCM class, SCM layout),
 207             "")
 208 #define FUNC_NAME s_scm_sys_init_layout_x
 209 {
 210   SCM_VALIDATE_INSTANCE (1, class);
 211   SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME);
 212   SCM_VALIDATE_STRING (2, layout);
 213
 214   SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
 215   scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
 216   SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
 217
 218   return SCM_UNSPECIFIED;
 219 }
 220 #undef FUNC_NAME
 221
 222
 223 \f
 224
 225 /* This function is used for efficient type dispatch.  */
 226 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 227             (SCM x),
 228             "Return the class of @var{x}.")
 229 #define FUNC_NAME s_scm_class_of
 230 {
 231   switch (SCM_ITAG3 (x))
 232     {
 233     case scm_tc3_int_1:
 234     case scm_tc3_int_2:
 235       return class_integer;
 236
 237     case scm_tc3_imm24:
 238       if (SCM_CHARP (x))
 239         return class_char;
 240       else if (scm_is_bool (x))
 241         return class_boolean;
 242       else if (scm_is_null (x))
 243         return class_null;
 244       else
 245         return class_unknown;
 246
 247     case scm_tc3_cons:
 248       switch (SCM_TYP7 (x))
 249         {
 250         case scm_tcs_cons_nimcar:
 251           return class_pair;
 252         case scm_tc7_symbol:
 253           return class_symbol;
 254         case scm_tc7_vector:
 255         case scm_tc7_wvect:
 256           return class_vector;
 257         case scm_tc7_pointer:
 258           return class_foreign;
 259         case scm_tc7_hashtable:
 260           return class_hashtable;
 261         case scm_tc7_fluid:
 262           return class_fluid;
 263         case scm_tc7_dynamic_state:
 264           return class_dynamic_state;
 265         case scm_tc7_frame:
 266           return class_frame;
 267         case scm_tc7_keyword:
 268           return class_keyword;
 269         case scm_tc7_vm_cont:
 270           return class_vm_cont;
 271         case scm_tc7_bytevector:
 272           if (SCM_BYTEVECTOR_ELEMENT_TYPE (x) == SCM_ARRAY_ELEMENT_TYPE_VU8)
 273             return class_bytevector;
 274           else
 275             return class_uvec;
 276         case scm_tc7_array:
 277           return class_array;
 278         case scm_tc7_bitvector:
 279           return class_bitvector;
 280         case scm_tc7_string:
 281           return class_string;
 282         case scm_tc7_number:
 283           switch SCM_TYP16 (x) {
 284           case scm_tc16_big:
 285             return class_integer;
 286           case scm_tc16_real:
 287             return class_real;
 288           case scm_tc16_complex:
 289             return class_complex;
 290           case scm_tc16_fraction:
 291             return class_fraction;
 292           }
 293         case scm_tc7_program:
 294           if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
 295               && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
 296             return class_primitive_generic;
 297           else
 298             return class_procedure;
 299
 300         case scm_tc7_smob:
 301           {
 302             scm_t_bits type = SCM_TYP16 (x);
 303             if (type != scm_tc16_port_with_ps)
 304               return scm_i_smob_class[SCM_TC2SMOBNUM (type)];
 305             x = SCM_PORT_WITH_PS_PORT (x);
 306             /* fall through to ports */
 307           }
 308         case scm_tc7_port:
 309           return scm_i_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
 310                                    ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
 311                                       ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
 312                                       : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
 313                                    : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
 314         case scm_tcs_struct:
 315           if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
 316             /* A GOOPS object with a valid class.  */
 317             return SCM_CLASS_OF (x);
 318           else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
 319             /* A GOOPS object whose class might have been redefined.  */
 320             {
 321               SCM class = SCM_CLASS_OF (x);
 322               SCM new_class = scm_slot_ref (class, sym_redefined);
 323               if (!scm_is_false (new_class))
 324                 scm_change_object_class (x, class, new_class);
 325               /* Re-load class from instance.  */
 326               return SCM_CLASS_OF (x);
 327             }
 328           else
 329             return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
 330         default:
 331           if (scm_is_pair (x))
 332             return class_pair;
 333           else
 334             return class_unknown;
 335         }
 336
 337     case scm_tc3_struct:
 338     case scm_tc3_tc7_1:
 339     case scm_tc3_tc7_2:
 340       /* case scm_tc3_unused: */
 341       /* Never reached */
 342       break;
 343     }
 344   return class_unknown;
 345 }
 346 #undef FUNC_NAME
 347
 348
 349 \f
 350
 351 SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
 352             (SCM obj),
 353             "Return @code{#t} if @var{obj} is an instance.")
 354 #define FUNC_NAME s_scm_instance_p
 355 {
 356   return scm_from_bool (SCM_INSTANCEP (obj));
 357 }
 358 #undef FUNC_NAME
 359
 360 SCM_DEFINE (scm_class_p, "class?", 1, 0, 0,
 361             (SCM obj),
 362             "Return @code{#t} if @var{obj} is a class.")
 363 #define FUNC_NAME s_scm_class_p
 364 {
 365   return scm_from_bool (SCM_CLASSP (obj));
 366 }
 367 #undef FUNC_NAME
 368
 369 int
 370 scm_is_generic (SCM x)
 371 {
 372   return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_generic);
 373 }
 374
 375 int
 376 scm_is_method (SCM x)
 377 {
 378   return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method);
 379 }
 380
 381
 382 \f
 383
 384 SCM
 385 scm_class_name (SCM obj)
 386 {
 387   return scm_call_1 (scm_variable_ref (var_class_name), obj);
 388 }
 389
 390 SCM
 391 scm_class_direct_supers (SCM obj)
 392 {
 393   return scm_call_1 (scm_variable_ref (var_class_direct_supers), obj);
 394 }
 395
 396 SCM
 397 scm_class_direct_slots (SCM obj)
 398 {
 399   return scm_call_1 (scm_variable_ref (var_class_direct_slots), obj);
 400 }
 401
 402 SCM
 403 scm_class_direct_subclasses (SCM obj)
 404 {
 405   return scm_call_1 (scm_variable_ref (var_class_direct_subclasses), obj);
 406 }
 407
 408 SCM
 409 scm_class_direct_methods (SCM obj)
 410 {
 411   return scm_call_1 (scm_variable_ref (var_class_direct_methods), obj);
 412 }
 413
 414 SCM
 415 scm_class_precedence_list (SCM obj)
 416 {
 417   return scm_call_1 (scm_variable_ref (var_class_precedence_list), obj);
 418 }
 419
 420 SCM
 421 scm_class_slots (SCM obj)
 422 {
 423   return scm_call_1 (scm_variable_ref (var_class_slots), obj);
 424 }
 425
 426
 427 \f
 428
 429 SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
 430             (SCM obj),
 431             "Return the name of the generic function @var{obj}.")
 432 #define FUNC_NAME s_scm_generic_function_name
 433 {
 434   SCM_VALIDATE_GENERIC (1, obj);
 435   return scm_procedure_property (obj, scm_sym_name);
 436 }
 437 #undef FUNC_NAME
 438
 439 SCM
 440 scm_generic_function_methods (SCM obj)
 441 {
 442   return scm_call_1 (scm_variable_ref (var_generic_function_methods), obj);
 443 }
 444
 445 SCM
 446 scm_method_generic_function (SCM obj)
 447 {
 448   return scm_call_1 (scm_variable_ref (var_method_generic_function), obj);
 449 }
 450
 451 SCM
 452 scm_method_specializers (SCM obj)
 453 {
 454   return scm_call_1 (scm_variable_ref (var_method_specializers), obj);
 455 }
 456
 457 SCM
 458 scm_method_procedure (SCM obj)
 459 {
 460   return scm_call_1 (scm_variable_ref (var_method_procedure), obj);
 461 }
 462
 463
 464 \f
 465
 466 SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
 467             (),
 468             "Return the unbound value.")
 469 #define FUNC_NAME s_scm_make_unbound
 470 {
 471   return SCM_GOOPS_UNBOUND;
 472 }
 473 #undef FUNC_NAME
 474
 475 SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
 476             (SCM obj),
 477             "Return @code{#t} if @var{obj} is unbound.")
 478 #define FUNC_NAME s_scm_unbound_p
 479 {
 480   return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
 481 }
 482 #undef FUNC_NAME
 483
 484
 485 \f
 486
 487 SCM
 488 scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
 489 {
 490   return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
 491                      class, obj, slot_name);
 492 }
 493
 494 SCM
 495 scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
 496 {
 497   return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
 498                      class, obj, slot_name, value);
 499 }
 500
 501 SCM
 502 scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
 503 {
 504   return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
 505                      class, obj, slot_name);
 506 }
 507
 508 SCM
 509 scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
 510 {
 511   return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
 512                      class, obj, slot_name);
 513 }
 514
 515 SCM
 516 scm_slot_ref (SCM obj, SCM slot_name)
 517 {
 518   return scm_call_2 (scm_variable_ref (var_slot_ref), obj, slot_name);
 519 }
 520
 521 SCM
 522 scm_slot_set_x (SCM obj, SCM slot_name, SCM value)
 523 {
 524   return scm_call_3 (scm_variable_ref (var_slot_set_x), obj, slot_name, value);
 525 }
 526
 527 SCM
 528 scm_slot_bound_p (SCM obj, SCM slot_name)
 529 {
 530   return scm_call_2 (scm_variable_ref (var_slot_bound_p), obj, slot_name);
 531 }
 532
 533 SCM
 534 scm_slot_exists_p (SCM obj, SCM slot_name)
 535 {
 536   return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name);
 537 }
 538
 539
 540 \f
 541
 542 SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 1, 0, 0,
 543             (SCM obj),
 544             "")
 545 #define FUNC_NAME s_scm_sys_clear_fields_x
 546 {
 547   scm_t_signed_bits n, i;
 548   SCM vtable, layout;
 549
 550   SCM_VALIDATE_STRUCT (1, obj);
 551   vtable = SCM_STRUCT_VTABLE (obj);
 552
 553   n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
 554   layout = SCM_VTABLE_LAYOUT (vtable);
 555
 556   /* Set all SCM-holding slots to the GOOPS unbound value.  */
 557   for (i = 0; i < n; i++)
 558     if (scm_i_symbol_ref (layout, i*2) == 'p')
 559       SCM_STRUCT_SLOT_SET (obj, i, SCM_GOOPS_UNBOUND);
 560
 561   return SCM_UNSPECIFIED;
 562 }
 563 #undef FUNC_NAME
 564
 565
 566 \f
 567
 568 SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
 569             (SCM old, SCM new),
 570             "Used by change-class to modify objects in place.")
 571 #define FUNC_NAME s_scm_sys_modify_instance
 572 {
 573   SCM_VALIDATE_INSTANCE (1, old);
 574   SCM_VALIDATE_INSTANCE (2, new);
 575
 576   /* Exchange the data contained in old and new. We exchange rather than
 577    * scratch the old value with new to be correct with GC.
 578    * See "Class redefinition protocol above".
 579    */
 580   SCM_CRITICAL_SECTION_START;
 581   {
 582     scm_t_bits word0, word1;
 583     word0 = SCM_CELL_WORD_0 (old);
 584     word1 = SCM_CELL_WORD_1 (old);
 585     SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
 586     SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
 587     SCM_SET_CELL_WORD_0 (new, word0);
 588     SCM_SET_CELL_WORD_1 (new, word1);
 589   }
 590   SCM_CRITICAL_SECTION_END;
 591   return SCM_UNSPECIFIED;
 592 }
 593 #undef FUNC_NAME
 594
 595 SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
 596             (SCM old, SCM new),
 597             "")
 598 #define FUNC_NAME s_scm_sys_modify_class
 599 {
 600   SCM_VALIDATE_CLASS (1, old);
 601   SCM_VALIDATE_CLASS (2, new);
 602
 603   SCM_CRITICAL_SECTION_START;
 604   {
 605     scm_t_bits word0, word1;
 606     word0 = SCM_CELL_WORD_0 (old);
 607     word1 = SCM_CELL_WORD_1 (old);
 608     SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
 609     SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
 610     SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
 611     SCM_SET_CELL_WORD_0 (new, word0);
 612     SCM_SET_CELL_WORD_1 (new, word1);
 613     SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
 614   }
 615   SCM_CRITICAL_SECTION_END;
 616   return SCM_UNSPECIFIED;
 617 }
 618 #undef FUNC_NAME
 619
 620 SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
 621             (SCM class),
 622             "")
 623 #define FUNC_NAME s_scm_sys_invalidate_class
 624 {
 625   SCM_VALIDATE_CLASS (1, class);
 626   SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
 627   return SCM_UNSPECIFIED;
 628 }
 629 #undef FUNC_NAME
 630
 631 /* When instances change class, they finally get a new body, but
 632  * before that, they go through purgatory in hell.  Odd as it may
 633  * seem, this data structure saves us from eternal suffering in
 634  * infinite recursions.
 635  */
 636
 637 static scm_t_bits **hell;
 638 static long n_hell = 1;         /* one place for the evil one himself */
 639 static long hell_size = 4;
 640 static SCM hell_mutex;
 641
 642 static long
 643 burnin (SCM o)
 644 {
 645   long i;
 646   for (i = 1; i < n_hell; ++i)
 647     if (SCM_STRUCT_DATA (o) == hell[i])
 648       return i;
 649   return 0;
 650 }
 651
 652 static void
 653 go_to_hell (void *o)
 654 {
 655   SCM obj = *(SCM*)o;
 656   scm_lock_mutex (hell_mutex);
 657   if (n_hell >= hell_size)
 658     {
 659       hell_size *= 2;
 660       hell = scm_realloc (hell, hell_size * sizeof(*hell));
 661     }
 662   hell[n_hell++] = SCM_STRUCT_DATA (obj);
 663   scm_unlock_mutex (hell_mutex);
 664 }
 665
 666 static void
 667 go_to_heaven (void *o)
 668 {
 669   SCM obj = *(SCM*)o;
 670   scm_lock_mutex (hell_mutex);
 671   hell[burnin (obj)] = hell[--n_hell];
 672   scm_unlock_mutex (hell_mutex);
 673 }
 674
 675
 676 static SCM
 677 purgatory (SCM obj, SCM new_class)
 678 {
 679   return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
 680 }
 681
 682 /* This function calls the generic function change-class for all
 683  * instances which aren't currently undergoing class change.
 684  */
 685
 686 void
 687 scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
 688 {
 689   if (!burnin (obj))
 690     {
 691       scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 692       scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY);
 693       scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY);
 694       purgatory (obj, new_class);
 695       scm_dynwind_end ();
 696     }
 697 }
 698
 699
 700 \f
 701
 702 /* Primitive generics: primitives that can dispatch to generics if their
 703    arguments fail to apply.  */
 704
 705 SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
 706             (SCM proc),
 707             "")
 708 #define FUNC_NAME s_scm_generic_capability_p
 709 {
 710   SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
 711               proc, SCM_ARG1, FUNC_NAME);
 712   return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F);
 713 }
 714 #undef FUNC_NAME
 715
 716 SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
 717             (SCM subrs),
 718             "")
 719 #define FUNC_NAME s_scm_enable_primitive_generic_x
 720 {
 721   SCM_VALIDATE_REST_ARGUMENT (subrs);
 722   while (!scm_is_null (subrs))
 723     {
 724       SCM subr = SCM_CAR (subrs);
 725       SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
 726       SCM_SET_SUBR_GENERIC (subr,
 727                             scm_make (scm_list_3 (class_generic,
 728                                                   k_name,
 729                                                   SCM_SUBR_NAME (subr))));
 730       subrs = SCM_CDR (subrs);
 731     }
 732   return SCM_UNSPECIFIED;
 733 }
 734 #undef FUNC_NAME
 735
 736 SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
 737             (SCM subr, SCM generic),
 738             "")
 739 #define FUNC_NAME s_scm_set_primitive_generic_x
 740 {
 741   SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
 742   SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
 743   SCM_SET_SUBR_GENERIC (subr, generic);
 744   return SCM_UNSPECIFIED;
 745 }
 746 #undef FUNC_NAME
 747
 748 SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
 749             (SCM subr),
 750             "")
 751 #define FUNC_NAME s_scm_primitive_generic_generic
 752 {
 753   if (SCM_PRIMITIVE_GENERIC_P (subr))
 754     {
 755       if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr)))
 756         scm_enable_primitive_generic_x (scm_list_1 (subr));
 757       return *SCM_SUBR_GENERIC (subr);
 758     }
 759   SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
 760 }
 761 #undef FUNC_NAME
 762
 763 SCM
 764 scm_wta_dispatch_0 (SCM gf, const char *subr)
 765 {
 766   if (!SCM_UNPACK (gf))
 767     scm_error_num_args_subr (subr);
 768
 769   return scm_call_0 (gf);
 770 }
 771
 772 SCM
 773 scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr)
 774 {
 775   if (!SCM_UNPACK (gf))
 776     scm_wrong_type_arg (subr, pos, a1);
 777
 778   return scm_call_1 (gf, a1);
 779 }
 780
 781 SCM
 782 scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr)
 783 {
 784   if (!SCM_UNPACK (gf))
 785     scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
 786
 787   return scm_call_2 (gf, a1, a2);
 788 }
 789
 790 SCM
 791 scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
 792 {
 793   if (!SCM_UNPACK (gf))
 794     scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos)));
 795
 796   return scm_apply_0 (gf, args);
 797 }
 798
 799
 800 \f
 801
 802 SCM_DEFINE (scm_make, "make",  0, 0, 1,
 803             (SCM args),
 804             "Make a new object.  @var{args} must contain the class and\n"
 805             "all necessary initialization information.")
 806 #define FUNC_NAME s_scm_make
 807 {
 808   return scm_apply_0 (scm_variable_ref (var_make), args);
 809 }
 810 #undef FUNC_NAME
 811
 812
 813 \f
 814
 815 /* SMOB, struct, and port classes.  */
 816
 817 static SCM
 818 make_class_name (const char *prefix, const char *type_name, const char *suffix)
 819 {
 820   if (!type_name)
 821     type_name = "";
 822   return scm_string_to_symbol (scm_string_append
 823                                (scm_list_3 (scm_from_utf8_string (prefix),
 824                                             scm_from_utf8_string (type_name),
 825                                             scm_from_utf8_string (suffix))));
 826 }
 827
 828 SCM
 829 scm_make_extended_class (char const *type_name, int applicablep)
 830 {
 831   SCM name, meta, supers;
 832
 833   name = make_class_name ("<", type_name, ">");
 834   meta = class_class;
 835
 836   if (applicablep)
 837     supers = scm_list_1 (class_applicable);
 838   else
 839     supers = scm_list_1 (class_top);
 840
 841   return scm_make_standard_class (meta, name, supers, SCM_EOL);
 842 }
 843
 844 void
 845 scm_i_inherit_applicable (SCM c)
 846 {
 847   scm_call_1 (scm_variable_ref (var_inherit_applicable), c);
 848 }
 849
 850 static void
 851 create_smob_classes (void)
 852 {
 853   long i;
 854
 855   for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
 856     scm_i_smob_class[i] = SCM_BOOL_F;
 857
 858   for (i = 0; i < scm_numsmob; ++i)
 859     if (scm_is_false (scm_i_smob_class[i]))
 860       scm_i_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
 861                                                      scm_smobs[i].apply != 0);
 862 }
 863
 864 void
 865 scm_make_port_classes (long ptobnum, char *type_name)
 866 {
 867   SCM name, meta, super, supers;
 868
 869   meta = class_class;
 870
 871   name = make_class_name ("<", type_name, "-port>");
 872   supers = scm_list_1 (class_port);
 873   super = scm_make_standard_class (meta, name, supers, SCM_EOL);
 874
 875   name = make_class_name ("<", type_name, "-input-port>");
 876   supers = scm_list_2 (super, class_input_port);
 877   scm_i_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
 878     = scm_make_standard_class (meta, name, supers, SCM_EOL);
 879
 880   name = make_class_name ("<", type_name, "-output-port>");
 881   supers = scm_list_2 (super, class_output_port);
 882   scm_i_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
 883     = scm_make_standard_class (meta, name, supers, SCM_EOL);
 884
 885   name = make_class_name ("<", type_name, "-input-output-port>");
 886   supers = scm_list_2 (super, class_input_output_port);
 887   scm_i_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
 888     = scm_make_standard_class (meta, name, supers, SCM_EOL);
 889 }
 890
 891 static void
 892 create_port_classes (void)
 893 {
 894   long i;
 895
 896   for (i = scm_c_num_port_types () - 1; i >= 0; i--)
 897     scm_make_port_classes (i, SCM_PTOBNAME (i));
 898 }
 899
 900 SCM
 901 scm_i_define_class_for_vtable (SCM vtable)
 902 {
 903   SCM class;
 904
 905   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
 906   if (scm_is_false (vtable_class_map))
 907     vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 908   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 909
 910   if (scm_is_false (scm_struct_vtable_p (vtable)))
 911     abort ();
 912
 913   class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
 914
 915   if (scm_is_false (class))
 916     {
 917       if (SCM_UNPACK (class_class))
 918         {
 919           SCM name, meta, supers;
 920
 921           name = SCM_VTABLE_NAME (vtable);
 922           if (scm_is_symbol (name))
 923             name = scm_string_to_symbol
 924               (scm_string_append
 925                (scm_list_3 (scm_from_latin1_string ("<"),
 926                             scm_symbol_to_string (name),
 927                             scm_from_latin1_string (">"))));
 928           else
 929             name = scm_from_latin1_symbol ("<>");
 930
 931           if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER))
 932             {
 933               meta = class_applicable_struct_with_setter_class;
 934               supers = scm_list_1 (class_applicable_struct_with_setter);
 935             }
 936           else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable,
 937                                                   SCM_VTABLE_FLAG_APPLICABLE))
 938             {
 939               meta = class_applicable_struct_class;
 940               supers = scm_list_1 (class_applicable_struct);
 941             }
 942           else
 943             {
 944               meta = class_class;
 945               supers = scm_list_1 (class_top);
 946             }
 947
 948           return scm_make_standard_class (meta, name, supers, SCM_EOL);
 949         }
 950       else
 951         /* `create_struct_classes' will fill this in later.  */
 952         class = SCM_BOOL_F;
 953
 954       /* Don't worry about races.  This only happens when creating a
 955          vtable, which happens by definition in one thread.  */
 956       scm_weak_table_putq_x (vtable_class_map, vtable, class);
 957     }
 958
 959   return class;
 960 }
 961
 962 static SCM
 963 make_struct_class (void *closure SCM_UNUSED,
 964                    SCM vtable, SCM data, SCM prev SCM_UNUSED)
 965 {
 966   if (scm_is_false (data))
 967     scm_i_define_class_for_vtable (vtable);
 968   return SCM_UNSPECIFIED;
 969 }
 970
 971 static void
 972 create_struct_classes (void)
 973 {
 974   /* FIXME: take the vtable_class_map while initializing goops?  */
 975   scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
 976                           vtable_class_map);
 977 }
 978
 979
 980 \f
 981
 982 void
 983 scm_load_goops ()
 984 {
 985   if (!goops_loaded_p)
 986     scm_c_resolve_module ("oop goops");
 987 }
 988
 989 SCM
 990 scm_ensure_accessor (SCM name)
 991 {
 992   SCM var, gf;
 993
 994   var = scm_module_variable (scm_current_module (), name);
 995   if (SCM_VARIABLEP (var) && !SCM_UNBNDP (SCM_VARIABLE_REF (var)))
 996     gf = SCM_VARIABLE_REF (var);
 997   else
 998     gf = SCM_BOOL_F;
 999
1000   if (!SCM_IS_A_P (gf, class_accessor))
1001     {
1002       gf = scm_make (scm_list_3 (class_generic, k_name, name));
1003       gf = scm_make (scm_list_5 (class_accessor,
1004                                  k_name, name, k_setter, gf));
1005     }
1006
1007   return gf;
1008 }
1009
1010
1011 \f
1012
1013 SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
1014             (),
1015             "")
1016 #define FUNC_NAME s_scm_sys_goops_early_init
1017 {
1018   var_make_standard_class = scm_c_lookup ("make-standard-class");
1019   var_make = scm_c_lookup ("make");
1020   var_inherit_applicable = scm_c_lookup ("inherit-applicable!");
1021
1022   /* For SCM_SUBCLASSP.  */
1023   var_class_precedence_list = scm_c_lookup ("class-precedence-list");
1024
1025   var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
1026   var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
1027   var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
1028   var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
1029
1030   var_slot_ref = scm_c_lookup ("slot-ref");
1031   var_slot_set_x = scm_c_lookup ("slot-set!");
1032   var_slot_bound_p = scm_c_lookup ("slot-bound?");
1033   var_slot_exists_p = scm_c_lookup ("slot-exists?");
1034
1035   class_class = scm_variable_ref (scm_c_lookup ("<class>"));
1036   class_top = scm_variable_ref (scm_c_lookup ("<top>"));
1037   class_object = scm_variable_ref (scm_c_lookup ("<object>"));
1038
1039   class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
1040   class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
1041   class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
1042   class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
1043   class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
1044   class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
1045   class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
1046   class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
1047   class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
1048   class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
1049   class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
1050   class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
1051   class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
1052
1053   /* Applicables */
1054   class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
1055   class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
1056   class_applicable_struct_with_setter_class =
1057     scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>"));
1058
1059   class_method = scm_variable_ref (scm_c_lookup ("<method>"));
1060   class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
1061   class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
1062   class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
1063   class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
1064   class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
1065   class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
1066   class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
1067   class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
1068   class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
1069   class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
1070
1071   /* Primitive types classes */
1072   class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
1073   class_char = scm_variable_ref (scm_c_lookup ("<char>"));
1074   class_list = scm_variable_ref (scm_c_lookup ("<list>"));
1075   class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
1076   class_null = scm_variable_ref (scm_c_lookup ("<null>"));
1077   class_string = scm_variable_ref (scm_c_lookup ("<string>"));
1078   class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
1079   class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
1080   class_foreign = scm_variable_ref (scm_c_lookup ("<foreign>"));
1081   class_hashtable = scm_variable_ref (scm_c_lookup ("<hashtable>"));
1082   class_fluid = scm_variable_ref (scm_c_lookup ("<fluid>"));
1083   class_dynamic_state = scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
1084   class_frame = scm_variable_ref (scm_c_lookup ("<frame>"));
1085   class_vm_cont = scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
1086   class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
1087   class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
1088   class_array = scm_variable_ref (scm_c_lookup ("<array>"));
1089   class_bitvector = scm_variable_ref (scm_c_lookup ("<bitvector>"));
1090   class_number = scm_variable_ref (scm_c_lookup ("<number>"));
1091   class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
1092   class_real = scm_variable_ref (scm_c_lookup ("<real>"));
1093   class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
1094   class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
1095   class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
1096   class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
1097   class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
1098   class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
1099   class_port = scm_variable_ref (scm_c_lookup ("<port>"));
1100   class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
1101   class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
1102   class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
1103
1104   create_smob_classes ();
1105   create_struct_classes ();
1106   create_port_classes ();
1107
1108   return SCM_UNSPECIFIED;
1109 }
1110 #undef FUNC_NAME
1111
1112 SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
1113             (),
1114             "Announce that GOOPS is loaded and perform initialization\n"
1115             "on the C level which depends on the loaded GOOPS modules.")
1116 #define FUNC_NAME s_scm_sys_goops_loaded
1117 {
1118   goops_loaded_p = 1;
1119   var_class_name = scm_c_lookup ("class-name");
1120   var_class_direct_supers = scm_c_lookup ("class-direct-supers");
1121   var_class_direct_slots = scm_c_lookup ("class-direct-slots");
1122   var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses");
1123   var_class_direct_methods = scm_c_lookup ("class-direct-methods");
1124   var_class_slots = scm_c_lookup ("class-slots");
1125
1126   var_generic_function_methods = scm_c_lookup ("generic-function-methods");
1127   var_method_generic_function = scm_c_lookup ("method-generic-function");
1128   var_method_specializers = scm_c_lookup ("method-specializers");
1129   var_method_procedure = scm_c_lookup ("method-procedure");
1130
1131   var_change_class = scm_c_lookup ("change-class");
1132
1133 #if (SCM_ENABLE_DEPRECATED == 1)
1134   scm_init_deprecated_goops ();
1135 #endif
1136
1137   return SCM_UNSPECIFIED;
1138 }
1139 #undef FUNC_NAME
1140
1141 static void
1142 scm_init_goops_builtins (void *unused)
1143 {
1144   scm_module_goops = scm_current_module ();
1145
1146   hell = scm_calloc (hell_size * sizeof (*hell));
1147   hell_mutex = scm_make_mutex ();
1148
1149 #include "libguile/goops.x"
1150 }
1151
1152 void
1153 scm_init_goops ()
1154 {
1155   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1156                             "scm_init_goops_builtins", scm_init_goops_builtins,
1157                             NULL);
1158 }
1159
1160 /*
1161   Local Variables:
1162   c-file-style: "gnu"
1163   End:
1164 */