X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/783e77747821c3b79d5ea47fa6be4beb1a758253..999f1b26e74a7a8eb9e9e5e479f971e145aa7326:/libguile/procs.c diff --git a/libguile/procs.c b/libguile/procs.c index 0e59df8ad..6b4b586b6 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,48 +1,25 @@ -/* Copyright (C) 1995, 1996, 1997, 1999, 2000 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" @@ -50,103 +27,99 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/smob.h" +#include "libguile/deprecation.h" #include "libguile/validate.h" #include "libguile/procs.h" +#include "libguile/programs.h" /* {Procedures} */ -scm_subr_entry *scm_subr_table; +scm_t_subr_entry *scm_subr_table; /* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */ -int scm_subr_table_size = 0; -int scm_subr_table_room = 750; +/* 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_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) +scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { - SCM symbol; - SCM symcell; register SCM z; - int entry; + long entry; if (scm_subr_table_size == scm_subr_table_room) { - scm_sizet new_size = scm_subr_table_room * 3 / 2; + long 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_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); - if (set) - { - symcell = scm_sysintern (name, SCM_UNDEFINED); - symbol = SCM_CAR (symcell); - } - else - { - symcell = SCM_BOOL_F; /* to avoid warning */ - symbol = scm_str2symbol (name); - } - 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 = symbol; + 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++; - if (set) - SCM_SETCDR (symcell, z); - return z; } +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); + return subr; +} + /* This function isn't currently used since subrs are never freed. */ /* *fixme* Need mutex here. */ void scm_free_subr_entry (SCM subr) { - int entry = SCM_SUBRNUM (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 -scm_make_subr (const char *name, int type, SCM (*fcn) ()) +SCM +scm_c_make_subr_with_generic (const char *name, + long type, SCM (*fcn) (), SCM *gf) { - return scm_make_subr_opt (name, type, fcn, 1); + SCM subr = scm_c_make_subr (name, type, fcn); + SCM_SUBR_ENTRY(subr).generic = gf; + return subr; } SCM -scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf) +scm_c_define_subr_with_generic (const char *name, + long type, SCM (*fcn) (), SCM *gf) { - SCM subr = scm_make_subr_opt (name, type, fcn, 1); - scm_subr_table[scm_subr_table_size - 1].generic = gf; + SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); + scm_define (SCM_SUBR_ENTRY(subr).name, subr); return subr; } void scm_mark_subr_table () { - int i; + 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)) @@ -157,21 +130,18 @@ scm_mark_subr_table () #ifdef CCLO SCM -scm_makcclo (SCM proc, long len) +scm_makcclo (SCM proc, size_t len) { - scm_bits_t *base = scm_must_malloc (len * sizeof (scm_bits_t), "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; } @@ -183,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 @@ -199,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: @@ -210,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; } @@ -223,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 @@ -238,8 +208,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, switch (SCM_TYP7 (obj)) { case scm_tcs_closures: - if (SCM_NULLP (SCM_CAR (SCM_CODE (obj)))) - return SCM_BOOL_T; + 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 @@ -390,17 +356,14 @@ void scm_init_subr_table () { scm_subr_table - = ((scm_subr_entry *) - scm_must_malloc (sizeof (scm_subr_entry) * scm_subr_table_room, - "scm_subr_table")); + = ((scm_t_subr_entry *) + scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room)); } void scm_init_procs () { -#ifndef SCM_MAGIC_SNARFER #include "libguile/procs.x" -#endif } /*