/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation
*
- * 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 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 program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser 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 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.
- *
- * 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.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
+ * 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
+ */
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/fluids.h"
+#include "libguile/objects.h"
#include "libguile/validate.h"
#include "libguile/debug.h"
(SCM setting),
"Option interface for the debug options. Instead of using\n"
"this procedure directly, use the procedures @code{debug-enable},\n"
- "@code{debug-disable}, @code{debug-set!} and @var{debug-options}.")
+ "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
#define FUNC_NAME s_scm_debug_options
{
SCM ans;
SCM_DEFER_INTS;
- ans = scm_options (setting,
- scm_debug_opts,
- SCM_N_DEBUG_OPTIONS,
- FUNC_NAME);
-#ifndef SCM_RECKLESS
+ ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
{
scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
SCM_OUT_OF_RANGE (1, setting);
}
-#endif
SCM_RESET_DEBUG_MODE;
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
scm_debug_eframe_size = 2 * SCM_N_FRAMES;
#define FUNC_NAME s_scm_with_traps
{
int trap_flag;
- SCM_VALIDATE_THUNK (1,thunk);
+ SCM_VALIDATE_THUNK (1, thunk);
return scm_internal_dynamic_wind (with_traps_before,
with_traps_inner,
with_traps_after,
"offset @var{binding} and the cdr flag @var{cdrp}.")
#define FUNC_NAME s_scm_make_iloc
{
- SCM_VALIDATE_INUM (1,frame);
- SCM_VALIDATE_INUM (2,binding);
- return SCM_PACK (SCM_UNPACK (SCM_ILOC00)
- + SCM_IFRINC * SCM_INUM (frame)
- + (!SCM_FALSEP (cdrp) ? SCM_ICDR : 0)
- + SCM_IDINC * SCM_INUM (binding));
+ SCM_VALIDATE_INUM (1, frame);
+ SCM_VALIDATE_INUM (2, binding);
+ return SCM_MAKE_ILOC (SCM_INUM (frame),
+ SCM_INUM (binding),
+ !SCM_FALSEP (cdrp));
}
#undef FUNC_NAME
if (SCM_UNBNDP (env))
env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
else
- SCM_VALIDATE_NULLORCONS (3,env);
+ SCM_VALIDATE_NULLORCONS (3, env);
return scm_make_memoized (scm_cons (car, cdr), env);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_mem_to_proc
{
SCM env;
- SCM_VALIDATE_MEMOIZED (1,obj);
+ SCM_VALIDATE_MEMOIZED (1, obj);
env = SCM_MEMOIZED_ENV (obj);
obj = SCM_MEMOIZED_EXP (obj);
if (!SCM_CONSP (obj) || !SCM_EQ_P (SCM_CAR (obj), SCM_IM_LAMBDA))
"Unmemoize the memoized expression @var{m},")
#define FUNC_NAME s_scm_unmemoize
{
- SCM_VALIDATE_MEMOIZED (1,m);
+ SCM_VALIDATE_MEMOIZED (1, m);
return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
}
#undef FUNC_NAME
"Return the environment of the memoized expression @var{m}.")
#define FUNC_NAME s_scm_memoized_environment
{
- SCM_VALIDATE_MEMOIZED (1,m);
+ SCM_VALIDATE_MEMOIZED (1, m);
return SCM_MEMOIZED_ENV (m);
}
#undef FUNC_NAME
"Return the name of the procedure @var{proc}")
#define FUNC_NAME s_scm_procedure_name
{
- SCM_VALIDATE_PROC (1,proc);
+ SCM_VALIDATE_PROC (1, proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_subrs:
return SCM_SNAME (proc);
"Return the source of the procedure @var{proc}.")
#define FUNC_NAME s_scm_procedure_source
{
- SCM_VALIDATE_NIM (1,proc);
+ SCM_VALIDATE_NIM (1, proc);
+ again:
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
{
SCM_EOL,
SCM_ENV (proc))));
}
+ case scm_tcs_struct:
+ if (!SCM_I_OPERATORP (proc))
+ break;
+ goto procprop;
+ case scm_tc7_smob:
+ if (!SCM_SMOB_DESCRIPTOR (proc).apply)
+ break;
case scm_tcs_subrs:
#ifdef CCLO
case scm_tc7_cclo:
#endif
+ procprop:
/* It would indeed be a nice thing if we supplied source even for
built in procedures! */
return scm_procedure_property (proc, scm_sym_source);
+ case scm_tc7_pws:
+ {
+ SCM src = scm_procedure_property (proc, scm_sym_source);
+ if (!SCM_FALSEP (src))
+ return src;
+ proc = SCM_PROCEDURE (proc);
+ goto again;
+ }
default:
- SCM_WRONG_TYPE_ARG (1, proc);
- /* not reached */
+ ;
}
+ SCM_WRONG_TYPE_ARG (1, proc);
+ return SCM_BOOL_F; /* not reached */
}
#undef FUNC_NAME
"Return the environment of the procedure @var{proc}.")
#define FUNC_NAME s_scm_procedure_environment
{
- SCM_VALIDATE_NIM (1,proc);
+ SCM_VALIDATE_NIM (1, proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
return SCM_ENV (proc);
#endif
scm_add_feature ("debug-extensions");
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/debug.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff