;;; File: "debug.scm"

;;; Copyright (c) 1998-2019 by Marc Feeley, All Rights Reserved.

;;; Test program for Gambit's interpreter support for debugging.

;;;----------------------------------------------------------------------------

(define (redirect-repl-input str)
  (let ((c (##make-repl-channel-ports (open-input-string str)
                                      ##stdout-port ##stdout-port)))
    (##direct-structure-set! c
                             (lambda (channel)
                               (let* ((input-port
                                       (##direct-structure-ref
                                        channel
                                        3
                                        (##structure-type channel)
                                        #f))
                                      (output-port
                                       (##direct-structure-ref
                                        channel
                                        4
                                        (##structure-type channel)
                                        #f))
                                      (expr
                                       (##read-expr-from-port input-port)))
                                 (if (not (eof-object? expr))
                                     (begin
                                       (write (##desourcify expr) output-port)
                                       (newline output-port)))
                                 expr))
                             17
                             (##structure-type c)
                             #f)
    (set! ##stdio/console-repl-channel c)))

(repl-backtrace-detail-level 2)

(redirect-repl-input
 "(begin (step) (test 10 20 30 40) (exit)),s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s,s")

;;;----------------------------------------------------------------------------

(define (test a b c d)
  ((lambda (e f g h i j k l m)
     ((lambda (n o p q)
        (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))
        (set! k (+ k 1))
        (set! l (+ l 1))
        (set! m (+ m 1))
        (set! n (+ n 1))
        (set! o (+ o 1))
        (if (and a b)
            (force
             (begin
               (set! p (+ p 1))
               (set! q (+ q 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)))
                (let loop ((i 1)) (if (< i 10) (loop (* i 2)) (list i)))
                (do ((i 1 (* i 3)) (j 10)) ((< i j) (list i)) (set! j (- j 1)))
                (guard (e ((char? e) '("char")) ((number? e) (list (+ 5000 e))))
                  (+ 6000 (raise 1)))
                (r7rs-guard (x (else '(7000)))
                  (r7rs-guard (e ((char? e) '("char")))
                    (+ 8000 (raise 2))))))
      ((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)
   (letrec* ((w 1) (x 2) (y 3)) 400)
   (let-values ((() (values)) (a (values)) (b 1) (c (values 1 2)) ((d) 3) ((e . f) 4) ((g . h) (values 5 6)) ((i j) (values 7 8))) 10)
   (let*-values ((() (values)) (a (values)) (b 1) (c (values 1 2)) ((d) 3) ((e . f) 4) ((g . h) (values 5 6)) ((i j) (values 7 8))) 20)
   (letrec-values ((() (values)) (a (values)) (b 1) (c (values 1 2)) ((d) 3) ((e . f) 4) ((g . h) (values 5 6)) ((i j) (values 7 8))) 30)
   (letrec*-values ((() (values)) (a (values)) (b 1) (c (values 1 2)) ((d) 3) ((e . f) 4) ((g . h) (values 5 6)) ((i j) (values 7 8))) 40)
   ((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)))

      (define (write-serialize obj)
        (let ((old-rt (output-port-readtable (current-output-port))))
          (output-port-readtable-set!
           (current-output-port)
           (readtable-sharing-allowed?-set old-rt 'serialize))
          (write obj)
          (output-port-readtable-set!
           (current-output-port)
           old-rt)))

      (define (check-accessible var)
        (if (not (memq var vars))
            (begin
              (write-serialize subproc)
              (display ": ")
              (write var)
              (display " is not accessible ")
              (write (sort-symbols vars))
              (newline))))

      (if (not (procedure? subproc))
          (for-each check-accessible '($code rte)))))

  (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))))))

(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)

;;;----------------------------------------------------------------------------

(##repl)
