1#lang racket/base
2(require (for-syntax racket/base racket/struct-info)
3         racket/match
4         "deriv.rkt")
5
6(provide make
7         ok-node?
8         interrupted-node?
9         wderiv-e1
10         wderiv-e2
11         wlderiv-es1
12         wlderiv-es2
13         wbderiv-es1
14         wbderiv-es2
15         wderivlist-es2
16         for-subnodes)
17
18;; ----
19
20(define (check sym pred type x)
21  (unless (pred x)
22    (raise-type-error sym type x)))
23
24(define (ok-node? x)
25  (check 'ok-node? node? "node" x)
26  (and (node-z2 x) #t))
27(define (interrupted-node? x)
28  (check 'interrupted-node? node? "node" x)
29  (not (node-z2 x)))
30
31
32(define (wderiv-e1 x)
33  (check 'wderiv-e1 deriv? "deriv" x)
34  (node-z1 x))
35(define (wderiv-e2 x)
36  (check 'wderiv-e2 deriv? "deriv" x)
37  (node-z2 x))
38
39(define (wlderiv-es1 x)
40  (check 'wlderiv-es1 lderiv? "lderiv" x)
41  (node-z1 x))
42(define (wlderiv-es2 x)
43  (check 'wlderiv-es2 lderiv? "lderiv" x)
44  (node-z2 x))
45
46(define (wbderiv-es1 x)
47  (check 'wbderiv-es1 bderiv? "bderiv" x)
48  (node-z1 x))
49(define (wbderiv-es2 x)
50  (check 'wbderiv-es2 bderiv? "bderiv" x))
51
52;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
53(define (wderivlist-es2 xs)
54  (let ([es2 (map wderiv-e2 xs)])
55    (and (andmap syntax? es2) es2)))
56
57;; get-struct-info : identifier stx -> struct-info-list
58(define-for-syntax (get-struct-info id ctx)
59  (define (bad-struct-name x)
60    (raise-syntax-error #f "expected struct name" ctx x))
61  (unless (identifier? id)
62    (bad-struct-name id))
63  (let ([value (syntax-local-value id (lambda () #f))])
64    (unless (struct-info? value)
65      (bad-struct-name id))
66    (extract-struct-info value)))
67
68;; (make struct-name field-expr ...)
69;; Checks that correct number of fields given.
70(define-syntax (make stx)
71  (syntax-case stx ()
72    [(make S expr ...)
73     (let ()
74       (define info (get-struct-info #'S stx))
75       (define constructor (list-ref info 1))
76       (define accessors (list-ref info 3))
77       (unless (identifier? #'constructor)
78         (raise-syntax-error #f "constructor not available for struct" stx #'S))
79       (unless (andmap identifier? accessors)
80         (raise-syntax-error #f "incomplete info for struct type" stx #'S))
81       (let ([num-slots (length accessors)]
82             [num-provided (length (syntax->list #'(expr ...)))])
83         (unless (= num-provided num-slots)
84           (raise-syntax-error
85            #f
86            (format "wrong number of arguments for struct ~s (expected ~s, got ~s)"
87                    (syntax-e #'S)
88                    num-slots
89                    num-provided)
90            stx)))
91       (with-syntax ([constructor constructor])
92         (syntax-property #'(constructor expr ...)
93                          'disappeared-use
94                          #'S)))]))
95
96;; for-subnodes : X (X -> Void) -> Void
97;; where X is one of the structs listed in deriv-c.rkt; includes some non-Node structs
98(define (for-subnodes x #:recur recur1 #:recur/phase-up [recur1/phase-up recur1])
99  (define (recur* node)
100    (if (list? node) (for-each recur* node) (recur1 node)))
101  (define (recur*/phase-up nodes)
102    (if (list? nodes) (for-each recur*/phase-up nodes) (recur1/phase-up nodes)))
103  (define (recur . nodes) (recur* nodes))
104  (define (recur/phase-up . nodes) (recur*/phase-up nodes))
105  ;; Handle variants
106  (match x
107    [(ecte z1 z2 locals first second locals2)
108     (recur locals first second locals2)]
109    [(lift-deriv z1 z2 first lift-stx second)
110     (recur first second)]
111    [(lift/let-deriv z1 z2 first lift-stx second)
112     (recur first second)]
113    [(tagrule z1 z2 untagged-stx tagged-stx next)
114     (recur next)]
115    [(mrule z1 z2 rs da ?1 me1 locals me2 ?2 etx retx next)
116     (recur locals next)]
117    [(local-exn exn) (void)]
118    [(local-expansion z1 z2 for-stx? me1 inner lifted me2 opaque)
119     (if for-stx? (recur/phase-up inner) (recur inner))]
120    [(local-lift-expr ids orig renamed) (void)]
121    [(local-lift-end orig renamed wrapped) (void)]
122    [(local-lift-require req expr mexpr) (void)]
123    [(local-lift-provide prov) (void)]
124    [(local-lift-module orig renamed) (void)]
125    [(local-bind names ?1 renames bindrhs)
126     (recur bindrhs)]
127    [(local-value name ?1 resolves bound? binding) (void)]
128    [(track-syntax op new-stx old-stx) (void)]
129    [(local-remark contents) (void)]
130    [(p:variable z1 z2 rs da ?1) (void)]
131    [(p:module z1 z2 rs de1 ?1 prep rename ensure-mb body shift)
132     (recur prep ensure-mb body)]
133    [(mod:ensure-mb track1 check add-mb track2)
134     (recur check add-mb)]
135    [(mod:add-mb ?1 tag track check ?2)
136     (recur check)]
137    [(p:#%module-begin z1 z2 rs da ?1 me pass12 ?2 pass3 ?3 pass4)
138     (recur pass12 pass3 pass4)]
139    [(p:define-syntaxes z1 z2 rs da ?1 prep rhs locals)
140     (recur prep locals)
141     (recur/phase-up rhs)]
142    [(p:define-values z1 z2 rs da ?1 rhs)
143     (recur rhs)]
144    [(p:begin-for-syntax z1 z2 rs da ?1 prep body locals)
145     (recur prep locals)
146     (recur/phase-up body)]
147    [(p:#%expression z1 z2 rs da ?1 inner untag)
148     (recur inner)]
149    [(p:if z1 z2 rs da ?1 test then else)
150     (recur test then else)]
151    [(p:wcm z1 z2 rs da ?1 key mark body)
152     (recur key mark body)]
153    [(p:set! _ _ _ _ _ id-resolves ?2 rhs)
154     (recur rhs)]
155    [(p:set!-macro _ _ _ _ _ deriv)
156     (recur deriv)]
157    [(p:#%app _ _ _ _ _ derivs)
158     (recur derivs)]
159    [(p:begin _ _ _ _ _ derivs)
160     (recur derivs)]
161    [(p:begin0 _ _ _ _ _ derivs)
162     (recur derivs)]
163    [(p:lambda _ _ _ _ _ renames body)
164     (recur body)]
165    [(p:case-lambda _ _ _ _ _ renames+bodies)
166     (recur renames+bodies)]
167    [(p:let-values _ _ _ _ _ renames rhss body)
168     (recur rhss body)]
169    [(p:letrec-values _ _ _ _ _ renames rhss body)
170     (recur rhss body)]
171    [(p:letrec-syntaxes+values _ _ _ _ _ srenames prep sbindrhss vrhss body)
172     (recur prep sbindrhss vrhss body)]
173    [(p:provide _ _ _ _ _ inners ?2)
174     (recur inners)]
175    [(p:require _ _ _ _ _ locals)
176     (recur locals)]
177    [(p:submodule _ _ _ _ _ exp locals)
178     (recur exp)]
179    [(p:submodule* _ _ _ _ _ exp locals)
180     (recur exp locals)]
181    [(p:#%stratified-body _ _ _ _ _ bderiv)
182     (recur bderiv)]
183    [(? p::STOP?) (void)]
184    [(p:declare _ _ _ _ _) (void)]
185    [(lderiv _ _ ?1 derivs)
186     (recur derivs)]
187    [(bderiv _ _ _ pass1 pass2)
188     (recur pass1 pass2)]
189    [(block:letrec _ rhss body)
190     (recur rhss body)]
191    [(b:error ?1) (void)]
192    [(b:expr head)
193     (recur head)]
194    [(b:splice head _ ?1 tail ?2)
195     (recur head)]
196    [(b:defvals head _ ?1 rename ?2)
197     (recur head)]
198    [(b:defstx head _ ?1 rename ?2 prep bindrhs)
199     (recur head prep bindrhs)]
200    [(bind-syntaxes rhs locals)
201     (recur/phase-up rhs)
202     (recur locals)]
203    [(clc ?1 renames body)
204     (recur body)]
205    [(mod:pass-1-and-2 pass1 pass2)
206     (recur pass1 pass2)]
207    [(modp1:prim head prim)
208     (recur head prim)]
209    [(modp1:lift head _ _ _ mods)
210     (recur head mods)]
211    [(modp1:splice _ _ _) (void)]
212    [(modp2:skip) (void)]
213    [(modp2:cons deriv locals)
214     (recur deriv locals)]
215    [(modp2:lift deriv locals _ _ _ mods defs)
216     (recur deriv locals mods defs)]
217    [(mod:lift-end tail) (void)]
218    [(modp34:bfs derivs)
219     (recur derivs)]
220    [(bfs:lift lderiv lifts)
221     (recur lderiv)]
222    [#f (void)]))
223