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.
This commit is contained in:
sperber
parent
b5180b35af
commit
136e313af7
Binary file not shown.
|
|
@ -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))))
|
||||
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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!
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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!)
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
241
scsh/syslog.scm
241
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.
|
||||
|
|
|
|||
189
scsh/syslog1.c
189
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;
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue