File: debug.scm

package info (click to toggle)
guile-core 1%3A1.4-24
  • links: PTS
  • area: main
  • in suites: woody
  • size: 6,280 kB
  • ctags: 6,664
  • sloc: ansic: 49,704; lisp: 9,376; sh: 9,209; asm: 1,580; makefile: 696; awk: 198; csh: 50
file content (117 lines) | stat: -rw-r--r-- 3,463 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
;;;; 	Copyright (C) 1996, 1997, 1998, 1999 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 program 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.
;;;; 
;;;; 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
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
;;;;


(define-module (ice-9 debug))


;;; {Misc}
;;;
(define-public (frame-number->index n . stack)
  (let ((stack (if (null? stack)
		   (fluid-ref the-last-stack)
		   (car stack))))
    (if (memq 'backwards (debug-options))
	n
	(- (stack-length stack) n 1))))


;;; {Trace}
;;;
;;; This code is just an experimental prototype (e. g., it is not
;;; thread safe), but since it's at the same time useful, it's
;;; included anyway.
;;;
(define traced-procedures '())

(define-public (trace . args)
  (if (null? args)
      (nameify traced-procedures)
      (begin
	(for-each (lambda (proc)
		    (if (not (procedure? proc))
			(error "trace: Wrong type argument:" proc))
		    (set-procedure-property! proc 'trace #t)
		    (if (not (memq proc traced-procedures))
			(set! traced-procedures
			      (cons proc traced-procedures))))
		  args)
	(set! apply-frame-handler trace-entry)
	(set! exit-frame-handler trace-exit)
	(set! trace-level 0)
	(debug-enable 'trace)
	(nameify args))))

(define-public (untrace . args)
  (if (and (null? args)
	   (not (null? traced-procedures)))
      (apply untrace traced-procedures)
      (begin
	(for-each (lambda (proc)
		    (set-procedure-property! proc 'trace #f)
		    (set! traced-procedures (delq! proc traced-procedures)))
		  args)
	(if (null? traced-procedures)
	    (debug-disable 'trace))
	(nameify args))))

(define (nameify ls)
  (map (lambda (proc)
	 (let ((name (procedure-name proc)))
	   (or name proc)))
       ls))

(define trace-level 0)
(add-hook! abort-hook (lambda () (set! trace-level 0)))

(define (trace-entry key cont tail)
  (if (eq? (stack-id cont) 'repl-stack)
      (let ((cep (current-error-port))
	    (frame (last-stack-frame cont)))
	(if (not tail)
	    (set! trace-level (+ trace-level 1)))
	(let indent ((n trace-level))
	  (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
	(display-application frame cep)
	(newline cep)))
  ;; It's not necessary to call the continuation since
  ;; execution will continue if the handler returns
  ;(cont #f)
  )

(define (trace-exit key cont retval)
  (if (eq? (stack-id cont) 'repl-stack)
      (let ((cep (current-error-port)))
	(set! trace-level (- trace-level 1))
	(let indent ((n trace-level))
	  (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
	(write retval cep)
	(newline cep))))


;;; A fix to get the error handling working together with the module system.
;;;
(variable-set! (builtin-variable 'debug-options) debug-options)



(debug-enable 'debug)
(read-enable 'positions)