1 /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 #include "libguile/_scm.h"
23 #include "libguile/alist.h"
24 #include "libguile/eval.h"
25 #include "libguile/procs.h"
26 #include "libguile/gsubr.h"
27 #include "libguile/objects.h"
28 #include "libguile/smob.h"
29 #include "libguile/root.h"
30 #include "libguile/vectors.h"
31 #include "libguile/hashtab.h"
33 #include "libguile/validate.h"
34 #include "libguile/procprop.h"
37 SCM_GLOBAL_SYMBOL (scm_sym_system_procedure
, "system-procedure");
38 SCM_GLOBAL_SYMBOL (scm_sym_arity
, "arity");
41 scm_i_procedure_arity (SCM proc
)
43 int a
= 0, o
= 0, r
= 0;
47 switch (SCM_TYP7 (proc
))
76 if (SCM_SMOB_APPLICABLE_P (proc
))
78 int type
= SCM_SMOB_DESCRIPTOR (proc
).gsubr_type
;
79 a
+= SCM_GSUBR_REQ (type
);
80 o
= SCM_GSUBR_OPT (type
);
81 r
= SCM_GSUBR_REST (type
);
89 if (scm_is_eq (SCM_CCLO_SUBR (proc
), scm_f_gsubr_apply
))
91 int type
= scm_to_int (SCM_GSUBR_TYPE (proc
));
92 a
+= SCM_GSUBR_REQ (type
);
93 o
= SCM_GSUBR_OPT (type
);
94 r
= SCM_GSUBR_REST (type
);
99 proc
= SCM_CCLO_SUBR (proc
);
104 proc
= SCM_PROCEDURE (proc
);
106 case scm_tcs_closures
:
107 proc
= SCM_CLOSURE_FORMALS (proc
);
108 if (scm_is_null (proc
))
110 while (scm_is_pair (proc
))
113 proc
= SCM_CDR (proc
);
115 if (!scm_is_null (proc
))
119 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
124 else if (!SCM_I_OPERATORP (proc
))
126 proc
= (SCM_I_ENTITYP (proc
)
127 ? SCM_ENTITY_PROCEDURE (proc
)
128 : SCM_OPERATOR_PROCEDURE (proc
));
134 return scm_list_3 (scm_from_int (a
), scm_from_int (o
), scm_from_bool(r
));
137 /* XXX - instead of using a stand-in value for everything except
138 closures, we should find other ways to store the procedure
139 properties for those other kinds of procedures. For example, subrs
140 have their own property slot, which is unused at present.
144 scm_stand_in_scm_proc(SCM proc
)
147 handle
= scm_hashq_get_handle (scm_stand_in_procs
, proc
);
148 if (scm_is_false (handle
))
150 answer
= scm_closure (scm_list_2 (SCM_EOL
, SCM_BOOL_F
), SCM_EOL
);
151 scm_hashq_set_x (scm_stand_in_procs
, proc
, answer
);
154 answer
= SCM_CDR (handle
);
158 SCM_DEFINE (scm_procedure_properties
, "procedure-properties", 1, 0, 0,
160 "Return @var{obj}'s property list.")
161 #define FUNC_NAME s_scm_procedure_properties
163 SCM_VALIDATE_PROC (1, proc
);
164 return scm_acons (scm_sym_arity
, scm_i_procedure_arity (proc
),
165 SCM_PROCPROPS (SCM_CLOSUREP (proc
)
167 : scm_stand_in_scm_proc (proc
)));
171 SCM_DEFINE (scm_set_procedure_properties_x
, "set-procedure-properties!", 2, 0, 0,
172 (SCM proc
, SCM new_val
),
173 "Set @var{obj}'s property list to @var{alist}.")
174 #define FUNC_NAME s_scm_set_procedure_properties_x
176 if (!SCM_CLOSUREP (proc
))
177 proc
= scm_stand_in_scm_proc(proc
);
178 SCM_VALIDATE_CLOSURE (1, proc
);
179 SCM_SETPROCPROPS (proc
, new_val
);
180 return SCM_UNSPECIFIED
;
184 SCM_DEFINE (scm_procedure_property
, "procedure-property", 2, 0, 0,
186 "Return the property of @var{obj} with name @var{key}.")
187 #define FUNC_NAME s_scm_procedure_property
190 if (scm_is_eq (k
, scm_sym_arity
))
193 SCM_ASSERT (scm_is_true (arity
= scm_i_procedure_arity (p
)),
194 p
, SCM_ARG1
, FUNC_NAME
);
197 SCM_VALIDATE_PROC (1, p
);
198 assoc
= scm_sloppy_assq (k
,
199 SCM_PROCPROPS (SCM_CLOSUREP (p
)
201 : scm_stand_in_scm_proc (p
)));
202 return (SCM_NIMP (assoc
) ? SCM_CDR (assoc
) : SCM_BOOL_F
);
206 SCM_DEFINE (scm_set_procedure_property_x
, "set-procedure-property!", 3, 0, 0,
207 (SCM p
, SCM k
, SCM v
),
208 "In @var{obj}'s property list, set the property named @var{key} to\n"
210 #define FUNC_NAME s_scm_set_procedure_property_x
213 if (!SCM_CLOSUREP (p
))
214 p
= scm_stand_in_scm_proc(p
);
215 SCM_VALIDATE_CLOSURE (1, p
);
216 if (scm_is_eq (k
, scm_sym_arity
))
217 SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL
);
218 assoc
= scm_sloppy_assq (k
, SCM_PROCPROPS (p
));
219 if (SCM_NIMP (assoc
))
220 SCM_SETCDR (assoc
, v
);
222 SCM_SETPROCPROPS (p
, scm_acons (k
, v
, SCM_PROCPROPS (p
)));
223 return SCM_UNSPECIFIED
;
233 #include "libguile/procprop.x"