summaryrefslogtreecommitdiffstats
path: root/debug.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /debug.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'debug.scm')
-rw-r--r--debug.scm78
1 files changed, 78 insertions, 0 deletions
diff --git a/debug.scm b/debug.scm
new file mode 100644
index 0000000..08406a9
--- /dev/null
+++ b/debug.scm
@@ -0,0 +1,78 @@
+;;;; "debug.scm" Utility functions for debugging in Scheme.
+;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'trace)
+(require 'break)
+
+(define (for-each-top-level-definition-in-file file proc)
+ (call-with-input-file
+ file
+ (lambda
+ (port)
+ (letrec
+ ((walk
+ (lambda (exp)
+ (cond
+ ((not (and (pair? exp) (list? exp))))
+ ((not (symbol? (car exp))))
+ (else
+ (case (car exp)
+ ((begin) (for-each walk (cdr exp)))
+ ((cond) (for-each
+ (lambda (exp)
+ (for-each walk
+ (if (list? (car exp)) exp (cdr exp))))
+ (cdr exp)))
+ ((if) (for-each
+ walk
+ (if (list? (cadr exp)) (cdr exp) (cddr exp))))
+ ((defmacro define-syntax) "should do something clever here")
+ ((define)
+ (proc exp))))))))
+ (do ((form (read port) (read port)))
+ ((eof-object? form))
+ (walk form))))))
+
+(define (for-each-top-level-defined-procedure-symbol-in-file file proc)
+ (letrec ((get-defined-symbol
+ (lambda (form)
+ (if (pair? form)
+ (get-defined-symbol (car form))
+ form))))
+ (for-each-top-level-definition-in-file
+ file
+ (lambda (form) (let ((sym (get-defined-symbol (cadr form))))
+ (cond ((procedure? (slib:eval sym))
+ (proc sym))))))))
+
+(define (debug:trace-all file)
+ (for-each-top-level-defined-procedure-symbol-in-file
+ file
+ (lambda (sym)
+ (slib:eval `(set! ,sym (trace:tracef ,sym ',sym))))))
+
+(define trace-all debug:trace-all)
+
+(define (debug:break-all file)
+ (for-each-top-level-defined-procedure-symbol-in-file
+ file
+ (lambda (sym)
+ (slib:eval `(set! ,sym (break:breakf ,sym ',sym))))))
+
+(define break-all debug:break-all)