-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
+ * If you do not wish that, delete this exception notice. */
\f
#include <stdio.h>
#include "_scm.h"
+
#include "alist.h"
#include "eval.h"
+#include "procs.h"
+#include "gsubr.h"
+#include "objects.h"
#include "procprop.h"
\f
+SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
+SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+
+SCM
+scm_i_procedure_arity (SCM proc)
+{
+ int a = 0, o = 0, r = 0;
+ if (SCM_IMP (proc))
+ return SCM_BOOL_F;
+ loop:
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_1o:
+ o = 1;
+ case scm_tc7_subr_0:
+ break;
+ case scm_tc7_subr_2o:
+ o = 1;
+ case scm_tc7_subr_1:
+ case scm_tc7_cxr:
+ case scm_tc7_contin:
+ a += 1;
+ break;
+ case scm_tc7_subr_2:
+ a += 2;
+ break;
+ case scm_tc7_subr_3:
+ a += 3;
+ break;
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_lsubr:
+ r = 1;
+ break;
+ case scm_tc7_lsubr_2:
+ a += 2;
+ r = 1;
+ break;
+#ifdef CCLO
+ case scm_tc7_cclo:
+ if (SCM_CCLO_SUBR (proc) == scm_f_gsubr_apply)
+ {
+ int type = SCM_INUM (SCM_GSUBR_TYPE (proc));
+ a += SCM_GSUBR_REQ (type);
+ o = SCM_GSUBR_OPT (type);
+ r = SCM_GSUBR_REST (type);
+ break;
+ }
+ proc = SCM_CCLO_SUBR (proc);
+ a -= 1;
+ goto loop;
+#endif
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ goto loop;
+ case scm_tcs_closures:
+ proc = SCM_CAR (SCM_CODE (proc));
+ if (SCM_IMP (proc))
+ break;
+ while (SCM_NIMP (proc) && SCM_CONSP (proc))
+ {
+ ++a;
+ proc = SCM_CDR (proc);
+ }
+ if (SCM_NIMP (proc))
+ r = 1;
+ break;
+ case scm_tcs_cons_gloc:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ r = 1;
+ break;
+ }
+ else if (!SCM_I_OPERATORP (proc))
+ return SCM_BOOL_F;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+ a -= 1;
+ goto loop;
+ default:
+ return SCM_BOOL_F;
+ }
+ return SCM_LIST3 (SCM_MAKINUM (a),
+ SCM_MAKINUM (o),
+ r ? SCM_BOOL_T : SCM_BOOL_F);
+}
+
static SCM
scm_stand_in_scm_proc(proc)
SCM proc;
scm_procedure_properties (proc)
SCM proc;
{
- SCM_ASSERT (scm_procedure_p (proc), proc, SCM_ARG1, s_procedure_properties);
- if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
- proc = scm_stand_in_scm_proc(proc);
- return SCM_PROCPROPS (proc);
+ SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
+ proc, SCM_ARG1, s_procedure_properties);
+ return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
+ SCM_PROCPROPS (SCM_NIMP (proc) && SCM_CLOSUREP (proc)
+ ? proc
+ : scm_stand_in_scm_proc (proc)));
}
SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x);
if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
proc = scm_stand_in_scm_proc(proc);
SCM_ASSERT (SCM_NIMP (proc) && SCM_CLOSUREP (proc), proc, SCM_ARG1, s_set_procedure_properties_x);
- SCM_PROCPROPS (proc) = new_val;
+ SCM_SETPROCPROPS (proc, new_val);
return SCM_UNSPECIFIED;
}
SCM k;
{
SCM assoc;
- if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
- p = scm_stand_in_scm_proc(p);
- SCM_ASSERT (scm_procedure_p (p), p, SCM_ARG1, s_procedure_property);
- assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
+ if (k == scm_sym_arity)
+ {
+ SCM arity;
+ SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (p)),
+ p, SCM_ARG1, s_procedure_property);
+ return arity;
+ }
+ SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (p)),
+ p, SCM_ARG1, s_procedure_property);
+ assoc = scm_sloppy_assq (k,
+ SCM_PROCPROPS (SCM_NIMP (p) && SCM_CLOSUREP (p)
+ ? p
+ : scm_stand_in_scm_proc (p)));
return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
p = scm_stand_in_scm_proc(p);
SCM_ASSERT (SCM_NIMP (p) && SCM_CLOSUREP (p), p, SCM_ARG1, s_set_procedure_property_x);
+ if (k == scm_sym_arity)
+ scm_misc_error (s_set_procedure_property_x,
+ "arity is a read-only property",
+ SCM_EOL);
assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, v);
else
- SCM_PROCPROPS (p) = scm_acons (k, v, SCM_PROCPROPS (p));
+ SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
return SCM_UNSPECIFIED;
}
HCoop / bpt / guile.git / blobdiff