home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / debug < prev    next >
Text File  |  1994-05-25  |  7KB  |  232 lines
  1. ;;;; "debug.scm" Utility functions for debugging in Scheme.
  2. ;;; Copyright (C) 1991, 1992, 1993 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. (define (debug:print . args)
  21.   (define result #f)
  22.   (for-each (lambda (x) (set! result x) (write x) (display #\ )) args)
  23.   (newline)
  24.   result)
  25.  
  26. (define *qp-width* (output-port-width (current-output-port)))
  27.  
  28. (define debug:qpn
  29.   (let ((newline newline) (apply apply))
  30.     (lambda objs (apply debug:qp objs) (newline))))
  31.  
  32. (define debug:qpr
  33.   (let ((- -) (apply apply) (length length) (list-ref list-ref))
  34.     (lambda objs (apply debug:qpn objs)
  35.         (list-ref objs (- (length objs) 1)))))
  36.  
  37. (define debug:qp
  38.   (let
  39.       ((+ +) (- -) (< <) (= =) (>= >=) (apply apply) (boolean? boolean?)
  40.        (car car) (cdr cdr) (char? char?) (display display) (eq? eq?)
  41.        (for-each for-each) (input-port? input-port?)
  42.        (not not) (null? null?) (number->string number->string)
  43.        (number? number?) (output-port? output-port?) (eof-object? eof-object?)
  44.        (procedure? procedure?) (string-length string-length)
  45.        (string? string?) (substring substring)
  46.        (symbol->string symbol->string) (symbol? symbol?)
  47.        (vector-length vector-length) (vector-ref vector-ref)
  48.        (vector? vector?) (write write) (quotient quotient))
  49.     (letrec
  50.     ((num-cdrs
  51.       (lambda (pairs max-cdrs)
  52.         (cond
  53.          ((null? pairs) 0)
  54.          ((< max-cdrs 1) 1)
  55.          ((pair? pairs) (+ 1 (num-cdrs (cdr pairs) (- max-cdrs 1))))
  56.          (else 1))))
  57.      
  58.      (l-elt-room
  59.       (lambda (room pairs)
  60.         (quotient room (num-cdrs pairs (quotient room 8)))))
  61.  
  62.      (qp-pairs
  63.       (lambda (cdrs room)
  64.         (cond
  65.          ((null? cdrs) 0)
  66.          ((not (pair? cdrs))
  67.           (display " . ")
  68.           (+ 3 (qp-obj cdrs (l-elt-room (- room 3) cdrs))))
  69.          ((< 11 room)
  70.           (display #\ )
  71.           ((lambda (used)
  72.          (+ (qp-pairs (cdr cdrs) (- room used)) used))
  73.            (+ 1 (qp-obj (car cdrs) (l-elt-room (- room 1) cdrs)))))
  74.          (else
  75.           (display " ...") 4))))
  76.  
  77.      (v-elt-room
  78.       (lambda (room vleft)
  79.         (quotient room (min vleft (quotient room 8)))))
  80.  
  81.      (qp-vect
  82.       (lambda (vect i room)
  83.         (cond
  84.          ((= (vector-length vect) i) 0)
  85.          ((< 11 room)
  86.           (display #\ )
  87.           ((lambda (used)
  88.          (+ (qp-vect vect (+ i 1) (- room used)) used))
  89.            (+ 1 (qp-obj (vector-ref vect i)
  90.                 (v-elt-room (- room 1)
  91.                     (- (vector-length vect) i))))))
  92.          (else
  93.           (display " ...") 4))))
  94.  
  95.      (qp-string
  96.       (lambda (str room)
  97.         (cond
  98.          ((>= (string-length str) room 3)
  99.           (display (substring str 0 (- room 3)))
  100.           (display "...")
  101.           room)
  102.          (else
  103.           (display str)
  104.           (string-length str)))))
  105.  
  106.      (qp-obj
  107.       (lambda (obj room)
  108.         (cond
  109.          ((null? obj) (write obj) 2)
  110.          ((boolean? obj) (write obj) 2)
  111.          ((char? obj) (write obj) 8)
  112.          ((number? obj) (qp-string (number->string obj) room))
  113.          ((string? obj)
  114.           (display #\")
  115.           ((lambda (ans) (display #\") ans)
  116.            (+ 2 (qp-string obj (- room 2)))))
  117.          ((symbol? obj) (qp-string (symbol->string obj) room))
  118.          ((input-port? obj) (display "#[input]") 8)
  119.          ((output-port? obj) (display "#[output]") 9)
  120.          ((procedure? obj) (display "#[proc]") 7)
  121.          ((eof-object? obj) (display "#[eof]") 6)
  122.          ((vector? obj)
  123.           (set! room (- room 3))
  124.           (display "#(")
  125.           ((lambda (used) (display #\)) (+ used 3))
  126.            (cond
  127.         ((= 0 (vector-length obj)) 0)
  128.         ((< room 8) (display "...") 3)
  129.         (else
  130.          ((lambda (used) (+ (qp-vect obj 1 (- room used)) used))
  131.           (qp-obj (vector-ref obj 0)
  132.               (v-elt-room room (vector-length obj))))))))
  133.          ((pair? obj) 
  134.           (set! room (- room 2))
  135.           (display #\()
  136.           ((lambda (used) (display #\)) (+ 2 used))
  137.            (if (< room 8) (begin (display "...") 3)
  138.            ((lambda (used)
  139.               (+ (qp-pairs (cdr obj) (- room used)) used))
  140.             (qp-obj (car obj) (l-elt-room room obj))))))
  141.          (else (display "#[unknown]") 10)))))
  142.  
  143.       (lambda objs
  144.     (qp-pairs (cdr objs)
  145.           (- *qp-width*
  146.              (qp-obj (car objs) (l-elt-room *qp-width* objs))))))))
  147.  
  148. (define debug:indent 0)
  149.  
  150. (define debug:tracef
  151.   (let ((null? null?)            ;These bindings are so that
  152.     (not not)            ;tracef will not trace parts
  153.     (car car) (cdr cdr)        ;of itself.
  154.     (eq? eq?) (+ +) (zero? zero?) (modulo modulo)
  155.     (apply apply) (display display) (qpn debug:qpn))
  156.     (lambda (function . optname)
  157.       (set! debug:indent 0)
  158.       (let ((name (if (null? optname) function (car optname))))
  159.     (lambda args
  160.       (cond ((and (not (null? args))
  161.               (eq? (car args) 'debug:untrace-object)
  162.               (null? (cdr args)))
  163.          function)
  164.         (else
  165.          (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
  166.          (apply qpn "CALLED" name args)
  167.          (set! debug:indent (modulo (+ 1 debug:indent) 8))
  168.          (let ((ans (apply function args)))
  169.            (set! debug:indent (modulo (+ -1 debug:indent) 8))
  170.            (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
  171.            (qpn "RETURNED" name ans)
  172.            ans))))))))
  173.  
  174. ;;; the reason I use a symbol for debug:untrace-object is so
  175. ;;; that functions can still be untraced if this file is read in twice.
  176.  
  177. (define (debug:untracef function)
  178.   (set! debug:indent 0)
  179.   (function 'debug:untrace-object))
  180.  
  181. ;;;; BREAKPOINTS
  182.  
  183. ;;; Typing (init-debug) at top level sets up a continuation for break.
  184. ;;; When (break arg1 ...) is then called it returns from the top level
  185. ;;; continuation and pushes the continuation from which it was called
  186. ;;; on debug:break-continuation-stack.  If (continue) is later
  187. ;;; called, it pops the topmost continuation off of
  188. ;;; debug:break-continuation-stack and returns #f to it.
  189.  
  190. (define debug:break-continuation-stack '())
  191.  
  192. (define debug:break
  193.   (let ((call-with-current-continuation call-with-current-continuation)
  194.     (apply apply) (qpn debug:qpn)
  195.     (cons cons) (length length))
  196.     (lambda args
  197.       (apply qpn "BREAK:" args)
  198.       (call-with-current-continuation
  199.        (lambda (x) 
  200.      (set! debug:break-continuation-stack
  201.            (cons x debug:break-continuation-stack))
  202.      (debug:top-continuation
  203.       (length debug:break-continuation-stack)))))))
  204.  
  205. (define debug:continue
  206.   (let ((null? null?) (car car) (cdr cdr))
  207.     (lambda ()
  208.       (cond ((null? debug:break-continuation-stack) #f)
  209.         (else
  210.          (let ((cont (car debug:break-continuation-stack)))
  211.            (set! debug:break-continuation-stack
  212.              (cdr debug:break-continuation-stack))
  213.            (cont #f)))))))
  214.  
  215. (define debug:top-continuation
  216.   (if (provided? 'abort)
  217.       (lambda (val) (display val) (newline) (abort))
  218.       (begin (display "; type (init-debug)") #f)))
  219.  
  220. (define (init-debug)
  221.   (call-with-current-continuation
  222.    (lambda (x) (set! debug:top-continuation x))))
  223.  
  224. (define print debug:print)
  225. (define qp debug:qp)
  226. (define qpn debug:qpn)
  227. (define qpr debug:qpr)
  228. (define tracef debug:tracef)
  229. (define untracef debug:untracef)
  230. (define break debug:break)
  231. (define continue debug:continue)
  232.