module/slib/break.scm

   1 ;;;; "break.scm" Breakpoints for debugging in Scheme.
   2 ;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (require 'qp)
  21
  22 ;;;; BREAKPOINTS
  23
  24 ;;; Typing (init-debug) at top level sets up a continuation for
  25 ;;; breakpoint.  When (breakpoint arg1 ...) is then called it returns
  26 ;;; from the top level continuation and pushes the continuation from
  27 ;;; which it was called on breakpoint:continuation-stack.  If
  28 ;;; (continue) is later called, it pops the topmost continuation off
  29 ;;; of breakpoint:continuation-stack and returns #f to it.
  30
  31 (define breakpoint:continuation-stack '())
  32
  33 (define debug:breakpoint
  34   (let ((call-with-current-continuation call-with-current-continuation)
  35         (apply apply) (qpn qpn)
  36         (cons cons) (length length))
  37     (lambda args
  38       (if (provided? 'trace) (print-call-stack (current-error-port)))
  39       (apply qpn "BREAKPOINT:" args)
  40       (let ((ans
  41              (call-with-current-continuation
  42               (lambda (x)
  43                 (set! breakpoint:continuation-stack
  44                       (cons x breakpoint:continuation-stack))
  45                 (debug:top-continuation
  46                  (length breakpoint:continuation-stack))))))
  47         (cond ((not (eq? ans breakpoint:continuation-stack)) ans))))))
  48
  49 (define debug:continue
  50   (let ((null? null?) (car car) (cdr cdr))
  51     (lambda args
  52       (cond ((null? breakpoint:continuation-stack)
  53              (display "; no break to continue from")
  54              (newline))
  55             (else
  56              (let ((cont (car breakpoint:continuation-stack)))
  57                (set! breakpoint:continuation-stack
  58                      (cdr breakpoint:continuation-stack))
  59                (if (null? args) (cont #f)
  60                    (apply cont args))))))))
  61
  62 (define debug:top-continuation
  63   (if (provided? 'abort)
  64       (lambda (val) (display val) (newline) (abort))
  65       (begin (display "; type (init-debug)") #f)))
  66
  67 (define (init-debug)
  68   (call-with-current-continuation
  69    (lambda (x) (set! debug:top-continuation x))))
  70
  71 (define breakpoint debug:breakpoint)
  72 (define bkpt debug:breakpoint)
  73 (define continue debug:continue)
  74
  75 (define breakf
  76   (let ((null? null?)                   ;These bindings are so that
  77         (not not)                       ;breakf will not break on parts
  78         (car car) (cdr cdr)             ;of itself.
  79         (eq? eq?) (+ +) (zero? zero?) (modulo modulo)
  80         (apply apply) (display display) (breakpoint debug:breakpoint))
  81     (lambda (function . optname)
  82       ;; (set! trace:indent 0)
  83       (let ((name (if (null? optname) function (car optname))))
  84         (lambda args
  85           (cond ((and (not (null? args))
  86                       (eq? (car args) 'debug:unbreak-object)
  87                       (null? (cdr args)))
  88                  function)
  89                 (else
  90                  (breakpoint name args)
  91                  (apply function args))))))))
  92
  93 ;;; the reason I use a symbol for debug:unbreak-object is so
  94 ;;; that functions can still be unbreaked if this file is read in twice.
  95
  96 (define (unbreakf function)
  97   ;; (set! trace:indent 0)
  98   (function 'debug:unbreak-object))
  99
 100 ;;;;The break: functions wrap around the debug: functions to provide
 101 ;;; niceties like keeping track of breakd functions and dealing with
 102 ;;; redefinition.
 103
 104 (require 'alist)
 105 (define break:adder (alist-associator eq?))
 106 (define break:deler (alist-remover eq?))
 107
 108 (define *breakd-procedures* '())
 109 (define (break:breakf fun sym)
 110   (cond ((not (procedure? fun))
 111          (display "WARNING: not a procedure " (current-error-port))
 112          (display sym (current-error-port))
 113          (newline (current-error-port))
 114          (set! *breakd-procedures* (break:deler *breakd-procedures* sym))
 115          fun)
 116         (else
 117          (let ((p (assq sym *breakd-procedures*)))
 118            (cond ((and p (eq? (cdr p) fun))
 119                   fun)
 120                  (else
 121                   (let ((tfun (breakf fun sym)))
 122                     (set! *breakd-procedures*
 123                           (break:adder *breakd-procedures* sym tfun))
 124                     tfun)))))))
 125
 126 (define (break:unbreakf fun sym)
 127   (let ((p (assq sym *breakd-procedures*)))
 128     (set! *breakd-procedures* (break:deler *breakd-procedures* sym))
 129     (cond ((not (procedure? fun)) fun)
 130           ((not p) fun)
 131           ((eq? (cdr p) fun)
 132            (unbreakf fun))
 133           (else fun))))
 134
 135 ;;;; Finally, the macros break and unbreak
 136
 137 (defmacro break xs
 138   (if (null? xs)
 139       `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x)))
 140                      (map car *breakd-procedures*))
 141               (map car *breakd-procedures*))
 142       `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) xs))))
 143 (defmacro unbreak xs
 144   (if (null? xs)
 145       (slib:eval
 146        `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x)))
 147                       (map car *breakd-procedures*))
 148                '',(map car *breakd-procedures*)))
 149       `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) xs))))