Skip to content

Commit

Permalink
some minor hygiene fixes (JuliaLang#49897)
Browse files Browse the repository at this point in the history 
This code does a bad job handling `(escape symbol)` in a lot of places.
This attempts to fix some of them by peeking through it more.
  • Loading branch information
@vtjnash
vtjnash authored May 26, 2023
1 parent 23e0b2d commit ba1391a
Show file tree
Hide file tree
Showing 2 changed files with 70 additions and 57 deletions.
2 changes: 1 addition & 1 deletion src/julia-syntax.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -187,7 +187,7 @@
;; a bound is #f if not specified
(define (analyze-typevar e)
(define (check-sym s)
(if (symbol? s)
(if (symbol? (unescape s)) ; unescape for macroexpand.scm use
s
(error (string "invalid type parameter name \"" (deparse s) "\""))))
(cond ((atom? e) (list (check-sym e) #f #f))
Expand Down
125 changes: 69 additions & 56 deletions src/macroexpand.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -99,31 +99,32 @@
(vars '()))
(if (null? binds)
(cons 'varlist vars)
(cond
((or (symbol? (car binds)) (decl? (car binds)))
;; just symbol -> add local
(loop (cdr binds)
(cons (decl-var (car binds)) vars)))
((and (length= (car binds) 3)
(eq? (caar binds) '=))
;; some kind of assignment
(cond
((or (symbol? (cadar binds))
(decl? (cadar binds)))
;; a=b -> add argument
(loop (cdr binds)
(cons (decl-var (cadar binds)) vars)))
((eventually-call? (cadar binds))
;; f()=c
(let ((asgn (cadr (julia-expand0 (car binds) 'none 0))))
(loop (cdr binds)
(cons (cadr asgn) vars))))
((and (pair? (cadar binds))
(eq? (caadar binds) 'tuple))
(loop (cdr binds)
(append (map decl-var (lhs-vars (cadar binds))) vars)))
(else '())))
(else '())))))
(let ((ux (unescape (car binds))))
(cond
((or (symbol? ux) (decl? ux))
;; just symbol -> add local
(loop (cdr binds)
(cons (let-decl-var ux) vars)))
((and (length= (car binds) 3)
(eq? (caar binds) '=))
(set! ux (unescape (cadar binds)))
;; some kind of assignment
(cond
((or (symbol? ux) (decl? ux))
;; a=b -> add argument
(loop (cdr binds)
(cons (let-decl-var ux) vars)))
((eventually-call? (cadar binds))
;; f()=c
(let ((name (assigned-name (cadar binds))))
(loop (cdr binds)
(cons name vars))))
((and (pair? (cadar binds))
(eq? (caadar binds) 'tuple))
(loop (cdr binds)
(append (map let-decl-var (lhs-vars (cadar binds))) vars)))
(else '())))
(else '()))))))

;; macro definition
(pattern-lambda (macro (call name . argl) body)
Expand Down Expand Up @@ -180,12 +181,12 @@

(define (unescape e)
(if (and (pair? e) (eq? (car e) 'escape))
(cadr e)
(unescape (cadr e))
e))

(define (unescape-global-lhs e env m parent-scope inarg)
(cond ((not (pair? e)) e)
((eq? (car e) 'escape) (cadr e))
((eq? (car e) 'escape) (unescape-global-lhs (cadr e) env m parent-scope inarg))
((memq (car e) '(parameters tuple))
(list* (car e) (map (lambda (e)
(unescape-global-lhs e env m parent-scope inarg))
Expand All @@ -207,7 +208,7 @@
((eq? (car e) 'curly) (cddr e))
(else '())))

(define (typevar-expr-name e) (car (analyze-typevar e)))
(define (typevar-expr-name e) (unescape (car (analyze-typevar e))))

;; get the list of names from a list of `where` variable expressions
(define (typevar-names lst)
Expand Down Expand Up @@ -276,13 +277,13 @@
(list (cadr name))
'()))

;; resolve-expansion-vars-with-new-env, but turn on `inarg` once we get inside
;; the formal argument list. `e` in general might be e.g. `(f{T}(x)::T) where T`,
;; resolve-expansion-vars-with-new-env, but turn on `inarg` if we get inside
;; a formal argument list. `e` in general might be e.g. `(f{T}(x)::T) where T`,
;; and we want `inarg` to be true for the `(x)` part.
(define (resolve-in-function-lhs e env m parent-scope inarg)
(define (recur x) (resolve-in-function-lhs x env m parent-scope inarg))
(define (resolve-in-lhs e env m parent-scope inarg)
(define (recur x) (resolve-in-lhs x env m parent-scope inarg))
(define (other x) (resolve-expansion-vars-with-new-env x env m parent-scope inarg))
(case (car e)
(case (and (pair? e) (car e))
((where) `(where ,(recur (cadr e)) ,@(map other (cddr e))))
((|::|) `(|::| ,(recur (cadr e)) ,(other (caddr e))))
((call) `(call ,(other (cadr e))
Expand Down Expand Up @@ -337,6 +338,11 @@
(new-expansion-env-for x env outermost))
m parent-scope inarg))

(define (reescape ux x)
(if (and (pair? x) (eq? (car x) 'escape))
(reescape '(escape ,ux) (cadr x)))
ux)

(define (resolve-expansion-vars- e env m parent-scope inarg)
(cond ((or (eq? e 'begin) (eq? e 'end) (eq? e 'ccall) (eq? e 'cglobal) (underscore-symbol? e))
e)
Expand Down Expand Up @@ -374,36 +380,35 @@
;; type has special behavior: identifiers inside are
;; field names, not expressions.
,(map (lambda (x)
(cond ((atom? x) x)
((and (pair? x) (eq? (car x) '|::|))
`(|::| ,(cadr x)
,(resolve-expansion-vars- (caddr x) env m parent-scope inarg)))
(else
(resolve-expansion-vars-with-new-env x env m parent-scope inarg))))
(let ((ux (unescape x)))
(cond ((atom? ux) ux)
((and (pair? ux) (eq? (car ux) '|::|))
`(|::| ,(unescape (cadr ux))
,(resolve-expansion-vars- (reescape (caddr ux) x) env m parent-scope inarg)))
(else
(resolve-expansion-vars-with-new-env x env m parent-scope inarg)))))
(cadddr e))))

((parameters)
(cons 'parameters
(map (lambda (x)
;; `x` by itself after ; means `x=x`
(let ((x (if (and (not inarg) (symbol? x))
`(kw ,x ,x)
x)))
(let* ((ux (unescape x))
(x (if (and (not inarg) (symbol? ux))
`(kw ,ux ,x)
x)))
(resolve-expansion-vars- x env m parent-scope #f)))
(cdr e))))

((->)
`(-> ,(resolve-in-function-lhs (tuple-wrap-arrow-sig (cadr e)) env m parent-scope inarg)
`(-> ,(resolve-in-lhs (tuple-wrap-arrow-sig (cadr e)) env m parent-scope inarg)
,(resolve-expansion-vars-with-new-env (caddr e) env m parent-scope inarg)))

((= function)
(if (and (pair? (cadr e)) (function-def? e) (length> e 2))
;; in (kw x 1) inside an arglist, the x isn't actually a kwarg
`(,(car e) ,(resolve-in-function-lhs (cadr e) env m parent-scope inarg)
,(resolve-expansion-vars-with-new-env (caddr e) env m parent-scope inarg))
`(,(car e) ,@(map (lambda (x)
(resolve-expansion-vars-with-new-env x env m parent-scope inarg))
(cdr e)))))
`(,(car e) ,(resolve-in-lhs (cadr e) env m parent-scope inarg)
,@(map (lambda (x)
(resolve-expansion-vars-with-new-env x env m parent-scope inarg))
(cddr e))))

((kw)
(cond
Expand Down Expand Up @@ -442,7 +447,7 @@
newenv m parent-scope inarg))
;; expand initial values in old env
(resolve-expansion-vars- (caddr bind) env m parent-scope inarg))
bind))
(resolve-expansion-vars- bind env m parent-scope inarg)))
binds))
,body)))
((hygienic-scope) ; TODO: move this lowering to resolve-scopes, instead of reimplementing it here badly
Expand Down Expand Up @@ -471,20 +476,32 @@
(define (decl-var* e)
(if (pair? e)
(case (car e)
((hygienic-scope) '())
((escape) '())
((call) (decl-var* (cadr e)))
((=) (decl-var* (cadr e)))
((curly) (decl-var* (cadr e)))
((|::|) (if (length= e 2) '() (decl-var* (cadr e))))
((where) (decl-var* (cadr e)))
(else (decl-var e)))
(else e))
e))

(define (decl-vars* e)
(if (and (pair? e) (eq? (car e) 'tuple))
(apply append (map decl-vars* (cdr e)))
(list (decl-var* e))))

;; decl-var that can sort of handle scope hygiene, but very badly
(define (let-decl-var e)
(if (pair? e)
(case (car e)
((hygienic-scope) (let-decl-var (cadr e)))
((escape) (let-decl-var (cadr e)))
((|::|) (if (length= e 2) '() (let-decl-var (cadr e))))
(else e))
e))


;; count hygienic / escape pairs
;; and fold together a list resulting from applying the function to
;; any block at the same hygienic scope
Expand Down Expand Up @@ -614,9 +631,5 @@
(rename-symbolic-labels
(julia-expand-quotes e))))

(define (contains-macrocall e)
(and (pair? e)
(contains (lambda (e) (and (pair? e) (eq? (car e) 'macrocall))) e)))

(define (julia-bq-macro x)
(julia-bq-expand x 0))

0 comments on commit ba1391a

Please sign in to comment.