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_NULLP (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 #if SCM_HAVE_ARRAYS
  93         case scm_tc7_bvect:
  94         case scm_tc7_byvect:
  95         case scm_tc7_svect:
  96         case scm_tc7_ivect:
  97         case scm_tc7_uvect:
  98         case scm_tc7_fvect:
  99         case scm_tc7_dvect:
 100         case scm_tc7_cvect:
 101 #endif
 102           return scm_class_vector;
 103         case scm_tc7_string:
 104           return scm_class_string;
 105         case scm_tc7_number:
 106           switch SCM_TYP16 (x) {
 107           case scm_tc16_big:
 108             return scm_class_integer;
 109           case scm_tc16_real:
 110             return scm_class_real;
 111           case scm_tc16_complex:
 112             return scm_class_complex;
 113           case scm_tc16_fraction:
 114             return scm_class_fraction;
 115           }
 116         case scm_tc7_asubr:
 117         case scm_tc7_subr_0:
 118         case scm_tc7_subr_1:
 119         case scm_tc7_dsubr:
 120         case scm_tc7_cxr:
 121         case scm_tc7_subr_3:
 122         case scm_tc7_subr_2:
 123         case scm_tc7_rpsubr:
 124         case scm_tc7_subr_1o:
 125         case scm_tc7_subr_2o:
 126         case scm_tc7_lsubr_2:
 127         case scm_tc7_lsubr:
 128           if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
 129             return scm_class_primitive_generic;
 130           else
 131             return scm_class_procedure;
 132         case scm_tc7_cclo:
 133           return scm_class_procedure;
 134         case scm_tc7_pws:
 135           return scm_class_procedure_with_setter;
 136
 137         case scm_tc7_smob:
 138           {
 139             scm_t_bits type = SCM_TYP16 (x);
 140             if (type != scm_tc16_port_with_ps)
 141               return scm_smob_class[SCM_TC2SMOBNUM (type)];
 142             x = SCM_PORT_WITH_PS_PORT (x);
 143             /* fall through to ports */
 144           }
 145         case scm_tc7_port:
 146           return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
 147                                  ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
 148                                     ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
 149                                     : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
 150                                  : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
 151         case scm_tcs_struct:
 152           if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
 153             return SCM_CLASS_OF (x);
 154           else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
 155             {
 156               /* Goops object */
 157               if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
 158                 scm_change_object_class (x,
 159                                          SCM_CLASS_OF (x),         /* old */
 160                                          SCM_OBJ_CLASS_REDEF (x)); /* new */
 161               return SCM_CLASS_OF (x);
 162             }
 163           else
 164             {
 165               /* ordinary struct */
 166               SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
 167               if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
 168                 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
 169               else
 170                 {
 171                   SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
 172                   SCM class = scm_make_extended_class (scm_is_true (name)
 173                                                        ? scm_i_symbol_chars (name)
 174                                                        : 0,
 175                                                        SCM_I_OPERATORP (x));
 176                   SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
 177                   return class;
 178                 }
 179             }
 180         default:
 181           if (SCM_CONSP (x))
 182             return scm_class_pair;
 183           else
 184             return scm_class_unknown;
 185         }
 186
 187     case scm_tc3_struct:
 188     case scm_tc3_tc7_1:
 189     case scm_tc3_tc7_2:
 190     case scm_tc3_closure:
 191       /* Never reached */
 192       break;
 193     }
 194   return scm_class_unknown;
 195 }
 196 #undef FUNC_NAME
 197
 198 /* The cache argument for scm_mcache_lookup_cmethod has one of two possible
 199  * formats:
 200  *
 201  * Format #1:
 202  * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
 203  *   #((TYPE1 ... ENV FORMALS FORM ...) ...)
 204  *   GF)
 205  *
 206  * Format #2:
 207  * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
 208  *   #((TYPE1 ... ENV FORMALS FORM ...) ...)
 209  *   GF)
 210  *
 211  * ARGS is either a list of expressions, in which case they
 212  * are interpreted as the arguments of an application, or
 213  * a non-pair, which is interpreted as a single expression
 214  * yielding all arguments.
 215  *
 216  * SCM_IM_DISPATCH expressions in generic functions always
 217  * have ARGS = the symbol `args' or the iloc #@0-0.
 218  *
 219  * Need FORMALS in order to support varying arity.  This
 220  * also avoids the need for renaming of bindings.
 221  *
 222  * We should probably not complicate this mechanism by
 223  * introducing "optimizations" for getters and setters or
 224  * primitive methods.  Getters and setter will normally be
 225  * compiled into @slot-[ref|set!] or a procedure call.
 226  * They rely on the dispatch performed before executing
 227  * the code which contains them.
 228  *
 229  * We might want to use a more efficient representation of
 230  * this form in the future, perhaps after we have introduced
 231  * low-level support for syntax-case macros.
 232  */
 233
 234 SCM
 235 scm_mcache_lookup_cmethod (SCM cache, SCM args)
 236 {
 237   unsigned long i, mask, n, end;
 238   SCM ls, methods, z = SCM_CDDR (cache);
 239   n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
 240   methods = SCM_CADR (z);
 241
 242   if (SCM_VECTORP (methods))
 243     {
 244       /* cache format #1: prepare for linear search */
 245       mask = -1;
 246       i = 0;
 247       end = SCM_VECTOR_LENGTH (methods);
 248     }
 249   else
 250     {
 251       /* cache format #2: compute a hash value */
 252       unsigned long hashset = scm_to_ulong (methods);
 253       long j = n;
 254       z = SCM_CDDR (z);
 255       mask = scm_to_ulong (SCM_CAR (z));
 256       methods = SCM_CADR (z);
 257       i = 0;
 258       ls = args;
 259       if (!SCM_NULLP (ls))
 260         do
 261           {
 262             i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
 263                  [scm_si_hashsets + hashset];
 264             ls = SCM_CDR (ls);
 265           }
 266         while (j-- && !SCM_NULLP (ls));
 267       i &= mask;
 268       end = i;
 269     }
 270
 271   /* Search for match  */
 272   do
 273     {
 274       long j = n;
 275       z = SCM_VELTS (methods)[i];
 276       ls = args; /* list of arguments */
 277       if (!SCM_NULLP (ls))
 278         do
 279           {
 280             /* More arguments than specifiers => CLASS != ENV */
 281             if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
 282               goto next_method;
 283             ls = SCM_CDR (ls);
 284             z = SCM_CDR (z);
 285           }
 286         while (j-- && !SCM_NULLP (ls));
 287       /* Fewer arguments than specifiers => CAR != ENV */
 288       if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))
 289         return z;
 290     next_method:
 291       i = (i + 1) & mask;
 292     } while (i != end);
 293   return SCM_BOOL_F;
 294 }
 295
 296 SCM
 297 scm_mcache_compute_cmethod (SCM cache, SCM args)
 298 {
 299   SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
 300   if (scm_is_false (cmethod))
 301     /* No match - memoize */
 302     return scm_memoize_method (cache, args);
 303   return cmethod;
 304 }
 305
 306 SCM
 307 scm_apply_generic (SCM gf, SCM args)
 308 {
 309   SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
 310   return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
 311                         SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
 312                                         args,
 313                                         SCM_CMETHOD_ENV (cmethod)));
 314 }
 315
 316 SCM
 317 scm_call_generic_0 (SCM gf)
 318 {
 319   return scm_apply_generic (gf, SCM_EOL);
 320 }
 321
 322 SCM
 323 scm_call_generic_1 (SCM gf, SCM a1)
 324 {
 325   return scm_apply_generic (gf, scm_list_1 (a1));
 326 }
 327
 328 SCM
 329 scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
 330 {
 331   return scm_apply_generic (gf, scm_list_2 (a1, a2));
 332 }
 333
 334 SCM
 335 scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
 336 {
 337   return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
 338 }
 339
 340 SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0,
 341             (SCM obj),
 342             "Return @code{#t} if @var{obj} is an entity.")
 343 #define FUNC_NAME s_scm_entity_p
 344 {
 345   return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
 346 }
 347 #undef FUNC_NAME
 348
 349 SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0,
 350             (SCM obj),
 351             "Return @code{#t} if @var{obj} is an operator.")
 352 #define FUNC_NAME s_scm_operator_p
 353 {
 354   return scm_from_bool(SCM_STRUCTP (obj)
 355                   && SCM_I_OPERATORP (obj)
 356                   && !SCM_I_ENTITYP (obj));
 357 }
 358 #undef FUNC_NAME
 359
 360 /* XXX - What code requires the object procedure to be only of certain
 361          types? */
 362
 363 SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
 364             (SCM proc),
 365             "Return @code{#t} iff @var{proc} is a procedure that can be used "
 366             "with @code{set-object-procedure}.  It is always valid to use "
 367             "a closure constructed by @code{lambda}.")
 368 #define FUNC_NAME s_scm_valid_object_procedure_p
 369 {
 370   if (SCM_IMP (proc))
 371     return SCM_BOOL_F;
 372   switch (SCM_TYP7 (proc))
 373     {
 374     default:
 375       return SCM_BOOL_F;
 376     case scm_tcs_closures:
 377     case scm_tc7_subr_1:
 378     case scm_tc7_subr_2:
 379     case scm_tc7_subr_3:
 380     case scm_tc7_lsubr_2:
 381       return SCM_BOOL_T;
 382     }
 383 }
 384 #undef FUNC_NAME
 385
 386 SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
 387             (SCM obj, SCM proc),
 388             "Set the object procedure of @var{obj} to @var{proc}.\n"
 389             "@var{obj} must be either an entity or an operator.")
 390 #define FUNC_NAME s_scm_set_object_procedure_x
 391 {
 392   SCM_ASSERT (SCM_STRUCTP (obj)
 393               && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
 394                   || (SCM_I_ENTITYP (obj)
 395                       && !(SCM_OBJ_CLASS_FLAGS (obj)
 396                            & SCM_CLASSF_PURE_GENERIC))),
 397               obj,
 398               SCM_ARG1,
 399               FUNC_NAME);
 400   SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME);
 401   if (SCM_I_ENTITYP (obj))
 402     SCM_SET_ENTITY_PROCEDURE (obj, proc);
 403   else
 404     SCM_OPERATOR_CLASS (obj)->procedure = proc;
 405   return SCM_UNSPECIFIED;
 406 }
 407 #undef FUNC_NAME
 408
 409 #ifdef GUILE_DEBUG
 410 SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0,
 411             (SCM obj),
 412             "Return the object procedure of @var{obj}. @var{obj} must be\n"
 413             "an entity or an operator.")
 414 #define FUNC_NAME s_scm_object_procedure
 415 {
 416   SCM_ASSERT (SCM_STRUCTP (obj)
 417               && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
 418                   || SCM_I_ENTITYP (obj)),
 419               obj, SCM_ARG1, FUNC_NAME);
 420   return (SCM_I_ENTITYP (obj)
 421           ? SCM_ENTITY_PROCEDURE (obj)
 422           : SCM_OPERATOR_CLASS (obj)->procedure);
 423 }
 424 #undef FUNC_NAME
 425 #endif /* GUILE_DEBUG */
 426
 427 /* The following procedures are not a part of Goops but a minimal
 428  * object system built upon structs.  They are here for those who
 429  * want to implement their own object system.
 430  */
 431
 432 SCM
 433 scm_i_make_class_object (SCM meta,
 434                          SCM layout_string,
 435                          unsigned long flags)
 436 {
 437   SCM c;
 438   SCM layout = scm_make_struct_layout (layout_string);
 439   c = scm_make_struct (meta,
 440                        SCM_INUM0,
 441                        scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
 442   SCM_SET_CLASS_FLAGS (c, flags);
 443   return c;
 444 }
 445
 446 SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0,
 447             (SCM metaclass, SCM layout),
 448             "Create a new class object of class @var{metaclass}, with the\n"
 449             "slot layout specified by @var{layout}.")
 450 #define FUNC_NAME s_scm_make_class_object
 451 {
 452   unsigned long flags = 0;
 453   SCM_VALIDATE_STRUCT (1, metaclass);
 454   SCM_VALIDATE_STRING (2, layout);
 455   if (scm_is_eq (metaclass, scm_metaclass_operator))
 456     flags = SCM_CLASSF_OPERATOR;
 457   return scm_i_make_class_object (metaclass, layout, flags);
 458 }
 459 #undef FUNC_NAME
 460
 461 SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0,
 462             (SCM class, SCM layout),
 463             "Create a subclass object of @var{class}, with the slot layout\n"
 464             "specified by @var{layout}.")
 465 #define FUNC_NAME s_scm_make_subclass_object
 466 {
 467   SCM pl;
 468   SCM_VALIDATE_STRUCT (1, class);
 469   SCM_VALIDATE_STRING (2, layout);
 470   pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]);
 471   pl = scm_symbol_to_string (pl);
 472   return scm_i_make_class_object (SCM_STRUCT_VTABLE (class),
 473                                   scm_string_append (scm_list_2 (pl, layout)),
 474                                   SCM_CLASS_FLAGS (class));
 475 }
 476 #undef FUNC_NAME
 477
 478 void
 479 scm_init_objects ()
 480 {
 481   SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT);
 482   SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0,
 483                                    scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
 484
 485   SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT);
 486   SCM ot = scm_make_vtable_vtable (os, SCM_INUM0,
 487                                    scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
 488
 489   SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT);
 490   SCM el = scm_make_struct_layout (es);
 491   SCM et = scm_make_struct (mt, SCM_INUM0,
 492                             scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));
 493
 494   scm_c_define ("<class>", mt);
 495   scm_metaclass_standard = mt;
 496   scm_c_define ("<operator-class>", ot);
 497   scm_metaclass_operator = ot;
 498   SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
 499   SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity);
 500   scm_c_define ("<entity>", et);
 501
 502 #include "libguile/objects.x"
 503 }
 504
 505 /*
 506   Local Variables:
 507   c-file-style: "gnu"
 508   End:
 509 */