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}. When no value\n"
53 "has yet been associated with @var{prop} and @var{obj}, call\n"
54 "@var{not-found-proc} instead (see @code{primitive-make-property})\n"
55 "and use its return value. That value is also associated with\n"
56 "@var{obj} via @code{primitive-property-set!}. When\n"
57 "@var{not-found-proc} is @code{#f}, use @code{#f} as the\n"
58 "default value of @var{prop}.")
59 #define FUNC_NAME s_scm_primitive_property_ref
63 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
65 h
= scm_hashq_get_handle (scm_properties_whash
, obj
);
68 SCM assoc
= scm_assq (prop
, SCM_CDR (h
));
69 if (!SCM_FALSEP (assoc
))
70 return SCM_CDR (assoc
);
73 if (SCM_FALSEP (SCM_CAR (prop
)))
77 SCM val
= scm_call_2 (SCM_CAR (prop
), prop
, obj
);
79 h
= scm_hashq_create_handle_x (scm_properties_whash
, obj
, SCM_EOL
);
80 SCM_SETCDR (h
, scm_acons (prop
, val
, SCM_CDR (h
)));
87 SCM_DEFINE (scm_primitive_property_set_x
, "primitive-property-set!", 3, 0, 0,
88 (SCM prop
, SCM obj
, SCM val
),
89 "Associate @var{code} with @var{prop} and @var{obj}.")
90 #define FUNC_NAME s_scm_primitive_property_set_x
93 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
94 h
= scm_hashq_create_handle_x (scm_properties_whash
, obj
, SCM_EOL
);
95 assoc
= scm_assq (prop
, SCM_CDR (h
));
97 SCM_SETCDR (assoc
, val
);
100 assoc
= scm_acons (prop
, val
, SCM_CDR (h
));
101 SCM_SETCDR (h
, assoc
);
103 return SCM_UNSPECIFIED
;
108 SCM_DEFINE (scm_primitive_property_del_x
, "primitive-property-del!", 2, 0, 0,
110 "Remove any value associated with @var{prop} and @var{obj}.")
111 #define FUNC_NAME s_scm_primitive_property_del_x
114 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
115 h
= scm_hashq_get_handle (scm_properties_whash
, obj
);
117 SCM_SETCDR (h
, scm_assq_remove_x (SCM_CDR (h
), prop
));
118 return SCM_UNSPECIFIED
;
124 scm_init_properties ()
126 scm_properties_whash
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
127 #include "libguile/properties.x"