1 /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
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.
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
25 #include "libguile/_scm.h"
27 #include "libguile/alist.h"
28 #include "libguile/eval.h"
29 #include "libguile/procs.h"
30 #include "libguile/gsubr.h"
31 #include "libguile/smob.h"
32 #include "libguile/root.h"
33 #include "libguile/vectors.h"
34 #include "libguile/hashtab.h"
35 #include "libguile/programs.h"
37 #include "libguile/validate.h"
38 #include "libguile/procprop.h"
41 SCM_GLOBAL_SYMBOL (scm_sym_system_procedure
, "system-procedure");
42 SCM_GLOBAL_SYMBOL (scm_sym_arity
, "arity");
44 static SCM non_closure_props
;
45 static scm_i_pthread_mutex_t non_closure_props_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
48 scm_i_procedure_arity (SCM proc
)
50 int a
= 0, o
= 0, r
= 0;
54 switch (SCM_TYP7 (proc
))
79 if (scm_i_program_arity (proc
, &a
, &o
, &r
))
88 if (SCM_SMOB_APPLICABLE_P (proc
))
90 int type
= SCM_SMOB_DESCRIPTOR (proc
).gsubr_type
;
91 a
+= SCM_GSUBR_REQ (type
);
92 o
= SCM_GSUBR_OPT (type
);
93 r
= SCM_GSUBR_REST (type
);
102 unsigned int type
= SCM_GSUBR_TYPE (proc
);
103 a
= SCM_GSUBR_REQ (type
);
104 o
= SCM_GSUBR_OPT (type
);
105 r
= SCM_GSUBR_REST (type
);
109 proc
= SCM_PROCEDURE (proc
);
111 case scm_tcs_closures
:
112 proc
= SCM_CLOSURE_FORMALS (proc
);
113 if (scm_is_null (proc
))
115 while (scm_is_pair (proc
))
118 proc
= SCM_CDR (proc
);
120 if (!scm_is_null (proc
))
124 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
129 else if (!SCM_STRUCT_APPLICABLE_P (proc
))
131 proc
= SCM_STRUCT_PROCEDURE (proc
);
136 return scm_list_3 (scm_from_int (a
), scm_from_int (o
), scm_from_bool(r
));
139 /* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
140 other means; for example subrs have their own property slot, which is unused
143 SCM_DEFINE (scm_procedure_properties
, "procedure-properties", 1, 0, 0,
145 "Return @var{obj}'s property list.")
146 #define FUNC_NAME s_scm_procedure_properties
150 SCM_VALIDATE_PROC (1, proc
);
151 if (SCM_CLOSUREP (proc
))
152 props
= SCM_PROCPROPS (proc
);
155 scm_i_pthread_mutex_lock (&non_closure_props_lock
);
156 props
= scm_hashq_ref (non_closure_props
, proc
, SCM_EOL
);
157 scm_i_pthread_mutex_unlock (&non_closure_props_lock
);
159 return scm_acons (scm_sym_arity
, scm_i_procedure_arity (proc
), props
);
163 SCM_DEFINE (scm_set_procedure_properties_x
, "set-procedure-properties!", 2, 0, 0,
164 (SCM proc
, SCM alist
),
165 "Set @var{proc}'s property list to @var{alist}.")
166 #define FUNC_NAME s_scm_set_procedure_properties_x
168 SCM_VALIDATE_PROC (1, proc
);
170 if (SCM_CLOSUREP (proc
))
171 SCM_SETPROCPROPS (proc
, alist
);
174 scm_i_pthread_mutex_lock (&non_closure_props_lock
);
175 scm_hashq_set_x (non_closure_props
, proc
, alist
);
176 scm_i_pthread_mutex_unlock (&non_closure_props_lock
);
178 return SCM_UNSPECIFIED
;
182 SCM_DEFINE (scm_procedure_property
, "procedure-property", 2, 0, 0,
184 "Return the property of @var{proc} with name @var{key}.")
185 #define FUNC_NAME s_scm_procedure_property
187 SCM_VALIDATE_PROC (1, proc
);
189 if (scm_is_eq (key
, scm_sym_arity
))
190 /* avoid a cons in this case */
191 return scm_i_procedure_arity (proc
);
195 if (SCM_CLOSUREP (proc
))
196 props
= SCM_PROCPROPS (proc
);
199 scm_i_pthread_mutex_lock (&non_closure_props_lock
);
200 props
= scm_hashq_ref (non_closure_props
, proc
, SCM_EOL
);
201 scm_i_pthread_mutex_unlock (&non_closure_props_lock
);
203 return scm_assq_ref (props
, key
);
208 SCM_DEFINE (scm_set_procedure_property_x
, "set-procedure-property!", 3, 0, 0,
209 (SCM proc
, SCM key
, SCM val
),
210 "In @var{proc}'s property list, set the property named @var{key} to\n"
212 #define FUNC_NAME s_scm_set_procedure_property_x
214 SCM_VALIDATE_PROC (1, proc
);
216 if (scm_is_eq (key
, scm_sym_arity
))
217 SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL
);
219 if (SCM_CLOSUREP (proc
))
220 SCM_SETPROCPROPS (proc
,
221 scm_assq_set_x (SCM_PROCPROPS (proc
), key
, val
));
224 scm_i_pthread_mutex_lock (&non_closure_props_lock
);
225 scm_hashq_set_x (non_closure_props
, proc
,
226 scm_assq_set_x (scm_hashq_ref (non_closure_props
, proc
,
229 scm_i_pthread_mutex_unlock (&non_closure_props_lock
);
232 return SCM_UNSPECIFIED
;
242 non_closure_props
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
243 #include "libguile/procprop.x"