|
46 | 46 | (call (top append_any) ,@forms))) |
47 | 47 | (loop (cdr p) (cons (julia-bq-bracket (car p) d) q))))))) |
48 | 48 |
|
| 49 | +(define (julia-bq-expand-hygienic x unhygienic) |
| 50 | + (let ((expanded (julia-bq-expand x 0))) |
| 51 | + (if unhygienic expanded `(escape ,expanded)))) |
| 52 | + |
49 | 53 | ;; hygiene |
50 | 54 |
|
51 | 55 | ;; return the names of vars introduced by forms, instead of their transformations. |
|
191 | 195 | (case (car v) |
192 | 196 | ((... kw |::|) (try-arg-name (cadr v))) |
193 | 197 | ((escape) (list v)) |
| 198 | + ((hygienic-scope) (try-arg-name (cadr v))) |
194 | 199 | ((meta) ;; allow certain per-argument annotations |
195 | 200 | (if (nospecialize-meta? v #t) |
196 | 201 | (try-arg-name (caddr v)) |
|
230 | 235 | ;; resolve-expansion-vars-with-new-env, but turn on `inarg` once we get inside |
231 | 236 | ;; the formal argument list. `e` in general might be e.g. `(f{T}(x)::T) where T`, |
232 | 237 | ;; and we want `inarg` to be true for the `(x)` part. |
233 | | -(define (resolve-in-function-lhs e env m inarg) |
234 | | - (define (recur x) (resolve-in-function-lhs x env m inarg)) |
235 | | - (define (other x) (resolve-expansion-vars-with-new-env x env m inarg)) |
| 238 | +(define (resolve-in-function-lhs e env m parent-scope inarg) |
| 239 | + (define (recur x) (resolve-in-function-lhs x env m parent-scope inarg)) |
| 240 | + (define (other x) (resolve-expansion-vars-with-new-env x env m parent-scope inarg)) |
236 | 241 | (case (car e) |
237 | 242 | ((where) `(where ,(recur (cadr e)) ,@(map other (cddr e)))) |
238 | 243 | ((|::|) `(|::| ,(recur (cadr e)) ,(other (caddr e)))) |
239 | 244 | ((call) `(call ,(other (cadr e)) |
240 | 245 | ,@(map (lambda (x) |
241 | | - (resolve-expansion-vars-with-new-env x env m #t)) |
| 246 | + (resolve-expansion-vars-with-new-env x env m parent-scope #t)) |
242 | 247 | (cddr e)))) |
243 | 248 | (else (other e)))) |
244 | 249 |
|
|
268 | 273 | (diff (keywords-introduced-by x) globals)))) |
269 | 274 | env))))))) |
270 | 275 |
|
271 | | -(define (resolve-expansion-vars-with-new-env x env m inarg (outermost #f)) |
| 276 | +(define (resolve-expansion-vars-with-new-env x env m parent-scope inarg (outermost #f)) |
272 | 277 | (resolve-expansion-vars- |
273 | 278 | x |
274 | 279 | (if (and (pair? x) (eq? (car x) 'let)) |
275 | 280 | ;; let is strange in that it needs both old and new envs within |
276 | 281 | ;; the same expression |
277 | 282 | env |
278 | 283 | (new-expansion-env-for x env outermost)) |
279 | | - m inarg)) |
| 284 | + m parent-scope inarg)) |
280 | 285 |
|
281 | | -(define (resolve-expansion-vars- e env m inarg) |
| 286 | +(define (resolve-expansion-vars- e env m parent-scope inarg) |
282 | 287 | (cond ((or (eq? e 'true) (eq? e 'false) (eq? e 'end) (eq? e 'ccall)) |
283 | 288 | e) |
284 | 289 | ((symbol? e) |
|
291 | 296 | (else |
292 | 297 | (case (car e) |
293 | 298 | ((ssavalue) e) |
294 | | - ((escape) (cadr e)) |
| 299 | + ((escape) (if (null? parent-scope) |
| 300 | + (julia-expand-macroscopes (cadr e)) |
| 301 | + (let* ((scope (car parent-scope)) |
| 302 | + (env (car scope)) |
| 303 | + (m (cadr scope)) |
| 304 | + (parent-scope (cdr parent-scope))) |
| 305 | + (resolve-expansion-vars-with-new-env (cadr e) env m parent-scope inarg)))) |
295 | 306 | ((global) (let ((arg (cadr e))) |
296 | 307 | (cond ((symbol? arg) e) |
297 | 308 | ((assignment? arg) |
|
301 | 312 | (else |
302 | 313 | `(global ,(resolve-expansion-vars-with-new-env arg env m inarg)))))) |
303 | 314 | ((using import importall export meta line inbounds boundscheck simdloop) (map unescape e)) |
304 | | - ((macrocall) |
305 | | - (if (or (eq? (cadr e) '@label) (eq? (cadr e) '@goto)) e |
306 | | - `(macrocall ,.(map (lambda (x) |
307 | | - (resolve-expansion-vars-with-new-env x env m inarg)) |
308 | | - (cdr e))))) |
| 315 | + ((macrocall) e) ; invalid syntax anyways, so just act like it's quoted. |
309 | 316 | ((symboliclabel) e) |
310 | 317 | ((symbolicgoto) e) |
311 | 318 | ((type) |
312 | | - `(type ,(cadr e) ,(resolve-expansion-vars- (caddr e) env m inarg) |
| 319 | + `(type ,(cadr e) ,(resolve-expansion-vars- (caddr e) env m parent-scope inarg) |
313 | 320 | ;; type has special behavior: identifiers inside are |
314 | 321 | ;; field names, not expressions. |
315 | 322 | ,(map (lambda (x) |
316 | 323 | (cond ((atom? x) x) |
317 | 324 | ((and (pair? x) (eq? (car x) '|::|)) |
318 | 325 | `(|::| ,(cadr x) |
319 | | - ,(resolve-expansion-vars- (caddr x) env m inarg))) |
| 326 | + ,(resolve-expansion-vars- (caddr x) env m parent-scope inarg))) |
320 | 327 | (else |
321 | | - (resolve-expansion-vars-with-new-env x env m inarg)))) |
| 328 | + (resolve-expansion-vars-with-new-env x env m parent-scope inarg)))) |
322 | 329 | (cadddr e)))) |
323 | 330 |
|
324 | 331 | ((parameters) |
325 | 332 | (cons 'parameters |
326 | 333 | (map (lambda (x) |
327 | | - (resolve-expansion-vars- x env m #f)) |
| 334 | + (resolve-expansion-vars- x env m parent-scope #f)) |
328 | 335 | (cdr e)))) |
329 | 336 |
|
330 | 337 | ((= function) |
331 | 338 | (if (and (pair? (cadr e)) (function-def? e)) |
332 | 339 | ;; in (kw x 1) inside an arglist, the x isn't actually a kwarg |
333 | | - `(,(car e) ,(resolve-in-function-lhs (cadr e) env m inarg) |
334 | | - ,(resolve-expansion-vars-with-new-env (caddr e) env m inarg)) |
| 340 | + `(,(car e) ,(resolve-in-function-lhs (cadr e) env m parent-scope inarg) |
| 341 | + ,(resolve-expansion-vars-with-new-env (caddr e) env m parent-scope inarg)) |
335 | 342 | `(,(car e) ,@(map (lambda (x) |
336 | | - (resolve-expansion-vars-with-new-env x env m inarg)) |
| 343 | + (resolve-expansion-vars-with-new-env x env m parent-scope inarg)) |
337 | 344 | (cdr e))))) |
338 | 345 |
|
339 | 346 | ((kw) |
340 | 347 | (if (and (pair? (cadr e)) |
341 | 348 | (eq? (caadr e) '|::|)) |
342 | 349 | `(kw (|::| |
343 | 350 | ,(if inarg |
344 | | - (resolve-expansion-vars- (cadr (cadr e)) env m inarg) |
| 351 | + (resolve-expansion-vars- (cadr (cadr e)) env m parent-scope inarg) |
345 | 352 | ;; in keyword arg A=B, don't transform "A" |
346 | 353 | (unescape (cadr (cadr e)))) |
347 | | - ,(resolve-expansion-vars- (caddr (cadr e)) env m inarg)) |
348 | | - ,(resolve-expansion-vars- (caddr e) env m inarg)) |
| 354 | + ,(resolve-expansion-vars- (caddr (cadr e)) env m parent-scope inarg)) |
| 355 | + ,(resolve-expansion-vars- (caddr e) env m parent-scope inarg)) |
349 | 356 | `(kw ,(if inarg |
350 | | - (resolve-expansion-vars- (cadr e) env m inarg) |
| 357 | + (resolve-expansion-vars- (cadr e) env m parent-scope inarg) |
351 | 358 | (unescape (cadr e))) |
352 | | - ,(resolve-expansion-vars- (caddr e) env m inarg)))) |
| 359 | + ,(resolve-expansion-vars- (caddr e) env m parent-scope inarg)))) |
353 | 360 |
|
354 | 361 | ((let) |
355 | 362 | (let* ((newenv (new-expansion-env-for e env)) |
356 | | - (body (resolve-expansion-vars- (cadr e) newenv m inarg))) |
| 363 | + (body (resolve-expansion-vars- (cadr e) newenv m parent-scope inarg))) |
357 | 364 | `(let ,body |
358 | 365 | ,@(map |
359 | 366 | (lambda (bind) |
360 | 367 | (if (assignment? bind) |
361 | 368 | (make-assignment |
362 | 369 | ;; expand binds in old env with dummy RHS |
363 | 370 | (cadr (resolve-expansion-vars- (make-assignment (cadr bind) 0) |
364 | | - newenv m inarg)) |
| 371 | + newenv m parent-scope inarg)) |
365 | 372 | ;; expand initial values in old env |
366 | | - (resolve-expansion-vars- (caddr bind) env m inarg)) |
| 373 | + (resolve-expansion-vars- (caddr bind) env m parent-scope inarg)) |
367 | 374 | bind)) |
368 | 375 | (cddr e))))) |
| 376 | + ((hygienic-scope) ; TODO: move this lowering to resolve-scopes, instead of reimplementing it here badly |
| 377 | + (let ((parent-scope (cons (list env m) parent-scope)) |
| 378 | + (body (cadr e)) |
| 379 | + (m (caddr e))) |
| 380 | + (resolve-expansion-vars-with-new-env body env m parent-scope inarg))) |
369 | 381 |
|
370 | 382 | ;; todo: trycatch |
371 | 383 | (else |
372 | 384 | (cons (car e) |
373 | 385 | (map (lambda (x) |
374 | | - (resolve-expansion-vars-with-new-env x env m inarg)) |
| 386 | + (resolve-expansion-vars-with-new-env x env m parent-scope inarg)) |
375 | 387 | (cdr e)))))))) |
376 | 388 |
|
377 | 389 | ;; decl-var that also identifies f in f()=... |
|
398 | 410 | (define (find-declared-vars-in-expansion e decl (outer #t)) |
399 | 411 | (cond ((or (not (pair? e)) (quoted? e)) '()) |
400 | 412 | ((eq? (car e) 'escape) '()) |
| 413 | + ((eq? (car e) 'hygienic-scope) '()) |
401 | 414 | ((eq? (car e) decl) (map decl-var* (cdr e))) |
402 | 415 | ((and (not outer) (function-def? e)) '()) |
403 | 416 | (else |
|
408 | 421 | (define (find-assigned-vars-in-expansion e (outer #t)) |
409 | 422 | (cond ((or (not (pair? e)) (quoted? e)) '()) |
410 | 423 | ((eq? (car e) 'escape) '()) |
| 424 | + ((eq? (car e) 'hygienic-scope) '()) |
411 | 425 | ((and (not outer) (function-def? e)) |
412 | 426 | ;; pick up only function name |
413 | 427 | (let ((fname (cond ((eq? (car e) '=) (decl-var* (cadr e))) |
|
436 | 450 | (define (resolve-expansion-vars e m) |
437 | 451 | ;; expand binding form patterns |
438 | 452 | ;; keep track of environment, rename locals to gensyms |
439 | | - ;; and wrap globals in (getfield module var) for macro's home module |
440 | | - (resolve-expansion-vars-with-new-env e '() m #f #t)) |
| 453 | + ;; and wrap globals in (globalref module var) for macro's home module |
| 454 | + (resolve-expansion-vars-with-new-env e '() m '() #f #t)) |
441 | 455 |
|
442 | 456 | (define (find-symbolic-labels e) |
443 | 457 | (let ((defs (table)) |
|
470 | 484 | ;; macro expander entry point |
471 | 485 |
|
472 | 486 | (define (julia-expand-macros e (max-depth -1)) |
| 487 | + (julia-expand-macroscopes |
| 488 | + (julia-expand-macros- '() e max-depth))) |
| 489 | + |
| 490 | +(define (julia-expand-macros- m e max-depth) |
473 | 491 | (cond ((= max-depth 0) e) |
474 | | - ((not (pair? e)) e) |
| 492 | + ((not (pair? e)) e) |
475 | 493 | ((eq? (car e) 'quote) |
476 | | - ;; backquote is essentially a built-in macro at the moment |
477 | | - (julia-expand-macros (julia-bq-expand (cadr e) 0) max-depth)) |
| 494 | + ;; backquote is essentially a built-in unhygienic macro at the moment |
| 495 | + (julia-expand-macros- m (julia-bq-expand-hygienic (cadr e) (null? m)) max-depth)) |
478 | 496 | ((eq? (car e) 'inert) e) |
479 | 497 | ((eq? (car e) 'macrocall) |
480 | 498 | ;; expand macro |
481 | | - (let ((form (apply invoke-julia-macro (cadr e) (cddr e)))) |
| 499 | + (let ((form (apply invoke-julia-macro (if (null? m) 'false (car m)) (cdr e)))) |
482 | 500 | (if (not form) |
483 | 501 | (error (string "macro \"" (cadr e) "\" not defined"))) |
484 | 502 | (if (and (pair? form) (eq? (car form) 'error)) |
485 | 503 | (error (cadr form))) |
486 | | - (let ((form (car form)) |
487 | | - (m (cdr form))) |
488 | | - ;; m is the macro's def module |
489 | | - (rename-symbolic-labels |
490 | | - (julia-expand-macros (resolve-expansion-vars form m) (- max-depth 1)))))) |
| 504 | + (let ((form (car form)) ;; form is the expression returned from expand-macros |
| 505 | + (modu (cdr form))) ;; modu is the macro's def module |
| 506 | + `(hygienic-scope |
| 507 | + ,(julia-expand-macros- (cons modu m) (rename-symbolic-labels form) (- max-depth 1)) |
| 508 | + ,modu)))) |
| 509 | + ((eq? (car e) 'module) e) |
| 510 | + ((eq? (car e) 'escape) |
| 511 | + (let ((m (if (null? m) m (cdr m)))) |
| 512 | + `(escape ,(julia-expand-macros- m (cadr e) max-depth)))) |
| 513 | + (else |
| 514 | + (map (lambda (ex) |
| 515 | + (julia-expand-macros- m ex max-depth)) |
| 516 | + e)))) |
| 517 | + |
| 518 | +;; TODO: delete this file and fold this operation into resolve-scopes |
| 519 | +(define (julia-expand-macroscopes e) |
| 520 | + (cond ((not (pair? e)) e) |
| 521 | + ((eq? (car e) 'inert) e) |
491 | 522 | ((eq? (car e) 'module) e) |
| 523 | + ((eq? (car e) 'hygienic-scope) |
| 524 | + (let ((form (cadr e)) ;; form is the expression returned from expand-macros |
| 525 | + (modu (caddr e))) ;; m is the macro's def module |
| 526 | + (resolve-expansion-vars form modu))) |
492 | 527 | (else |
493 | | - (map (lambda (ex) (julia-expand-macros ex max-depth)) e)))) |
| 528 | + (map julia-expand-macroscopes e)))) |
0 commit comments