smalltalk-tng
view etng-r1/node.scm @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (7 months ago) |
| parents | |
| children |
line source
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.
6 (define-record-type node
7 (make-node* kind fields)
8 node?
9 (kind node-kind)
10 (fields node-fields set-node-fields!))
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))))))))
21 (define (node-kind? node k)
22 (eq? (node-kind node) k))
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))))
32 (define (node-getter kind name)
33 (lambda (node) (node-get node kind name)))
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))))
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))))
51 (define (node-push! node kind name value)
52 (node-set! node kind name (cons value (node-get node kind name))))
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)))
60 (define (lookup-language-token token language)
61 (cond
62 ((assq token language) => cadr)
63 (else (error "Missing language token" (list token language)))))
65 (define (type-error node type)
66 (error "Language error" (list node type)))
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))))))
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)))))
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))))
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))))))))
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 ...))))
139 ((_ #f v k)
140 (syntax (error "node-match: no match for node-kind" k)))
142 ((_ #f v k (else expr ...))
143 (syntax (begin expr ...)))
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 ...))))
150 ((_ #t v kind () (binding ...) body ...)
151 (syntax (let (binding ...)
152 body ...)))
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 ...)))
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 ...)))))))