X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/92c2555f6972b5fbc2236fe486e9432040b43812..999f1b26e74a7a8eb9e9e5e479f971e145aa7326:/libguile/procs.c diff --git a/libguile/procs.c b/libguile/procs.c index 5f23d43ed..6b4b586b6 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,48 +1,25 @@ -/* Copyright (C) 1995,1996,1997,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * 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, 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. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * 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. */ + * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +#ifdef HAVE_CONFIG_H +# include +#endif #include "libguile/_scm.h" @@ -54,6 +31,7 @@ #include "libguile/validate.h" #include "libguile/procs.h" +#include "libguile/programs.h" @@ -80,24 +58,18 @@ scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { long new_size = scm_subr_table_room * 3 / 2; void *new_table - = scm_must_realloc ((char *) scm_subr_table, - sizeof (scm_t_subr_entry) * scm_subr_table_room, - sizeof (scm_t_subr_entry) * new_size, - "scm_subr_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; } - SCM_NEWCELL (z); - 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].name = scm_from_locale_symbol (name); scm_subr_table[entry].generic = 0; scm_subr_table[entry].properties = SCM_EOL; - - SCM_SET_SUBRF (z, fcn); - SCM_SET_CELL_TYPE (z, (entry << 8) + type); scm_subr_table_size++; return z; @@ -147,7 +119,7 @@ scm_mark_subr_table () long i; for (i = 0; i < scm_subr_table_size; ++i) { - SCM_SETGCMARK (scm_subr_table[i].name); + 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)) @@ -160,19 +132,16 @@ scm_mark_subr_table () SCM scm_makcclo (SCM proc, size_t len) { - scm_t_bits *base = scm_must_malloc (len * sizeof (scm_t_bits), "compiled-closure"); + 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); - SCM_NEWCELL (s); - SCM_DEFER_INTS; - SCM_SET_CCLO_BASE (s, base); - SCM_SET_CCLO_LENGTH (s, len); + s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base); SCM_SET_CCLO_SUBR (s, proc); - SCM_ALLOW_INTS; return s; } @@ -184,7 +153,7 @@ SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0, "@var{len} objects for its usage.") #define FUNC_NAME s_scm_make_cclo { - return scm_makcclo (proc, SCM_INUM (len)); + return scm_makcclo (proc, scm_to_size_t (len)); } #undef FUNC_NAME #endif @@ -200,7 +169,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, if (SCM_NIMP (obj)) switch (SCM_TYP7 (obj)) { - case scm_tcs_cons_gloc: + case scm_tcs_struct: if (!SCM_I_OPERATORP (obj)) break; case scm_tcs_closures: @@ -211,7 +180,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, 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; } @@ -224,7 +193,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 @@ -239,7 +208,7 @@ 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: @@ -253,7 +222,9 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, obj = SCM_PROCEDURE (obj); goto again; default: - ; + if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0) + return SCM_BOOL_T; + /* otherwise fall through */ } } return SCM_BOOL_F; @@ -284,19 +255,19 @@ 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_NIMP (proc), + SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, SCM_ARG1, FUNC_NAME); switch (SCM_TYP7 (proc)) { case scm_tcs_closures: - code = SCM_CDR (SCM_CODE (proc)); - if (SCM_IMP (SCM_CDR (code))) + code = SCM_CLOSURE_BODY (proc); + if (scm_is_null (SCM_CDR (code))) return SCM_BOOL_F; code = SCM_CAR (code); - if (SCM_IMP (code)) - return SCM_BOOL_F; - if (SCM_STRINGP (code)) + if (scm_is_string (code)) return code; + else + return SCM_BOOL_F; default: return SCM_BOOL_F; /* @@ -319,7 +290,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 @@ -329,16 +300,11 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, "with the associated setter @var{setter}.") #define FUNC_NAME s_scm_make_procedure_with_setter { - SCM z; SCM_VALIDATE_PROC (1, procedure); SCM_VALIDATE_PROC (2, setter); - SCM_NEWCELL2 (z); - SCM_ENTER_A_SECTION; - SCM_SET_CELL_OBJECT_1 (z, procedure); - SCM_SET_CELL_OBJECT_2 (z, setter); - SCM_SET_CELL_TYPE (z, scm_tc7_pws); - SCM_EXIT_A_SECTION; - return z; + return scm_double_cell (scm_tc7_pws, + SCM_UNPACK (procedure), + SCM_UNPACK (setter), 0); } #undef FUNC_NAME @@ -391,54 +357,15 @@ scm_init_subr_table () { scm_subr_table = ((scm_t_subr_entry *) - scm_must_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room, - "scm_subr_table")); + scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room)); } void scm_init_procs () { -#ifndef SCM_MAGIC_SNARFER #include "libguile/procs.x" -#endif } -#if SCM_DEBUG_DEPRECATED == 0 - -SCM -scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) -{ - scm_c_issue_deprecation_warning - ("`scm_make_subr_opt' is deprecated. Use `scm_c_make_subr' or " - "`scm_c_define_subr' instead."); - - if (set) - return scm_c_define_subr (name, type, fcn); - else - return scm_c_make_subr (name, type, fcn); -} - -SCM -scm_make_subr (const char *name, int type, SCM (*fcn) ()) -{ - scm_c_issue_deprecation_warning - ("`scm_make_subr' is deprecated. Use `scm_c_define_subr' instead."); - - return scm_c_define_subr (name, type, fcn); -} - -SCM -scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf) -{ - scm_c_issue_deprecation_warning - ("`scm_make_subr_with_generic' is deprecated. Use " - "`scm_c_define_subr_with_generic' instead."); - - return scm_c_define_subr_with_generic (name, type, fcn, gf); -} - -#endif /* !SCM_DEBUG_DEPRECATION */ - /* Local Variables: c-file-style: "gnu"