New implementation of (no-inheritance) thread-local cells and thread

fluids.

New implementation of syslog.

Both are to be compatible with what's actually probably going into
Scheme 48.

scheme/big/enum-set.scm

@@ -0,0 +1,187 @@
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Sets over finite types.
+;
+; (define-enum-set-type id type-name predicate constructor
+;   element-syntax element-predicate all-elements element-index-ref)
+;
+; Defines ID to be syntax for constructing sets, PREDICATE to be a predicate
+; for those sets, and CONSTRUCTOR an procedure for constructing one
+; from a list.
+;
+; (enum-set->list <enum-set>)                   -> <list>
+; (enum-set-member? <enum-set> <enumerand>)     -> <boolean>
+; (enum-set=? <enum-set> <enum-set>)            -> <boolean>
+; (enum-set-union <enum-set> <enum-set>)        -> <enum-set>
+; (enum-set-intersection <enum-set> <enum-set>) -> <enum-set>
+; (enum-set-negation <enum-set>)                -> <enum-set>
+;
+; Given an enumerated type:
+;   (define-enumerated-type color :color
+;     color?
+;     colors
+;     color-name
+;     color-index
+;     (red blue green))
+; we can define sets of colors:
+;   (define-enum-set-type color-set :color-set
+;                         color-set?
+;                         make-color-set
+;     color color? colors color-index)
+;
+;   (enum-set->list (color-set red blue))
+;     -> (#{Color red} #{Color blue})
+;   (enum-set->list (enum-set-negation (color-set red blue)))
+;     -> (#{Color green})
+;   (enum-set-member? (color-set red blue) (color blue))
+;     -> #t
+
+(define-syntax define-enum-set-type
+  (syntax-rules ()
+    ((define-enum-set-type id type predicate constructor
+       element-syntax element-predicate all-elements element-index-ref)
+     (begin
+       (define type
+	 (make-enum-set-type 'id
+			     element-predicate
+			     all-elements
+			     element-index-ref))
+       (define (predicate x)
+	 (and (enum-set? x)
+	      (eq? (enum-set-type x)
+		   type)))
+       (define (constructor elements)
+	 (if (every element-predicate elements)
+	     (make-enum-set type (elements->mask elements element-index-ref))
+	     (error "invalid set elements" element-predicate elements)))
+       (define-enum-set-maker id constructor element-syntax)))))
+
+; (define-enum-set-maker id constructor element-syntax)
+
+(define-syntax define-enum-set-maker
+  (lambda (e r c)
+    (let ((id             (list-ref e 1))
+	  (constructor    (list-ref e 2))
+	  (element-syntax (list-ref e 3))
+	  (%define-syntax (r 'define-syntax)))
+      `(,%define-syntax ,id
+          (syntax-rules ()
+	    ((,id element ...)
+	     (,constructor (list (,element-syntax element) ...))))))))
+
+(define-record-type enum-set-type :enum-set-type
+  (make-enum-set-type id predicate values index-ref)
+  enum-set-type?
+  (id        enum-set-type-id)
+  (predicate enum-set-type-predicate)
+  (values    enum-set-type-values)
+  (index-ref enum-set-type-index-ref))
+
+(define-record-discloser :enum-set-type
+  (lambda (e-s-t)
+    (list 'enum-set-type (enum-set-type-id e-s-t))))
+
+; The mask is settable to allow for destructive operations.  There aren't
+; any such yet.
+
+(define-record-type enum-set :enum-set
+  (make-enum-set type mask)
+  enum-set?
+  (type enum-set-type)
+  (mask enum-set-mask set-enum-set-mask!))
+
+(define-record-discloser :enum-set
+  (lambda (e-s)
+    (cons (enum-set-type-id (enum-set-type e-s))
+	  (enum-set->list e-s))))
+
+(define (enum-set-has-type? enum-set enum-set-type)
+  (eq? (enum-set-type enum-set) enum-set-type))
+
+(define enum-set->integer enum-set-mask)
+
+(define integer->enum-set make-enum-set)
+
+(define-exported-binding "enum-set?" enum-set?)
+(define-exported-binding "enum-set->integer" enum-set->integer)
+(define-exported-binding "integer->enum-set" integer->enum-set)
+(define-exported-binding "enum-set-has-type?" enum-set-has-type?)
+
+(define (make-set-constructor id predicate values index-ref)
+  (let ((type (make-enum-set-type id predicate values index-ref)))
+    (lambda elements
+      (if (every predicate elements)
+	  (make-enum-set type (elements->mask elements index-ref))
+	  (error "invalid set elements" predicate elements)))))
+
+(define (elements->mask elements index-ref)
+  (do ((elements elements (cdr elements))
+       (mask 0
+	     (bitwise-ior mask
+			  (arithmetic-shift 1 (index-ref (car elements))))))
+      ((null? elements)
+       mask)))
+				  
+(define (enum-set-member? enum-set element)
+  (if ((enum-set-type-predicate (enum-set-type enum-set))
+         element)
+      (not (= (bitwise-and (enum-set-mask enum-set)
+			   (element-mask element (enum-set-type enum-set)))
+	      0))
+      (call-error "invalid arguments" enum-set-member? enum-set element)))
+
+(define (enum-set=? enum-set0 enum-set1)
+  (if (eq? (enum-set-type enum-set0)
+	   (enum-set-type enum-set1))
+      (= (enum-set-mask enum-set0) 
+	 (enum-set-mask enum-set1))
+      (call-error "invalid arguments" enum-set=? enum-set0 enum-set1)))
+
+(define (element-mask element enum-set-type)
+  (arithmetic-shift 1
+		    ((enum-set-type-index-ref enum-set-type) element)))
+
+; To reduce the number of bitwise operations required we bite off two bytes
+; at a time.
+
+(define (enum-set->list enum-set)
+  (let ((values (enum-set-type-values (enum-set-type enum-set))))
+    (do ((i 0 (+ i 16))
+	 (mask (enum-set-mask enum-set) (arithmetic-shift mask -16))
+	 (elts '()
+	       (do ((m (bitwise-and mask #xFFFF) (arithmetic-shift m -1))
+		    (i i (+ i 1))
+		    (elts elts (if (odd? m)
+				   (cons (vector-ref values i)
+					 elts)
+				   elts)))
+		   ((= m 0)
+		    elts))))
+	((= mask 0)
+	 (reverse elts)))))
+
+(define (enum-set-union enum-set0 enum-set1)
+  (if (eq? (enum-set-type enum-set0)
+	   (enum-set-type enum-set1))
+      (make-enum-set (enum-set-type enum-set0)
+		     (bitwise-ior (enum-set-mask enum-set0)
+				  (enum-set-mask enum-set1)))
+      (call-error "invalid arguments" enum-set-union enum-set0 enum-set1)))
+
+(define (enum-set-intersection enum-set0 enum-set1)
+  (if (eq? (enum-set-type enum-set0)
+	   (enum-set-type enum-set1))
+      (make-enum-set (enum-set-type enum-set0)
+		     (bitwise-and (enum-set-mask enum-set0)
+				  (enum-set-mask enum-set1)))
+      (call-error "invalid arguments" enum-set-union enum-set0 enum-set1)))
+
+(define (enum-set-negation enum-set)
+  (let* ((type (enum-set-type enum-set))
+	 (mask (- (arithmetic-shift 1
+				    (vector-length (enum-set-type-values type)))
+		  1)))
+    (make-enum-set type
+		   (bitwise-and (bitwise-not (enum-set-mask enum-set))
+				mask))))
+

scheme/big/thread-fluid.scm

@@ -1,18 +1,14 @@
 ; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
 
 (define-record-type thread-fluid :thread-fluid
-  (really-make-thread-fluid top cell)
+  (really-make-thread-fluid cell)
   thread-fluid?
-  (top thread-fluid-top-level-value)
   (cell thread-fluid-cell set-thread-fluid-cell!))
 
 (define *no-fluid-value* (list 'no-fluid-value))
 
 (define (thread-fluid thread-fluid)
-  (let ((val (thread-cell-ref (thread-fluid-cell thread-fluid))))
+  (thread-cell-ref (thread-fluid-cell thread-fluid)))
-    (if (eq? val *no-fluid-value*)
-	(thread-fluid-top-level-value thread-fluid)
-	val)))
 
 (define (set-thread-fluid! thread-fluid val)
   (thread-cell-set! (thread-fluid-cell thread-fluid) val))
@@ -50,35 +46,26 @@
 	       (loop (cddr args) (cdr old-vals))))))))))
 
 (define (make-thread-fluid top)
-  (really-make-thread-fluid top (make-thread-cell *no-fluid-value*)))
+  (really-make-thread-fluid (make-thread-cell top)))
 
+(define *preserved-fluids* (make-population))
 
-;; (define-record-type thread-fluid :thread-fluid
+(define (make-preserved-thread-fluid top)
-;;   (really-make-thread-fluid fluid)
+  (let* ((t-fluid (make-thread-fluid top)))
-;;   thread-fluid?
+    (add-to-population! t-fluid *preserved-fluids*)
-;;   (fluid thread-fluid-fluid))
+    t-fluid))
-;; 
+
-;; (define (make-thread-fluid top)
+(define (preserve-thread-fluids thunk)
-;;   (really-make-thread-fluid (make-fluid (make-thread-cell top))))
+  (let ((args (list thunk)))
-;; 
+    (walk-population
-;; (define (thread-fluid t-fluid)
+     (lambda (t-fluid)
-;;   (thread-cell-ref (fluid (thread-fluid-fluid t-fluid))))
+       (set! args
-;; 
+	     (cons t-fluid
-;; (define (set-thread-fluid! thread-fluid val)
+		   (cons (thread-fluid t-fluid)
-;;   (thread-cell-set! (fluid (thread-fluid-fluid thread-fluid)) val))
+			 args))))
-;; 
+     *preserved-fluids*)
-;; (define (let-thread-fluid t-fluid val thunk)
+    (lambda ()
-;;   (let-fluid (thread-fluid-fluid t-fluid)
+      (apply let-thread-fluids args))))
-;; 	     (make-thread-cell val)
+
-;; 	     thunk))
+(define (fork-thread thunk)
-;; 
+  (spawn (preserve-thread-fluids thunk)))
-;; ;; avoid creating too many dynamic environments
-;; (define (let-thread-fluids . args)
-;;   (let loop ((args args) (rev-new-args '()))
-;;     (if (not (null? (cdr args)))
-;; 	(loop (cddr args)
-;; 	      (cons (make-thread-cell (cadr args))
-;; 		    (cons (thread-fluid-fluid (car args))
-;; 			  rev-new-args)))
-;; 	;; we're done
-;; 	(apply let-fluids (reverse (cons (car args) rev-new-args))))))

scheme/env/command-level.scm

@@ -168,11 +168,8 @@
 ; that when it is rescheduled after blocking it can be put on the correct
 ; run queue.
 
-(define (spawn-on-command-level level thunk cell-values id)
+(define (spawn-on-command-level level thunk id)    
-  (let ((thread (make-thread thunk
+  (let ((thread (make-thread thunk (command-level-dynamic-env level) id)))
-			     (command-level-dynamic-env level)
-			     cell-values
-			     id)))
     (set-thread-scheduler! thread (command-thread))
     (set-thread-data! thread level)
     (enqueue-thread! (command-level-queue level) thread)
@@ -184,7 +181,6 @@
 (define (spawn-repl-thread! level)
   (let ((thread (spawn-on-command-level level
 					(command-level-repl-thunk level)
-					(empty-cell-values)
 					'command-loop)))
     (set-command-level-repl-thread! level thread)))
 
@@ -357,7 +353,7 @@
     (lambda (event args)
       (enum-case event-type event
 	((spawned)
-	 (spawn-on-command-level level (car args) (cadr args) (caddr args))
+	 (spawn-on-command-level level (car args) (cadr args))
 	 #t)
 	((runnable)
 	 (let* ((thread (car args))

scheme/interfaces.scm

@@ -390,16 +390,6 @@
 	  really-string->number &really-string->number ;exactness argument
 	  string->integer))
 
-(define-interface thread-cells-interface
-  (export make-thread-cell
-	  thread-cell-ref
-	  thread-cell-set!))
-
-(define-interface thread-cells-internal-interface
-  (export get-cell-values
-	  empty-cell-values		; env/command-level.scm
-	  initialize-dynamic-state!))
-
 (define-interface fluids-interface
   (export make-fluid
 	  let-fluid
@@ -408,13 +398,23 @@
 	  set-fluid!))
 
 (define-interface fluids-internal-interface
-  (export current-thread
+  (export initialize-dynamic-state!
+	  current-thread
 	  set-current-thread!
 	  get-dynamic-env		; wind.scm, env/command-level.scm
 	  set-dynamic-env!		; wind.scm
 	  get-dynamic-point		; wind.scm
-	  set-dynamic-point!		; wind.scm
+	  set-dynamic-point!))		; wind.scm
-	  empty-dynamic-env))		; thread-cell.scm
+
+(define-interface thread-cells-internal-interface
+  (export get-thread-cell-env
+	  set-thread-cell-env!
+	  empty-thread-cell-env))
+
+(define-interface thread-cells-interface
+  (export make-thread-cell
+	  thread-cell-ref
+	  thread-cell-set!))
 
 (define-interface enumerated-interface
   (export (define-enumeration :syntax)

scheme/more-interfaces.scm

@@ -327,12 +327,30 @@
 	  array->vector		; <array>
 	  array))		; <bounds> . <elements>
 
+(define-interface enum-sets-interface
+  (export (define-enum-set-type :syntax)
+	  enum-set->list
+	  enum-set-member?
+	  enum-set=?
+	  enum-set-union
+	  enum-set-intersection
+	  enum-set-negation))
+
+(define-interface enum-sets-internal-interface
+  (export enum-set-has-type?
+	  enum-set?
+	  enum-set-type
+	  enum-set->integer
+	  integer->enum-set))
+
 (define-interface thread-fluids-interface
   (export make-thread-fluid
 	  thread-fluid
 	  let-thread-fluid
 	  let-thread-fluids
-	  set-thread-fluid!))
+	  set-thread-fluid!
+	  make-preserved-thread-fluid
+	  fork-thread))
 
 (define-interface search-trees-interface
   (export make-search-tree

scheme/more-packages.scm

@@ -72,7 +72,6 @@
 	util                    ; unspecific
 	channel-i/o             ; steal-channel-port
 	fluids-internal         ; get-dynamic-env, set-dynamic-env!
-	thread-cells-internal	; empty-cell-values
 	root-scheduler          ; call-when-deadlocked!
 	conditions)             ; define-condition-type
   (files (env command-level)))
@@ -477,11 +476,23 @@
 	primitives) ; unspecific
   (files (big defrecord)))
 
+(define-structures ((enum-sets enum-sets-interface)
+		    (enum-sets-internal enum-sets-internal-interface))
+  (open scheme define-record-types
+	finite-types
+	bitwise 
+	util
+	signals
+	external-calls)
+  (optimize auto-integrate)
+  (files (big enum-set)))
+
 (define general-tables tables)    ; backward compatibility
 
 (define-structure thread-fluids thread-fluids-interface
-  (open scheme define-record-types thread-cells fluids)
+  (open scheme define-record-types weak
-  (files (big thread-fluids)))
+	threads thread-cells fluids)
+  (files (big thread-fluid)))
 
 (define-structure big-util big-util-interface
   (open scheme-level-2
@@ -687,6 +698,7 @@
 	    dump/restore
 	    dynamic-externals
 	    enum-case
+	    enum-sets
 	    extended-numbers
 	    extended-ports
 	    externals

scheme/rts-packages.scm

@@ -49,15 +49,11 @@
   (files (rts numio)))
 
 (define-structures ((fluids fluids-interface)
-		    (fluids-internal fluids-internal-interface))
+ 		    (fluids-internal fluids-internal-interface)
+ 		    (thread-cells thread-cells-interface)
+ 		    (thread-cells-internal thread-cells-internal-interface))
   (open scheme-level-1 define-record-types primitives)
-  (files (rts fluid))
+  (files (rts thread-env))
-  (optimize auto-integrate))
-
-(define-structures ((thread-cells thread-cells-interface)
-		    (thread-cells-internal thread-cells-internal-interface))
-  (open scheme-level-1 define-record-types primitives fluids-internal)
-  (files (rts thread-cell))
   (optimize auto-integrate))
 
 (define-structure wind wind-interface
@@ -245,7 +241,7 @@
         wind
         fluids
 	fluids-internal         ;get-dynamic-env
-	thread-cells-internal	;get-cell-values
+	thread-cells-internal   ;get-thread-cell-env, empty-thread-cell-env
         escapes                 ;primitive-cwcc
         conditions              ;error?
         handle                  ;with-handler
@@ -260,8 +256,7 @@
   (files (rts thread) (rts sleep)))
 
 (define-structure scheduler scheduler-interface
-  (open scheme-level-1 threads threads-internal thread-cells-internal
+  (open scheme-level-1 threads threads-internal enumerated enum-case
-	enumerated enum-case
 	debug-messages
 	signals)       		;error
   (files (rts scheduler)))
@@ -279,7 +274,6 @@
 	writing			;display
 	i/o-internal            ;output-port-forcer, output-forcer-id
 	fluids-internal         ;get-dynamic-env
-	thread-cells-internal	;get-cell-values
 	interrupts              ;with-interrupts-inhibited
 	wind                    ;call-with-current-continuation
 	channel-i/o		;waiting-for-i/o?
@@ -328,7 +322,7 @@
 	i/o		 ;initialize-i/o, etc.
 	channel-i/o      ;{in,out}put-channel->port, initialize-channel-i/o
 	session-data     ;initialize-session-data!
-	thread-cells-internal	 ;initialize-dynamic-state!
+	fluids-internal	 ;initialize-dynamic-state!
 	exceptions	 ;initialize-exceptions!
 	interrupts	 ;initialize-interrupts!
 	rts-sigevents-internal  ;initialize-sigevents!

scheme/rts/root-scheduler.scm

@@ -30,7 +30,6 @@
 	(safe-dynamic-env (with-handler root-handler get-dynamic-env))
 	(thread (make-thread thunk
 			     (get-dynamic-env)
-			     (get-cell-values)
 			     'scheduler-initial-thread)))
     (increment-counter! thread-count)
     (enqueue-thread! runnable thread)

scheme/rts/scheduler.scm

@@ -100,8 +100,7 @@
 	   (enqueue-thread! runnable
 			    (make-thread (car event-data)
 					 dynamic-env
-					 (cadr event-data)
+					 (cadr event-data))))
-					 (caddr event-data))))
 	  ((no-event)
 	   (values))
 	  (else

scheme/rts/thread-env.scm

@@ -1,4 +1,4 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
 
 ; This is file fluid.scm.
 
@@ -23,17 +23,10 @@
 ; efficiency concerns.
 
 (define-record-type thread :thread
-  (make-thread dynamic-env dynamic-point)
+  (make-thread dynamic-env dynamic-point cell-env)
-  (dynamic-env thread-dynamic-env)
+  (dynamic-env   thread-dynamic-env)
-  (dynamic-point thread-dynamic-point))
+  (dynamic-point thread-dynamic-point)
-
+  (cell-env      thread-cell-env))
-;; (define *dynamic-env* (make-thread-cell (empty-dynamic-env)))
-;; 
-;; (define (get-dynamic-env)
-;;   (thread-cell-ref *dynamic-env*))
-;; 
-;; (define (set-dynamic-env! env)
-;;   (thread-cell-set! *dynamic-env* env))
 
 (define (get-dynamic-env)
   (record-ref (current-thread) 1))
@@ -41,7 +34,7 @@
 (define (set-dynamic-env! env)
   (record-set! (current-thread) 1 env))
 
-; The dynamic-wind point used to be just an ordinary fluid variable, which
+; The dynamic-wind point used to be just an ordinary fluid variable, but that
 ; doesn't work well with threads.
 
 (define (get-dynamic-point)
@@ -78,6 +71,8 @@
   (let ((probe (assq f (get-dynamic-env))))
     (if probe (cdr probe) (fluid-top-level-value f))))
 
+; Deprecated.
+
 (define (set-fluid! f val)
   (let ((probe (assq f (get-dynamic-env))))
     (if probe (set-cdr! probe val) (set-fluid-top-level-value! f val))))
@@ -92,3 +87,41 @@
 	(with-dynamic-env env (car args))
 	(loop (cddr args)
 	      (cons (cons (car args) (cadr args)) env)))))
+
+; Thread cells
+
+(define-record-type thread-cell :thread-cell
+  (make-thread-cell default)
+  (default thread-cell-default))
+
+(define (get-thread-cell-env)
+  (record-ref (current-thread) 3))
+
+(define (set-thread-cell-env! value)
+  (record-set! (current-thread) 3 value))
+
+(define (empty-thread-cell-env) '())
+
+(define (thread-cell-ref thread-cell)
+  (let ((probe (assq thread-cell (get-thread-cell-env))))
+    (if probe
+        (cdr probe)
+        (thread-cell-default thread-cell))))
+
+(define (thread-cell-set! thread-cell value)
+  (let ((probe (assq thread-cell (get-thread-cell-env))))
+    (if probe
+        (set-cdr! probe value)
+        (set-thread-cell-env! (cons (cons thread-cell
+                                           value)
+                                     (get-thread-cell-env))))))
+
+
+; Initialize
+
+(define (initialize-dynamic-state!)
+  (set-current-thread!
+   (make-thread (empty-dynamic-env) #f (empty-thread-cell-env))))
+
+(initialize-dynamic-state!)
+

scheme/rts/thread.scm

@@ -39,8 +39,7 @@
 ; the list is spliced back together and eN's continuation is resumed.
 
 (define-record-type thread :thread
-  (really-make-thread dynamic-env dynamic-point
+  (really-make-thread dynamic-env dynamic-point cell-env
-		      cell-values own-cell-values?
 		      continuation scheduler
 		      queues arguments
 		      events current-task uid name)
@@ -48,11 +47,7 @@
   (dynamic-env    thread-dynamic-env)   ;Must be first!  (See fluid.scm)
   (dynamic-point  thread-dynamic-point set-thread-dynamic-point!)
   					;Must be second!  (See fluid.scm)
-
+  (cell-env       thread-cell-env)      ;Must be fourth! (See thread-env.scm)
-					;Must be third! (See thread-cell.scm)
-  (cell-values    thread-cell-values set-thread-cell-values!)
-					;Must be fourth! (See thread-cell.scm)
-  (own-cell-values? thread-own-cell-values? set-thread-own-values?!)
   (continuation   thread-continuation set-thread-continuation!)
   (queues         thread-queues set-thread-queues!)
   (arguments      thread-arguments set-thread-arguments!)
@@ -75,11 +70,10 @@
 
 (define *thread-uid* 0)
 
-(define (make-thread thunk dynamic-env cell-values name)
+(define (make-thread thunk dynamic-env name)
   (let ((thread (really-make-thread dynamic-env
 				    #f               ; dynamic-point root
-				    cell-values
+				    (empty-thread-cell-env)
-				    #f		     ; own-cell-values?
 				    (thunk->continuation
 				     (thread-top-level thunk))
 				    (current-thread) ; scheduler
@@ -576,29 +570,20 @@
 ; scheduler.
 
 (define (spawn thunk . id)
-  (set-thread-own-values?! (current-thread) #f)
+  (apply spawn-on-scheduler (thread-scheduler (current-thread)) thunk id))
-  (apply spawn-on-scheduler
-	 (thread-scheduler (current-thread))
-	 thunk
-	 (thread-cell-values (current-thread))
-	 id))
 
 (define (spawn-on-root thunk . id)
   (if (root-scheduler)
-      (begin
+      (apply spawn-on-scheduler
-	(set-thread-own-values?! (current-thread) #f)
+	     (root-scheduler)
-	(apply spawn-on-scheduler
+	     thunk
-	       (root-scheduler)
+	     id)
-	       thunk
-	       (thread-cell-values (current-thread))
-	       id))
       (thunk)))
 
-(define (spawn-on-scheduler scheduler thunk cell-values . id)
+(define (spawn-on-scheduler scheduler thunk . id)
   (schedule-event scheduler
 		  (enum event-type spawned)
 		  thunk
-		  cell-values
 		  (if (null? id) #f (car id))))
 
 ; Enqueue a RUNNABLE for THREAD's scheduler.
@@ -666,7 +651,6 @@
 		 (set! *thread-uid* 0)
 		 (let ((thread (make-thread #f    ; thunk
 					    (get-dynamic-env)
-					    (get-cell-values)
 					    'initial-thread)))
 		   (set-thread-scheduler! thread #f)
 		   (set-thread-time! thread #f)

scsh/scsh-interfaces.scm

@@ -1088,33 +1088,33 @@
 
 (define-interface syslog-interface
   (export (syslog-option :syntax)
+	  syslog-option?
+
 	  make-syslog-options
-	  syslog-options->list
 	  syslog-options?
 	  (syslog-options :syntax)
-	  syslog-options-on?
-	  syslog-options=?
 
 	  (syslog-facility :syntax)
 	  syslog-facility?
-	  syslog-facility=?
 
 	  (syslog-level :syntax)
 	  syslog-level?
-	  syslog-level=?
 
-	  levels->syslog-mask
+	  make-syslog-mask
+	  syslog-mask?
 	  (syslog-mask :syntax)
-	  syslog-mask->levels
 	  syslog-mask-all
 	  syslog-mask-upto
-	  syslog-mask-levels-on?
-	  syslog-mask?
-	  syslog-mask=?
-
-	  open-syslog-channel
-	  close-syslog-channel
 
 	  with-syslog-destination
+	  set-syslog-destination!
+
 	  syslog))
 
+(define-interface syslog-channels-interface
+  (export open-syslog-channel
+	  close-syslog-channel
+	  set-syslog-channel!
+	  with-syslog-channel))
+
+

scsh/scsh-package.scm

@@ -464,10 +464,12 @@
 	threads) ; sleep
   (files dot-locking)) 
 
-(define-structure syslog syslog-interface
+(define-structures ((syslog syslog-interface)
-  (open scheme define-record-types finite-types
+		    (syslog-channels syslog-channels-interface))
+  (open scheme
+	define-record-types finite-types enum-sets
 	locks thread-fluids
 	external-calls
-	scsh-utilities
 	bitwise)
   (files syslog))
+

scsh/syslog.scm

@@ -2,64 +2,31 @@
 
 ;; Options for openlog
 
-(define-finite-type syslog-option :syslog-option
+(define-enumerated-type syslog-option :syslog-option
-  (mask)
   syslog-option?
   the-syslog-options
   syslog-option-name
   syslog-option-index
-  (mask syslog-option-mask)
+  ;; The order of these is known to the C code.
-  ;; These values are known to the C code.
+  (console
-  ((console		#o01)
+   delay
-   (delay		#o02)
+   no-delay
-   (no-delay		#o04)
+   log-pid))
-   (log-pid		#o10)))
 
-(define-record-type syslog-options :syslog-options
+(define-exported-binding "syslog-options" the-syslog-options)
-  (really-make-syslog-options value)
+
+(define-enum-set-type syslog-options :syslog-options
   syslog-options?
-  (value syslog-options-value))
+  make-syslog-options
+  
+  syslog-option
+  syslog-option?
+  the-syslog-options
+  syslog-option-index)
 
-(define syslog-options=? eq?)
+(define-exported-binding "syslog-options?" syslog-options?)
 
-(define-exported-binding "syslog-options-type" :syslog-options)
+(define default-syslog-options (syslog-options))
-
-(define (syslog-options-on? options0 options1)
-  (= 0 (bitwise-and (syslog-options-value options1)
-		    (bitwise-not (syslog-options-value options0)))))
-
-(define (make-syslog-options options)
-  (really-make-syslog-options
-   (apply bitwise-ior (map syslog-option-mask options))))
-
-(define default-syslog-options (make-syslog-options '()))
-
-(define (make-mask-record->list get-value get-mask record-vector)
-  (lambda (mask-record)
-    (let ((value (get-value mask-record))
-	  (n-syslog-options (vector-length record-vector)))
-      (let loop ((i 0) (list '()))
-	(cond
-	 ((>= i n-syslog-options)
-	  list)
-	 ((zero? (bitwise-and value
-			      (get-mask (vector-ref record-vector i))))
-	  (loop (+ 1 i) list))
-	 (else
-	  (loop (+ 1 i) (cons (vector-ref record-vector i)
-			      list))))))))
-
-(define syslog-options->list
-  (make-mask-record->list syslog-options-value
-			  syslog-option-mask
-			  the-syslog-options))
-
-; Simplifying syntax, e.g. (syslog-options delay console)
-
-(define-syntax syslog-options
-  (syntax-rules ()
-    ((syslog-options name ...)
-     (make-syslog-options (list (syslog-option name) ...)))))
 
 (define-enumerated-type syslog-facility :syslog-facility
   syslog-facility?
@@ -79,73 +46,50 @@
    uucp
    local0 local1 local2 local3 local4 local5 local6 local7))
 
-(define syslog-facility=? eq?)
-
 (define default-syslog-facility (syslog-facility user))
 
 (define-exported-binding "syslog-facility-type" :syslog-facility)
 (define-exported-binding "syslog-facilities" syslog-facilities)
 
-(define-finite-type syslog-level :syslog-level
+(define-enumerated-type syslog-level :syslog-level
-  (mask)
   syslog-level?
   syslog-levels
   syslog-level-name
   syslog-level-index
-  (mask syslog-level-mask)
+  ;; The order of these is known to the C code.
-  ;; Options for syslog
+  (emergency	
-  ;; The order and the values of these is known to the C code.
+   alert	
-  ((emergency	#o001)
+   critical	
-   (alert	#o002)
+   error	
-   (critical	#o004)
+   warning	
-   (error	#o010)
+   notice	
-   (warning	#o020)
+   info	
-   (notice	#o040)
+   debug))
-   (info	#o100)
-   (debug	#o200)))
-
-(define syslog-level=? eq?)
 
 (define-exported-binding "syslog-level-type" :syslog-level)
 (define-exported-binding "syslog-levels" syslog-levels)
 
-(define-record-type syslog-mask :syslog-mask
+(define-enum-set-type syslog-mask :syslog-mask
-  (make-syslog-mask value)
   syslog-mask?
-  (value syslog-mask-value))
+  make-syslog-mask
 
-(define (syslog-mask=? mask-1 mask-2)
+  syslog-level
-  (= (syslog-mask-value mask-1)
+  syslog-level?
-     (syslog-mask-value mask-2)))
+  syslog-levels
+  syslog-level-index)
 
-(define-exported-binding "syslog-mask-type" :syslog-mask)
+(define-exported-binding "syslog-mask?" syslog-mask?)
-
+(define-exported-binding ":syslog-mask" :syslog-mask)
-(define (syslog-mask-levels-on? mask-1 mask-2)
-  (= 0 (bitwise-and (syslog-mask-value mask-2)
-		    (bitwise-not (syslog-mask-value mask-1)))))
-
-(define (levels->syslog-mask levels)
-  (make-syslog-mask
-   (apply bitwise-ior
-	  (map syslog-level-mask levels))))
-
-(define syslog-mask->levels
-  (make-mask-record->list syslog-mask-value
-			  syslog-level-mask
-			  syslog-levels))
-
-(define-syntax syslog-mask
-  (syntax-rules ()
-    ((syslog-mask name ...)
-     (levels->syslog-mask (list (syslog-level name) ...)))))
 
 (define (syslog-mask-upto level)
   (let loop ((index (syslog-level-index level)) (levels '()))
     (if (< index 0)
-	(levels->syslog-mask levels)
+	(make-syslog-mask levels)
-	(loop (- index 1) (cons index levels)))))
+	(loop (- index 1)
+	      (cons (vector-ref syslog-levels index)
+		    levels)))))
 
-(define syslog-mask-all (levels->syslog-mask (vector->list syslog-levels)))
+(define syslog-mask-all (make-syslog-mask (vector->list syslog-levels)))
 
 (define default-syslog-mask syslog-mask-all)
 
@@ -169,11 +113,11 @@
 (define (syslog-channel-equivalent? channel-1 channel-2)
   (and (string=? (syslog-channel-ident channel-1)
 		 (syslog-channel-ident channel-2))
-       (syslog-options=? (syslog-channel-options channel-1)
+       (enum-set=? (syslog-channel-options channel-1)
-			 (syslog-channel-options channel-2))
+		   (syslog-channel-options channel-2))
        ;; facility can be specified with each syslog-write
-       (syslog-mask=? (syslog-channel-mask channel-1)
+       (enum-set=? (syslog-channel-mask channel-1)
-		      (syslog-channel-mask channel-2))))
+		   (syslog-channel-mask channel-2))))
 
 (define current-syslog-channel 'unitinialized)
 (define current-syslog-channel-lock 'unitinialized)
@@ -191,24 +135,27 @@
       (closelog))
   (release-lock current-syslog-channel-lock))
 
-;; THUNK must not escape
 (define (with-syslog-channel channel thunk)
-  (obtain-lock current-syslog-channel-lock)
+  (dynamic-wind
-  (if (or (not current-syslog-channel)
+   (lambda ()
-	  (not (syslog-channel-equivalent? channel
+     (obtain-lock current-syslog-channel-lock))
-					   current-syslog-channel)))
+   (lambda ()
-      (begin
+     (if (or (not current-syslog-channel)
-	(if current-syslog-channel
+	     (not (syslog-channel-equivalent? channel
-	    (closelog))
+					      current-syslog-channel)))
-	(openlog (syslog-channel-ident channel)
+	 (begin
-		 (syslog-channel-options channel)
+	   (if current-syslog-channel
-		 (syslog-channel-facility channel))
+	       (closelog))
-	(if (not (syslog-mask=? (syslog-channel-mask channel)
+	   (openlog (syslog-channel-ident channel)
+		    (syslog-channel-options channel)
+		    (syslog-channel-facility channel))
+	   (if (not (enum-set=? (syslog-channel-mask channel)
 				default-syslog-mask))
-	    (setlogmask! (syslog-channel-mask channel)))
+	       (setlogmask! (syslog-channel-mask channel)))
-	(set! current-syslog-channel channel)))
+	   (set! current-syslog-channel channel)))
-  (thunk)
+     (thunk))
-  (release-lock current-syslog-channel-lock))
+   (lambda ()
+     (release-lock current-syslog-channel-lock))))
 
 (define (syslog-write level message channel)
   (with-syslog-channel
@@ -216,44 +163,36 @@
    (lambda ()
      (unix-syslog level (syslog-channel-facility channel) message))))
 
-(define (list-ref-carefully list n default)
+(define (change-syslog-channel channel ident options facility mask)
-  (cond
+  (make-syslog-channel (or ident
-   ((null? list) default)
+			   (syslog-channel-ident channel))
-   ((zero? n) (car list))
+		       (or options
-   (else
+			   (syslog-channel-options channel))
-    (list-ref-carefully (cdr list) (- n 1) default))))
+		       (or facility
-
+			   (syslog-channel-facility channel))
-(define (change-syslog-channel channel . rest)
+		       (or mask
-  (let ((ident (list-ref-carefully rest 0 #f))
+			   (syslog-channel-mask channel))))
-	(options (list-ref-carefully rest 1 #f))
-	(facility (list-ref-carefully rest 2 #f))
-	(mask (list-ref-carefully rest 3 #f)))
-    (make-syslog-channel (or ident
-			     (syslog-channel-ident channel))
-			 (or options
-			     (syslog-channel-options channel))
-			 (or facility
-			     (syslog-channel-facility channel))
-			 (or mask
-			     (syslog-channel-mask channel)))))
 
 (define dynamic-syslog-channel
-  (make-thread-fluid
+  (make-preserved-thread-fluid
-   (make-syslog-channel "scheme48"
+   (make-syslog-channel "scsh"
 			default-syslog-options
 			default-syslog-facility
 			default-syslog-mask)))
 
 (define (syslog level message . rest)
   (syslog-write level message
-		(if (and (not (null? rest))
+		(cond
-			 (null? (cdr rest))
+		 ((null? rest)
-			 (syslog-channel? (car rest)))
+		  (thread-fluid dynamic-syslog-channel))
-		    (car rest)
+		 ((and (null? (cdr rest))
-		    ;; this might be a little excessive allocation
+		       (syslog-channel? (car rest)))
-		    (apply change-syslog-channel
+		  (car rest))
-			   (thread-fluid dynamic-syslog-channel)
+		 (else
-			   rest))))
+		  ;; this might be a little excessive allocation
+		  (apply change-syslog-channel
+			 (thread-fluid dynamic-syslog-channel)
+			 (append rest '(#f)))))))
 
 (define (with-syslog-destination ident options facility mask thunk)
   (let-thread-fluid dynamic-syslog-channel
@@ -262,6 +201,16 @@
 		     ident options facility mask)
 		    thunk))
 
+(define (set-syslog-channel! channel)
+  (set-thread-fluid! dynamic-syslog-channel
+		    channel))
+
+(define (set-syslog-destination! ident options facility mask)
+  (set-thread-fluid! dynamic-syslog-channel
+		     (change-syslog-channel
+		      (thread-fluid dynamic-syslog-channel)
+		      ident options facility mask)))
+
 ;----------------
 ; A record type whose only purpose is to run some code when we start up an
 ; image.

scsh/syslog1.c

@@ -16,13 +16,18 @@ static s48_value	sch_openlog(s48_value sch_ident,
 /*
  * Record types imported from Scheme.
  */
-static s48_value	syslog_options_type_binding = S48_FALSE;
+static s48_value	is_syslog_options_binding = S48_FALSE;
 static s48_value	syslog_facility_type_binding = S48_FALSE;
 static s48_value	syslog_facilities_binding = S48_FALSE;
 static s48_value	syslog_level_type_binding = S48_FALSE;
 static s48_value	syslog_levels_binding = S48_FALSE;
+static s48_value	is_syslog_mask_binding = S48_FALSE;
 static s48_value	syslog_mask_type_binding = S48_FALSE;
 
+static s48_value	is_enum_set_binding = S48_FALSE;
+static s48_value	enum_set2integer_binding = S48_FALSE;
+static s48_value	integer2enum_set_binding = S48_FALSE;
+
 /*
  * Install all exported functions in Scheme 48.
  */
@@ -34,9 +39,9 @@ s48_init_syslog(void)
   S48_EXPORT_FUNCTION(sch_setlogmask);
   S48_EXPORT_FUNCTION(sch_closelog);
 
-  S48_GC_PROTECT_GLOBAL(syslog_options_type_binding);
+  S48_GC_PROTECT_GLOBAL(is_syslog_options_binding);
-  syslog_options_type_binding =
+  is_syslog_options_binding =
-    s48_get_imported_binding("syslog-options-type");
+    s48_get_imported_binding("syslog-options?");
 
   S48_GC_PROTECT_GLOBAL(syslog_facility_type_binding);
   syslog_facility_type_binding =
@@ -52,45 +57,106 @@ s48_init_syslog(void)
   syslog_levels_binding =
     s48_get_imported_binding("syslog-levels");
 
+  S48_GC_PROTECT_GLOBAL(is_syslog_mask_binding);
+  is_syslog_mask_binding =
+    s48_get_imported_binding("syslog-mask?");
+
   S48_GC_PROTECT_GLOBAL(syslog_mask_type_binding);
   syslog_mask_type_binding =
-    s48_get_imported_binding("syslog-mask-type");
+    s48_get_imported_binding(":syslog-mask");
+
+  S48_GC_PROTECT_GLOBAL(is_enum_set_binding);
+  is_enum_set_binding =
+    s48_get_imported_binding("enum-set?");
+
+  S48_GC_PROTECT_GLOBAL(enum_set2integer_binding);
+  enum_set2integer_binding =
+    s48_get_imported_binding("enum-set->integer");
+
+  S48_GC_PROTECT_GLOBAL(integer2enum_set_binding);
+  integer2enum_set_binding =
+    s48_get_imported_binding("integer->enum-set");
+}
+
+/* ************************************************************
+ * General procedures
+ */
+
+static int
+is_enum_set(s48_value sch_thing)
+{
+  S48_SHARED_BINDING_CHECK(is_enum_set_binding);
+
+  return !S48_FALSE_P
+    (s48_call_scheme(S48_SHARED_BINDING_REF(is_enum_set_binding),
+		     1,
+		     sch_thing));
+}
+
+static void
+check_enum_set(s48_value sch_thing)
+{
+  if (!is_enum_set(sch_thing))
+    s48_raise_argument_type_error(sch_thing);
+}
+
+static long
+enum_set2integer(s48_value sch_enum_set)
+{
+  check_enum_set(sch_enum_set);
+
+  S48_SHARED_BINDING_CHECK(enum_set2integer_binding);
+
+  return s48_extract_fixnum
+    (s48_call_scheme(S48_SHARED_BINDING_REF(enum_set2integer_binding),
+		     1,
+		     sch_enum_set));
+}
+
+static s48_value
+integer2enum_set(s48_value sch_enum_type, long mask)
+{
+  S48_SHARED_BINDING_CHECK(integer2enum_set_binding);
+
+  return s48_call_scheme(S48_SHARED_BINDING_REF(integer2enum_set_binding),
+			 2,
+			 sch_enum_type,
+			 s48_enter_fixnum(mask));
 }
 
 /* ************************************************************ */
 /* Syslog options.
  *
- * We translate the local bits into our own bits and vice versa.
+ * We translate the our own bits into local bits
  */
 
-static s48_value
+static int
-s48_enter_syslog_options(int syslog_options)
+is_syslog_options(s48_value sch_thing)
 {
-  s48_value	sch_syslog_options;
+  S48_SHARED_BINDING_CHECK(is_syslog_options_binding);
-  int		my_syslog_options;
 
-  my_syslog_options =
+  return !S48_FALSE_P
-    (LOG_CONS    & syslog_options ? 00001 : 0) |
+    (s48_call_scheme(S48_SHARED_BINDING_REF(is_syslog_options_binding),
-    (LOG_ODELAY  & syslog_options ? 00002 : 0) |
+		     1,
-    (LOG_NDELAY  & syslog_options ? 00004 : 0) |
+		     sch_thing));
-    (LOG_PID     & syslog_options ? 00010 : 0);
+}
 
-  sch_syslog_options = s48_make_record(syslog_options_type_binding);
+static void
-  S48_UNSAFE_RECORD_SET(sch_syslog_options, 0, s48_enter_fixnum(my_syslog_options));
+check_syslog_options(s48_value sch_thing)
-
+{
-  return sch_syslog_options;
+  if (!is_syslog_options(sch_thing))
+    s48_raise_argument_type_error(sch_thing);
 }
 
 static int
 s48_extract_syslog_options(s48_value sch_syslog_options)
 {
   int	c_syslog_options;
-  int	syslog_options;
+  long	syslog_options;
 
-  s48_check_record_type(sch_syslog_options, syslog_options_type_binding);
+  check_syslog_options(sch_syslog_options);
 
-  syslog_options =
+  syslog_options = enum_set2integer(sch_syslog_options);
-    s48_extract_fixnum(S48_UNSAFE_RECORD_REF(sch_syslog_options, 0));
 
   c_syslog_options =
     (00001 & syslog_options ? LOG_CONS   : 0) |
@@ -123,26 +189,6 @@ static int syslog_facilities[] = {
 };
 
 
-static s48_value
-s48_enter_syslog_facility(int syslog_facility)
-{
-  s48_value	sch_syslog_facility;
-  int		my_syslog_facility;
-
-  for (my_syslog_facility = 0;
-       my_syslog_facility < (sizeof(syslog_facilities) / sizeof(int));
-       ++my_syslog_facility) {
-    if (syslog_facility == my_syslog_facility)
-      break;
-  }
-
-  sch_syslog_facility =
-    S48_VECTOR_REF(S48_SHARED_BINDING_REF(syslog_facilities_binding),
-		   my_syslog_facility);
-
-  return sch_syslog_facility;
-}
-
 static s48_value
 s48_extract_syslog_facility(s48_value sch_syslog_facility)
 {
@@ -179,26 +225,6 @@ static int syslog_levels[] = {
 };
 
 
-static s48_value
-s48_enter_syslog_level(int syslog_level)
-{
-  s48_value	sch_syslog_level;
-  int		my_syslog_level;
-
-  for (my_syslog_level = 0;
-       my_syslog_level < (sizeof(syslog_levels) / sizeof(int));
-       ++my_syslog_level) {
-    if (syslog_level == my_syslog_level)
-      break;
-  }
-
-  sch_syslog_level =
-    S48_VECTOR_REF(S48_SHARED_BINDING_REF(syslog_levels_binding),
-		   my_syslog_level);
-
-  return sch_syslog_level;
-}
-
 static s48_value
 s48_extract_syslog_level(s48_value sch_syslog_level)
 {
@@ -224,7 +250,6 @@ s48_extract_syslog_level(s48_value sch_syslog_level)
 static s48_value
 s48_enter_syslog_mask(int syslog_mask)
 {
-  s48_value	sch_syslog_mask;
   int		my_syslog_mask;
 
   my_syslog_mask =
@@ -237,10 +262,28 @@ s48_enter_syslog_mask(int syslog_mask)
     (LOG_MASK(LOG_INFO)    & syslog_mask ? 00100 : 0) |
     (LOG_MASK(LOG_DEBUG)   & syslog_mask ? 00200 : 0);
 
-  sch_syslog_mask = s48_make_record(syslog_mask_type_binding);
-  S48_UNSAFE_RECORD_SET(sch_syslog_mask, 0, s48_enter_fixnum(my_syslog_mask));
 
-  return sch_syslog_mask;
+  return integer2enum_set
+    (S48_SHARED_BINDING_REF(syslog_mask_type_binding),
+     my_syslog_mask);
+}
+
+static int
+is_syslog_mask(s48_value sch_thing)
+{
+  S48_SHARED_BINDING_CHECK(is_enum_set_binding);
+
+  return !S48_FALSE_P
+    (s48_call_scheme(S48_SHARED_BINDING_REF(is_syslog_mask_binding),
+					    1,
+					    sch_thing));
+}
+
+static void
+check_syslog_mask(s48_value sch_thing)
+{
+  if (!is_syslog_mask(sch_thing))
+    s48_raise_argument_type_error(sch_thing);
 }
 
 static int
@@ -249,11 +292,10 @@ s48_extract_syslog_mask(s48_value sch_syslog_mask)
   int	c_syslog_mask;
   int	syslog_mask;
 
-  s48_check_record_type(sch_syslog_mask, syslog_mask_type_binding);
+  check_syslog_mask(sch_syslog_mask);
-
-  syslog_mask =
-    s48_extract_fixnum(S48_UNSAFE_RECORD_REF(sch_syslog_mask, 0));
 
+  syslog_mask = enum_set2integer(sch_syslog_mask);
+   
   c_syslog_mask =
     (00001 & syslog_mask ? LOG_MASK(LOG_EMERG)   : 0) |
     (00002 & syslog_mask ? LOG_MASK(LOG_ALERT)   : 0) |
@@ -287,7 +329,6 @@ sch_openlog(s48_value sch_ident,
   if (syslog_open)
     s48_raise_string_os_error("syslog is already open");
 
-
   /* sch_ident may be copied to a different location by GC,
      and openlog doesn't copy the input string, at least not
      on every system.  That's just great. */
@@ -301,7 +342,7 @@ sch_openlog(s48_value sch_ident,
   syslog_ident[i] = '\0';
 
   openlog(syslog_ident, 
-	  s48_extract_syslog_options(sch_options), 
+	  s48_extract_syslog_options(sch_options),
 	  s48_extract_syslog_facility(sch_facility));
   syslog_open = 1;
   return S48_UNSPECIFIC;
@@ -334,10 +375,10 @@ sch_syslog(s48_value sch_level, s48_value sch_opt_facility,
 static s48_value
 sch_closelog(void)
 {
-
   if (!syslog_open)
     s48_raise_string_os_error("syslog isn't open");
   closelog();
   syslog_open = 0;
   return S48_UNSPECIFIC;
 }
+