103
|
1 |
;; node.scm -- taken from newmoon |
|
2 |
;; |
|
3 |
;; Defines AST nodes, a macro for binding variables from a node, and a |
|
4 |
;; language-checker for dynamic type checking. |
|
5 |
|
|
6 |
(define-record-type node |
|
7 |
(make-node* kind fields) |
|
8 |
node? |
|
9 |
(kind node-kind) |
|
10 |
(fields node-fields set-node-fields!)) |
|
11 |
|
|
12 |
(define (make-node kind . fields0) |
|
13 |
(make-node* kind |
|
14 |
(let loop ((fields fields0)) |
|
15 |
(cond |
|
16 |
((null? fields) '()) |
|
17 |
((null? (cdr fields)) (error "Odd number of arguments to make-node" |
|
18 |
(list kind fields0))) |
|
19 |
(else (cons (list (car fields) (cadr fields)) (loop (cddr fields)))))))) |
|
20 |
|
|
21 |
(define (node-kind? node k) |
|
22 |
(eq? (node-kind node) k)) |
|
23 |
|
|
24 |
(define (node-get node kind name) |
|
25 |
(if (eq? kind (node-kind node)) |
|
26 |
(let ((cell (assq name (node-fields node)))) |
|
27 |
(if cell |
|
28 |
(cadr cell) |
|
29 |
(error "Unknown field name in node-get:" (list (node-kind node) name node)))) |
|
30 |
(error "Node kind did not match in node-get:" (list (node-kind node) kind node)))) |
|
31 |
|
|
32 |
(define (node-getter kind name) |
|
33 |
(lambda (node) (node-get node kind name))) |
|
34 |
|
|
35 |
(define (node-get/default! node name deft) |
|
36 |
(let ((cell (assq name (node-fields node)))) |
|
37 |
(if cell |
|
38 |
(cadr cell) |
|
39 |
(begin |
|
40 |
(set-node-fields! node (cons (list name deft) (node-fields node))) |
|
41 |
deft)))) |
|
42 |
|
|
43 |
(define (node-set! node kind name value) |
|
44 |
(if (eq? kind (node-kind node)) |
|
45 |
(let ((cell (assq name (node-fields node)))) |
|
46 |
(if cell |
|
47 |
(set-car! (cdr cell) value) |
|
48 |
(set-node-fields! node (cons (list name value) (node-fields node))))) |
|
49 |
(error "Node kind did not match in node-set!:" (list (node-kind node) kind node)))) |
|
50 |
|
|
51 |
(define (node-push! node kind name value) |
|
52 |
(node-set! node kind name (cons value (node-get node kind name)))) |
|
53 |
|
|
54 |
(define (node->list node) |
|
55 |
(cond |
|
56 |
((node? node) (cons (node-kind node) (node->list (node-fields node)))) |
|
57 |
((pair? node) (cons (node->list (car node)) (node->list (cdr node)))) |
|
58 |
(else node))) |
|
59 |
|
|
60 |
(define (lookup-language-token token language) |
|
61 |
(cond |
|
62 |
((assq token language) => cadr) |
|
63 |
(else (error "Missing language token" (list token language))))) |
|
64 |
|
|
65 |
(define (type-error node type) |
|
66 |
(error "Language error" (list node type))) |
|
67 |
|
|
68 |
(define (check-language node start-token language error-handler) |
|
69 |
(let validate ((node node) |
|
70 |
(type start-token)) |
|
71 |
(cond |
|
72 |
((procedure? type) (type node)) |
|
73 |
((symbol? type) (or (validate node (lookup-language-token type language)) |
|
74 |
(and error-handler (error-handler node type)))) |
|
75 |
((pair? type) |
|
76 |
(case (car type) |
|
77 |
((%or) (let loop ((types (cdr type))) |
|
78 |
(if (null? types) |
|
79 |
#f |
|
80 |
(or (validate node (car types)) |
|
81 |
(loop (cdr types)))))) |
|
82 |
((%list-of) (and (list? node) |
|
83 |
(every (lambda (n) (validate n (cadr type))) node))) |
|
84 |
(else |
|
85 |
(and (node? node) |
|
86 |
(eq? (car type) (node-kind node)) |
|
87 |
(let loop ((type-fields (cdr type))) |
|
88 |
(or (null? type-fields) |
|
89 |
(let* ((expected-field-name (caar type-fields)) |
|
90 |
(expected-field-type (cadar type-fields)) |
|
91 |
(field-cell (assq expected-field-name (node-fields node)))) |
|
92 |
(and field-cell |
|
93 |
(validate (cadr field-cell) expected-field-type) |
|
94 |
(loop (cdr type-fields)))))))))) |
|
95 |
((eq? type #t) #t) |
|
96 |
((eq? type #f) #f) |
|
97 |
(else (error "Illegal language" (list type language)))))) |
|
98 |
|
|
99 |
(define (node-collect-subnodes expr attrs) |
|
100 |
(let loop ((attrs attrs)) |
|
101 |
(cond |
|
102 |
((null? attrs) '()) |
|
103 |
((pair? attrs) (cons (node-get expr (node-kind expr) (car attrs)) |
|
104 |
(loop (cdr attrs)))) |
|
105 |
(else |
|
106 |
(node-get expr (node-kind expr) attrs))))) |
|
107 |
|
|
108 |
(define (node-tree-foreach child-attrs-of fn node) |
|
109 |
(fn node) |
|
110 |
(for-each (lambda (child) (node-tree-foreach fn child)) |
|
111 |
(node-collect-subnodes node (child-attrs-of node)))) |
|
112 |
|
|
113 |
(define (node-children-map! child-attrs-of fn node) |
|
114 |
(let loop ((attrs (child-attrs-of node))) |
|
115 |
(cond |
|
116 |
((null? attrs) node) |
|
117 |
((pair? attrs) |
|
118 |
(let* ((name (car attrs)) |
|
119 |
(cell (assq name (node-fields node))) |
|
120 |
(oldval (cadr cell)) |
|
121 |
(newval (fn oldval))) |
|
122 |
(if (not (eq? oldval newval)) |
|
123 |
(set-car! (cdr cell) newval)) |
|
124 |
(loop (cdr attrs)))) |
|
125 |
(else |
|
126 |
(let ((cell (assq attrs (node-fields node)))) |
|
127 |
(set-car! (cdr cell) (map fn (cadr cell)))))))) |
|
128 |
|
|
129 |
(define-syntax node-match |
|
130 |
(let () |
|
131 |
(lambda (x) |
|
132 |
(syntax-case x (else) |
|
133 |
((_ expr clause ...) |
|
134 |
(not (boolean? (syntax-object->datum (syntax expr)))) |
|
135 |
(syntax (let* ((v expr) |
|
136 |
(k (node-kind v))) |
|
137 |
(node-match #f v k clause ...)))) |
|
138 |
|
|
139 |
((_ #f v k) |
|
140 |
(syntax (error "node-match: no match for node-kind" k))) |
|
141 |
|
|
142 |
((_ #f v k (else expr ...)) |
|
143 |
(syntax (begin expr ...))) |
|
144 |
|
|
145 |
((_ #f v k ((kind var ...) body ...) clause ...) |
|
146 |
(syntax (if (eq? k 'kind) |
|
147 |
(node-match #t v kind (var ...) () body ...) |
|
148 |
(node-match #f v k clause ...)))) |
|
149 |
|
|
150 |
((_ #t v kind () (binding ...) body ...) |
|
151 |
(syntax (let (binding ...) |
|
152 |
body ...))) |
|
153 |
|
|
154 |
((_ #t v kind ((var name) vars ...) (binding ...) body ...) |
|
155 |
(syntax (node-match #t v kind (vars ...) ((var (node-get v 'kind 'name)) binding ...) |
|
156 |
body ...))) |
|
157 |
|
|
158 |
((_ #t v kind (var vars ...) (binding ...) body ...) |
|
159 |
(syntax (node-match #t v kind (vars ...) ((var (node-get v 'kind 'var)) binding ...) |
|
160 |
body ...))))))) |