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