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