guile/guile-core/libguile ChangeLog debug.c

[Mikael Djurfeldt]

CVSROOT:        /cvs
Module name:    guile
Branch:         branch_release-1-6
Changes by:     Mikael Djurfeldt <address@hidden>       03/02/05 14:05:42

Modified files:
        guile-core/libguile: ChangeLog debug.c 

Log message:
        * debug.c (scm_procedure_source): Handle all objects for which
        procedure? is #t.  (Thanks to Bill Schottstaedt.)

CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/ChangeLog.diff?cvsroot=OldCVS&only_with_tag=branch_release-1-6&tr1=1.1465.2.107&tr2=1.1465.2.108&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/debug.c.diff?cvsroot=OldCVS&only_with_tag=branch_release-1-6&tr1=1.92.2.4&tr2=1.92.2.5&r1=text&r2=text

Patches:
Index: guile/guile-core/libguile/ChangeLog
diff -c guile/guile-core/libguile/ChangeLog:1.1775 
guile/guile-core/libguile/ChangeLog:1.1776
*** guile/guile-core/libguile/ChangeLog:1.1775  Thu Jan 23 15:31:38 2003
--- guile/guile-core/libguile/ChangeLog Wed Feb  5 14:04:40 2003
***************
*** 1,3 ****
--- 1,8 ----
+ 2003-02-05  Mikael Djurfeldt  <address@hidden>
+ 
+       * debug.c (scm_procedure_source): Handle all objects for which
+       procedure? is #t.  (Thanks to Bill Schottstaedt.)
+ 
  2003-01-23  Mikael Djurfeldt  <address@hidden>
  
        * futures.c (mark_futures): Don't need to mark data of recycled
Index: guile/guile-core/libguile/debug.c
diff -c guile/guile-core/libguile/debug.c:1.105 
guile/guile-core/libguile/debug.c:1.106
*** guile/guile-core/libguile/debug.c:1.105     Sun Nov 17 17:18:51 2002
--- guile/guile-core/libguile/debug.c   Wed Feb  5 14:04:40 2003
***************
*** 1,5 ****
  /* Debugging extensions for Guile
!  * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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
--- 1,5 ----
  /* Debugging extensions for Guile
!  * 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
***************
*** 64,69 ****
--- 64,70 ----
  #include "libguile/ports.h"
  #include "libguile/root.h"
  #include "libguile/fluids.h"
+ #include "libguile/objects.h"
  
  #include "libguile/validate.h"
  #include "libguile/debug.h"
***************
*** 374,379 ****
--- 375,381 ----
  #define FUNC_NAME s_scm_procedure_source
  {
    SCM_VALIDATE_NIM (1, proc);
+  again:
    switch (SCM_TYP7 (proc)) {
    case scm_tcs_closures:
      {
***************
*** 387,403 ****
                                                       SCM_EOL,
                                                       SCM_ENV (proc))));
      }
    case scm_tcs_subrs:
  #ifdef CCLO
    case scm_tc7_cclo:
  #endif
      /* It would indeed be a nice thing if we supplied source even for
         built in procedures! */
      return scm_procedure_property (proc, scm_sym_source);
    default:
!     SCM_WRONG_TYPE_ARG (1, proc);
!     /* not reached */
    }
  }
  #undef FUNC_NAME
  
--- 389,422 ----
                                                       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);
+   return SCM_BOOL_F; /* not reached */
  }
  #undef FUNC_NAME