From 5f3e413789bdb455a166057c392ab1999cd80155 Mon Sep 17 00:00:00 2001
From: Julian Graham <address@hidden(none)>
Date: Sat, 24 May 2008 20:52:45 -0400
Subject: [PATCH] * srfi-18.scm: Remove redundant module imports and symbol exports.
   (object-names, object-specifics, thread-start-conds,
   thread-exception-handlers): Convert to object properties.
   (current-handler-stack, with-exception-handler, make-thread,
   thread-name, thread-specific, thread-specific-set!, thread-start!,
   make-mutex, mutex-name, mutex-specific, mutex-specific-set!,
   make-condition-variable, condition-variable-name,
   condition-variable-specific, condition-variable-specific-set!): Use
   object properties instead of hash tables.
   (with-exception-handler, wrap): Remove unnecessary use of `apply'.

---
 srfi/srfi-18.scm |  115 ++++++++++++++++++++++++------------------------------
 1 files changed, 51 insertions(+), 64 deletions(-)

diff --git a/srfi/srfi-18.scm b/srfi/srfi-18.scm
index 0593f4e..21db266 100644
--- a/srfi/srfi-18.scm
+++ b/srfi/srfi-18.scm
@@ -31,7 +31,6 @@
 ;;; Code:
 
 (define-module (srfi srfi-18)
-  :use-module (srfi srfi-34)
   :export (
 
 ;;; Threads
@@ -49,7 +48,6 @@
 
 ;;; Mutexes
  ;; mutex?				<= in the core
- make-mutex
  mutex-name
  mutex-specific
  mutex-specific-set!
@@ -59,7 +57,6 @@
 
 ;;; Condition variables
  ;; condition-variable?			<= in the core
- make-condition-variable
  condition-variable-name
  condition-variable-specific
  condition-variable-specific-set!
@@ -68,7 +65,6 @@
  condition-variable-wait!
 
 ;;; Time
- current-time
  time?
  time->seconds
  seconds->time
@@ -82,7 +78,6 @@
  uncaught-exception?
  uncaught-exception-reason
  )
-  :re-export (thread? mutex? condition-variable?)
   :replace (current-time 
 	    make-thread 
 	    make-mutex 
@@ -102,11 +97,10 @@
 (define terminated-thread-exception (list 'terminated-thread-exception))
 (define uncaught-exception (list 'uncaught-exception))
 
-(define mutex-owners (make-weak-key-hash-table))
-(define object-names (make-weak-key-hash-table))
-(define object-specifics (make-weak-key-hash-table))
-(define thread-start-conds (make-weak-key-hash-table))
-(define thread-exception-handlers (make-weak-key-hash-table))
+(define object-name (make-object-property))
+(define object-specific (make-object-property))
+(define thread-start-cond (make-object-property))
+(define thread-exception-handler (make-object-property))
 
 ;; EXCEPTIONS
 
@@ -134,22 +128,21 @@
 
 (define (current-handler-stack)
   (let ((ct (current-thread)))
-    (or (hashq-ref thread-exception-handlers ct)
-	(hashq-set! thread-exception-handlers ct (list initial-handler)))))
+    (or (thread-exception-handler ct)
+	(let ((ih (list initial-handler)))
+	  (set! (thread-exception-handler ct) ih)
+	  ih))))
 
 (define (with-exception-handler handler thunk)
   (let ((ct (current-thread))
         (hl (current-handler-stack)))
     (check-arg-type procedure? handler "with-exception-handler") 
     (check-arg-type thunk? thunk "with-exception-handler")
-    (hashq-set! thread-exception-handlers ct (cons handler hl))
-    (apply (@ (srfi srfi-34) with-exception-handler) 
-           (list (lambda (obj)
-                   (hashq-set! thread-exception-handlers ct hl) 
-                   (handler obj))
-                 (lambda () 
-                   (let ((r (thunk)))
-                     (hashq-set! thread-exception-handlers ct hl) r))))))
+    (set! (thread-exception-handler ct) (cons handler hl))
+    ((@ (srfi srfi-34) with-exception-handler) 
+     (lambda (obj) (set! (thread-exception-handler ct) hl) (handler obj))
+     (lambda () 
+       (let ((r (thunk))) (set! (thread-exception-handler ct) hl) r)))))
 
 (define (current-exception-handler)
   (car (current-handler-stack)))
@@ -191,31 +184,29 @@
 	(lock-mutex lm)
 	(let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
 				       srfi-18-exception-handler)))
-	  (hashq-set! thread-start-conds t (cons sm sc))
-	  (and n (hashq-set! object-names t n))
+	  (set! (thread-start-cond t) (cons sm sc))
+	  (and n (set! (object-name t) n))
 	  (wait-condition-variable lc lm)
 	  (unlock-mutex lm)
 	  t)))))
 
 (define (thread-name thread)
-  (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
+  (object-name (check-arg-type thread? thread "thread-name")))
 
 (define (thread-specific thread)
-  (hashq-ref object-specifics 
-	     (check-arg-type thread? thread "thread-specific")))
+  (object-specific (check-arg-type thread? thread "thread-specific")))
 
 (define (thread-specific-set! thread obj)
-  (hashq-set! object-specifics
-	      (check-arg-type thread? thread "thread-specific-set!")
-	      obj)
-  *unspecified*)
+  (set! (object-specific 
+	 (check-arg-type thread? thread "thread-specific-set!"))
+	obj))
 
 (define (thread-start! thread)
-  (let ((x (hashq-ref thread-start-conds
-		      (check-arg-type thread? thread "thread-start!"))))
+  (let ((x (thread-start-cond
+	    (check-arg-type thread? thread "thread-start!"))))
     (and x (let ((smutex (car x))
 		 (scond (cdr x)))
-	     (hashq-remove! thread-start-conds thread)
+	     (set! (thread-start-cond thread) #f)
 	     (lock-mutex smutex)
 	     (signal-condition-variable scond)
 	     (unlock-mutex smutex)))
@@ -284,27 +275,24 @@
 ;; MUTEXES
 ;; These functions are all pass-thrus to the existing Guile implementations.
 
-(define make-mutex
-  (lambda name
-    (let ((n (and (pair? name) (car name)))
-	  (m ((@ (guile) make-mutex) 
-	      'unchecked-unlock 
-	      'allow-external-unlock 
-	      'recursive)))
-      (and n (hashq-set! object-names m n)) m)))
+(define (make-mutex . name)
+  (let ((n (and (pair? name) (car name)))
+	(m ((@ (guile) make-mutex) 
+	    'unchecked-unlock 
+	    'allow-external-unlock 
+	    'recursive)))
+    (and n (set! (object-name m) n)) 
+    m))
 
 (define (mutex-name mutex)
-  (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
+  (object-name (check-arg-type mutex? mutex "mutex-name")))
 
 (define (mutex-specific mutex)
-  (hashq-ref object-specifics 
-	     (check-arg-type mutex? mutex "mutex-specific")))
+  (object-specific (check-arg-type mutex? mutex "mutex-specific")))
 
 (define (mutex-specific-set! mutex obj)
-  (hashq-set! object-specifics
-	      (check-arg-type mutex? mutex "mutex-specific-set!")
-	      obj)
-  *unspecified*)
+  (set! (object-specific (check-arg-type mutex? mutex "mutex-specific-set!"))
+	obj))
 
 (define (mutex-state mutex)
   (let ((owner (mutex-owner mutex)))
@@ -326,29 +314,28 @@
 ;; CONDITION VARIABLES
 ;; These functions are all pass-thrus to the existing Guile implementations.
 
-(define make-condition-variable
-  (lambda name
-    (let ((n (and (pair? name) (car name)))
-	  (m ((@ (guile) make-condition-variable))))
-      (and n (hashq-set! object-names m n)) m)))
+(define (make-condition-variable . name)
+  (let ((n (and (pair? name) (car name)))
+	(m ((@ (guile) make-condition-variable))))
+    (and n (set! (object-name m) n)) 
+    m))
 
 (define (condition-variable-name condition-variable)
-  (hashq-ref object-names (check-arg-type condition-variable? 
-					  condition-variable
-					  "condition-variable-name")))
+  (object-name (check-arg-type condition-variable? 
+			       condition-variable
+			       "condition-variable-name")))
 
 (define (condition-variable-specific condition-variable)
-  (hashq-ref object-specifics (check-arg-type condition-variable? 
-					      condition-variable 
-					      "condition-variable-specific")))
+  (object-specific (check-arg-type condition-variable? 
+				   condition-variable 
+				   "condition-variable-specific")))
 
 (define (condition-variable-specific-set! condition-variable obj)
-  (hashq-set! object-specifics
-	      (check-arg-type condition-variable? 
-			      condition-variable 
-			      "condition-variable-specific-set!")
-	      obj)
-  *unspecified*)
+  (set! (object-specific
+	 (check-arg-type condition-variable? 
+			 condition-variable 
+			 "condition-variable-specific-set!"))
+	obj))
 
 (define (condition-variable-signal! cond) 
   (signal-condition-variable cond) 
-- 
1.5.4.3