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
124
125
126
127
128
129
130
131
132
133
134
135
|
; File: "debug.scm"
; Copyright (c) 1998-2018 by Marc Feeley, All Rights Reserved.
; Test program for Gambit'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 (sort-list lst <?)
(define (mergesort lst)
(define (merge lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
(else
(let ((e1 (car lst1)) (e2 (car lst2)))
(if (<? e1 e2)
(cons e1 (merge (cdr lst1) lst2))
(cons e2 (merge lst1 (cdr lst2))))))))
(define (split lst)
(if (or (null? lst) (null? (cdr lst)))
lst
(cons (car lst) (split (cddr lst)))))
(if (or (null? lst) (null? (cdr lst)))
lst
(let* ((lst1 (mergesort (split lst)))
(lst2 (mergesort (split (cdr lst)))))
(merge lst1 lst2))))
(mergesort lst))
(define (sort-symbols lst)
(sort-list lst
(lambda (x y)
(string<? (symbol->string x) (symbol->string y)))))
(define (subprocedure p i)
(##make-subprocedure p i))
(define (check cprc)
(define (check-label x)
(let* ((subproc (subprocedure cprc (vector-ref x 0)))
(vars (accessible-vars subproc)))
(let ((old-rt (output-port-readtable (current-output-port))))
(output-port-readtable-set!
(current-output-port)
(readtable-sharing-allowed?-set old-rt 'serialize))
(write subproc)
(output-port-readtable-set!
(current-output-port)
old-rt))
(if (not (procedure? subproc))
(begin
(display " : ")
(write (sort-symbols vars))
(if (not (and (memq '$code vars) (memq 'rte vars)))
(display " ERROR"))))
(newline)))
(let ((info (##subprocedure-parent-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-apply4
##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")))
|
