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