Merge commit 'e20d7001c3f7150400169fecb0bf0eefdf122fe2' into vm-check
[bpt/guile.git] / libguile / debug.c
index a6ae69a..5d0e208 100644 (file)
@@ -1,51 +1,28 @@
 /* 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, 2006, 2008, 2009 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
 
 
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
 
 #include "libguile/_scm.h"
+#include "libguile/async.h"
 #include "libguile/eval.h"
 #include "libguile/list.h"
 #include "libguile/stackchk.h"
 #include "libguile/ports.h"
 #include "libguile/root.h"
 #include "libguile/fluids.h"
+#include "libguile/objects.h"
+#include "libguile/programs.h"
 
 #include "libguile/validate.h"
 #include "libguile/debug.h"
+
+#include "libguile/private-options.h"
 \f
 
+
 /* {Run time control of the debugging evaluator}
  */
 
@@ -80,21 +62,28 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
 #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);
+
+  scm_dynwind_begin (0);
+  scm_dynwind_critical_section (SCM_BOOL_F);
+
+  ans = scm_options (setting, scm_debug_opts, 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_options (ans, scm_debug_opts, FUNC_NAME);
       SCM_OUT_OF_RANGE (1, setting);
     }
   SCM_RESET_DEBUG_MODE;
+#ifdef STACK_CHECKING
   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
   scm_debug_eframe_size = 2 * SCM_N_FRAMES;
-  SCM_ALLOW_INTS;
+
+  scm_dynwind_end ();
   return ans;
 }
 #undef FUNC_NAME
 
+
 static void
 with_traps_before (void *data)
 {
@@ -113,7 +102,7 @@ with_traps_after (void *data)
 static SCM
 with_traps_inner (void *data)
 {
-  SCM thunk = SCM_PACK (data);
+  SCM thunk = SCM_PACK ((scm_t_bits) data);
   return scm_call_0 (thunk);
 }
 
@@ -133,7 +122,6 @@ SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
 #undef FUNC_NAME
 
 \f
-
 SCM_SYMBOL (scm_sym_procname, "procname");
 SCM_SYMBOL (scm_sym_dots, "...");
 SCM_SYMBOL (scm_sym_source, "source");
@@ -149,11 +137,7 @@ memoized_print (SCM obj, SCM port, scm_print_state *pstate)
   int writingp = SCM_WRITINGP (pstate);
   scm_puts ("#<memoized ", port);
   SCM_SET_WRITINGP (pstate, 1);
-#ifdef GUILE_DEBUG
   scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
-#else
-  scm_iprin1 (scm_unmemoize (obj), port, pstate);
-#endif
   SCM_SET_WRITINGP (pstate, writingp);
   scm_putc ('>', port);
   return 1;
@@ -164,7 +148,7 @@ SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
            "Return @code{#t} if @var{obj} is memoized.")
 #define FUNC_NAME s_scm_memoized_p
 {
-  return SCM_BOOL(SCM_MEMOIZEDP (obj));
+  return scm_from_bool(SCM_MEMOIZEDP (obj));
 }
 #undef FUNC_NAME
 
@@ -172,12 +156,7 @@ SCM
 scm_make_memoized (SCM exp, SCM env)
 {
   /* *fixme* Check that env is a valid environment. */
-  register SCM z, ans;
-  SCM_ENTER_A_SECTION;
-  SCM_NEWSMOB (z, SCM_UNPACK (exp), SCM_UNPACK (env));
-  SCM_NEWSMOB (ans, scm_tc16_memoized, SCM_UNPACK (z));
-  SCM_EXIT_A_SECTION;
-  return ans;
+  SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env)));
 }
 
 #ifdef GUILE_DEBUG
@@ -237,27 +216,6 @@ scm_make_memoized (SCM exp, SCM env)
 #include "libguile/variable.h"
 #include "libguile/procs.h"
 
-SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0,
-            (SCM frame, SCM binding, SCM cdrp),
-           "Return a new iloc with frame offset @var{frame}, binding\n"
-           "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);
-  SCM_MAKE_ILOC (SCM_INUM (frame), SCM_INUM (binding), !SCM_FALSEP (cdrp));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_iloc_p, "iloc?", 1, 0, 0, 
-          (SCM obj),
-           "Return @code{#t} if @var{obj} is an iloc.")
-#define FUNC_NAME s_scm_iloc_p
-{
-  return SCM_BOOL(SCM_ILOCP (obj));
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
             (SCM car, SCM cdr, SCM env),
            "Return a new memoized cons cell with @var{car} and @var{cdr}\n"
@@ -293,7 +251,7 @@ SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
 
 SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0, 
             (SCM obj),
-           "Convert a memoized object (which must be a lambda expression)\n"
+           "Convert a memoized object (which must represent a body)\n"
            "to a procedure.")
 #define FUNC_NAME s_scm_mem_to_proc
 {
@@ -301,9 +259,7 @@ SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
   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))
-    SCM_MISC_ERROR ("expected lambda expression", scm_list_1 (obj));
-  return scm_closure (SCM_CDR (obj), env);
+  return scm_closure (obj, env);
 }
 #undef FUNC_NAME
 
@@ -313,20 +269,19 @@ SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
 #define FUNC_NAME s_scm_proc_to_mem
 {
   SCM_VALIDATE_CLOSURE (1, obj);
-  return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)),
-                           SCM_ENV (obj));
+  return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj));
 }
 #undef FUNC_NAME
 
 #endif /* GUILE_DEBUG */
 
-SCM_DEFINE (scm_unmemoize, "unmemoize", 1, 0, 0, 
+SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0, 
             (SCM m),
            "Unmemoize the memoized expression @var{m},")
