home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / debugging / trc.scm < prev   
Encoding:
Text File  |  2008-12-17  |  1.7 KB  |  64 lines
  1. ;;;; (ice-9 debugging trc) -- tracing for Guile debugger code
  2.  
  3. ;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
  4. ;;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;; 
  10. ;; This library is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; Lesser General Public License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18.  
  19. (define-module (ice-9 debugging trc)
  20.   #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
  21.  
  22. (define *syms* #f)
  23.  
  24. (define (trc-set! syms)
  25.   (set! *syms* syms))
  26.  
  27. (define (trc-syms . syms)
  28.   (trc-set! syms))
  29.  
  30. (define (trc-all)
  31.   (trc-set! #f))
  32.  
  33. (define (trc-none)
  34.   (trc-set! '()))
  35.  
  36. (define (trc-add sym)
  37.   (trc-set! (cons sym *syms*)))
  38.  
  39. (define (trc-remove sym)
  40.   (trc-set! (delq1! sym *syms*)))
  41.  
  42. (define (trc sym . args)
  43.   (if (or (not *syms*)
  44.       (memq sym *syms*))
  45.       (let ((port (trc-port)))
  46.     (write sym port)
  47.     (display ":" port)
  48.     (for-each (lambda (arg)
  49.             (display " " port)
  50.             (write arg port))
  51.           args)
  52.     (newline port))))
  53.  
  54. (define trc-port
  55.   (let ((port (current-error-port)))
  56.     (make-procedure-with-setter
  57.      (lambda () port)
  58.      (lambda (p) (set! port p)))))
  59.  
  60. ;; Default to no tracing.
  61. (trc-none)
  62.  
  63. ;;; (ice-9 debugging trc) ends here.
  64.