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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; --------------------
; Operators (= special operators and primitives)
(define-record-type operator :operator
(make-operator type nargs uid name)
operator?
(type operator-type set-operator-type!)
(nargs operator-nargs)
(uid operator-uid)
(name operator-name))
(define-record-discloser :operator
(lambda (s)
(list 'operator
(operator-name s)
(if (symbol? (operator-type s))
(operator-type s)
(type->sexp (operator-type s) #t)))))
(define usual-operator-type
(procedure-type any-arguments-type value-type #f))
(define (get-operator name . type-option)
(let ((type (if (null? type-option) #f (car type-option)))
(probe (table-ref operators-table name)))
(if (operator? probe)
(let ((previous-type (operator-type probe)))
(cond ((not type))
((not previous-type)
(set-operator-type! probe type))
((symbol? type) ; 'leaf or 'internal
(if (not (eq? type previous-type))
(warning 'get-operator
"operator type inconsistency" name type previous-type)))
((subtype? type previous-type) ;Improvement
(set-operator-type! probe type))
((not (subtype? previous-type type))
(warning 'get-operator
"operator type inconsistency"
name
(type->sexp previous-type 'foo)
(type->sexp type 'foo))))
probe)
(let* ((uid *operator-uid*)
(op (make-operator type
(if (and type
(not (symbol? type))
(fixed-arity-procedure-type? type))
(procedure-type-arity type)
#f)
uid
name)))
(if (>= uid number-of-operators)
(warning 'get-operator
"too many operators" (operator-name op) (operator-type op)))
(set! *operator-uid* (+ *operator-uid* 1))
(table-set! operators-table (operator-name op) op)
(vector-set! the-operators uid op)
op))))
(define *operator-uid* 0)
(define operators-table (make-table))
(define number-of-operators 400) ;Fixed-size limits bad, but speed good
(define the-operators (make-vector number-of-operators #f))
; --------------------
; Operator tables (for fast dispatch)
(define (make-operator-table default)
(make-vector number-of-operators default))
(define operator-table-ref vector-ref)
(define (operator-lookup table op)
(operator-table-ref table (operator-uid op)))
(define (operator-define! table name type proc)
(vector-set! table
(operator-uid (get-operator name type))
proc))
; --------------------
; Nodes
; A node is an annotated expression (or definition or other form).
; The FORM component of a node is an S-expression of the same form as
; the S-expression representation of the expression. E.g. for
; literals, the form is the literal value; for variables the form is
; the variable name; for IF expressions the form is a 4-element list
; (<if> test con alt). Nodes also have a tag identifying what kind
; of node it is (literal, variable, if, etc.) and a property list.
(define-record-type node :node
(really-make-node uid form plist)
node?
(uid node-operator-id)
(form node-form)
(plist node-plist set-node-plist!))
(define-record-discloser :node
(lambda (n) (list (operator-name (node-operator n)) (node-form n))))
(define (make-node operator form)
(really-make-node (operator-uid operator) form '()))
(define (node-ref node key)
(let ((probe (assq key (node-plist node))))
(if probe (cdr probe) #f)))
; removes property if value is #f
(define (node-set! node key value) ;gross
(if value
(let ((probe (assq key (node-plist node))))
(if probe
(set-cdr! probe value)
(set-node-plist! node (cons (cons key value) (node-plist node)))))
(let loop ((l (node-plist node)) (prev #f))
(cond ((null? l) 'lose)
((eq? key (caar l))
(if prev
(set-cdr! prev (cdr l))
(set-node-plist! node (cdr l))))
(else (loop (cdr l) l))))))
(define (node-operator node)
(vector-ref the-operators (node-operator-id node)))
(define (node-predicate name . type-option)
(let ((id (operator-uid (apply get-operator name type-option))))
(lambda (node)
(= (node-operator-id node) id))))
(define (make-similar-node node form)
(if (equal? form (node-form node))
node
(make-node (node-operator node) form)))
; Top-level nodes are often delayed.
(define (force-node node)
(if (node? node)
node
(force node)))
; Node predicates and operators.
(define lambda-node? (node-predicate 'lambda syntax-type))
(define flat-lambda-node? (node-predicate 'flat-lambda syntax-type))
(define call-node? (node-predicate 'call))
(define name-node? (node-predicate 'name 'leaf))
(define literal-node? (node-predicate 'literal 'leaf))
(define quote-node? (node-predicate 'quote syntax-type))
(define define-node? (node-predicate 'define))
(define loophole-node? (node-predicate 'loophole))
(define operator/flat-lambda (get-operator 'flat-lambda))
(define operator/lambda (get-operator 'lambda syntax-type))
(define operator/set! (get-operator 'set! syntax-type))
(define operator/call (get-operator 'call 'internal))
(define operator/begin (get-operator 'begin syntax-type))
(define operator/name (get-operator 'name 'leaf))
(define operator/letrec (get-operator 'letrec))
(define operator/letrec* (get-operator 'letrec*))
(define operator/pure-letrec (get-operator 'pure-letrec))
(define operator/literal (get-operator 'literal))
(define operator/quote (get-operator 'quote syntax-type))
(define operator/unassigned (get-operator 'unassigned))
(define operator/unspecific (get-operator 'unspecific (proc () unspecific-type)))
(define operator/define (get-operator 'define syntax-type))
(define operator/define-syntax (get-operator 'define-syntax syntax-type))
(define operator/primitive-procedure
(get-operator 'primitive-procedure syntax-type))
(define operator/structure-ref (get-operator 'structure-ref syntax-type))
|
