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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Shared binding between Scheme and external C code
;----------------
; Two tables of shared bindings: those we import from the outside and those
; that we provide to the outside.
(define *imported-bindings* false)
(define *exported-bindings* false)
; When resuming a statically-linked image these tables are FALSE.
(define (install-shared-bindings!+gc imported-bindings exported-bindings)
(if (vm-eq? imported-bindings false)
(begin
(set! *imported-bindings* (make-hash-table+gc))
(set! *exported-bindings* (make-hash-table+gc)))
(begin
(set! *imported-bindings* imported-bindings)
(set! *exported-bindings* exported-bindings))))
(define shared-binding-table-size
(* hash-table-size 2))
(let ((tracer (table-tracer shared-binding-next
set-shared-binding-next!
s48-trace-value)))
(add-gc-root!
(lambda ()
(set! *imported-bindings* (tracer *imported-bindings*))
(set! *exported-bindings* (tracer *exported-bindings*)))))
; These next two procedure are used to write the bindings tables out in images.
(define (s48-exported-bindings)
*exported-bindings*)
(define (s48-imported-bindings)
*imported-bindings*)
; Imported bindings.
(define lookup-imported-binding
(let* ((maker (lambda (string next key)
(make-shared-binding string true unspecific-value next key)))
(lookup (table-searcher shared-binding-name
shared-binding-next
maker)))
(lambda (name key)
(lookup *imported-bindings* name key))))
; Exporting bindings.
(define lookup-exported-binding
(let* ((maker (lambda (string next key)
(make-shared-binding string false unspecific-value next key)))
(lookup (table-searcher shared-binding-name
shared-binding-next
maker)))
(lambda (name key)
(lookup *exported-bindings* name key))))
; Print warnings about all imported bindings which the external code
; has not yet defined.
(define (shared-binding-undefined? binding)
(undefined? (shared-binding-ref binding)))
(define for-each-imported-binding
(let ((walker (table-while-walker shared-binding-next)))
(lambda (proc)
(walker proc *imported-bindings*))))
(define undefine-shared-binding!
(table-remover shared-binding-name
shared-binding-next
set-shared-binding-next!))
(define (get-imported-binding name)
(save-temp0! (enter-string+gc name))
(let* ((key (ensure-space shared-binding-size))
(name (recover-temp0!)))
(lookup-imported-binding name key)))
;----------------
; The following two functions are exported to C, hence the reversal of the
; export/import terminology.
(define (s48-define-exported-binding name value)
(save-temp0! value)
(let ((name (enter-string+gc name)))
(save-temp1! name)
(let ((key (ensure-space shared-binding-size)))
(let ((name (recover-temp1!))
(value (recover-temp0!))
(binding (lookup-imported-binding name key)))
(shared-binding-set! binding value)
binding))))
(define (s48-get-imported-binding name)
(save-temp0! (enter-string+gc name))
(let* ((key (ensure-space shared-binding-size))
(name (recover-temp0!)))
(lookup-exported-binding name key)))
|
