1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
4
5; Bindings: used to store bindings in packages.
6
7; Representation is type place operator-or-transform-or-#f.
8; PLACE is a unique (to EQ?) value, usually a location.
9
10(define-record-type binding :binding
11  (really-make-binding type place static)
12  binding?
13  (type binding-type set-binding-type!)
14  (place binding-place set-binding-place!)
15  (static binding-static set-binding-static!))
16
17(define-record-discloser :binding
18  (lambda (b)
19    (list 'binding
20	  (binding-type b)
21	  (binding-place b)
22	  (binding-static b))))
23
24(define (make-binding type place static)
25  (really-make-binding type place static))
26
27; Used when updating a package binding.
28
29(define (clobber-binding! binding type place static)
30  (set-binding-type! binding type)
31  (if place
32      (set-binding-place! binding place))
33  (set-binding-static! binding static))
34
35; Return a binding that's similar to the given one, but has its type
36; replaced with the given type.
37
38(define (impose-type type binding integrate?)
39  (if (or (eq? type syntax-type)
40	  (not (binding? binding)))
41      binding
42      (make-binding (if (eq? type undeclared-type)
43			(let ((type (binding-type binding)))
44			  (if (variable-type? type)
45			      (variable-value-type type)
46			      type))
47			type)
48		    (binding-place binding)
49		    (if integrate?
50			(binding-static binding)
51			#f))))
52
53; Return a binding that's similar to the given one, but has any
54; procedure integration or other unnecesary static information
55; removed.  But don't remove static information for macros (or
56; structures, interfaces, etc.)
57
58(define (forget-integration binding)
59  (if (and (binding-static binding)
60	   (subtype? (binding-type binding) any-values-type))
61      (make-binding (binding-type binding)
62		    (binding-place binding)
63		    #f)
64      binding))
65
66; Do X and Y denote the same thing?
67
68(define (same-denotation? x y)
69  (or (eq? x y)	    ; was EQUAL? because of names, now just for nodes
70      (and (binding? x)
71	   (binding? y)
72	   (eq? (binding-place x)
73		(binding-place y)))))
74
75; Special kludge for shadowing and package mutation.
76; Ignore this on first reading.  See env/shadow.scm.
77
78(define (maybe-fix-place! binding)
79  (let ((place (binding-place binding)))
80    (if (and (location? place)
81             (vector? (location-id place)))
82        (set-binding-place! binding (follow-forwarding-pointers place))))
83  binding)
84
85(define (follow-forwarding-pointers place)
86  (let ((id (location-id place)))
87    (if (vector? id)
88        (follow-forwarding-pointers (vector-ref id 0))
89        place)))
90
91