X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/73be1d9e8ef3744723949752311e60d6a0f89342..e20d7001c3f7150400169fecb0bf0eefdf122fe2:/libguile/procs.c diff --git a/libguile/procs.c b/libguile/procs.c index cc0ee2dac..221514777 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -12,11 +12,14 @@ * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ +#ifdef HAVE_CONFIG_H +# include +#endif #include "libguile/_scm.h" @@ -34,40 +37,20 @@ /* {Procedures} */ -scm_t_subr_entry *scm_subr_table; - -/* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */ - -/* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on - startup, 786 with guile-readline. 'martin */ -long scm_subr_table_size = 0; -long scm_subr_table_room = 800; - -SCM +SCM scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { register SCM z; - long entry; + SCM *meta_info; - if (scm_subr_table_size == scm_subr_table_room) - { - long new_size = scm_subr_table_room * 3 / 2; - void *new_table - = scm_realloc ((char *) scm_subr_table, - sizeof (scm_t_subr_entry) * new_size); - scm_subr_table = new_table; - scm_subr_table_room = new_size; - } + meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info"); + meta_info[0] = scm_from_locale_symbol (name); + meta_info[1] = SCM_EOL; /* properties */ + + z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn, + 0 /* generic */, (scm_t_bits) meta_info); - entry = scm_subr_table_size; - z = scm_cell ((entry << 8) + type, (scm_t_bits) fcn); - scm_subr_table[entry].handle = z; - scm_subr_table[entry].name = scm_str2symbol (name); - scm_subr_table[entry].generic = 0; - scm_subr_table[entry].properties = SCM_EOL; - scm_subr_table_size++; - return z; } @@ -75,7 +58,7 @@ SCM scm_c_define_subr (const char *name, long type, SCM (*fcn) ()) { SCM subr = scm_c_make_subr (name, type, fcn); - scm_define (SCM_SUBR_ENTRY(subr).name, subr); + scm_define (SCM_SNAME (subr), subr); return subr; } @@ -84,11 +67,8 @@ scm_c_define_subr (const char *name, long type, SCM (*fcn) ()) void scm_free_subr_entry (SCM subr) { - long entry = SCM_SUBRNUM (subr); - /* Move last entry in table to the free position */ - scm_subr_table[entry] = scm_subr_table[scm_subr_table_size - 1]; - SCM_SET_SUBRNUM (scm_subr_table[entry].handle, entry); - scm_subr_table_size--; + scm_gc_free (SCM_SUBR_META_INFO (subr), 2 * sizeof (SCM), + "subr meta-info"); } SCM @@ -96,7 +76,7 @@ scm_c_make_subr_with_generic (const char *name, long type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr (name, type, fcn); - SCM_SUBR_ENTRY(subr).generic = gf; + SCM_SET_SUBR_GENERIC_LOC (subr, gf); return subr; } @@ -105,57 +85,10 @@ scm_c_define_subr_with_generic (const char *name, long type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); - scm_define (SCM_SUBR_ENTRY(subr).name, subr); + scm_define (SCM_SNAME (subr), subr); return subr; } -void -scm_mark_subr_table () -{ - long i; - for (i = 0; i < scm_subr_table_size; ++i) - { - scm_gc_mark (scm_subr_table[i].name); - if (scm_subr_table[i].generic && *scm_subr_table[i].generic) - scm_gc_mark (*scm_subr_table[i].generic); - if (SCM_NIMP (scm_subr_table[i].properties)) - scm_gc_mark (scm_subr_table[i].properties); - } -} - - -#ifdef CCLO -SCM -scm_makcclo (SCM proc, size_t len) -{ - scm_t_bits *base = scm_gc_malloc (len * sizeof (scm_t_bits), - "compiled closure"); - unsigned long i; - SCM s; - - for (i = 0; i < len; ++i) - base [i] = SCM_UNPACK (SCM_UNSPECIFIED); - - s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base); - SCM_SET_CCLO_SUBR (s, proc); - return s; -} - -/* Undocumented debugging procedure */ -#ifdef GUILE_DEBUG -SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0, - (SCM proc, SCM len), - "Create a compiled closure for @var{proc}, which reserves\n" - "@var{len} objects for its usage.") -#define FUNC_NAME s_scm_make_cclo -{ - return scm_makcclo (proc, SCM_INUM (len)); -} -#undef FUNC_NAME -#endif -#endif - - SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, (SCM obj), @@ -170,13 +103,10 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, break; case scm_tcs_closures: case scm_tcs_subrs: -#ifdef CCLO - case scm_tc7_cclo: -#endif case scm_tc7_pws: return SCM_BOOL_T; case scm_tc7_smob: - return SCM_BOOL (SCM_SMOB_DESCRIPTOR (obj).apply); + return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply); default: return SCM_BOOL_F; } @@ -189,7 +119,7 @@ SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0, "Return @code{#t} if @var{obj} is a closure.") #define FUNC_NAME s_scm_closure_p { - return SCM_BOOL (SCM_CLOSUREP (obj)); + return scm_from_bool (SCM_CLOSUREP (obj)); } #undef FUNC_NAME @@ -204,16 +134,15 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, switch (SCM_TYP7 (obj)) { case scm_tcs_closures: - return SCM_BOOL (!SCM_CONSP (SCM_CLOSURE_FORMALS (obj))); + return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj))); case scm_tc7_subr_0: case scm_tc7_subr_1o: case scm_tc7_lsubr: case scm_tc7_rpsubr: case scm_tc7_asubr: -#ifdef CCLO - case scm_tc7_cclo: -#endif return SCM_BOOL_T; + case scm_tc7_gsubr: + return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0); case scm_tc7_pws: obj = SCM_PROCEDURE (obj); goto again; @@ -249,27 +178,21 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, #define FUNC_NAME s_scm_procedure_documentation { SCM code; - SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T), + SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, SCM_ARG1, FUNC_NAME); switch (SCM_TYP7 (proc)) { case scm_tcs_closures: code = SCM_CLOSURE_BODY (proc); - if (SCM_NULLP (SCM_CDR (code))) + if (scm_is_null (SCM_CDR (code))) return SCM_BOOL_F; code = SCM_CAR (code); - if (SCM_STRINGP (code)) + if (scm_is_string (code)) return code; else return SCM_BOOL_F; default: return SCM_BOOL_F; -/* - case scm_tcs_subrs: -#ifdef CCLO - case scm_tc7_cclo: -#endif -*/ } } #undef FUNC_NAME @@ -284,7 +207,7 @@ SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, "associated setter procedure.") #define FUNC_NAME s_scm_procedure_with_setter_p { - return SCM_BOOL(SCM_PROCEDURE_WITH_SETTER_P (obj)); + return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj)); } #undef FUNC_NAME @@ -345,15 +268,7 @@ scm_setter (SCM proc) return SCM_BOOL_F; /* not reached */ } - -void -scm_init_subr_table () -{ - scm_subr_table - = ((scm_t_subr_entry *) - scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room)); -} - + void scm_init_procs () {