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
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; --------------------
; 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))
(warn "operator type inconsistency" name type previous-type)))
((subtype? type previous-type) ;Improvement
(set-operator-type! probe type))
((not (subtype? previous-type type))
(warn "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)
(warn "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
; (ignored 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)))
(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)))
|
