Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

107 lines (89 sloc) 3.589 kb
; File: "debug.scm", Time-stamp: <2007-04-04 11:39:46 feeley>
; Copyright (c) 1998-2007 by Marc Feeley, All Rights Reserved.
; 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 (subprocedure p i) ; may not work in the future
(##encoding->object (+ (* i (* 4 word-size)) (##object->encoding p))))
(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 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")))
Jump to Line
Something went wrong with that request. Please try again.