libguile/objects.c

   1 /* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18
  19 \f
  20
  21 /* This file and objects.h contains those minimal pieces of the Guile
  22  * Object Oriented Programming System which need to be included in
  23  * libguile.  See the comments in objects.h.
  24  */
  25
  26 #include "libguile/_scm.h"
  27
  28 #include "libguile/struct.h"
  29 #include "libguile/procprop.h"
  30 #include "libguile/chars.h"
  31 #include "libguile/keywords.h"
  32 #include "libguile/smob.h"
  33 #include "libguile/eval.h"
  34 #include "libguile/alist.h"
  35 #include "libguile/ports.h"
  36 #include "libguile/strings.h"
  37 #include "libguile/vectors.h"
  38
  39 #include "libguile/validate.h"
  40 #include "libguile/objects.h"
  41 \f
  42
  43 SCM scm_metaclass_standard;
  44 SCM scm_metaclass_operator;
  45
  46 /* These variables are filled in by the object system when loaded. */
  47 SCM scm_class_boolean, scm_class_char, scm_class_pair;
  48 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
  49 SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
  50 SCM scm_class_vector, scm_class_null;
  51 SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
  52 SCM scm_class_unknown;
  53
  54 SCM *scm_port_class = 0;
  55 SCM *scm_smob_class = 0;
  56
  57 SCM scm_no_applicable_method;
  58
  59 /* This function is used for efficient type dispatch.  */
  60 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
  61             (SCM x),
  62             "Return the class of @var{x}.")
  63 #define FUNC_NAME s_scm_class_of
  64 {
  65   switch (SCM_ITAG3 (x))
  66     {
  67     case scm_tc3_int_1:
  68     case scm_tc3_int_2:
  69       return scm_class_integer;
  70
  71     case scm_tc3_imm24:
  72       if (SCM_CHARP (x))
  73         return scm_class_char;
  74       else if (scm_is_bool (x))
  75         return scm_class_boolean;
  76       else if (scm_is_null (x))
  77         return scm_class_null;
  78       else
  79         return scm_class_unknown;
  80
  81     case scm_tc3_cons:
  82       switch (SCM_TYP7 (x))
  83         {
  84         case scm_tcs_cons_nimcar:
  85           return scm_class_pair;
  86         case scm_tcs_closures:
  87           return scm_class_procedure;
  88         case scm_tc7_symbol:
  89           return scm_class_symbol;
  90         case scm_tc7_vector:
  91         case scm_tc7_wvect:
  92           return scm_class_vector;
  93         case scm_tc7_string:
  94           return scm_class_string;
  95         case scm_tc7_number:
  96           switch SCM_TYP16 (x) {
  97           case scm_tc16_big:
  98             return scm_class_integer;
  99           case scm_tc16_real:
 100             return scm_class_real;
 101           case scm_tc16_complex:
 102             return scm_class_complex;
 103           case scm_tc16_fraction:
 104             return scm_class_fraction;
 105           }
 106         case scm_tc7_asubr:
 107         case scm_tc7_subr_0:
 108         case scm_tc7_subr_1:
 109         case scm_tc7_dsubr:
 110         case scm_tc7_cxr:
 111         case scm_tc7_subr_3:
 112         case scm_tc7_subr_2:
 113         case scm_tc7_rpsubr:
 114         case scm_tc7_subr_1o:
 115         case scm_tc7_subr_2o:
 116         case scm_tc7_lsubr_2:
 117         case scm_tc7_lsubr:
 118           if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
 119             return scm_class_primitive_generic;
 120           else
 121             return scm_class_procedure;
 122         case scm_tc7_cclo:
 123           return scm_class_procedure;
 124         case scm_tc7_pws:
 125           return scm_class_procedure_with_setter;
 126
 127         case scm_tc7_smob:
 128           {
 129             scm_t_bits type = SCM_TYP16 (x);
 130             if (type != scm_tc16_port_with_ps)
 131               return scm_smob_class[SCM_TC2SMOBNUM (type)];
 132             x = SCM_PORT_WITH_PS_PORT (x);
 133             /* fall through to ports */
 134           }
 135         case scm_tc7_port:
 136           return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
 137                                  ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
 138                                     ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
 139                                     : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
 140                                  : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
 141         case scm_tcs_struct:
 142           if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
 143             return SCM_CLASS_OF (x);
 144           else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
 145             {
 146               /* Goops object */
 147               if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
 148                 scm_change_object_class (x,
 149                                          SCM_CLASS_OF (x),         /* old */
 150                                          SCM_OBJ_CLASS_REDEF (x)); /* new */
 151               return SCM_CLASS_OF (x);
 152             }
 153           else
 154             {
 155               /* ordinary struct */
 156               SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
 157               if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
 158                 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
 159               else
 160                 {
 161                   SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
 162                   SCM class = scm_make_extended_class (scm_is_true (name)
 163                                                        ? scm_i_symbol_chars (name)
 164                                                        : 0,
 165                                                        SCM_I_OPERATORP (x));
 166                   SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
 167                   return class;
 168                 }
 169             }
 170         default:
 171           if (scm_is_pair (x))
 172             return scm_class_pair;
 173           else
 174             return scm_class_unknown;
 175         }
 176
 177     case scm_tc3_struct:
 178     case scm_tc3_tc7_1:
 179     case scm_tc3_tc7_2:
 180     case scm_tc3_closure:
 181       /* Never reached */
 182       break;
 183     }
 184   return scm_class_unknown;
 185 }
 186 #undef FUNC_NAME
 187
 188 /* The cache argument for scm_mcache_lookup_cmethod has one of two possible
 189  * formats:
 190  *
 191  * Format #1:
 192  * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
 193  *   #((TYPE1 ... ENV FORMALS FORM ...) ...)
 194  *   GF)
 195  *
 196  * Format #2:
 197  * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
 198  *   #((TYPE1 ... ENV FORMALS FORM ...) ...)
 199  *   GF)
 200  *
 201  * ARGS is either a list of expressions, in which case they
 202  * are interpreted as the arguments of an application, or
 203  * a non-pair, which is interpreted as a single expression
 204  * yielding all arguments.
 205  *
 206  * SCM_IM_DISPATCH expressions in generic functions always
 207  * have ARGS = the symbol `args' or the iloc #@0-0.
 208  *
 209  * Need FORMALS in order to support varying arity.  This
 210  * also avoids the need for renaming of bindings.
 211  *
 212  * We should probably not complicate this mechanism by
 213  * introducing "optimizations" for getters and setters or
 214  * primitive methods.  Getters and setter will normally be
 215  * compiled into @slot-[ref|set!] or a procedure call.
 216  * They rely on the dispatch performed before executing
 217  * the code which contains them.
 218  *
 219  * We might want to use a more efficient representation of
 220  * this form in the future, perhaps after we have introduced
 221  * low-level support for syntax-case macros.
 222  */
 223
 224 SCM
 225 scm_mcache_lookup_cmethod (SCM cache, SCM args)
 226 {
 227   unsigned long i, mask, n, end;
 228   SCM ls, methods, z = SCM_CDDR (cache);
 229   n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
 230   methods = SCM_CADR (z);
 231
 232   if (SCM_VECTORP (methods))
 233     {
 234       /* cache format #1: prepare for linear search */
 235       mask = -1;
 236       i = 0;
 237       end = SCM_VECTOR_LENGTH (methods);
 238     }
 239   else
 240     {
 241       /* cache format #2: compute a hash value */
 242       unsigned long hashset = scm_to_ulong (methods);
 243       long j = n;
 244       z = SCM_CDDR (z);
 245       mask = scm_to_ulong (SCM_CAR (z));
 246       methods = SCM_CADR (z);
 247       i = 0;
 248       ls = args;
 249       if (!scm_is_null (ls))
 250         do
 251           {
 252             i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
 253                  [scm_si_hashsets + hashset];
 254             ls = SCM_CDR (ls);
 255           }
 256         while (j-- && !scm_is_null (ls));
 257       i &= mask;
 258       end = i;
 259     }
 260
 261   /* Search for match  */
 262   do
 263     {
 264       long j = n;
 265       z = SCM_VELTS (methods)[i];
 266       ls = args; /* list of arguments */
 267       if (!scm_is_null (ls))
 268         do
 269           {
 270             /* More arguments than specifiers => CLASS != ENV */
 271             if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
 272               goto next_method;
 273             ls = SCM_CDR (ls);
 274             z = SCM_CDR (z);
 275           }
 276         while (j-- && !scm_is_null (ls));
 277       /* Fewer arguments than specifiers => CAR != ENV */
 278       if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
 279         return z;
 280     next_method:
 281       i = (i + 1) & mask;
 282     } while (i != end);
 283   return SCM_BOOL_F;
 284 }
 285
 286 SCM
 287 scm_mcache_compute_cmethod (SCM cache, SCM args)
 288 {
 289   SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
 290   if (scm_is_false (cmethod))
 291     /* No match - memoize */
 292     return scm_memoize_method (cache, args);
 293   return cmethod;
 294 }
 295
 296 SCM
 297 scm_apply_generic (SCM gf, SCM args)
 298 {
 299   SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
 300   return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
 301                         SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
 302                                         args,
 303                                         SCM_CMETHOD_ENV (cmethod)));
 304 }
 305
 306 SCM
 307 scm_call_generic_0 (SCM gf)
 308 {
 309   return scm_apply_generic (gf, SCM_EOL);
 310 }
 311
 312 SCM
 313 scm_call_generic_1 (SCM gf, SCM a1)
 314 {
 315   return scm_apply_generic (gf, scm_list_1 (a1));
 316 }
 317
 318 SCM
 319 scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
 320 {
 321   return scm_apply_generic (gf, scm_list_2 (a1, a2));
 322 }
 323
 324 SCM
 325 scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
 326 {
 327   return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
 328 }
 329
 330 SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0,
 331             (SCM obj),
 332             "Return @code{#t} if @var{obj} is an entity.")
 333 #define FUNC_NAME s_scm_entity_p
 334 {
 335   return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
 336 }
 337 #undef FUNC_NAME
 338
 339 SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0,
 340             (SCM obj),
 341             "Return @code{#t} if @var{obj} is an operator.")
 342 #define FUNC_NAME s_scm_operator_p
 343 {
 344   return scm_from_bool(SCM_STRUCTP (obj)
 345                   && SCM_I_OPERATORP (obj)
 346                   && !SCM_I_ENTITYP (obj));
 347 }
 348 #undef FUNC_NAME
 349
 350 /* XXX - What code requires the object procedure to be only of certain
 351          types? */
 352
 353 SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
 354             (SCM proc),
 355             "Return @code{#t} iff @var{proc} is a procedure that can be used "
 356             "with @code{set-object-procedure}.  It is always valid to use "
 357             "a closure constructed by @code{lambda}.")
 358 #define FUNC_NAME s_scm_valid_object_procedure_p
 359 {
 360   if (SCM_IMP (proc))
 361     return SCM_BOOL_F;
 362   switch (SCM_TYP7 (proc))
 363     {
 364     default:
 365       return SCM_BOOL_F;
 366     case scm_tcs_closures:
 367     case scm_tc7_subr_1:
 368     case scm_tc7_subr_2:
 369     case scm_tc7_subr_3:
 370     case scm_tc7_lsubr_2:
 371       return SCM_BOOL_T;
 372     }
 373 }
 374 #undef FUNC_NAME
 375
 376 SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
 377             (SCM obj, SCM proc),
 378             "Set the object procedure of @var{obj} to @var{proc}.\n"
 379             "@var{obj} must be either an entity or an operator.")
 380 #define FUNC_NAME s_scm_set_object_procedure_x
 381 {
 382   SCM_ASSERT (SCM_STRUCTP (obj)
 383               && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
 384                   || (SCM_I_ENTITYP (obj)
 385                       && !(SCM_OBJ_CLASS_FLAGS (obj)
 386                            & SCM_CLASSF_PURE_GENERIC))),
 387               obj,
 388               SCM_ARG1,
 389               FUNC_NAME);
 390   SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME);
 391   if (SCM_I_ENTITYP (obj))
 392     SCM_SET_ENTITY_PROCEDURE (obj, proc);
 393   else
 394     SCM_OPERATOR_CLASS (obj)->procedure = proc;
 395   return SCM_UNSPECIFIED;
 396 }
 397 #undef FUNC_NAME
 398
 399 #ifdef GUILE_DEBUG
 400 SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0,
 401             (SCM obj),
 402             "Return the object procedure of @var{obj}. @var{obj} must be\n"
 403             "an entity or an operator.")
 404 #define FUNC_NAME s_scm_object_procedure
 405 {
 406   SCM_ASSERT (SCM_STRUCTP (obj)
 407               && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
 408                   || SCM_I_ENTITYP (obj)),
 409               obj, SCM_ARG1, FUNC_NAME);
 410   return (SCM_I_ENTITYP (obj)
 411           ? SCM_ENTITY_PROCEDURE (obj)
 412           : SCM_OPERATOR_CLASS (obj)->procedure);
 413 }
 414 #undef FUNC_NAME
 415 #endif /* GUILE_DEBUG */
 416
 417 /* The following procedures are not a part of Goops but a minimal
 418  * object system built upon structs.  They are here for those who
 419  * want to implement their own object system.
 420  */
 421
 422 SCM
 423 scm_i_make_class_object (SCM meta,
 424                          SCM layout_string,
 425                          unsigned long flags)
 426 {
 427   SCM c;
 428   SCM layout = scm_make_struct_layout (layout_string);
 429   c = scm_make_struct (meta,
 430                        SCM_INUM0,
 431                        scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
 432   SCM_SET_CLASS_FLAGS (c, flags);
 433   return c;
 434 }
 435
 436 SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0,
 437             (SCM metaclass, SCM layout),
 438             "Create a new class object of class @var{metaclass}, with the\n"
 439             "slot layout specified by @var{layout}.")
 440 #define FUNC_NAME s_scm_make_class_object
 441 {
 442   unsigned long flags = 0;
 443   SCM_VALIDATE_STRUCT (1, metaclass);
 444   SCM_VALIDATE_STRING (2, layout);
 445   if (scm_is_eq (metaclass, scm_metaclass_operator))
 446     flags = SCM_CLASSF_OPERATOR;
 447   return scm_i_make_class_object (metaclass, layout, flags);
 448 }
 449 #undef FUNC_NAME
 450
 451 SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0,
 452             (SCM class, SCM layout),
 453             "Create a subclass object of @var{class}, with the slot layout\n"
 454             "specified by @var{layout}.")
 455 #define FUNC_NAME s_scm_make_subclass_object
 456 {
 457   SCM pl;
 458   SCM_VALIDATE_STRUCT (1, class);
 459   SCM_VALIDATE_STRING (2, layout);
 460   pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]);
 461   pl = scm_symbol_to_string (pl);
 462   return scm_i_make_class_object (SCM_STRUCT_VTABLE (class),
 463                                   scm_string_append (scm_list_2 (pl, layout)),
 464                                   SCM_CLASS_FLAGS (class));
 465 }
 466 #undef FUNC_NAME
 467
 468 void
 469 scm_init_objects ()
 470 {
 471   SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT);
 472   SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0,
 473                                    scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
 474
 475   SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT);
 476   SCM ot = scm_make_vtable_vtable (os, SCM_INUM0,
 477                                    scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
 478
 479   SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT);
 480   SCM el = scm_make_struct_layout (es);
 481   SCM et = scm_make_struct (mt, SCM_INUM0,
 482                             scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));
 483
 484   scm_c_define ("<class>", mt);
 485   scm_metaclass_standard = mt;
 486   scm_c_define ("<operator-class>", ot);
 487   scm_metaclass_operator = ot;
 488   SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
 489   SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity);
 490   scm_c_define ("<entity>", et);
 491
 492 #include "libguile/objects.x"
 493 }
 494
 495 /*
 496   Local Variables:
 497   c-file-style: "gnu"
 498   End:
 499 */