1 /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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/weak-table.h"
35 #include "libguile/programs.h"
36 #include "libguile/vm-builtins.h"
38 #include "libguile/validate.h"
39 #include "libguile/procprop.h"
42 SCM_GLOBAL_SYMBOL (scm_sym_system_procedure
, "system-procedure");
43 SCM_GLOBAL_SYMBOL (scm_sym_name
, "name");
47 static SCM arity_overrides
;
50 scm_i_procedure_arity (SCM proc
, int *req
, int *opt
, int *rest
)
54 o
= scm_weak_table_refq (arity_overrides
, proc
, SCM_BOOL_F
);
58 *req
= scm_to_int (scm_car (o
));
59 *opt
= scm_to_int (scm_cadr (o
));
60 *rest
= scm_is_true (scm_caddr (o
));
64 while (!SCM_PROGRAM_P (proc
))
66 if (SCM_STRUCTP (proc
))
68 if (!SCM_STRUCT_APPLICABLE_P (proc
))
70 proc
= SCM_STRUCT_PROCEDURE (proc
);
72 else if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
))
74 if (!SCM_SMOB_APPLICABLE_P (proc
))
76 if (!scm_i_program_arity (SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
,
80 /* The trampoline gets the smob too, which users don't
90 return scm_i_program_arity (proc
, req
, opt
, rest
);
93 SCM_DEFINE (scm_set_procedure_minimum_arity_x
, "set-procedure-minimum-arity!",
94 4, 0, 0, (SCM proc
, SCM req
, SCM opt
, SCM rest
),
96 #define FUNC_NAME s_scm_set_procedure_minimum_arity_x
100 SCM_VALIDATE_PROC (1, proc
);
101 SCM_VALIDATE_INT_COPY (2, req
, t
);
102 SCM_VALIDATE_INT_COPY (3, opt
, t
);
103 SCM_VALIDATE_BOOL (4, rest
);
105 scm_weak_table_putq_x (arity_overrides
, proc
, scm_list_3 (req
, opt
, rest
));
106 return SCM_UNDEFINED
;
110 SCM_DEFINE (scm_procedure_minimum_arity
, "procedure-minimum-arity", 1, 0, 0,
112 "Return the \"minimum arity\" of a procedure.\n\n"
113 "If the procedure has only one arity, that arity is returned\n"
114 "as a list of three values: the number of required arguments,\n"
115 "the number of optional arguments, and a boolean indicating\n"
116 "whether or not the procedure takes rest arguments.\n\n"
117 "For a case-lambda procedure, the arity returned is the one\n"
118 "with the lowest minimum number of arguments, and the highest\n"
119 "maximum number of arguments.\n\n"
120 "If it was not possible to determine the arity of the procedure,\n"
121 "@code{#f} is returned.")
122 #define FUNC_NAME s_scm_procedure_minimum_arity
126 if (scm_i_procedure_arity (proc
, &req
, &opt
, &rest
))
127 return scm_list_3 (scm_from_int (req
),
129 scm_from_bool (rest
));
135 SCM_DEFINE (scm_procedure_properties
, "procedure-properties", 1, 0, 0,
137 "Return @var{proc}'s property list.")
138 #define FUNC_NAME s_scm_procedure_properties
142 SCM_VALIDATE_PROC (1, proc
);
144 user_props
= scm_weak_table_refq (overrides
, proc
, SCM_BOOL_F
);
146 if (scm_is_pair (user_props
) && scm_is_true (scm_car (user_props
)))
147 return scm_cdr (user_props
);
149 if (SCM_PROGRAM_P (proc
))
150 ret
= scm_i_program_properties (proc
);
154 if (scm_is_pair (user_props
))
155 for (user_props
= scm_cdr (user_props
);
156 scm_is_pair (user_props
);
157 user_props
= scm_cdr (user_props
))
158 ret
= scm_assq_set_x (ret
, scm_caar (user_props
), scm_cdar (user_props
));
164 SCM_DEFINE (scm_set_procedure_properties_x
, "set-procedure-properties!", 2, 0, 0,
165 (SCM proc
, SCM alist
),
166 "Set @var{proc}'s property list to @var{alist}.")
167 #define FUNC_NAME s_scm_set_procedure_properties_x
169 SCM_VALIDATE_PROC (1, proc
);
171 scm_weak_table_putq_x (overrides
, proc
, scm_cons (SCM_BOOL_T
, alist
));
173 return SCM_UNSPECIFIED
;
177 SCM_DEFINE (scm_procedure_property
, "procedure-property", 2, 0, 0,
179 "Return the property of @var{proc} with name @var{key}.")
180 #define FUNC_NAME s_scm_procedure_property
184 SCM_VALIDATE_PROC (1, proc
);
186 if (scm_is_eq (key
, scm_sym_name
))
187 return scm_procedure_name (proc
);
188 if (scm_is_eq (key
, scm_sym_documentation
))
189 return scm_procedure_documentation (proc
);
191 user_props
= scm_weak_table_refq (overrides
, proc
, SCM_BOOL_F
);
192 if (scm_is_true (user_props
))
194 SCM pair
= scm_assq (key
, scm_cdr (user_props
));
195 if (scm_is_pair (pair
))
196 return scm_cdr (pair
);
197 if (scm_is_true (scm_car (user_props
)))
201 return scm_assq_ref (scm_procedure_properties (proc
), key
);
205 SCM_DEFINE (scm_set_procedure_property_x
, "set-procedure-property!", 3, 0, 0,
206 (SCM proc
, SCM key
, SCM val
),
207 "In @var{proc}'s property list, set the property named @var{key} to\n"
209 #define FUNC_NAME s_scm_set_procedure_property_x
211 SCM user_props
, override_p
;
213 SCM_VALIDATE_PROC (1, proc
);
215 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
216 user_props
= scm_weak_table_refq (overrides
, proc
, SCM_BOOL_F
);
217 if (scm_is_false (user_props
))
219 override_p
= SCM_BOOL_F
;
220 user_props
= SCM_EOL
;
224 override_p
= scm_car (user_props
);
225 user_props
= scm_cdr (user_props
);
227 scm_weak_table_putq_x (overrides
, proc
,
228 scm_cons (override_p
,
229 scm_assq_set_x (user_props
, key
, val
)));
230 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
232 return SCM_UNSPECIFIED
;
239 SCM_SYMBOL (scm_sym_source
, "source");
242 SCM_DEFINE (scm_procedure_name
, "procedure-name", 1, 0, 0,
244 "Return the name of the procedure @var{proc}")
245 #define FUNC_NAME s_scm_procedure_name
249 SCM_VALIDATE_PROC (1, proc
);
251 user_props
= scm_weak_table_refq (overrides
, proc
, SCM_BOOL_F
);
252 if (scm_is_true (user_props
))
254 SCM pair
= scm_assq (scm_sym_name
, scm_cdr (user_props
));
255 if (scm_is_pair (pair
))
256 return scm_cdr (pair
);
257 if (scm_is_true (scm_car (user_props
)))
261 if (SCM_PROGRAM_P (proc
))
262 return scm_i_program_name (proc
);
263 else if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
264 return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc
));
271 SCM_GLOBAL_SYMBOL (scm_sym_documentation
, "documentation");
273 SCM_DEFINE (scm_procedure_documentation
, "procedure-documentation", 1, 0, 0,
275 "Return the documentation string associated with @code{proc}. By\n"
276 "convention, if a procedure contains more than one expression and the\n"
277 "first expression is a string constant, that string is assumed to contain\n"
278 "documentation for that procedure.")
279 #define FUNC_NAME s_scm_procedure_documentation
283 SCM_VALIDATE_PROC (1, proc
);
285 while (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
286 proc
= SCM_STRUCT_PROCEDURE (proc
);
288 user_props
= scm_weak_table_refq (overrides
, proc
, SCM_BOOL_F
);
289 if (scm_is_true (user_props
))
291 SCM pair
= scm_assq (scm_sym_documentation
, scm_cdr (user_props
));
292 if (scm_is_pair (pair
))
293 return scm_cdr (pair
);
294 if (scm_is_true (scm_car (user_props
)))
298 if (SCM_PROGRAM_P (proc
))
299 return scm_i_program_documentation (proc
);
306 SCM_DEFINE (scm_procedure_source
, "procedure-source", 1, 0, 0,
308 "Return the source of the procedure @var{proc}.")
309 #define FUNC_NAME s_scm_procedure_source
312 SCM_VALIDATE_PROC (1, proc
);
316 src
= scm_procedure_property (proc
, scm_sym_source
);
317 if (scm_is_true (src
))
320 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
)
321 && SCM_HEAP_OBJECT_P ((proc
= SCM_STRUCT_PROCEDURE (proc
))))
336 overrides
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
337 arity_overrides
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
338 #include "libguile/procprop.x"
339 scm_init_vm_builtin_properties ();