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
118
119
120
121
122
123
|
; file: "debug.scm", 1/2/98
; Test program for Gambit-C's interpreter support for debugging.
;------------------------------------------------------------------------------
(define (test a b c d)
((lambda (e f g h)
((lambda (i j k l)
(set! a (+ a 1))
(set! b (+ b 1))
(set! c (+ c 1))
(set! d (+ d 1))
(set! e (+ e 1))
(set! f (+ f 1))
(set! g (+ g 1))
(set! h (+ h 1))
(set! i (+ i 1))
(set! j (+ j 1))
(if (and a b)
(force
(begin
(set! k (+ k 1))
(set! l (+ l 1))
(delay (set! z (+ z 1))))))
(append (case a ((11) (list a)) (else '()))
(case b ((20) '()) (else (list b)))
(if (or a b) (list c) '())
(if (not d) (list f e d) (list d e f))
(cond (g => list) (else '()))
(cond ((list h)) (else '()))
(cond (i `(,@(list i j) #(,k ,l) ,z)))))
((lambda () 1000))
((lambda (w) 2000) 1)
((lambda (w x) 3000) 1 2)
((lambda (w x y) 4000) 1 2 3)))
(let ((w 1) (x 2) (y 3)) 100)
(let* ((w 1) (x 2) (y 3)) 200)
(letrec ((w 1) (x 2) (y 3)) 300)
((lambda w 400) 1 2 3)))
(define z 10000)
;------------------------------------------------------------------------------
(define word-size (##u8vector-length '#(#f))) ; may not work in the future
(define big-endian? (= 0 (##u8vector-ref '#(1) 0))); may not work in the future
(define (subprocedure p i) ; may not work in the future
(let* ((n (quotient word-size 4))
(v (##make-u32vector n 0))
(j1 (if big-endian? (- n 1) 0))
(j2 (if big-endian? 0 (- n 1))))
(##vector-set! v 0 p)
(let ((a
(+ (* i (* 4 word-size))
(##u32vector-ref v j1))))
(if (< a 4294967296)
(##u32vector-set! v j1 a)
(let ((b
(+ (quotient a 4294967296)
(##u32vector-ref v j2))))
(##u32vector-set! v j1 (modulo a 4294967296))
(##u32vector-set! v j2 b))))
(##vector-ref v 0)))
(define (subprocedure-kind p) ; may not work in the future
(case (modulo (##fixnum.shl (##vector-ref p 1) 2) 8)
((1) 'proc)
((3) 'retn)
((4) 'rett)
((7) 'reti)
(else (error "unknown subprocedure kind"))))
(define (check cprc)
(define (check-label x)
(let* ((subproc (subprocedure cprc (vector-ref x 0)))
(kind (subprocedure-kind subproc))
(vars (accessible-vars subproc)))
(write subproc)
(display " : ")
(write kind)
(display " ")
(write vars)
(if (not (eq? kind 'proc))
(if (not (and (memq '$code vars) (memq 'rte vars)))
(display " ERROR")))
(newline)))
(let ((info (##procedure-info cprc)))
(if (not info)
(begin
(write cprc)
(display " : ")
(display "*** no procedure info")
(newline))
(for-each check-label (vector->list (##vector-ref info 0))))
(newline)))
(define (accessible-vars proc)
(##subprocedure-locals proc))
(define (go)
(for-each check
(append (map car ##decomp-dispatch-table)
(list ##subproblem-apply0
##subproblem-apply1
##subproblem-apply2
##subproblem-apply3
##subproblem-apply
##step-handler))))
(go)
;------------------------------------------------------------------------------
'(begin
(set-display-environment! #t)
(##repl
(open-input-string "(begin (step) (test 10 20 30 40)),s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s")))
|
