libguile/properties.c

   1 /* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009 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 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include "libguile/_scm.h"
  26 #include "libguile/hashtab.h"
  27 #include "libguile/alist.h"
  28 #include "libguile/root.h"
  29 #include "libguile/weaks.h"
  30 #include "libguile/validate.h"
  31 #include "libguile/eval.h"
  32
  33 #include "libguile/properties.h"
  34 \f
  35
  36 /* {Properties}
  37  */
  38
  39 static SCM properties_whash;
  40
  41 SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0,
  42             (SCM not_found_proc),
  43             "Create a @dfn{property token} that can be used with\n"
  44             "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
  45             "See @code{primitive-property-ref} for the significance of\n"
  46             "@var{not_found_proc}.")
  47 #define FUNC_NAME s_scm_primitive_make_property
  48 {
  49   if (not_found_proc != SCM_BOOL_F)
  50     SCM_VALIDATE_PROC (SCM_ARG1, not_found_proc);
  51   return scm_cons (not_found_proc, SCM_EOL);
  52 }
  53 #undef FUNC_NAME
  54
  55
  56 SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
  57             (SCM prop, SCM obj),
  58             "Return the property @var{prop} of @var{obj}.\n"
  59             "\n"
  60             "When no value has yet been associated with @var{prop} and\n"
  61             "@var{obj}, the @var{not-found-proc} from @var{prop} is used.  A\n"
  62             "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
  63             "and the result set as the property value.  If\n"
  64             "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
  65             "property value.")
  66 #define FUNC_NAME s_scm_primitive_property_ref
  67 {
  68   SCM h;
  69
  70   SCM_VALIDATE_CONS (SCM_ARG1, prop);
  71
  72   h = scm_hashq_get_handle (properties_whash, obj);
  73   if (scm_is_true (h))
  74     {
  75       SCM assoc = scm_assq (prop, SCM_CDR (h));
  76       if (scm_is_true (assoc))
  77         return SCM_CDR (assoc);
  78     }
  79
  80   if (scm_is_false (SCM_CAR (prop)))
  81     return SCM_BOOL_F;
  82   else
  83     {
  84       SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
  85       if (scm_is_false (h))
  86         h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
  87       SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
  88       return val;
  89     }
  90 }
  91 #undef FUNC_NAME
  92
  93
  94 SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
  95             (SCM prop, SCM obj, SCM val),
  96             "Set the property @var{prop} of @var{obj} to @var{val}.")
  97 #define FUNC_NAME s_scm_primitive_property_set_x
  98 {
  99   SCM h, assoc;
 100   SCM_VALIDATE_CONS (SCM_ARG1, prop);
 101   h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
 102   assoc = scm_assq (prop, SCM_CDR (h));
 103   if (SCM_NIMP (assoc))
 104     SCM_SETCDR (assoc, val);
 105   else
 106     {
 107       assoc = scm_acons (prop, val, SCM_CDR (h));
 108       SCM_SETCDR (h, assoc);
 109     }
 110   return SCM_UNSPECIFIED;
 111 }
 112 #undef FUNC_NAME
 113
 114
 115 SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
 116             (SCM prop, SCM obj),
 117             "Remove any value associated with @var{prop} and @var{obj}.")
 118 #define FUNC_NAME s_scm_primitive_property_del_x
 119 {
 120   SCM h;
 121   SCM_VALIDATE_CONS (SCM_ARG1, prop);
 122   h = scm_hashq_get_handle (properties_whash, obj);
 123   if (scm_is_true (h))
 124     SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
 125   return SCM_UNSPECIFIED;
 126 }
 127 #undef FUNC_NAME
 128
 129
 130 void
 131 scm_init_properties ()
 132 {
 133   properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 134 #include "libguile/properties.x"
 135 }
 136
 137
 138 /*
 139   Local Variables:
 140   c-file-style: "gnu"
 141   End:
 142 */