File: debuginfo.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (77 lines) | stat: -rw-r--r-- 2,191 bytes parent folder | download
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
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; Reading/writing debugging info

(define (write-debug-info location-info file)
  (call-with-output-file file
    (lambda (port)

      (display "Writing ") (display file) (newline)
      (let ((write-table
	     (lambda (table comment)
	       (display "; " port) (display comment port) (newline port)
	       (table-walk (lambda (key datum)
			     (write (list key datum) port)
			     (newline port))
			   table)
	       (write '- port) (newline port))))
	(write-table package-name-table "Package uid -> name")
	(write-table location-info "Location uid -> (name . package-uid)"))

      (display "; Template uid -> name, parent, pc in parent, env maps" port)
      (newline port)
      (table-walk (lambda (id data)
		    ;; Fields: (uid name parent pc-in-parent
		    ;;	        env-maps source)
		    (write (list id
				 (let ((name (debug-data-name data)))
				   (if name
				       (name->symbol name)
				       #f))
				 (let ((p (debug-data-parent data)))
				   ;; we'd like to (note-debug-data! p)
				   (if (debug-data? p)
				       (debug-data-uid p)
				       p))
				 (debug-data-pc-in-parent data)
				 (debug-data-env-maps data)
				 ;; Don't retain source code, right?
				 )
			   port)
		    (newline port))
		  (debug-data-table))
      (write '- port) (newline port))))

(define (read-debug-info file)
  (call-with-input-file file
    (lambda (port)

      (display "Reading ") (display file) (newline)

      (let ((read-table
	     (lambda (table)
	       (let loop ()
		 (let ((z (read port)))
		   (if (pair? z)
		       (begin (table-set! table
					  (car z)
					  (make-immutable! (cadr z)))
			      ;; (set! *location-uid*
			      ;;       (max *location-uid* (+ (car z) 1)))
			      (loop))))))))
	(read-table package-name-table)
	(read-table location-info-table))

      (let loop ()
	(let ((z (read port)))
	  (if (pair? z)
	      (begin ;; (set! *template-uid*
		     ;;	      (max *template-uid* (+ (car z) 1)))
		     (table-set! (debug-data-table)
				 (car z)
				 (make-immutable!
				  (apply make-debug-data
					 (append z '(())))))
		     (loop))))))))