File: fluid.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (89 lines) | stat: -rw-r--r-- 2,630 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.

; This is file fluid.scm.

; Fluid (dynamic) variables.

; Fluid variables are implemented using deep binding.  This allows
; each thread in a multiprocessor system to have its own fluid
; environment, and allows for fast thread switching in a multitasking
; one.

; get-dynamic-state and set-dynamic-state! access a special virtual
; machine register.  On a multiprocessor, each processor has its own
; dynamic-state register.  The run-time system stores the current
; thread in the dynamic-state register.

; Here we define a particular thread record, but a different one is
; defined by the (uniprocessor) threads package.  The current thread
; may actually be any kind of record as long as its first component
; can be used by the fluid variable implementation to maintain the
; deep-binding dynamic environment.  This is kind of gross but it is
; motivated by efficiency concerns.

(define-record-type thread :thread
  (make-thread dynamic-env)
  (dynamic-env thread-dynamic-env))

(define (current-thread) (get-dynamic-state))
(define (set-current-thread! thread) (set-dynamic-state! thread))

(define (get-dynamic-env)
  (record-ref (current-thread) 1))
(define (set-dynamic-env! env)
  (record-set! (current-thread) 1 env))

(define (initialize-dynamic-state!)
  (set-dynamic-state! (make-thread (empty-dynamic-env))))


; Dynamic environment

(define (with-dynamic-env env thunk)
  (let ((saved-env (get-dynamic-env)))
    (set-dynamic-env! env)
    (set! env #f)			;For GC and debugger
    (call-with-values
	;; thunk
	(let ((x thunk)) (set! thunk #f) x) ;For GC
      (lambda results
	(set-dynamic-env! saved-env)
	(apply values results)))))

(define (empty-dynamic-env) '())


; Fluids

(define-record-type fluid :fluid
  (make-fluid top)
  (top fluid-top-level-value set-fluid-top-level-value!))

(define (fluid f)
  (let ((probe (assq f (get-dynamic-env))))
    (if probe (cdr probe) (fluid-top-level-value f))))

(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))))

(define (let-fluid f val thunk)
  (with-dynamic-env (cons (cons f val) (get-dynamic-env)) thunk))

(define (let-fluids . args)
  (let loop ((args args)
	     (env (get-dynamic-env)))
    (if (null? (cdr args))
	(with-dynamic-env env (car args))
	(loop (cddr args)
	      (cons (cons (car args) (cadr args)) env)))))

(define (fluid-lookup env f)
  (let ((probe (assq f env)))
    (if probe (cdr probe) (fluid-top-level-value f))))


; Initialize

(initialize-dynamic-state!)