-/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1999, 2000 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
* 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. */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+
\f
#include <stdio.h>
#include "objects.h"
+#include "validate.h"
#include "procs.h"
\f
scm_subr_entry *scm_subr_table;
-/* libguile contained approx. 700 primitive procedures 990824. */
+/* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */
int scm_subr_table_size = 0;
int scm_subr_table_room = 750;
SCM
-scm_make_subr_opt (name, type, fcn, set)
- const char *name;
- int type;
- SCM (*fcn) ();
- int set;
+scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
{
SCM symcell;
register SCM z;
if (scm_subr_table_size == scm_subr_table_room)
{
- scm_sizet new_size = scm_port_table_room * 3 / 2;
- void *new_table = scm_must_realloc ((char *) scm_subr_table,
- scm_subr_table_room,
- new_size,
- "scm_make_subr_opt");
+ scm_sizet new_size = scm_subr_table_room * 3 / 2;
+ void *new_table
+ = scm_must_realloc ((char *) scm_subr_table,
+ sizeof (scm_subr_entry) * scm_subr_table_room,
+ sizeof (scm_subr_entry) * new_size,
+ "scm_make_subr_opt");
scm_subr_table = new_table;
scm_subr_table_room = new_size;
}
}
SCM
-scm_make_subr (name, type, fcn)
- const char *name;
- int type;
- SCM (*fcn) ();
+scm_make_subr (const char *name, int type, SCM (*fcn) ())
{
return scm_make_subr_opt (name, type, fcn, 1);
}
#ifdef CCLO
SCM
-scm_makcclo (proc, len)
- SCM proc;
- long len;
+scm_makcclo (SCM proc, long len)
{
SCM s;
SCM_NEWCELL (s);
/* Undocumented debugging procedure */
#ifdef GUILE_DEBUG
-SCM_PROC (s_make_cclo, "make-cclo", 2, 0, 0, scm_make_cclo);
-
-SCM
-scm_make_cclo (proc, len)
- SCM proc;
- SCM len;
+SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0,
+ (SCM proc, SCM len),
+"")
+#define FUNC_NAME s_scm_make_cclo
{
return scm_makcclo (proc, SCM_INUM (len));
}
+#undef FUNC_NAME
#endif
#endif
-SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p);
-
-SCM
-scm_procedure_p (obj)
- SCM obj;
+SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_procedure_p
{
if (SCM_NIMP (obj))
switch (SCM_TYP7 (obj))
}
return SCM_BOOL_F;
}
+#undef FUNC_NAME
-SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p);
-
-SCM
-scm_closure_p (obj)
- SCM obj;
+SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_closure_p
{
- return SCM_NIMP (obj) && SCM_CLOSUREP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+ return SCM_BOOL(SCM_CLOSUREP (obj));
}
+#undef FUNC_NAME
-SCM_PROC(s_thunk_p, "thunk?", 1, 0, 0, scm_thunk_p);
-
-#ifdef __STDC__
-SCM
-scm_thunk_p (SCM obj)
-#else
-SCM
-scm_thunk_p (obj)
- SCM obj;
-#endif
+SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_thunk_p
{
if (SCM_NIMP (obj))
{
}
return SCM_BOOL_F;
}
+#undef FUNC_NAME
/* Only used internally. */
int
return 0;
}
-SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
-
-SCM
-scm_procedure_documentation (proc)
- SCM proc;
+SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
+ (SCM proc),
+ "Return the documentation string associated with @code{proc}. By\n"
+ "convention, if a procedure contains more than one expression and the\n"
+ "first expression is a string constant, that string is assumed to contain\n"
+ "documentation for that procedure.")
+#define FUNC_NAME s_scm_procedure_documentation
{
SCM code;
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin,
- proc, SCM_ARG1, s_procedure_documentation);
+ proc, SCM_ARG1, FUNC_NAME);
switch (SCM_TYP7 (proc))
{
case scm_tcs_closures:
*/
}
}
+#undef FUNC_NAME
/* Procedure-with-setter
*/
-SCM_PROC (s_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, scm_procedure_with_setter_p);
-
-SCM
-scm_procedure_with_setter_p (SCM obj)
+SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_procedure_with_setter_p
{
- return (SCM_NIMP (obj) && SCM_PROCEDURE_WITH_SETTER_P (obj)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return SCM_BOOL(SCM_PROCEDURE_WITH_SETTER_P (obj));
}
+#undef FUNC_NAME
-SCM_PROC (s_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0, scm_make_procedure_with_setter);
-
-SCM
-scm_make_procedure_with_setter (SCM procedure, SCM setter)
+SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0,
+ (SCM procedure, SCM setter),
+ "")
+#define FUNC_NAME s_scm_make_procedure_with_setter
{
SCM z;
- SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (procedure)),
- procedure, SCM_ARG1, s_make_procedure_with_setter);
- SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (setter)),
- setter, SCM_ARG2, s_make_procedure_with_setter);
- SCM_NEWCELL (z);
+ SCM_VALIDATE_PROC (1, procedure);
+ SCM_VALIDATE_PROC (2, setter);
+ SCM_NEWCELL2 (z);
SCM_ENTER_A_SECTION;
- SCM_SETCDR (z, scm_cons (procedure, setter));
+ SCM_SET_CELL_WORD1 (z, procedure);
+ SCM_SET_CELL_WORD2 (z, setter);
SCM_SETCAR (z, scm_tc7_pws);
SCM_EXIT_A_SECTION;
return z;
}
+#undef FUNC_NAME
-SCM_PROC (s_procedure, "procedure", 1, 0, 0, scm_procedure);
-
-SCM
-scm_procedure (SCM proc)
+SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
+ (SCM proc),
+ "")
+#define FUNC_NAME s_scm_procedure
{
- SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure);
+ SCM_VALIDATE_NIM (1, proc);
if (SCM_PROCEDURE_WITH_SETTER_P (proc))
return SCM_PROCEDURE (proc);
else if (SCM_STRUCTP (proc))
{
- SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, s_procedure);
+ SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME);
return proc;
}
- scm_wrong_type_arg (s_procedure, SCM_ARG1, proc);
+ SCM_WRONG_TYPE_ARG (1, proc);
return 0; /* not reached */
}
+#undef FUNC_NAME
SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
return SCM_SETTER (proc);
else if (SCM_STRUCTP (proc))
{
+ SCM setter;
SCM_GASSERT1 (SCM_I_OPERATORP (proc),
g_setter, proc, SCM_ARG1, s_setter);
- return (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_SETTER (proc)
- : SCM_OPERATOR_SETTER (proc));
+ setter = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_SETTER (proc)
+ : SCM_OPERATOR_SETTER (proc));
+ if (SCM_NIMP (setter))
+ return setter;
+ /* fall through */
}
SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
return 0;
void
-scm_init_iprocs(subra, type)
- const scm_iproc *subra;
- int type;
+scm_init_iprocs(const scm_iproc *subra, int type)
{
for(;subra->scm_string; subra++)
scm_make_subr(subra->scm_string,
HCoop / bpt / guile.git / blobdiff