home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / debug.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  2.9 KB  |  99 lines
  1. ;;;; "debug.scm" Utility functions for debugging in Scheme.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1995, 1999 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'trace)
  21. (require 'break)
  22. (require 'line-i/o)
  23.  
  24. (define (for-each-top-level-definition-in-file file proc)
  25.   (call-with-input-file
  26.       file
  27.     (lambda (port)
  28.       (letrec
  29.       ((walk
  30.         (lambda (exp)
  31.           (cond
  32.            ((not (and (pair? exp) (list? exp))))
  33.            ((not (symbol? (car exp))))
  34.            (else
  35.         (case (car exp)
  36.           ((begin) (for-each walk (cdr exp)))
  37.           ((cond)  (for-each
  38.                 (lambda (exp)
  39.                   (for-each walk
  40.                     (if (list? (car exp)) exp (cdr exp))))
  41.                 (cdr exp)))
  42.           ((if)    (for-each
  43.                 walk
  44.                 (if (list? (cadr exp)) (cdr exp) (cddr exp))))
  45.           ((defmacro define-syntax) "should do something clever here")
  46.           ((define)
  47.            (proc exp))))))))
  48.     (if (eqv? #\# (peek-char port))
  49.         (read-line port))        ;remove `magic-number'
  50.     (do ((form (read port) (read port)))
  51.         ((eof-object? form))
  52.       (walk form))))))
  53.  
  54. (define (for-each-top-level-defined-procedure-symbol-in-file file proc)
  55.   (letrec ((get-defined-symbol
  56.         (lambda (form)
  57.           (if (pair? form)
  58.           (get-defined-symbol (car form))
  59.           form))))
  60.     (for-each-top-level-definition-in-file
  61.      file
  62.      (lambda (form) (let ((sym (get-defined-symbol (cadr form))))
  63.               (cond ((procedure? (slib:eval sym))
  64.                  (proc sym))))))))
  65.  
  66. (define (trace-all file . ...)
  67.   (for-each
  68.    (lambda (file)
  69.      (for-each-top-level-defined-procedure-symbol-in-file
  70.       file
  71.       (lambda (sym)
  72.     (slib:eval `(set! ,sym (trace:trace-procedure 'trace ,sym ',sym))))))
  73.    (cons file ...)))
  74. (define (track-all file . ...)
  75.   (for-each
  76.    (lambda (file)
  77.      (for-each-top-level-defined-procedure-symbol-in-file
  78.       file
  79.       (lambda (sym)
  80.     (slib:eval `(set! ,sym (trace:trace-procedure 'track ,sym ',sym))))))
  81.    (cons file ...)))
  82. (define (stack-all file . ...)
  83.   (for-each
  84.    (lambda (file)
  85.      (for-each-top-level-defined-procedure-symbol-in-file
  86.       file
  87.       (lambda (sym)
  88.     (slib:eval `(set! ,sym (trace:trace-procedure 'stack ,sym ',sym))))))
  89.    (cons file ...)))
  90.  
  91. (define (break-all file . ...)
  92.   (for-each
  93.    (lambda (file)
  94.      (for-each-top-level-defined-procedure-symbol-in-file
  95.       file
  96.       (lambda (sym)
  97.     (slib:eval `(set! ,sym (break:breakf ,sym ',sym))))))
  98.    (cons file ...)))
  99.