-#define FUNC_NAME s_scm_unmemoize
+#define FUNC_NAME s_scm_i_unmemoize_expr
 {
   SCM_VALIDATE_MEMOIZED (1, m);
-  return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
+  return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
 }
 #undef FUNC_NAME
 
@@ -355,11 +310,13 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 #if 0
       /* Source property scm_sym_procname not implemented yet... */
       SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname);
-      if (SCM_FALSEP (name))
+      if (scm_is_false (name))
        name = scm_procedure_property (proc, scm_sym_name);
 #endif
-      if (SCM_FALSEP (name) && SCM_CLOSUREP (proc))
+      if (scm_is_false (name) && SCM_CLOSUREP (proc))
        name = scm_reverse_lookup (SCM_ENV (proc), proc);
+      if (scm_is_false (name) && SCM_PROGRAM_P (proc))
+        name = scm_program_name (proc);
       return name;
     }
   }
@@ -372,30 +329,51 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 #define FUNC_NAME s_scm_procedure_source
 {
   SCM_VALIDATE_NIM (1, proc);
+ again:
   switch (SCM_TYP7 (proc)) {
   case scm_tcs_closures:
     {
-      SCM formals = SCM_CLOSURE_FORMALS (proc);
-      SCM src = scm_source_property (SCM_CLOSURE_BODY (proc), scm_sym_copy);
-      if (!SCM_FALSEP (src))
-       return scm_cons2 (scm_sym_lambda, formals, src);
-      return scm_cons (scm_sym_lambda,
-                      scm_unmemocopy (SCM_CODE (proc),
-                                      SCM_EXTEND_ENV (formals,
-                                                      SCM_EOL,
-                                                      SCM_ENV (proc))));
+      const SCM formals = SCM_CLOSURE_FORMALS (proc);
+      const SCM body = SCM_CLOSURE_BODY (proc);
+      const SCM src = scm_source_property (body, scm_sym_copy);
+
+      if (scm_is_true (src))
+        {
+          return scm_cons2 (scm_sym_lambda, formals, src);
+        }
+      else
+        {
+          const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+          return scm_cons2 (scm_sym_lambda,
+                            scm_i_finite_list_copy (formals),
+                            scm_i_unmemocopy_body (body, env));
+        }
     }
+  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_is_true (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
 
@@ -409,9 +387,6 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
   case scm_tcs_closures:
     return SCM_ENV (proc);
   case scm_tcs_subrs:
-#ifdef CCLO
-  case scm_tc7_cclo:
-#endif
     return SCM_EOL;
   default:
     SCM_WRONG_TYPE_ARG (1, proc);
@@ -452,56 +427,43 @@ SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_look
 SCM
 scm_reverse_lookup (SCM env, SCM data)
 {
-  while (SCM_CONSP (env) && SCM_CONSP (SCM_CAR (env)))
+  while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
     {
       SCM names = SCM_CAAR (env);
       SCM values = SCM_CDAR (env);
-      while (SCM_CONSP (names))
+      while (scm_is_pair (names))
        {
-         if (SCM_EQ_P (SCM_CAR (values), data))
+         if (scm_is_eq (SCM_CAR (values), data))
            return SCM_CAR (names);
          names = SCM_CDR (names);
          values = SCM_CDR (values);
        }
-      if (!SCM_NULLP (names) && SCM_EQ_P (values, data))
+      if (!scm_is_null (names) && scm_is_eq (values, data))
        return names;
       env = SCM_CDR (env);
     }
   return SCM_BOOL_F;
 }
 
-SCM
-scm_start_stack (SCM id, SCM exp, SCM env)
+SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
+            (SCM id, SCM thunk),
+           "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
+#define FUNC_NAME s_scm_sys_start_stack
 {
   SCM answer;
   scm_t_debug_frame vframe;
   scm_t_debug_info vframe_vect_body;
-  vframe.prev = scm_last_debug_frame;
+  vframe.prev = scm_i_last_debug_frame ();
   vframe.status = SCM_VOIDFRAME;
   vframe.vect = &vframe_vect_body;
   vframe.vect[0].id = id;
-  scm_last_debug_frame = &vframe;
-  answer = scm_i_eval (exp, env);
-  scm_last_debug_frame = vframe.prev;
+  scm_i_set_last_debug_frame (&vframe);
+  answer = scm_call_0 (thunk);
+  scm_i_set_last_debug_frame (vframe.prev);
   return answer;
 }
-
-SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack);
-
-static SCM
-scm_m_start_stack (SCM exp, SCM env)
-#define FUNC_NAME s_start_stack
-{
-  exp = SCM_CDR (exp);
-  if (!SCM_CONSP (exp) 
-      || !SCM_CONSP (SCM_CDR (exp))
-      || !SCM_NULLP (SCM_CDDR (exp)))
-    SCM_WRONG_NUM_ARGS ();
-  return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
-}
 #undef FUNC_NAME
 
-
 /* {Debug Objects}
  *
  * The debugging evaluator throws these on frame traps.
@@ -523,7 +485,7 @@ SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
            "Return @code{#t} if @var{obj} is a debug object.")
 #define FUNC_NAME s_scm_debug_object_p
 {
-  return SCM_BOOL(SCM_DEBUGOBJP (obj));
+  return scm_from_bool(SCM_DEBUGOBJP (obj));
 }
 #undef FUNC_NAME
 
@@ -556,7 +518,7 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 void
 scm_init_debug ()
 {
-  scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
+  scm_init_opts (scm_debug_options, scm_debug_opts);
 
   scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
   scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);