summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-05-20 23:14:56 +0200
committerAndy Wingo <wingo@pobox.com>2016-05-20 23:15:50 +0200
commit1852633a9bf449e4a2399de969db70a0d095a5ea (patch)
tree0e5cb1f909619eddfc8b2f99326f3665376dd0d4
parent534139e45852f5b59ef4a75c99d757c7456ce19c (diff)
downloadguile-1852633a9bf449e4a2399de969db70a0d095a5ea.tar.gz
Add install-sports!, uninstall-sports! functions
* module/ice-9/sports.scm (install-sports!, uninstall-sports!): New functions.
-rw-r--r--module/ice-9/sports.scm37
1 files changed, 36 insertions, 1 deletions
diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm
index c178b7310..91e51e37a 100644
--- a/module/ice-9/sports.scm
+++ b/module/ice-9/sports.scm
@@ -51,12 +51,15 @@
(define-module (ice-9 sports)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 ports internal)
+ #:use-module (ice-9 match)
#:replace (peek-char
read-char)
#:export (lookahead-u8
get-u8
current-read-waiter
- current-write-waiter))
+ current-write-waiter
+ install-sports!
+ uninstall-sports!))
(define (write-bytes port src start count)
(let ((written ((port-write port) port src start count)))
@@ -426,3 +429,35 @@
(else (slow-path)))))
(peek-bytes port 1 fast-path
(lambda (buf bv cur buffered) (slow-path))))
+
+(define saved-port-bindings #f)
+(define port-bindings
+ '(((guile) read-char peek-char)
+ ((ice-9 binary-ports) get-u8 lookahead-u8)))
+(define (install-sports!)
+ (unless saved-port-bindings
+ (set! saved-port-bindings (make-hash-table))
+ (for-each
+ (match-lambda
+ ((mod . syms)
+ (let ((mod (resolve-module mod)))
+ (for-each (lambda (sym)
+ (hashq-set! saved-port-bindings sym
+ (module-ref mod sym))
+ (module-set! mod sym
+ (module-ref (current-module) sym)))
+ syms))))
+ port-bindings)))
+
+(define (uninstall-sports!)
+ (when saved-port-bindings
+ (for-each
+ (match-lambda
+ ((mod . syms)
+ (let ((mod (resolve-module mod)))
+ (for-each (lambda (sym)
+ (let ((saved (hashq-ref saved-port-bindings sym)))
+ (module-set! mod sym saved)))
+ syms))))
+ port-bindings)
+ (set! saved-port-bindings #f)))