X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/4079f87ed21341a8654ecaa29ac3e6a2344d9252..999f1b26e74a7a8eb9e9e5e479f971e145aa7326:/libguile/procs.c diff --git a/libguile/procs.c b/libguile/procs.c index d3b539c36..6b4b586b6 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,175 +1,159 @@ -/* Copyright (C) 1995, 1996, 1997, 1999 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. - * - * 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 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. * - * 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 -#include "_scm.h" +#include "libguile/_scm.h" -#include "objects.h" +#include "libguile/objects.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/smob.h" +#include "libguile/deprecation.h" -#include "scm_validate.h" -#include "procs.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 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_make_subr_opt"); + = 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); - symcell = set ? scm_sysintern0 (name) : scm_intern0 (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 = SCM_CAR (symcell); + scm_subr_table[entry].name = scm_from_locale_symbol (name); scm_subr_table[entry].generic = 0; scm_subr_table[entry].properties = SCM_EOL; - scm_subr_table[entry].documentation = SCM_BOOL_F; - - SCM_SUBRF (z) = fcn; - SCM_SETCAR (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_SETGC8MARK (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)) scm_gc_mark (scm_subr_table[i].properties); - if (SCM_NIMP (scm_subr_table[i].documentation)) - scm_gc_mark (scm_subr_table[i].documentation); } } #ifdef CCLO SCM -scm_makcclo (SCM proc, long len) +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; - SCM_NEWCELL (s); - SCM_DEFER_INTS; - SCM_SETCHARS (s, scm_must_malloc (len * sizeof (SCM), "compiled-closure")); - SCM_SETLENGTH (s, len, scm_tc7_cclo); - while (--len) - SCM_VELTS (s)[len] = SCM_UNSPECIFIED; - SCM_CCLO_SUBR (s) = proc; - SCM_ALLOW_INTS; + + 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 -GUILE_PROC (scm_make_cclo, "make-cclo", 2, 0, 0, +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)); + return scm_makcclo (proc, scm_to_size_t (len)); } #undef FUNC_NAME #endif @@ -177,25 +161,26 @@ GUILE_PROC (scm_make_cclo, "make-cclo", 2, 0, 0, -GUILE_PROC(scm_procedure_p, "procedure?", 1, 0, 0, - (SCM obj), -"") +SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a procedure.") #define FUNC_NAME s_scm_procedure_p { 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: - case scm_tc7_contin: 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_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply); default: return SCM_BOOL_F; } @@ -203,18 +188,18 @@ GUILE_PROC(scm_procedure_p, "procedure?", 1, 0, 0, } #undef FUNC_NAME -GUILE_PROC(scm_closure_p, "closure?", 1, 0, 0, +SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is a closure.") #define FUNC_NAME s_scm_closure_p { - return SCM_BOOL(SCM_NIMP (obj) && SCM_CLOSUREP (obj)); + return scm_from_bool (SCM_CLOSUREP (obj)); } #undef FUNC_NAME -GUILE_PROC(scm_thunk_p, "thunk?", 1, 0, 0, - (SCM obj), -"") +SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a thunk.") #define FUNC_NAME s_scm_thunk_p { if (SCM_NIMP (obj)) @@ -223,8 +208,7 @@ GUILE_PROC(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: @@ -238,7 +222,9 @@ GUILE_PROC(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; @@ -260,28 +246,28 @@ scm_subr_p (SCM obj) return 0; } -GUILE_PROC(scm_procedure_documentation, "procedure-documentation", 1, 0, 0, +SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, (SCM proc), -"Return the documentation string associated with @code{proc}. By -convention, if a procedure contains more than one expression and the -first expression is a string constant, that string is assumed to contain -documentation for that procedure.") + "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, FUNC_NAME); + 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; /* @@ -298,38 +284,37 @@ documentation for that procedure.") /* Procedure-with-setter */ -GUILE_PROC (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, +SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is a procedure with an\n" + "associated setter procedure.") #define FUNC_NAME s_scm_procedure_with_setter_p { - return SCM_BOOL(SCM_NIMP (obj) && SCM_PROCEDURE_WITH_SETTER_P (obj)); + return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj)); } #undef FUNC_NAME -GUILE_PROC (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0, +SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0, (SCM procedure, SCM setter), -"") + "Create a new procedure which behaves like @var{procedure}, but\n" + "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_NEWCELL (z); - SCM_ENTER_A_SECTION; - SCM_SETCDR (z, scm_cons (procedure, setter)); - SCM_SETCAR (z, scm_tc7_pws); - SCM_EXIT_A_SECTION; - return z; + SCM_VALIDATE_PROC (1, procedure); + SCM_VALIDATE_PROC (2, setter); + return scm_double_cell (scm_tc7_pws, + SCM_UNPACK (procedure), + SCM_UNPACK (setter), 0); } #undef FUNC_NAME -GUILE_PROC (scm_procedure, "procedure", 1, 0, 0, +SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0, (SCM proc), -"") + "Return the procedure of @var{proc}, which must be either a\n" + "procedure with setter, or an operator struct.") #define FUNC_NAME s_scm_procedure { - SCM_VALIDATE_NIM (1,proc); + SCM_VALIDATE_NIM (1, proc); if (SCM_PROCEDURE_WITH_SETTER_P (proc)) return SCM_PROCEDURE (proc); else if (SCM_STRUCTP (proc)) @@ -338,7 +323,7 @@ GUILE_PROC (scm_procedure, "procedure", 1, 0, 0, return proc; } SCM_WRONG_TYPE_ARG (1, proc); - return 0; /* not reached */ + return SCM_BOOL_F; /* not reached */ } #undef FUNC_NAME @@ -363,17 +348,7 @@ scm_setter (SCM proc) /* fall through */ } SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter); - return 0; -} - - -void -scm_init_iprocs(const scm_iproc *subra, int type) -{ - for(;subra->scm_string; subra++) - scm_make_subr(subra->scm_string, - type, - subra->cproc); + return SCM_BOOL_F; /* not reached */ } @@ -381,13 +356,18 @@ 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 () { -#include "procs.x" +#include "libguile/procs.x" } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/