diff --git a/build/initial.image b/build/initial.image new file mode 100644 index 0000000..aba9e6d Binary files /dev/null and b/build/initial.image differ diff --git a/scheme/big/enum-set.scm b/scheme/big/enum-set.scm new file mode 100644 index 0000000..1972b9b --- /dev/null +++ b/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-member? ) -> +; (enum-set=? ) -> +; (enum-set-union ) -> +; (enum-set-intersection ) -> +; (enum-set-negation ) -> +; +; 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)))) + diff --git a/scheme/big/thread-fluids.scm b/scheme/big/thread-fluid.scm similarity index 50% rename from scheme/big/thread-fluids.scm rename to scheme/big/thread-fluid.scm index 79e253d..1f7c5f2 100644 --- a/scheme/big/thread-fluids.scm +++ b/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)))) - (if (eq? val *no-fluid-value*) - (thread-fluid-top-level-value thread-fluid) - val))) + (thread-cell-ref (thread-fluid-cell thread-fluid))) (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 -;; (really-make-thread-fluid fluid) -;; thread-fluid? -;; (fluid thread-fluid-fluid)) -;; -;; (define (make-thread-fluid top) -;; (really-make-thread-fluid (make-fluid (make-thread-cell top)))) -;; -;; (define (thread-fluid t-fluid) -;; (thread-cell-ref (fluid (thread-fluid-fluid t-fluid)))) -;; -;; (define (set-thread-fluid! thread-fluid val) -;; (thread-cell-set! (fluid (thread-fluid-fluid thread-fluid)) val)) -;; -;; (define (let-thread-fluid t-fluid val thunk) -;; (let-fluid (thread-fluid-fluid t-fluid) -;; (make-thread-cell val) -;; 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)))))) +(define (make-preserved-thread-fluid top) + (let* ((t-fluid (make-thread-fluid top))) + (add-to-population! t-fluid *preserved-fluids*) + t-fluid)) + +(define (preserve-thread-fluids thunk) + (let ((args (list thunk))) + (walk-population + (lambda (t-fluid) + (set! args + (cons t-fluid + (cons (thread-fluid t-fluid) + args)))) + *preserved-fluids*) + (lambda () + (apply let-thread-fluids args)))) + +(define (fork-thread thunk) + (spawn (preserve-thread-fluids thunk))) diff --git a/scheme/env/command-level.scm b/scheme/env/command-level.scm index 7de9875..4841462 100644 --- a/scheme/env/command-level.scm +++ b/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) - (let ((thread (make-thread thunk - (command-level-dynamic-env level) - cell-values - id))) +(define (spawn-on-command-level level thunk id) + (let ((thread (make-thread thunk (command-level-dynamic-env level) 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)) diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm index e81e800..e475f9c 100644 --- a/scheme/interfaces.scm +++ b/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 - empty-dynamic-env)) ; thread-cell.scm + set-dynamic-point!)) ; wind.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) diff --git a/scheme/more-interfaces.scm b/scheme/more-interfaces.scm index 9112f82..6434f88 100644 --- a/scheme/more-interfaces.scm +++ b/scheme/more-interfaces.scm @@ -327,12 +327,30 @@ array->vector ; array)) ; . +(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 diff --git a/scheme/more-packages.scm b/scheme/more-packages.scm index 8a28685..43973e3 100644 --- a/scheme/more-packages.scm +++ b/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) - (files (big thread-fluids))) + (open scheme define-record-types weak + 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 diff --git a/scheme/rts-packages.scm b/scheme/rts-packages.scm index 9c72554..c0ebcc0 100644 --- a/scheme/rts-packages.scm +++ b/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)) - (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)) + (files (rts thread-env)) (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 - enumerated enum-case + (open scheme-level-1 threads threads-internal 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! diff --git a/scheme/rts/root-scheduler.scm b/scheme/rts/root-scheduler.scm index 1da0383..ba40533 100644 --- a/scheme/rts/root-scheduler.scm +++ b/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) diff --git a/scheme/rts/scheduler.scm b/scheme/rts/scheduler.scm index 0a89307..0eabbb6 100644 --- a/scheme/rts/scheduler.scm +++ b/scheme/rts/scheduler.scm @@ -100,8 +100,7 @@ (enqueue-thread! runnable (make-thread (car event-data) dynamic-env - (cadr event-data) - (caddr event-data)))) + (cadr event-data)))) ((no-event) (values)) (else diff --git a/scheme/rts/fluid.scm b/scheme/rts/thread-env.scm similarity index 68% rename from scheme/rts/fluid.scm rename to scheme/rts/thread-env.scm index 076047c..4937b62 100644 --- a/scheme/rts/fluid.scm +++ b/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) - (dynamic-env thread-dynamic-env) - (dynamic-point thread-dynamic-point)) - -;; (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)) + (make-thread dynamic-env dynamic-point cell-env) + (dynamic-env thread-dynamic-env) + (dynamic-point thread-dynamic-point) + (cell-env thread-cell-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!) + diff --git a/scheme/rts/thread.scm b/scheme/rts/thread.scm index 338aa0a..2f90099 100644 --- a/scheme/rts/thread.scm +++ b/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 - cell-values own-cell-values? + (really-make-thread dynamic-env dynamic-point cell-env 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) - - ;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?!) + (cell-env thread-cell-env) ;Must be fourth! (See thread-env.scm) (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 - #f ; own-cell-values? + (empty-thread-cell-env) (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 - (thread-cell-values (current-thread)) - id)) + (apply spawn-on-scheduler (thread-scheduler (current-thread)) thunk id)) (define (spawn-on-root thunk . id) (if (root-scheduler) - (begin - (set-thread-own-values?! (current-thread) #f) - (apply spawn-on-scheduler - (root-scheduler) - thunk - (thread-cell-values (current-thread)) - id)) + (apply spawn-on-scheduler + (root-scheduler) + thunk + 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) diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index 9eaa9df..7e144d4 100644 --- a/scsh/scsh-interfaces.scm +++ b/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)) + + diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index a8e4be7..9268afe 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -464,10 +464,12 @@ threads) ; sleep (files dot-locking)) -(define-structure syslog syslog-interface - (open scheme define-record-types finite-types +(define-structures ((syslog syslog-interface) + (syslog-channels syslog-channels-interface)) + (open scheme + define-record-types finite-types enum-sets locks thread-fluids external-calls - scsh-utilities bitwise) (files syslog)) + diff --git a/scsh/syslog.scm b/scsh/syslog.scm index 990ee94..08e1c4e 100644 --- a/scsh/syslog.scm +++ b/scsh/syslog.scm @@ -2,64 +2,31 @@ ;; Options for openlog -(define-finite-type syslog-option :syslog-option - (mask) +(define-enumerated-type syslog-option :syslog-option syslog-option? the-syslog-options syslog-option-name syslog-option-index - (mask syslog-option-mask) - ;; These values are known to the C code. - ((console #o01) - (delay #o02) - (no-delay #o04) - (log-pid #o10))) + ;; The order of these is known to the C code. + (console + delay + no-delay + log-pid)) -(define-record-type syslog-options :syslog-options - (really-make-syslog-options value) +(define-exported-binding "syslog-options" the-syslog-options) + +(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 (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 default-syslog-options (syslog-options)) (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 - (mask) +(define-enumerated-type syslog-level :syslog-level syslog-level? syslog-levels syslog-level-name syslog-level-index - (mask syslog-level-mask) - ;; Options for syslog - ;; The order and the values of these is known to the C code. - ((emergency #o001) - (alert #o002) - (critical #o004) - (error #o010) - (warning #o020) - (notice #o040) - (info #o100) - (debug #o200))) - -(define syslog-level=? eq?) + ;; The order of these is known to the C code. + (emergency + alert + critical + error + warning + notice + info + debug)) (define-exported-binding "syslog-level-type" :syslog-level) (define-exported-binding "syslog-levels" syslog-levels) -(define-record-type syslog-mask :syslog-mask - (make-syslog-mask value) +(define-enum-set-type syslog-mask :syslog-mask syslog-mask? - (value syslog-mask-value)) + make-syslog-mask -(define (syslog-mask=? mask-1 mask-2) - (= (syslog-mask-value mask-1) - (syslog-mask-value mask-2))) + syslog-level + syslog-level? + syslog-levels + syslog-level-index) -(define-exported-binding "syslog-mask-type" :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-exported-binding "syslog-mask?" syslog-mask?) +(define-exported-binding ":syslog-mask" :syslog-mask) (define (syslog-mask-upto level) (let loop ((index (syslog-level-index level)) (levels '())) (if (< index 0) - (levels->syslog-mask levels) - (loop (- index 1) (cons index levels))))) + (make-syslog-mask 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) - (syslog-channel-options channel-2)) + (enum-set=? (syslog-channel-options channel-1) + (syslog-channel-options channel-2)) ;; facility can be specified with each syslog-write - (syslog-mask=? (syslog-channel-mask channel-1) - (syslog-channel-mask channel-2)))) + (enum-set=? (syslog-channel-mask channel-1) + (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) - (if (or (not current-syslog-channel) - (not (syslog-channel-equivalent? channel - current-syslog-channel))) - (begin - (if current-syslog-channel - (closelog)) - (openlog (syslog-channel-ident channel) - (syslog-channel-options channel) - (syslog-channel-facility channel)) - (if (not (syslog-mask=? (syslog-channel-mask channel) + (dynamic-wind + (lambda () + (obtain-lock current-syslog-channel-lock)) + (lambda () + (if (or (not current-syslog-channel) + (not (syslog-channel-equivalent? channel + current-syslog-channel))) + (begin + (if current-syslog-channel + (closelog)) + (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))) - (set! current-syslog-channel channel))) - (thunk) - (release-lock current-syslog-channel-lock)) + (setlogmask! (syslog-channel-mask channel))) + (set! current-syslog-channel channel))) + (thunk)) + (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) - (cond - ((null? list) default) - ((zero? n) (car list)) - (else - (list-ref-carefully (cdr list) (- n 1) default)))) - -(define (change-syslog-channel channel . rest) - (let ((ident (list-ref-carefully rest 0 #f)) - (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 (change-syslog-channel channel ident options facility mask) + (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-syslog-channel "scheme48" + (make-preserved-thread-fluid + (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)) - (null? (cdr rest)) - (syslog-channel? (car rest))) - (car rest) - ;; this might be a little excessive allocation - (apply change-syslog-channel - (thread-fluid dynamic-syslog-channel) - rest)))) + (cond + ((null? rest) + (thread-fluid dynamic-syslog-channel)) + ((and (null? (cdr rest)) + (syslog-channel? (car rest))) + (car rest)) + (else + ;; 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. diff --git a/scsh/syslog1.c b/scsh/syslog1.c index f7330f5..24b2402 100644 --- a/scsh/syslog1.c +++ b/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); - syslog_options_type_binding = - s48_get_imported_binding("syslog-options-type"); + S48_GC_PROTECT_GLOBAL(is_syslog_options_binding); + is_syslog_options_binding = + 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 -s48_enter_syslog_options(int syslog_options) +static int +is_syslog_options(s48_value sch_thing) { - s48_value sch_syslog_options; - int my_syslog_options; + S48_SHARED_BINDING_CHECK(is_syslog_options_binding); - my_syslog_options = - (LOG_CONS & syslog_options ? 00001 : 0) | - (LOG_ODELAY & syslog_options ? 00002 : 0) | - (LOG_NDELAY & syslog_options ? 00004 : 0) | - (LOG_PID & syslog_options ? 00010 : 0); + return !S48_FALSE_P + (s48_call_scheme(S48_SHARED_BINDING_REF(is_syslog_options_binding), + 1, + sch_thing)); +} - sch_syslog_options = s48_make_record(syslog_options_type_binding); - S48_UNSAFE_RECORD_SET(sch_syslog_options, 0, s48_enter_fixnum(my_syslog_options)); - - return sch_syslog_options; +static void +check_syslog_options(s48_value sch_thing) +{ + 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 = - s48_extract_fixnum(S48_UNSAFE_RECORD_REF(sch_syslog_options, 0)); + syslog_options = enum_set2integer(sch_syslog_options); 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); - - syslog_mask = - s48_extract_fixnum(S48_UNSAFE_RECORD_REF(sch_syslog_mask, 0)); + check_syslog_mask(sch_syslog_mask); + 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; } +