summaryrefslogtreecommitdiff
path: root/module/ice-9/debugging/load-hooks.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/debugging/load-hooks.scm')
-rw-r--r--module/ice-9/debugging/load-hooks.scm33
1 files changed, 33 insertions, 0 deletions
diff --git a/module/ice-9/debugging/load-hooks.scm b/module/ice-9/debugging/load-hooks.scm
new file mode 100644
index 000000000..fb869ed23
--- /dev/null
+++ b/module/ice-9/debugging/load-hooks.scm
@@ -0,0 +1,33 @@
+
+(define-module (ice-9 debugging load-hooks)
+ #:export (before-load-hook
+ after-load-hook
+ install-load-hooks
+ uninstall-load-hooks))
+
+;; real-primitive-load: holds the real (C-implemented) definition of
+;; primitive-load, when the load hooks are installed.
+(define real-primitive-load #f)
+
+;; The load hooks themselves. These are called with one argument, the
+;; name of the file concerned.
+(define before-load-hook (make-hook 1))
+(define after-load-hook (make-hook 1))
+
+;; primitive-load-with-hooks: our new definition for primitive-load.
+(define (primitive-load-with-hooks filename)
+ (run-hook before-load-hook filename)
+ (real-primitive-load filename)
+ (run-hook after-load-hook filename))
+
+(define (install-load-hooks)
+ (if real-primitive-load
+ (error "load hooks are already installed"))
+ (set! real-primitive-load primitive-load)
+ (set! primitive-load primitive-load-with-hooks))
+
+(define (uninstall-load-hooks)
+ (or real-primitive-load
+ (error "load hooks are not installed"))
+ (set! primitive-load real-primitive-load)
+ (set! real-primitive-load #f))