1 /* Copyright (C) 1995,1996,2000,2001, 2003 Free Software Foundation, Inc.
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.
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.
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
21 #include "libguile/_scm.h"
22 #include "libguile/hashtab.h"
23 #include "libguile/alist.h"
24 #include "libguile/root.h"
25 #include "libguile/weaks.h"
26 #include "libguile/validate.h"
27 #include "libguile/eval.h"
29 #include "libguile/properties.h"
35 SCM_DEFINE (scm_primitive_make_property
, "primitive-make-property", 1, 0, 0,
37 "Create a @dfn{property token} that can be used with\n"
38 "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
39 "See @code{primitive-property-ref} for the significance of\n"
40 "@var{not_found_proc}.")
41 #define FUNC_NAME s_scm_primitive_make_property
43 if (not_found_proc
!= SCM_BOOL_F
)
44 SCM_VALIDATE_PROC (SCM_ARG1
, not_found_proc
);
45 return scm_cons (not_found_proc
, SCM_EOL
);
50 SCM_DEFINE (scm_primitive_property_ref
, "primitive-property-ref", 2, 0, 0,
52 "Return the property @var{prop} of @var{obj}.\n"
54 "When no value has yet been associated with @var{prop} and\n"
55 "@var{obj}, the @var{not-found-proc} from @var{prop} is used. A\n"
56 "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
57 "and the result set as the property value. If\n"
58 "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
60 #define FUNC_NAME s_scm_primitive_property_ref
64 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
66 h
= scm_hashq_get_handle (scm_properties_whash
, obj
);
69 SCM assoc
= scm_assq (prop
, SCM_CDR (h
));
70 if (!SCM_FALSEP (assoc
))
71 return SCM_CDR (assoc
);
74 if (SCM_FALSEP (SCM_CAR (prop
)))
78 SCM val
= scm_call_2 (SCM_CAR (prop
), prop
, obj
);
80 h
= scm_hashq_create_handle_x (scm_properties_whash
, obj
, SCM_EOL
);
81 SCM_SETCDR (h
, scm_acons (prop
, val
, SCM_CDR (h
)));
88 SCM_DEFINE (scm_primitive_property_set_x
, "primitive-property-set!", 3, 0, 0,
89 (SCM prop
, SCM obj
, SCM val
),
90 "Set the property @var{prop} of @var{obj} to @var{val}.")
91 #define FUNC_NAME s_scm_primitive_property_set_x
94 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
95 h
= scm_hashq_create_handle_x (scm_properties_whash
, obj
, SCM_EOL
);
96 assoc
= scm_assq (prop
, SCM_CDR (h
));
98 SCM_SETCDR (assoc
, val
);
101 assoc
= scm_acons (prop
, val
, SCM_CDR (h
));
102 SCM_SETCDR (h
, assoc
);
104 return SCM_UNSPECIFIED
;
109 SCM_DEFINE (scm_primitive_property_del_x
, "primitive-property-del!", 2, 0, 0,
111 "Remove any value associated with @var{prop} and @var{obj}.")
112 #define FUNC_NAME s_scm_primitive_property_del_x
115 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
116 h
= scm_hashq_get_handle (scm_properties_whash
, obj
);
118 SCM_SETCDR (h
, scm_assq_remove_x (SCM_CDR (h
), prop
));
119 return SCM_UNSPECIFIED
;
125 scm_init_properties ()
127 scm_properties_whash
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
128 #include "libguile/properties.x"