Update of /cvsroot/scsh/scsh-0.6/scheme/big
In directory usw-pr-cvs1:/tmp/cvs-serv3825/scheme/big
Added Files:
enum-set.scm thread-fluid.scm
Removed Files:
thread-fluids.scm
Log Message:
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.
--- NEW FILE ---
; 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))))
--- NEW FILE ---
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
(define-record-type thread-fluid :thread-fluid
(really-make-thread-fluid cell)
thread-fluid?
(cell thread-fluid-cell set-thread-fluid-cell!))
(define *no-fluid-value* (list 'no-fluid-value))
(define (thread-fluid thread-fluid)
(thread-cell-ref (thread-fluid-cell thread-fluid)))
(define (set-thread-fluid! thread-fluid val)
(thread-cell-set! (thread-fluid-cell thread-fluid) val))
(define (let-thread-fluid t-fluid val thunk)
(let ((old-val (thread-fluid t-fluid)))
(dynamic-wind
(lambda () (set-thread-fluid! t-fluid val))
thunk
(lambda () (set-thread-fluid! t-fluid old-val)))))
(define (let-thread-fluids . args)
(call-with-values
(lambda ()
(let loop ((args args) (rev-old-vals '()))
(if (null? (cdr args))
(values (car args) (reverse rev-old-vals))
(loop (cddr args)
(cons (thread-fluid (car args))
rev-old-vals)))))
(lambda (thunk old-vals)
(dynamic-wind
(lambda ()
(let loop ((args args))
(if (not (null? (cdr args)))
(begin
(set-thread-fluid! (car args) (cadr args))
(loop (cddr args))))))
thunk
(lambda ()
(let loop ((args args) (old-vals old-vals))
(if (not (null? (cdr args)))
(begin
(set-thread-fluid! (car args) (car old-vals))
(loop (cddr args) (cdr old-vals))))))))))
(define (make-thread-fluid top)
(really-make-thread-fluid (make-thread-cell top)))
(define *preserved-fluids* (make-population))
(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)))
--- thread-fluids.scm DELETED ---
|