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