libguile/objprop.c

   1 /*      Copyright (C) 1995,1996, 2000, 2001, 2003, 2006 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 #include "libguile/_scm.h"
  22 #include "libguile/async.h"
  23 #include "libguile/hashtab.h"
  24 #include "libguile/alist.h"
  25 #include "libguile/root.h"
  26 #include "libguile/weaks.h"
  27
  28 #include "libguile/objprop.h"
  29 \f
  30
  31 /* {Object Properties}
  32  */
  33
  34 SCM_DEFINE (scm_object_properties, "object-properties", 1, 0, 0,
  35            (SCM obj),
  36             "Return @var{obj}'s property list.")
  37 #define FUNC_NAME s_scm_object_properties
  38 {
  39   return scm_hashq_ref (scm_object_whash, obj, SCM_EOL);
  40 }
  41 #undef FUNC_NAME
  42
  43
  44 SCM_DEFINE (scm_set_object_properties_x, "set-object-properties!", 2, 0, 0,
  45             (SCM obj, SCM alist),
  46             "Set @var{obj}'s property list to @var{alist}.")
  47 #define FUNC_NAME s_scm_set_object_properties_x
  48 {
  49   SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, alist);
  50   SCM_SETCDR (handle, alist);
  51   return alist;
  52 }
  53 #undef FUNC_NAME
  54
  55 SCM_DEFINE (scm_object_property, "object-property", 2, 0, 0,
  56            (SCM obj, SCM key),
  57             "Return the property of @var{obj} with name @var{key}.")
  58 #define FUNC_NAME s_scm_object_property
  59 {
  60   SCM assoc;
  61   assoc = scm_assq (key, scm_object_properties (obj));
  62   return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
  63 }
  64 #undef FUNC_NAME
  65
  66 SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0,
  67             (SCM obj, SCM key, SCM value),
  68             "In @var{obj}'s property list, set the property named @var{key}\n"
  69             "to @var{value}.")
  70 #define FUNC_NAME s_scm_set_object_property_x
  71 {
  72   SCM h;
  73   SCM assoc;
  74   h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
  75   SCM_CRITICAL_SECTION_START;
  76   assoc = scm_assq (key, SCM_CDR (h));
  77   if (SCM_NIMP (assoc))
  78     SCM_SETCDR (assoc, value);
  79   else
  80     {
  81       assoc = scm_acons (key, value, SCM_CDR (h));
  82       SCM_SETCDR (h, assoc);
  83     }
  84   SCM_CRITICAL_SECTION_END;
  85   return value;
  86 }
  87 #undef FUNC_NAME
  88
  89
  90 void
  91 scm_init_objprop ()
  92 {
  93   scm_object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
  94 #include "libguile/objprop.x"
  95 }
  96
  97
  98 /*
  99   Local Variables:
 100   c-file-style: "gnu"
 101   End:
 102 */