libguile/objects.c

   1 /* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 #ifdef HAVE_CONFIG_H
  27 # include <config.h>
  28 #endif
  29
  30 #include "libguile/_scm.h"
  31
  32 #include "libguile/struct.h"
  33 #include "libguile/procprop.h"
  34 #include "libguile/chars.h"
  35 #include "libguile/keywords.h"
  36 #include "libguile/smob.h"
  37 #include "libguile/eval.h"
  38 #include "libguile/alist.h"
  39 #include "libguile/ports.h"
  40 #include "libguile/strings.h"
  41 #include "libguile/vectors.h"
  42 #include "libguile/programs.h"
  43 #include "libguile/vm.h"
  44
  45 #include "libguile/validate.h"
  46 #include "libguile/objects.h"
  47 #include "libguile/goops.h"
  48
  49 \f
  50
  51 SCM scm_metaclass_standard;
  52 SCM scm_metaclass_operator;
  53
  54 /* The cache argument for scm_mcache_lookup_cmethod has one of two possible
  55  * formats:
  56  *
  57  * Format #1:
  58  * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
  59  *   #((TYPE1 ... ENV FORMALS FORM ...) ...)
  60  *   GF)
  61  *
  62  * Format #2:
  63  * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
  64  *   #((TYPE1 ... ENV FORMALS FORM ...) ...)
  65  *   GF)
  66  *
  67  * ARGS is either a list of expressions, in which case they
  68  * are interpreted as the arguments of an application, or
  69  * a non-pair, which is interpreted as a single expression
  70  * yielding all arguments.
  71  *
  72  * SCM_IM_DISPATCH expressions in generic functions always
  73  * have ARGS = the symbol `args' or the iloc #@0-0.
  74  *
  75  * Need FORMALS in order to support varying arity.  This
  76  * also avoids the need for renaming of bindings.
  77  *
  78  * We should probably not complicate this mechanism by
  79  * introducing "optimizations" for getters and setters or
  80  * primitive methods.  Getters and setter will normally be
  81  * compiled into @slot-[ref|set!] or a procedure call.
  82  * They rely on the dispatch performed before executing
  83  * the code which contains them.
  84  *
  85  * We might want to use a more efficient representation of
  86  * this form in the future, perhaps after we have introduced
  87  * low-level support for syntax-case macros.
  88  */
  89
  90 SCM
  91 scm_mcache_lookup_cmethod (SCM cache, SCM args)
  92 {
  93   unsigned long i, mask, n, end;
  94   SCM ls, methods, z = SCM_CDDR (cache);
  95   n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
  96   methods = SCM_CADR (z);
  97
  98   if (scm_is_simple_vector (methods))
  99     {
 100       /* cache format #1: prepare for linear search */
 101       mask = -1;
 102       i = 0;
 103       end = SCM_SIMPLE_VECTOR_LENGTH (methods);
 104     }
 105   else
 106     {
 107       /* cache format #2: compute a hash value */
 108       unsigned long hashset = scm_to_ulong (methods);
 109       long j = n;
 110       z = SCM_CDDR (z);
 111       mask = scm_to_ulong (SCM_CAR (z));
 112       methods = SCM_CADR (z);
 113       i = 0;
 114       ls = args;
 115       if (!scm_is_null (ls))
 116         do
 117           {
 118             i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
 119                  [scm_si_hashsets + hashset];
 120             ls = SCM_CDR (ls);
 121           }
 122         while (j-- && !scm_is_null (ls));
 123       i &= mask;
 124       end = i;
 125     }
 126
 127   /* Search for match  */
 128   do
 129     {
 130       long j = n;
 131       z = SCM_SIMPLE_VECTOR_REF (methods, i);
 132       ls = args; /* list of arguments */
 133       if (!scm_is_null (ls))
 134         do
 135           {
 136             /* More arguments than specifiers => CLASS != ENV */
 137             if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
 138               goto next_method;
 139             ls = SCM_CDR (ls);
 140             z = SCM_CDR (z);
 141           }
 142         while (j-- && !scm_is_null (ls));
 143       /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */
 144       if (!scm_is_pair (z)
 145           || (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z))))
 146         return z;
 147     next_method:
 148       i = (i + 1) & mask;
 149     } while (i != end);
 150   return SCM_BOOL_F;
 151 }
 152
 153 SCM
 154 scm_mcache_compute_cmethod (SCM cache, SCM args)
 155 {
 156   SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
 157   if (scm_is_false (cmethod))
 158     /* No match - memoize */
 159     return scm_memoize_method (cache, args);
 160   return cmethod;
 161 }
 162
 163 SCM
 164 scm_apply_generic (SCM gf, SCM args)
 165 {
 166   SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
 167   if (SCM_PROGRAM_P (cmethod))
 168     return scm_vm_apply (scm_the_vm (), cmethod, args);
 169   else if (scm_is_pair (cmethod))
 170     return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
 171                           SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
 172                                           args,
 173                                           SCM_CMETHOD_ENV (cmethod)));
 174   else
 175     return scm_apply (cmethod, args, SCM_EOL);
 176 }
 177
 178 SCM
 179 scm_call_generic_0 (SCM gf)
 180 {
 181   return scm_apply_generic (gf, SCM_EOL);
 182 }
 183
 184 SCM
 185 scm_call_generic_1 (SCM gf, SCM a1)
 186 {
 187   return scm_apply_generic (gf, scm_list_1 (a1));
 188 }
 189
 190 SCM
 191 scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
 192 {
 193   return scm_apply_generic (gf, scm_list_2 (a1, a2));
 194 }
 195
 196 SCM
 197 scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
 198 {
 199   return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
 200 }
 201
 202 SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0,
 203             (SCM obj),
 204             "Return @code{#t} if @var{obj} is an entity.")
 205 #define FUNC_NAME s_scm_entity_p
 206 {
 207   return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
 208 }
 209 #undef FUNC_NAME
 210
 211 SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0,
 212             (SCM obj),
 213             "Return @code{#t} if @var{obj} is an operator.")
 214 #define FUNC_NAME s_scm_operator_p
 215 {
 216   return scm_from_bool(SCM_STRUCTP (obj)
 217                   && SCM_I_OPERATORP (obj)
 218                   && !SCM_I_ENTITYP (obj));
 219 }
 220 #undef FUNC_NAME
 221
 222 /* XXX - What code requires the object procedure to be only of certain
 223          types? */
 224
 225 SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
 226             (SCM proc),
 227             "Return @code{#t} iff @var{proc} is a procedure that can be used "
 228             "with @code{set-object-procedure}.  It is always valid to use "
 229             "a closure constructed by @code{lambda}.")
 230 #define FUNC_NAME s_scm_valid_object_procedure_p
 231 {
 232   if (SCM_IMP (proc))
 233     return SCM_BOOL_F;
 234   switch (SCM_TYP7 (proc))
 235     {
 236     default:
 237       return SCM_BOOL_F;
 238     case scm_tcs_closures:
 239     case scm_tc7_subr_1:
 240     case scm_tc7_subr_2:
 241     case scm_tc7_subr_3:
 242     case scm_tc7_lsubr_2:
 243       return SCM_BOOL_T;
 244     }
 245 }
 246 #undef FUNC_NAME
 247
 248 SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
 249             (SCM obj, SCM proc),
 250             "Set the object procedure of @var{obj} to @var{proc}.\n"
 251             "@var{obj} must be either an entity or an operator.")
 252 #define FUNC_NAME s_scm_set_object_procedure_x
 253 {
 254   SCM_ASSERT (SCM_STRUCTP (obj)
 255               && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
 256                   || (SCM_I_ENTITYP (obj)
 257                       && !(SCM_OBJ_CLASS_FLAGS (obj)
 258                            & SCM_CLASSF_PURE_GENERIC))),
 259               obj,
 260               SCM_ARG1,
 261               FUNC_NAME);
 262   SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME);
 263   if (SCM_I_ENTITYP (obj))
 264     SCM_SET_ENTITY_PROCEDURE (obj, proc);
 265   else
 266     SCM_OPERATOR_CLASS (obj)->procedure = proc;
 267   return SCM_UNSPECIFIED;
 268 }
 269 #undef FUNC_NAME
 270
 271 #ifdef GUILE_DEBUG
 272 SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0,
 273             (SCM obj),
 274             "Return the object procedure of @var{obj}. @var{obj} must be\n"
 275             "an entity or an operator.")
 276 #define FUNC_NAME s_scm_object_procedure
 277 {
 278   SCM_ASSERT (SCM_STRUCTP (obj)
 279               && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
 280                   || SCM_I_ENTITYP (obj)),
 281               obj, SCM_ARG1, FUNC_NAME);
 282   return (SCM_I_ENTITYP (obj)
 283           ? SCM_ENTITY_PROCEDURE (obj)
 284           : SCM_OPERATOR_CLASS (obj)->procedure);
 285 }
 286 #undef FUNC_NAME
 287 #endif /* GUILE_DEBUG */
 288
 289 /* The following procedures are not a part of Goops but a minimal
 290  * object system built upon structs.  They are here for those who
 291  * want to implement their own object system.
 292  */
 293
 294 SCM
 295 scm_i_make_class_object (SCM meta,
 296                          SCM layout_string,
 297                          unsigned long flags)
 298 {
 299   SCM c;
 300   SCM layout = scm_make_struct_layout (layout_string);
 301   c = scm_make_struct (meta,
 302                        SCM_INUM0,
 303                        scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
 304   SCM_SET_CLASS_FLAGS (c, flags);
 305   return c;
 306 }
 307
 308 SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0,
 309             (SCM metaclass, SCM layout),
 310             "Create a new class object of class @var{metaclass}, with the\n"
 311             "slot layout specified by @var{layout}.")
 312 #define FUNC_NAME s_scm_make_class_object
 313 {
 314   unsigned long flags = 0;
 315   SCM_VALIDATE_STRUCT (1, metaclass);
 316   SCM_VALIDATE_STRING (2, layout);
 317   if (scm_is_eq (metaclass, scm_metaclass_operator))
 318     flags = SCM_CLASSF_OPERATOR;
 319   return scm_i_make_class_object (metaclass, layout, flags);
 320 }
 321 #undef FUNC_NAME
 322
 323 SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0,
 324             (SCM class, SCM layout),
 325             "Create a subclass object of @var{class}, with the slot layout\n"
 326             "specified by @var{layout}.")
 327 #define FUNC_NAME s_scm_make_subclass_object
 328 {
 329   SCM pl;
 330   SCM_VALIDATE_STRUCT (1, class);
 331   SCM_VALIDATE_STRING (2, layout);
 332   pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]);
 333   pl = scm_symbol_to_string (pl);
 334   return scm_i_make_class_object (SCM_STRUCT_VTABLE (class),
 335                                   scm_string_append (scm_list_2 (pl, layout)),
 336                                   SCM_CLASS_FLAGS (class));
 337 }
 338 #undef FUNC_NAME
 339
 340 void
 341 scm_init_objects ()
 342 {
 343   SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT);
 344   SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0,
 345                                    scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
 346
 347   SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT);
 348   SCM ot = scm_make_vtable_vtable (os, SCM_INUM0,
 349                                    scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
 350
 351   SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT);
 352   SCM el = scm_make_struct_layout (es);
 353   SCM et = scm_make_struct (mt, SCM_INUM0,
 354                             scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));
 355
 356   scm_c_define ("<class>", mt);
 357   scm_metaclass_standard = mt;
 358   scm_c_define ("<operator-class>", ot);
 359   scm_metaclass_operator = ot;
 360   SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
 361   SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity);
 362   scm_c_define ("<entity>", et);
 363
 364 #include "libguile/objects.x"
 365 }
 366
 367 /*
 368   Local Variables:
 369   c-file-style: "gnu"
 370   End:
 371 */