1#lang racket/base 2(require (for-syntax racket/base 3 syntax/kerncase 4 syntax/struct 5 racket/struct-info) 6 racket/undefined) 7 8(provide (protect-out (for-syntax shared-body))) 9 10(define-for-syntax (shared-body stx cons-id code-insp make-check-cdr) 11 (syntax-case stx () 12 [(_ ([name expr] ...) body1 body ...) 13 (let ([names (syntax->list (syntax (name ...)))] 14 [exprs (syntax->list (syntax (expr ...)))]) 15 (for-each (lambda (name) 16 (unless (identifier? name) 17 (raise-syntax-error 18 'shared 19 "not an identifier" 20 stx 21 name))) 22 names) 23 (let ([dup (check-duplicate-identifier names)]) 24 (when dup 25 (raise-syntax-error 26 'shared 27 "duplicate identifier" 28 stx 29 dup))) 30 (let ([exprs (map (lambda (expr) 31 (let ([e (local-expand 32 expr 33 'expression 34 (append 35 (kernel-form-identifier-list) 36 names))]) 37 ;; Remove #%app if present... 38 (syntax-case (syntax-disarm e code-insp) (#%plain-app) 39 [(#%plain-app a ...) 40 (syntax/loc e (a ...))] 41 [_else e]))) 42 exprs)] 43 [temp-ids (generate-temporaries names)] 44 [placeholder-ids (generate-temporaries names)] 45 [ph-used?s (map (lambda (x) (box #f)) names)] 46 [struct-decl-for (lambda (id) 47 (and (identifier? id) 48 (let ([get-struct 49 (lambda (id) 50 (let ([v (syntax-local-value id (lambda () #f))]) 51 (and v 52 (struct-declaration-info? v) 53 (let ([decl (extract-struct-info v)]) 54 (and (cadr decl) 55 (andmap values (list-ref decl 4)) 56 (append decl 57 (list 58 (if (struct-auto-info? v) 59 (struct-auto-info-lists v) 60 (list null null)))))))))]) 61 (or (get-struct id) 62 (let ([s (syntax-property id 'constructor-for)]) 63 (and s 64 (identifier? s) 65 (get-struct s))) 66 (let* ([s (symbol->string (syntax-e id))] 67 [m (regexp-match-positions "make-" s)]) 68 (and m 69 (let ([name (datum->syntax 70 id 71 (string->symbol (string-append (substring s 0 (caar m)) 72 (substring s (cdar m) (string-length s)))) 73 id)]) 74 (get-struct name))))))))] 75 [append-ids null] 76 [same-special-id? (lambda (a b) 77 ;; Almost module-or-top-identifier=?, 78 ;; but handle `the-cons' specially 79 (and (identifier? a) 80 (identifier? b) 81 (or (free-identifier=? 82 a 83 (if (eq? 'the-cons (syntax-e b)) 84 cons-id 85 b)) 86 (free-identifier=? 87 a 88 (datum->syntax 89 #f 90 (if (eq? 'the-cons (syntax-e b)) 91 'cons 92 (syntax-e b)))))))] 93 [remove-all (lambda (lst rmv-lst) 94 (define (remove e l) 95 (cond 96 [(free-identifier=? e (car l)) (cdr l)] 97 [else (cons (car l) (remove e (cdr l)))])) 98 (let loop ([lst lst] [rmv-lst rmv-lst]) 99 (if (null? rmv-lst) 100 lst 101 (loop (remove (car rmv-lst) lst) 102 (cdr rmv-lst)))))] 103 [disarm (lambda (stx) (syntax-disarm stx code-insp))]) 104 (with-syntax ([(graph-expr ...) 105 (map (lambda (expr) 106 (let loop ([expr expr]) 107 (define (bad n) 108 (raise-syntax-error 109 'shared 110 (format "illegal use of ~a" n) 111 stx 112 expr)) 113 (define (cons-elem expr) 114 (or (and (identifier? expr) 115 (ormap (lambda (i ph ph-used?) 116 (and (free-identifier=? i expr) 117 (set-box! ph-used? #t) 118 ph)) 119 names placeholder-ids ph-used?s)) 120 (loop expr))) 121 (syntax-case* (disarm expr) (the-cons mcons append box box-immutable vector vector-immutable) same-special-id? 122 [(the-cons a d) 123 (with-syntax ([a (cons-elem #'a)] 124 [d (cons-elem #'d)]) 125 (syntax/loc expr (cons a d)))] 126 [(the-cons . _) 127 (bad "cons")] 128 [(mcons a d) 129 (syntax (mcons undefined undefined))] 130 [(mcons . _) 131 (bad "mcons")] 132 [(lst e ...) 133 (ormap (lambda (x) (same-special-id? #'lst x)) 134 (syntax->list #'(list list*))) 135 (with-syntax ([(e ...) 136 (map (lambda (x) (cons-elem x)) 137 (syntax->list (syntax (e ...))))]) 138 (syntax/loc expr (lst e ...)))] 139 [(lst . _) 140 (ormap (lambda (x) (same-special-id? #'lst x)) 141 (syntax->list #'(list list*))) 142 (bad (syntax-e #'lst))] 143 [(append e0 ... e) 144 (let ([len-id (car (generate-temporaries '(len)))]) 145 (set! append-ids (cons len-id append-ids)) 146 (with-syntax ([e (cons-elem #'e)] 147 [len-id len-id]) 148 (syntax/loc expr (let ([ph (make-placeholder e)] 149 [others (append e0 ... null)]) 150 (set! len-id (length others)) 151 (append others ph)))))] 152 [(append . _) 153 (bad "append")] 154 [(box v) 155 (syntax (box undefined))] 156 [(box . _) 157 (bad "box")] 158 [(box-immutable v) 159 (with-syntax ([v (cons-elem #'v)]) 160 (syntax/loc expr (box-immutable v)))] 161 [(vector e ...) 162 (with-syntax ([(e ...) 163 (map (lambda (x) (syntax undefined)) 164 (syntax->list (syntax (e ...))))]) 165 (syntax (vector e ...)))] 166 [(vector . _) 167 (bad "vector")] 168 [(vector-immutable e ...) 169 (with-syntax ([(e ...) 170 (map (lambda (x) (cons-elem x)) 171 (syntax->list (syntax (e ...))))]) 172 (syntax/loc expr (vector-immutable e ...)))] 173 [(vector-immutable . _) 174 (bad "vector-immutable")] 175 [(make-x . args) 176 (struct-decl-for (syntax make-x)) 177 (let ([decl (struct-decl-for (syntax make-x))] 178 [args (syntax->list (syntax args))]) 179 (unless args 180 (bad "structure constructor")) 181 (let ([expected (- (length (list-ref decl 4)) 182 (length (car (list-ref decl 6))))]) 183 (unless (= expected (length args)) 184 (raise-syntax-error 185 'shared 186 (format "wrong argument count for structure constructor; expected ~a, found ~a" 187 expected (length args)) 188 stx 189 expr))) 190 (with-syntax ([undefineds (map (lambda (x) (syntax undefined)) args)]) 191 (syntax (make-x . undefineds))))] 192 [_else expr]))) 193 exprs)] 194 [(init-expr ...) 195 (map (lambda (expr temp-id used?) 196 (let ([init-id 197 (syntax-case* expr (the-cons mcons list list* append box box-immutable vector vector-immutable) same-special-id? 198 [(the-cons . _) 199 temp-id] 200 [(mcons . _) temp-id] 201 [(list . _) temp-id] 202 [(list* . _) temp-id] 203 [(append . _) temp-id] 204 [(box . _) temp-id] 205 [(box-immutable . _) temp-id] 206 [(vector . _) temp-id] 207 [(vector-immutable . _) temp-id] 208 [(make-x . _) 209 (syntax-case (syntax-disarm expr code-insp) () 210 [(make-x . _) 211 (struct-decl-for (syntax make-x))]) 212 temp-id] 213 [else #f])]) 214 (cond 215 [init-id 216 (set-box! used? #t) 217 init-id] 218 [(unbox used?) 219 temp-id] 220 [else 221 expr]))) 222 exprs temp-ids ph-used?s)] 223 [(finish-expr ...) 224 (let ([gen-n (lambda (l) 225 (let loop ([l l][n 0]) 226 (if (null? l) 227 null 228 (cons (datum->syntax (quote-syntax here) n #f) 229 (loop (cdr l) (add1 n))))))] 230 [append-ids (reverse append-ids)]) 231 (map (lambda (name expr) 232 (let loop ([name name] [expr expr]) 233 (with-syntax ([name name]) 234 (syntax-case* (disarm expr) (the-cons mcons list list* append box box-immutable vector vector-immutable) 235 same-special-id? 236 [(the-cons a d) 237 #`(begin #,(loop #`(car name) #'a) 238 #,(loop #`(cdr name) #'d))] 239 [(mcons a d) 240 (syntax (begin 241 (set-mcar! name a) 242 (set-mcdr! name d)))] 243 [(list e ...) 244 (let ([es (syntax->list #'(e ...))]) 245 #`(begin 246 #,@(map (lambda (n e) 247 (loop #`(list-ref name #,n) e)) 248 (gen-n es) 249 es)))] 250 [(list* e ...) 251 (let* ([es (syntax->list #'(e ...))] 252 [last-n (sub1 (length es))]) 253 #`(begin 254 #,@(map (lambda (n e) 255 (loop #`(#,(if (= (syntax-e n) last-n) 256 #'list-tail 257 #'list-ref) 258 name 259 #,n) 260 e)) 261 (gen-n es) 262 es)))] 263 [(append e0 ... e) 264 (with-syntax ([len-id (car append-ids)]) 265 (set! append-ids (cdr append-ids)) 266 (loop #`(list-tail name len-id) #'e))] 267 [(box v) 268 (syntax (set-box! name v))] 269 [(box-immutable v) 270 (loop #'(unbox name) #'v)] 271 [(vector e ...) 272 (with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))]) 273 (syntax (let ([vec name]) 274 (vector-set! vec n e) 275 ...)))] 276 [(vector-immutable e ...) 277 (let ([es (syntax->list #'(e ...))]) 278 #`(begin 279 #,@(map (lambda (n e) 280 (loop #`(vector-ref name #,n) e)) 281 (gen-n es) 282 es)))] 283 [(make-x e ...) 284 (struct-decl-for (syntax make-x)) 285 (let ([decl (struct-decl-for (syntax make-x))]) 286 (syntax-case (remove-all (reverse (list-ref decl 4)) (cadr (list-ref decl 6))) () 287 [() 288 (syntax (void))] 289 [(setter ...) 290 (syntax (begin (setter name e) ...))]))] 291 [_else (syntax (void))])))) 292 names exprs))] 293 [(check-expr ...) 294 (if make-check-cdr 295 (map (lambda (name expr) 296 (syntax-case* expr (the-cons) same-special-id? 297 [(the-cons a d) 298 (make-check-cdr name)] 299 [_else (syntax #t)])) 300 names exprs) 301 null)] 302 [(temp-id ...) temp-ids] 303 [(placeholder-id ...) placeholder-ids] 304 [(ph-used? ...) (map unbox ph-used?s)] 305 [(used-ph-id ...) (filter values 306 (map (lambda (ph ph-used?) 307 (and (unbox ph-used?) 308 ph)) 309 placeholder-ids ph-used?s))] 310 [(maybe-ph-id ...) (map (lambda (ph ph-used?) 311 (and (unbox ph-used?) 312 ph)) 313 placeholder-ids ph-used?s)]) 314 (with-syntax ([(ph-init ...) (filter values 315 (map (lambda (ph ph-used? graph-expr) 316 (and (unbox ph-used?) 317 #`(placeholder-set! #,ph #,graph-expr))) 318 placeholder-ids ph-used?s 319 (syntax->list #'(graph-expr ...))))] 320 [(append-id ...) append-ids]) 321 (syntax/loc stx 322 (letrec-values ([(used-ph-id) (make-placeholder #f)] ... 323 [(append-id) #f] ... 324 [(temp-id ...) 325 (begin 326 ph-init ... 327 (apply values (make-reader-graph 328 (list maybe-ph-id ...))))] 329 [(name) init-expr] ...) 330 finish-expr 331 ... 332 check-expr 333 ... 334 body1 335 body 336 ...))))))])) 337