julia-syntax.scm

;; ignored variable name. TODO replace with _?
(define UNUSED '|#unused#|)

;; allow (:: T) => (:: #gensym T) in formal argument lists
(define (fill-missing-argname a unused)
  (if (and (pair? a) (eq? (car a) '|::|) (null? (cddr a)))
      `(|::| ,(if unused UNUSED (gensy)) ,(cadr a))
      a))
(define (fix-arglist l (unused #t))
  (if (any vararg? (butlast l))
      (error "invalid ... on non-final argument"))
  (map (lambda (a)
         (cond ((and (pair? a) (eq? (car a) 'kw))
                `(kw ,(fill-missing-argname (cadr a) unused) ,(caddr a)))
               ((and (pair? a) (eq? (car a) '...))
                `(... ,(fill-missing-argname (cadr a) unused)))
               (else
                (fill-missing-argname a unused))))
       l))

(define (effect-free? e)
  (or (not (pair? e)) (jlgensym? e) (sym-dot? e) (quoted? e) (equal? e '(null))))

; make an expression safe for multiple evaluation
; for example a[f(x)] => (temp=f(x); a[temp])
; retuns a pair (expr . assignments)
; where 'assignments' is a list of needed assignment statements
(define (remove-argument-side-effects e)
  (let ((a '()))
    (cond
     ((and (decl? e) (symbol? (cadr e)))
      (cons (cadr e) (list e)))
     ((not (pair? e))
      (cons e '()))
     (else
      (cons (map (lambda (x)
                   (cond
                    ((and (decl? x) (symbol? (cadr x)))
                     (set! a (cons x a))
                     (cadr x))
                    ((not (effect-free? x))
                     (let ((g (make-jlgensym)))
                       (if (or (eq? (car x) '...) (eq? (car x) '&))
                           (if (and (pair? (cadr x))
                                    (not (quoted? (cadr x))))
                               (begin (set! a (cons `(= ,g ,(cadr x)) a))
                                      `(,(car x) ,g))
                               x)
                           (begin (set! a (cons `(= ,g ,x) a))
                                  g))))
                    (else
                     x)))
                 e)
            (reverse a))))))

(define (expand-update-operator- op lhs rhs declT)
  (let ((e (remove-argument-side-effects lhs)))
    `(block ,@(cdr e)
            ,(if (null? declT)
                 `(= ,(car e) (call ,op ,(car e) ,rhs))
                 `(= ,(car e) (call ,op (:: ,(car e) ,(car declT)) ,rhs))))))

(define (expand-update-operator op lhs rhs . declT)
  (cond ((and (pair? lhs) (eq? (car lhs) 'ref))
         ;; expand indexing inside op= first, to remove "end" and ":"
         (let* ((ex (partially-expand-ref lhs))
                (stmts (butlast (cdr ex)))
                (refex (last    (cdr ex)))
                (nuref `(ref ,(caddr refex) ,@(cdddr refex))))
           `(block ,@stmts
                   ,(expand-update-operator- op nuref rhs declT))))
        ((and (pair? lhs) (eq? (car lhs) '|::|))
         ;; (+= (:: x T) rhs)
         (let ((e (remove-argument-side-effects (cadr lhs)))
               (T (caddr lhs)))
           `(block ,@(cdr e)
                   ,(expand-update-operator op (car e) rhs T))))
        (else
         (expand-update-operator- op lhs rhs declT))))

(define (partially-expand-ref e)
  (let ((a    (cadr e))
        (idxs (cddr e)))
    (let* ((reuse (and (pair? a)
                       (contains (lambda (x)
                                   (or (eq? x 'end)
                                       (eq? x ':)
                                       (and (pair? x)
                                            (eq? (car x) ':))))
                                 idxs)))
           (arr   (if reuse (make-jlgensym) a))
           (stmts (if reuse `((= ,arr ,a)) '())))
      (receive
       (new-idxs stuff) (process-indexes arr idxs)
       `(block
         ,@(append stmts stuff)
         (call getindex ,arr ,@new-idxs))))))

;; accumulate a series of comparisons, with the given "and" constructor,
;; exit criteria, and "take" function that consumes part of a list,
;; returning (expression . rest)
(define (comp-accum e make-and done? take)
  (let loop ((e e)
             (expr '()))
    (if (done? e) (cons expr e)
        (let ((ex_rest (take e)))
          (loop (cdr ex_rest)
                (if (null? expr)
                    (car ex_rest)
                    (make-and expr (car ex_rest))))))))

(define (add-init arg arg2 expr)
  (if (eq? arg arg2) expr
      `(block (= ,arg2 ,arg) ,expr)))

;; generate a comparison from e.g. (a < b ...)
;; returning (expr . rest)
(define (compare-one e)
  (let* ((arg   (caddr e))
         (arg2  (if (and (pair? arg)
                         (pair? (cdddr e)))
                    (make-jlgensym) arg)))
    (if (and (not (dotop? (cadr e)))
             (length> e 5)
             (pair? (cadddr (cdr e)))
             (dotop? (cadddr (cddr e))))
        ;; look ahead: if the 2nd argument of the next comparison is also
        ;; an argument to an eager (dot) op, make sure we don't skip the
        ;; initialization of its variable by short-circuiting
        (let ((s (make-jlgensym)))
          (cons `(block
                  ,@(if (eq? arg arg2) '() `((= ,arg2 ,arg)))
                  (= ,s ,(cadddr (cdr e)))
                  (call ,(cadr e) ,(car e) ,arg2))
                (list* arg2 (cadddr e) s (cddddr (cdr e)))))
        (cons
         (add-init arg arg2
                   `(call ,(cadr e) ,(car e) ,arg2))
         (cons arg2 (cdddr e))))))

;; convert a series of scalar comparisons into && expressions
(define (expand-scalar-compare e)
  (comp-accum e
              (lambda (a b) `(&& ,a ,b))
              (lambda (x) (or (not (length> x 2)) (dotop? (cadr x))))
              compare-one))

;; convert a series of scalar and vector comparisons into & calls,
;; combining as many scalar comparisons as possible into short-circuit
;; && sequences.
(define (expand-vector-compare e)
  (comp-accum e
              (lambda (a b) `(call & ,a ,b))
              (lambda (x) (not (length> x 2)))
              (lambda (e)
                (if (dotop? (cadr e))
                    (compare-one e)
                    (expand-scalar-compare e)))))

(define (expand-compare-chain e)
  (car (expand-vector-compare e)))

;; return the appropriate computation for an `end` symbol for indexing
;; the array `a` in the `n`th index.
;; `tuples` are a list of the splatted arguments that precede index `n`
;; `last` = is this last index?
;; returns a call to endof(a), trailingsize(a,n), or size(a,n)
(define (end-val a n tuples last)
  (if (null? tuples)
      (if last
          (if (= n 1)
              `(call (top endof) ,a)
              `(call (top trailingsize) ,a ,n))
          `(call (top size) ,a ,n))
      (let ((dimno `(call (top +) ,(- n (length tuples))
                          ,.(map (lambda (t) `(call (top length) ,t))
                                 tuples))))
        (if last
            `(call (top trailingsize) ,a ,dimno)
            `(call (top size) ,a ,dimno)))))

; replace `end` for the closest ref expression, so doesn't go inside nested refs
(define (replace-end ex a n tuples last)
  (cond ((eq? ex 'end)                (end-val a n tuples last))
        ((or (atom? ex) (quoted? ex)) ex)
        ((eq? (car ex) 'ref)
         ;; inside ref only replace within the first argument
         (list* 'ref (replace-end (cadr ex) a n tuples last)
                (cddr ex)))
        (else
         (cons (car ex)
               (map (lambda (x) (replace-end x a n tuples last))
                    (cdr ex))))))

;; go through indices and replace the `end` symbol
;; a = array being indexed, i = list of indexes
;; returns (values index-list stmts) where stmts are statements that need
;; to execute first.
(define (process-indexes a i)
  (let loop ((lst i)
             (n   1)
             (stmts '())
             (tuples '())
             (ret '()))
    (if (null? lst)
        (values (reverse ret) (reverse stmts))
        (let ((idx  (car lst))
              (last (null? (cdr lst))))
          (if (and (pair? idx) (eq? (car idx) '...))
              (if (symbol-like? (cadr idx))
                  (loop (cdr lst) (+ n 1)
                        stmts
                        (cons (cadr idx) tuples)
                        (cons `(... ,(replace-end (cadr idx) a n tuples last))
                              ret))
                  (let ((g (make-jlgensym)))
                    (loop (cdr lst) (+ n 1)
                          (cons `(= ,g ,(replace-end (cadr idx) a n tuples last))
                                stmts)
                          (cons g tuples)
                          (cons `(... ,g) ret))))
              (loop (cdr lst) (+ n 1)
                    stmts tuples
                    (cons (replace-end idx a n tuples last) ret)))))))

;; GF method does not need to keep decl expressions on lambda args
;; except for rest arg
(define (method-lambda-expr argl body)
  (let ((argl (map (lambda (x)
                     (if (vararg? x)
                         (make-decl (arg-name x) (arg-type x))
                         (if (varargexpr? x)
                             (if (pair? (caddr x))
                                 x
                                 `(|::| ,(arg-name x) (curly Vararg Any)))
                             (arg-name x))))
                   argl)))
    `(lambda ,argl
       (scope-block ,body))))

(define (symbols->typevars sl upperbounds bnd)
  (let ((bnd (if bnd '(true) '())))
    (if (null? upperbounds)
        (map (lambda (x)    `(call (top TypeVar) ',x ,@bnd)) sl)
        (map (lambda (x ub) `(call (top TypeVar) ',x ,ub ,@bnd)) sl upperbounds))))

(define (sparam-name sp)
  (cond ((symbol? sp)
         sp)
        ((and (length= sp 3)
              (eq? (car sp) '|<:|)
              (symbol? (cadr sp)))
         (cadr sp))
        (else (error "malformed type parameter list"))))

(define (sparam-name-bounds sparams names bounds)
  (cond ((null? sparams)
         (values (reverse names) (reverse bounds)))
        ((symbol? (car sparams))
         (sparam-name-bounds (cdr sparams) (cons (car sparams) names)
                             (cons '(top Any) bounds)))
        ((and (length= (car sparams) 3)
              (eq? (caar sparams) '|<:|)
              (symbol? (cadar sparams)))
         (sparam-name-bounds (cdr sparams) (cons (cadr (car sparams)) names)
                             (cons (caddr (car sparams)) bounds)))
        (else
         (error "malformed type parameter list"))))

(define (method-expr-name m) (cadr m))

(define (unwrap-getfield-expr e)
  (if (and (length= e 4) (eq? (car e) 'call) (equal? (cadr e) '(top getfield)))
      (cadr (last e))
      e))

(define (method-expr-static-parameters m)
  (if (eq? (car (caddr m)) 'block)
      (let ((lst '()))
        (pattern-replace
         (pattern-set
          (pattern-lambda (= v (call (top (-/ TypeVar)) (quote T) y z))
                          (begin (set! lst (cons T lst)) __)))
         (butlast (cdr (caddr m))))
        (reverse! lst))
      '()))

(define (sym-ref? e)
  (or (symbol? e)
      (and (length= e 3) (eq? (car e) '|.|)
           (or (atom? (cadr e)) (sym-ref? (cadr e)))
           (pair? (caddr e)) (memq (car (caddr e)) '(quote inert))
           (symbol? (cadr (caddr e))))))

;; convert final (... x) to (curly Vararg x)
(define (dots->vararg a)
  (if (null? a) a
      (let ((head (butlast a))
	    (las  (last a)))
	(if (vararg? las)
	    `(,@head (curly Vararg ,(cadr las)))
	    `(,@head ,las)))))

(define (hidden-name? s)
  (and (symbol? s)
       (eqv? (string.char (string s) 0) #\#)))

(define (is-call-name? name)
  (or (eq? name 'call) (and (pair? name) (sym-ref? name)
                            (equal? (caddr name) '(inert call)))))

(define (method-def-expr- name sparams argl body isstaged)
  (receive
   (names bounds) (sparam-name-bounds sparams '() '())
   (begin
     (let ((anames (llist-vars argl)))
       (if (has-dups (filter (lambda (x) (not (eq? x UNUSED))) anames))
           (error "function argument names not unique"))
       (if (has-dups names)
           (error "function static parameter names not unique"))
       (if (any (lambda (x) (and (not (eq? x UNUSED)) (memq x names))) anames)
           (error "function argument and static parameter names must be distinct")))
     (if (and name (not (sym-ref? name)))
         (error (string "invalid method name \"" (deparse name) "\"")))
     (let* ((iscall (is-call-name? name))
            (name  (if iscall #f name))
            (types (llist-types argl))
            (body  (method-lambda-expr argl body))
            (mdef
             (if (null? sparams)
                 `(method ,name (call (top svec) (curly Tuple ,@(dots->vararg types)) (call (top svec)))
                          ,body ,isstaged)
                 (let* ((gss (map (lambda (x) (make-jlgensym)) names))
                        (renames (map cons names gss)))
                   `(method ,name
                            (block
                             ,@(map make-assignment gss (symbols->typevars names bounds #t))
                             (call (top svec) (curly Tuple ,@(dots->vararg
                                                              (map (lambda (x) (rename-vars x renames))
                                                                   types)))
                                   (call (top svec) ,@gss)))
                            ,body ,isstaged)))))
       (if (and iscall (not (null? argl)))
           (let* ((n (arg-name (car argl)))
                  (n (if (hidden-name? n) "" n))
                  (t (deparse (arg-type (car argl)))))
             (syntax-deprecation #f
                                 (string "call(" n "::" t ", ...)")
                                 (string "(" n "::" t ")(...)"))))
       (if (symbol? name)
           `(block ,mdef ,name)  ;; return the function
           mdef)))))

(define (const-default? x)
  (or (number? x) (string? x) (char? x) (and (pair? x) (memq (car x) '(quote inert)))
      (eq? x 'true) (eq? x 'false)))
(define simple-atom? const-default?)

(define (keywords-method-def-expr name sparams argl body isstaged)
  (let* ((kargl (cdar argl))  ;; keyword expressions (= k v)
         (pargl (cdr argl))   ;; positional args
         (body  (if (and (pair? body) (eq? (car body) 'block))
                    body
                    `(block ,body)))
         (ftype (decl-type (car pargl)))
         ;; 1-element list of vararg argument, or empty if none
         (vararg (let ((l (if (null? pargl) '() (last pargl))))
                   (if (vararg? l)
                       (list l) '())))
         ;; positional args without vararg
         (pargl (if (null? vararg) pargl (butlast pargl)))
         ;; keywords glob
         (restkw (let ((l (last kargl)))
                   (if (vararg? l)
                       (list (cadr l)) '())))
         (kargl (if (null? restkw) kargl (butlast kargl)))
         ;; the keyword::Type expressions
         (vars     (map cadr kargl))
         ;; keyword default values
         (vals     (map caddr kargl))
         ;; just the keyword names
         (keynames (map decl-var vars))
         ;; do some default values depend on other keyword arguments?
         (ordered-defaults (any (lambda (v) (contains
                                             (lambda (x) (eq? x v))
                                             vals))
                                keynames))
         ;; 1-element list of function's line number node, or empty if none
         (lno  (if (and (pair? (cdr body))
                        (pair? (cadr body)) (eq? (caadr body) 'line))
                   (list (cadr body))
                   '()))
         ;; body statements, minus line number node
         (stmts (if (null? lno) (cdr body) (cddr body)))
         (positional-sparams
          (filter (lambda (s)
                    (let ((name (if (symbol? s) s (cadr s))))
                      (or (expr-contains-eq name (cons 'list pargl))
                          (and (pair? vararg) (expr-contains-eq name (car vararg)))
                          (not (expr-contains-eq name (cons 'list kargl))))))
                  sparams))
         (keyword-sparams
          (filter (lambda (s)
                    (let ((name (if (symbol? s) s (cadr s))))
                      (not (expr-contains-eq name (cons 'list positional-sparams)))))
                  sparams))
         (keyword-sparam-names
          (map (lambda (s) (if (symbol? s) s (cadr s))) keyword-sparams)))
    (let ((kw (gensy)) (i (gensy)) (ii (gensy)) (elt (gensy)) (rkw (gensy))
          (mangled (symbol (string "#" (if name (undot-name name) 'call) "#"
				   (string (current-julia-module-counter)))))
          (flags (map (lambda (x) (gensy)) vals)))
      `(block
        ;; call with no keyword args
        ,(method-def-expr-
          name positional-sparams (append pargl vararg)
          `(block
            ,(if (null? lno)
                 `(line 0 || ||)
                 (append (car lno) '(||)))
            ,@(if (not ordered-defaults)
                  '()
                  (map make-assignment keynames vals))
            ;; call mangled(vals..., [rest_kw ,]pargs..., [vararg]...)
            (return (call ,mangled
                          ,@(if ordered-defaults keynames vals)
                          ,@(if (null? restkw) '() '((cell1d)))
                          ,@(map arg-name pargl)
                          ,@(if (null? vararg) '()
                                (list `(... ,(arg-name (car vararg))))))))
          #f)

        ;; call with keyword args pre-sorted - original method code goes here
        ,(method-def-expr-
          mangled sparams
          `((|::| ,mangled (call (top typeof) ,mangled)) ,@vars ,@restkw
            ;; strip type off function self argument if not needed for a static param.
            ;; then it is ok for cl-convert to move this definition above the original def.
            ,(if (decl? (car pargl))
                 (if (any (lambda (sp)
                            (expr-contains-eq (sparam-name sp) (caddr (car pargl))))
                          positional-sparams)
                     (car pargl)
                     (decl-var (car pargl)))
                 (car pargl))
            ,@(cdr pargl) ,@vararg)
          `(block
            ,@(if (null? lno) '()
                  ;; TODO jb/functions get a better `name` for functions specified by type
                  (list (append (car lno) (list (undot-name name)))))
            ,@stmts) isstaged)

        ;; call with unsorted keyword args. this sorts and re-dispatches.
        ,(method-def-expr-
          name
          (filter ;; remove sparams that don't occur, to avoid printing the warning twice
           (lambda (s) (let ((name (if (symbol? s) s (cadr s))))
                         (expr-contains-eq name (cons 'list argl))))
           positional-sparams)
          `((|::| ,UNUSED (call (|.| Core 'kwftype) ,ftype)) (:: ,kw (top Array)) ,@pargl ,@vararg)
          `(block
            (line 0 || ||)
            ;; initialize keyword args to their defaults, or set a flag telling
            ;; whether this keyword needs to be set.
            ,@(map (lambda (name dflt flag)
                     (if (const-default? dflt)
                         `(= ,name ,dflt)
                         `(= ,flag true)))
                   keynames vals flags)
            ,@(if (null? restkw) '()
                  `((= ,rkw (cell1d))))
            ;; for i = 1:(length(kw)>>1)
            (for (= ,i (: 1 (call (top >>) (call (top length) ,kw) 1)))
                 (block
                  ;; ii = i*2 - 1
                  (= ,ii (call (top -) (call (top *) ,i 2) 1))
                  (= ,elt (call (top arrayref) ,kw ,ii))
                  ,(foldl (lambda (kvf else)
                            (let* ((k    (car kvf))
                                   (rval0 `(call (top arrayref) ,kw
                                                 (call (top +) ,ii 1)))
                                   ;; note: if the "declared" type of a KW arg
                                   ;; includes something from keyword-sparam-names,
                                   ;; then don't assert it here, since those static
                                   ;; parameters don't have values yet.
                                   ;; instead, the type will be picked up when the
                                   ;; underlying method is called.
                                   (rval (if (and (decl? k)
                                                  (not (any (lambda (s)
                                                              (expr-contains-eq s (caddr k)))
                                                            keyword-sparam-names)))
                                             `(call (top typeassert)
                                                    ,rval0
                                                    ,(caddr k))
                                             rval0)))
                              ;; if kw[ii] == 'k; k = kw[ii+1]::Type; end
                              `(if (comparison ,elt === (quote ,(decl-var k)))
                                   (block
                                    (= ,(decl-var k) ,rval)
                                    ,@(if (not (const-default? (cadr kvf)))
                                          `((= ,(caddr kvf) false))
                                          '()))
                                   ,else)))
                          (if (null? restkw)
                              ;; if no rest kw, give error for unrecognized
                              `(call (top kwerr) ,elt)
                              ;; otherwise add to rest keywords
                              `(ccall 'jl_cell_1d_push Void (tuple Any Any)
                                      ,rkw (tuple ,elt
                                                  (call (top arrayref) ,kw
                                                        (call (top +) ,ii 1)))))
                          (map list vars vals flags))))
            ;; set keywords that weren't present to their default values
            ,@(apply append
                     (map (lambda (name dflt flag)
                            (if (const-default? dflt)
                                '()
                                `((if ,flag (= ,name ,dflt)))))
                          keynames vals flags))
            ;; finally, call the core function
            (return (call ,mangled
                          ,@keynames
                          ,@(if (null? restkw) '() (list rkw))
                          ,@(map arg-name pargl)
                          ,@(if (null? vararg) '()
                                (list `(... ,(arg-name (car vararg))))))))
          #f)
        ;; return primary function
        ,(if (or (not (symbol? name)) (is-call-name? name))
             '(null) name)))))

(define (optional-positional-defs name sparams req opt dfl body isstaged overall-argl . kw)
  ;; prologue includes line number node and eventual meta nodes
  (let ((prologue (if (pair? body)
                       (take-while (lambda (e)
                                     (and (pair? e) (or (eq? (car e) 'line) (eq? (car e) 'meta))))
                                   (cdr body))
                       '())))
  `(block
    ,@(map (lambda (n)
             (let* ((passed (append req (list-head opt n)))
                    ;; only keep static parameters used by these arguments
                    (sp     (filter (lambda (sp)
                                      (contains (lambda (e) (eq? e (sparam-name sp)))
                                                passed))
                                    sparams))
                    (vals   (list-tail dfl n))
                    (absent (list-tail opt n)) ;; absent arguments
                    (body
                     (if (any (lambda (defaultv)
                                ;; does any default val expression...
                                (contains (lambda (e)
                                            ;; contain "e" such that...
                                            (any (lambda (a)
                                                   ;; "e" is in an absent arg
                                                   (contains (lambda (u)
                                                               (eq? u e))
                                                             a))
                                                 absent))
                                          defaultv))
                              vals)
                         ;; then add only one next argument
                         `(block
                           ,@prologue
                           (call ,(arg-name (car req)) ,@kw ,@(map arg-name (cdr passed)) ,(car vals)))
                         ;; otherwise add all
                         `(block
                           ,@prologue
                           (call ,(arg-name (car req)) ,@kw ,@(map arg-name (cdr passed)) ,@vals)))))
               (method-def-expr name sp (append kw passed) body #f)))
           (iota (length opt)))
    ,(method-def-expr name sparams overall-argl body isstaged))))

(define (remove-empty-parameters argl)
  (if (and (has-parameters? argl) (null? (cdar argl)))
      (cdr argl)
      argl))

(define (method-def-expr name sparams argl body isstaged)
  (let ((argl (remove-empty-parameters argl)))
    (if (any kwarg? argl)
        ;; has optional positional args
        (begin
          (let check ((l     argl)
                      (seen? #f))
            (if (pair? l)
                (if (kwarg? (car l))
                    (check (cdr l) #t)
                    (if (and seen? (not (vararg? (car l))))
                        (error "optional positional arguments must occur at end")
                        (check (cdr l) #f)))))
          (receive
           (kws argl) (separate kwarg? argl)
           (let ((opt  (map cadr  kws))
                 (dfl  (map caddr kws)))
             (if (has-parameters? argl)
                 ;; both!
                 ;; separate into keyword version with all positional args,
                 ;; and a series of optional-positional-defs that delegate keywords
                 (let ((kw   (car argl))
                       (argl (cdr argl)))
                   (check-kw-args (cdr kw))
                   (receive
                    (vararg req) (separate vararg? argl)
                    (optional-positional-defs name sparams req opt dfl body isstaged
                                              (cons kw (append req opt vararg))
                                              `(parameters (... ,(gensy))))))
                 ;; optional positional only
                 (receive
                  (vararg req) (separate vararg? argl)
                  (optional-positional-defs name sparams req opt dfl body isstaged
                                            (append req opt vararg)))))))
        (if (has-parameters? argl)
            ;; keywords only
            (begin (check-kw-args (cdar argl))
                   (keywords-method-def-expr name sparams argl body isstaged))
            ;; neither
            (method-def-expr- name sparams argl body isstaged)))))

;; remove nested blocks
(define (flatten-blocks e)
  (if (atom? e)
      e
      (apply append!
             (map (lambda (x)
                    (cond ((atom? x) (list x))
                          ((eq? (car x) 'block) (cdr (flatten-blocks x)))
                          (else (list x))))
                  e))))

(define (struct-def-expr name params super fields mut)
  (receive
   (params bounds) (sparam-name-bounds params '() '())
   (struct-def-expr- name params bounds super (flatten-blocks fields) mut)))

;; replace field names with gensyms if they conflict with field-types
(define (safe-field-names field-names field-types)
  (if (any (lambda (v) (contains (lambda (e) (eq? e v)) field-types))
           field-names)
      (map (lambda (x) (gensy)) field-names)
      field-names))

(define (default-inner-ctors name field-names field-types gen-specific? locs)
  (let* ((field-names (safe-field-names field-names field-types))
         (any-ctor
          ;; definition with Any for all arguments
          `(function (call ,name ,@field-names)
                     (block
		      ,@locs
                      (call new ,@field-names)))))
    (if (and gen-specific? (any (lambda (t) (not (eq? t 'Any))) field-types))
        (list
         ;; definition with field types for all arguments
         `(function (call ,name
                          ,@(map make-decl field-names field-types))
                    (block
		     ,@locs
                     (call new ,@field-names)))
         any-ctor)
        (list any-ctor))))

(define (default-outer-ctor name field-names field-types params bounds locs)
  (let ((field-names (safe-field-names field-names field-types)))
    `(function (call (curly ,name
                            ,@(map (lambda (p b) `(<: ,p ,b))
                                   params bounds))
                     ,@(map make-decl field-names field-types))
               (block
		,@locs
                (call (curly ,name ,@params) ,@field-names)))))

(define (new-call Tname type-params params args field-names field-types mutabl)
  (if (any vararg? args)
      (error "... is not supported inside \"new\""))
  (if (any kwarg? args)
      (error "\"new\" does not accept keyword arguments"))
  (if (length> params (length type-params))
      (error "too few type parameters specified in \"new{...}\""))
  (let ((Texpr (if (null? type-params)
                   `(|.| ,(current-julia-module) ',Tname)
                   `(curly (|.| ,(current-julia-module) ',Tname)
                           ,@type-params))))
    (cond ((length> args (length field-names))
           `(call (top error) "new: too many arguments"))
          (else
           (if (equal? type-params params)
               `(new ,Texpr ,@(map (lambda (fty val)
                                     `(call (top convert) ,fty ,val))
                                   (list-head field-types (length args)) args))
               (let ((tn (gensy)))
                 `(let (new ,tn ,@(map (lambda (fld val)
                                         `(call (top convert)
                                                (call (top fieldtype) ,tn (quote ,fld))
                                                ,val))
                                       (list-head field-names (length args)) args))
                    (= ,tn ,Texpr))))))))

;; insert a statement after line number node
(define (prepend-stmt stmt body)
  (if (and (pair? body) (eq? (car body) 'block))
      (cond ((atom? (cdr body))
             `(block ,stmt (null)))
            ((and (pair? (cadr body)) (eq? (caadr body) 'line))
             `(block ,(cadr body) ,stmt ,@(cddr body)))
            (else
             `(block ,stmt ,@(cdr body))))
      body))

;; insert item at start of arglist
(define (arglist-unshift sig item)
  (if (and (pair? sig) (pair? (car sig)) (eq? (caar sig) 'parameters))
      `(,(car sig) ,item ,@(cdr sig))
      `(,item ,@sig)))

(define (ctor-signature name params bounds method-params sig)
  (if (null? params)
      (if (null? method-params)
          (cons `(call (|::| (curly Type ,name)) ,@sig)
                params)
          (cons `(call (curly (|::| (curly Type ,name)) ,@method-params) ,@sig)
                params))
      (if (null? method-params)
          (cons `(call (curly (|::| (curly Type (curly ,name ,@params)))
                              ,@(map (lambda (p b) `(<: ,p ,b)) params bounds))
                       ,@sig)
                params)
          ;; rename parameters that conflict with user-written method parameters
          (let ((new-params (map (lambda (p) (if (memq p method-params)
                                                 (gensy)
                                                 p))
                                 params)))
            (cons `(call (curly (|::| (curly Type (curly ,name ,@new-params)))
                                ,@(map (lambda (p b) `(<: ,p ,b)) new-params bounds)
                                ,@method-params)
                         ,@sig)
                  new-params)))))

(define (ctor-def keyword name Tname params bounds method-params sig ctor-body body)
  (if (eq? name Tname)
      (let* ((temp   (ctor-signature name params bounds method-params sig))
             (sig    (car temp))
             (params (cdr temp)))
        `(,keyword ,sig ,(ctor-body body params)))
      `(,keyword (call (curly ,name ,@method-params) ,@sig)
                 ;; pass '() in order to require user-specified parameters with
                 ;; new{...} inside a non-ctor inner definition.
                 ,(ctor-body body '()))))

(define (rewrite-ctor ctor Tname params bounds field-names field-types mutabl)
  (define (ctor-body body type-params)
    (pattern-replace (pattern-set
                      (pattern-lambda
                       (call (-/ new) . args)
                       (new-call Tname type-params params
                                 (map (lambda (a) (ctor-body a type-params)) args)
				 field-names field-types mutabl))
                      (pattern-lambda
                       (call (curly (-/ new) . p) . args)
                       (new-call Tname p params
                                 (map (lambda (a) (ctor-body a type-params)) args)
				 field-names field-types mutabl)))
                     body))
  (pattern-replace
   (pattern-set
    (pattern-lambda (function (call (curly name . p) . sig) body)
                    (ctor-def 'function name Tname params bounds p sig ctor-body body))
    (pattern-lambda (stagedfunction (call (curly name . p) . sig) body)
                    (ctor-def 'stagedfunction name Tname params bounds p sig ctor-body body))
    (pattern-lambda (function (call name . sig) body)
                    (ctor-def 'function name Tname params bounds '() sig ctor-body body))
    (pattern-lambda (stagedfunction (call name . sig) body)
                    (ctor-def 'stagedfunction name Tname params bounds '() sig ctor-body body))
    (pattern-lambda (= (call (curly name . p) . sig) body)
                    (ctor-def 'function name Tname params bounds p sig ctor-body body))
    (pattern-lambda (= (call name . sig) body)
                    (ctor-def 'function name Tname params bounds '() sig ctor-body body)))
   ctor))

;; check if there are any calls to new with fewer than n arguments
(define (ctors-min-initialized expr)
  (and (pair? expr)
   (min
    ((pattern-lambda
      (call (-/ new) . args)
      (length args)) (car expr))
    ((pattern-lambda
      (call (curly (-/ new) . p) . args)
      (length args)) (car expr))
    (ctors-min-initialized (car expr))
    (ctors-min-initialized (cdr expr)))))

(define (struct-def-expr- name params bounds super fields0 mut)
  (receive
   (fields defs) (separate (lambda (x) (or (symbol? x) (decl? x)))
                           fields0)
   (let* ((defs        (filter (lambda (x) (not (effect-free? x))) defs))
	  (locs        (if (and (pair? fields0) (pair? (car fields0)) (eq? (caar fields0) 'line))
			   (list (car fields0))
			   '()))
          (field-names (map decl-var fields))
          (field-types (map decl-type fields))
          (defs2 (if (null? defs)
                     (default-inner-ctors name field-names field-types (null? params) locs)
                     defs))
          (min-initialized (min (ctors-min-initialized defs) (length fields))))
     (let ((dups (has-dups field-names)))
       (if dups (error (string "duplicate field name: \"" (car dups) "\" is not unique"))))
     (for-each (lambda (v)
                 (if (not (symbol? v))
                     (error (string "field name \"" (deparse v) "\" is not a symbol"))))
               field-names)
     `(block
       (scope-block
	(block
	 (global ,name) (const ,name)
	 ,@(map (lambda (v) `(local ,v)) params)
	 ,@(map make-assignment params (symbols->typevars params bounds #t))
	 (composite_type ,name (call (top svec) ,@params)
			 (call (top svec) ,@(map (lambda (x) `',x) field-names))
			 ,super (call (top svec) ,@field-types) ,mut ,min-initialized)))
       ;; "inner" constructors
       (scope-block
	(block
	 (global ,name)
	 ,@(map (lambda (c)
		  (rewrite-ctor c name params bounds field-names field-types mut))
		defs2)))
       ;; "outer" constructors
       ,@(if (and (null? defs)
		  (not (null? params))
		  ;; don't generate an outer constructor if the type has
		  ;; parameters not mentioned in the field types. such a
		  ;; constructor would not be callable anyway.
		  (every (lambda (sp)
			   (expr-contains-eq sp (cons 'list field-types)))
			 params))
	     `((scope-block
		(block
		 (global ,name)
		 ,(default-outer-ctor name field-names field-types
		    params bounds locs))))
	     '())
       (null)))))

(define (abstract-type-def-expr name params super)
  (receive
   (params bounds)
   (sparam-name-bounds params '() '())
   `(block
     (const ,name)
     (scope-block
      (block
       ,@(map (lambda (v) `(local ,v)) params)
       ,@(map make-assignment params (symbols->typevars params bounds #f))
       (abstract_type ,name (call (top svec) ,@params) ,super))))))

(define (bits-def-expr n name params super)
  (receive
   (params bounds)
   (sparam-name-bounds params '() '())
   `(block
     (const ,name)
     (scope-block
      (block
       ,@(map (lambda (v) `(local ,v)) params)
       ,@(map make-assignment params (symbols->typevars params bounds #f))
       (bits_type ,name (call (top svec) ,@params) ,n ,super))))))

; take apart a type signature, e.g. T{X} <: S{Y}
(define (analyze-type-sig ex)
  (or ((pattern-lambda (-- name (-s))
                       (values name '() 'Any)) ex)
      ((pattern-lambda (curly (-- name (-s)) . params)
                       (values name params 'Any)) ex)
      ((pattern-lambda (|<:| (-- name (-s)) super)
                       (values name '() super)) ex)
      ((pattern-lambda (|<:| (curly (-- name (-s)) . params) super)
                       (values name params super)) ex)
      (error "invalid type signature")))

;; insert calls to convert() in ccall, and pull out expressions that might
;; need to be rooted before conversion.
(define (lower-ccall name RT atypes args)
  (let loop ((F atypes)  ;; formals
             (A args)    ;; actuals
             (stmts '()) ;; initializers
             (C '()))    ;; converted
    (if (or (null? F) (null? A))
        `(block
          ,.(reverse! stmts)
          (call (top ccall) ,name ,RT (call (top svec) ,@(dots->vararg atypes))
		,.(reverse! C)
                ,@A))
        (let* ((a     (car A))
               (isseq (and (pair? (car F)) (eq? (caar F) '...)))
               (ty    (if isseq (cadar F) (car F))))
          (if (eq? ty 'Any)
            (loop (if isseq F (cdr F)) (cdr A) stmts (list* 0 a C))
            (let* ((g (make-jlgensym))
                   (isamp (and (pair? a) (eq? (car a) '&)))
                   (a (if isamp (cadr a) a))
                   (stmts (cons `(= ,g (call (top ,(if isamp 'ptr_arg_cconvert 'cconvert)) ,ty ,a)) stmts))
                   (ca `(call (top ,(if isamp 'ptr_arg_unsafe_convert 'unsafe_convert)) ,ty ,g)))
              (loop (if isseq F (cdr F)) (cdr A) stmts
                    (list* g (if isamp `(& ,ca) ca) C))))))))

(define (block-returns? e)
  (if (assignment? e)
      (block-returns? (caddr e))
      (and (pair? e) (eq? (car e) 'block)
           (any return? (cdr e)))))

(define (replace-return e bb ret retval)
  (cond ((or (atom? e) (quoted? e)) e)
        ((or (eq? (car e) 'lambda)
             (eq? (car e) 'function)
             (eq? (car e) 'stagedfunction)
             (eq? (car e) '->)) e)
        ((eq? (car e) 'return)
         `(block ,@(if ret `((= ,ret true)) '())
                 (= ,retval ,(cadr e))
                 (break ,bb)))
        (else (map (lambda (x) (replace-return x bb ret retval)) e))))

(define (expand-binding-forms e)
  (cond
   ((atom? e) e)
   ((quoted? e) e)
   (else
    (case (car e)
      ((function stagedfunction)
       (let ((name (cadr e)))
         (cond ((and (length= e 2) (symbol? name))  `(method ,name))
               ((not (pair? name))                  e)
               ((eq? (car name) 'tuple)
                (expand-binding-forms `(-> ,name ,(caddr e))))
               ((eq? (car name) 'call)
                (let* ((head    (cadr name))
                       (argl    (cddr name))
                       (has-sp  (and (pair? head) (eq? (car head) 'curly)))
                       (name    (if has-sp (cadr head) head))
                       (sparams (if has-sp (cddr head) '()))
                       (isstaged (eq? (car e) 'stagedfunction))
                       (adj-decl (lambda (n) (if (and (decl? n) (length= n 2))
                                                 `(|::| |#self#| ,(cadr n))
                                                 n)))
                       ;; fill in first (closure) argument
                       (farg    (if (decl? name)
                                    (adj-decl name)
                                    `(|::| |#self#| (call (|.| Core 'Typeof) ,name))))
                       (argl    (fix-arglist
                                 (if (and (not (decl? name)) (eq? (undot-name name) 'call))
                                     (cons (adj-decl (car argl)) (cdr argl))
                                     (arglist-unshift argl farg))
                                 (and (not (any kwarg? argl)) (not (and (pair? argl)
                                                                        (pair? (car argl))
                                                                        (eq? (caar argl) 'parameters))))))
                       (name    (if (decl? name) #f name)))
                  (expand-binding-forms
                   (method-def-expr name sparams argl (caddr e) isstaged))))
               (else e))))

      ((->)
       (let ((a    (cadr e))
             (body (caddr e)))
         (let ((argl (if (pair? a)
                         (if (eq? (car a) 'tuple)
                             (map =-to-kw (cdr a))
                             (if (eq? (car a) 'block)
                                 (cond ((length= a 1) '())
                                       ((length= a 2) (list (cadr a)))
                                       ((length= a 3)
                                        (if (assignment? (caddr a))
                                            `((parameters (kw ,@(cdr (caddr a)))) ,(cadr a))
                                            `((parameters ,(caddr a)) ,(cadr a))))
                                       (else
                                        (error "more than one semicolon in argument list")))
                                 (list (=-to-kw a))))
			 (list a)))
	       ;; TODO: always use a specific special name like #anon# or _, then ignore
	       ;; this as a local variable name.
	       (name (symbol (string "#" (current-julia-module-counter)))))
           (expand-binding-forms
	    `(block (local ,name)
                    (function (call ,name ,@argl) ,body))))))

      ((let)
       (let ((ex (cadr e))
             (binds (cddr e)))
         (expand-binding-forms
          (if
           (null? binds)
           `(scope-block (block ,ex))
           (let loop ((binds (reverse binds))
                      (blk   ex))
             (if (null? binds)
                 blk
                 (cond
                  ((or (symbol? (car binds)) (decl? (car binds)))
                   ;; just symbol -> add local
                   (loop (cdr binds)
                         `(scope-block
                           (block
                            (local ,(car binds))
                            (newvar ,(decl-var (car binds)))
                            ,blk))))
                  ((and (length= (car binds) 3)
                        (eq? (caar binds) '=))
                   ;; some kind of assignment
                   (cond
                    ((or (symbol? (cadar binds))
                         (decl?   (cadar binds)))
                     (let ((vname (decl-var (cadar binds))))
                       (loop (cdr binds)
                             (if (contains (lambda (x) (eq? x vname))
                                           (caddar binds))
                                 (let ((tmp (make-jlgensym)))
                                   `(scope-block
                                     (block (= ,tmp ,(caddar binds))
                                      (scope-block
                                       (block
                                        (local ,(cadar binds))
                                        (newvar ,vname)
                                        (= ,vname ,tmp)
                                        ,blk)))))
                                 `(scope-block
                                   (block
                                    (local ,(cadar binds))
                                    (newvar ,vname)
                                    (= ,vname ,(caddar binds))
                                    ,blk))))))
                    ((and (pair? (cadar binds))
                          (eq? (caadar binds) 'call))
                     ;; f()=c
                     (let* ((asgn (butlast (expand-binding-forms (car binds))))
                            (name (cadr (cadar binds)))
                            (name (cond ((symbol? name) name)
                                        ((and (pair? name) (eq? (car name) 'curly))
                                         (cadr name))
                                        (else (error "invalid let syntax")))))
                       (loop (cdr binds)
                             `(scope-block
                               (block
                                (local ,name)
                                (newvar ,name)
                                ,asgn
                                ,blk)))))
                    (else (error "invalid let syntax"))))
                  (else (error "invalid let syntax")))))))))

      ((macro)
       (cond ((and (pair? (cadr e))
                   (eq? (car (cadr e)) 'call)
                   (symbol? (cadr (cadr e))))
              (let ((anames (cddr (cadr e))))
                (expand-binding-forms
                 `(function (call ,(symbol (string #\@ (cadr (cadr e))))
                                  ,@(map (lambda (v)
                                           (if (symbol? v)
                                               `(|::| ,v (top ANY))
                                               v))
                                         anames))
                            ,@(cddr e)))))
             (else
              (error "invalid macro definition"))))

      ((type)
       (let ((mut (cadr e))
             (sig (caddr e))
             (fields (cdr (cadddr e))))
	 (let loop ((f fields))
	   (if (null? f)
	       '()
	       (let ((x (car f)))
		 (cond ((or (symbol? x) (decl? x) (and (pair? x) (eq? (car x) 'line)))
			(loop (cdr f)))
		       ((and (assignment? x) (or (symbol? (cadr x)) (decl? (cadr x))))
			(error (string "\"" (deparse x) "\" inside type definition is reserved")))
		       (else '())))))
         (expand-binding-forms
          (receive (name params super) (analyze-type-sig sig)
                   (struct-def-expr name params super fields mut)))))

      ((try)
       (if (length= e 5)
           (let (;; expand inner try blocks first, so their return statements
                 ;; will have been moved for `finally`, causing correct
                 ;; chaining behavior when the current (outer) try block is
                 ;; expanded.
                 (tryb (expand-binding-forms (cadr e)))
                 (var  (caddr e))
                 (catchb (cadddr e))
                 (finalb (cadddr (cdr e))))
             (if (has-unmatched-symbolic-goto? tryb)
                 (error "goto from a try/finally block is not permitted"))
             (let ((hasret (or (contains return? tryb)
                               (contains return? catchb))))
               (let ((err (gensy))
                     (ret (and hasret
                               (or (not (block-returns? tryb))
                                   (and catchb
                                        (not (block-returns? catchb))))
                               (gensy)))
                     (retval (if hasret (gensy) #f))
                     (bb  (gensy))
		     (finally-exception (gensy))
                     (val (gensy))) ;; this is jlgensym, but llvm has trouble determining that it dominates all uses
                 (let ((tryb   (replace-return tryb bb ret retval))
                       (catchb (replace-return catchb bb ret retval)))
                   (expand-binding-forms
                    `(scope-block
                      (block
                       ,@(if hasret `((local ,retval)) '())
                       (local ,val)
		       (local ,finally-exception)
                       (= ,err false)
                       ,@(if ret `((= ,ret false)) '())
                       (break-block
                        ,bb
                        (try (= ,val
                                ,(if catchb
                                     `(try ,tryb ,var ,catchb)
                                     tryb))
                             #f
                             (= ,err true)))
		       (= ,finally-exception (the_exception))
                       ,finalb
                       (if ,err (ccall 'jl_rethrow_other Void (tuple Any) ,finally-exception))
                       ,(if hasret
                            (if ret
                                `(if ,ret (return ,retval) ,val)
                                `(return ,retval))
                            val))))))))
           (if (length= e 4)
               (let ((tryb (cadr e))
                     (var  (caddr e))
                     (catchb (cadddr e)))
                 (expand-binding-forms
                  (if (symbol-like? var)
                      `(trycatch (scope-block ,tryb)
                                 (scope-block
                                  (block (= ,var (the_exception))
                                         ,catchb)))
                      `(trycatch (scope-block ,tryb)
                                 (scope-block ,catchb)))))
               (map expand-binding-forms e))))

      ((=)
       (if (and (pair? (cadr e))
                (eq? (car (cadr e)) 'call))
           (expand-binding-forms (cons 'function (cdr e)))
           (map expand-binding-forms e)))

      ((const)
       (if (atom? (cadr e))
           e
           (case (car (cadr e))
             ((global local)
              (expand-binding-forms
               (qualified-const-expr (cdr (cadr e)) e)))
             ((=)
              (let ((lhs (cadr (cadr e)))
                    (rhs (caddr (cadr e))))
                (let ((vars (if (and (pair? lhs) (eq? (car lhs) 'tuple))
                                (cdr lhs)
                                (list lhs))))
                  `(block
                    ,.(map (lambda (v)
                             `(const ,(const-check-symbol (decl-var v))))
                           vars)
                    ,(expand-binding-forms `(= ,lhs ,rhs))))))
             (else
              e))))

      ((local global)
       (if (and (symbol? (cadr e)) (length= e 2))
           e
           (expand-binding-forms (expand-decls (car e) (cdr e)))))

      ((typealias)
       (if (and (pair? (cadr e))
                (eq? (car (cadr e)) 'curly))
           (let ((name (cadr (cadr e)))
                 (params (cddr (cadr e)))
                 (type-ex (caddr e)))
             (receive
              (params bounds) (sparam-name-bounds params '() '())
	      `(block
		(const ,name)
		(= ,name
		   (scope-block
		    (block
		     ,@(map (lambda (v) `(local ,v)) params)
		     ,@(map make-assignment params (symbols->typevars params bounds #t))
		     (call (top TypeConstructor)
			   (call (top svec) ,@params)
			   ,(expand-binding-forms type-ex))))))))
           (expand-binding-forms
            `(const (= ,(cadr e) ,(caddr e))))))

      ((module) e)

      (else
       (map expand-binding-forms e))))))

(define (assigned-name e)
  (if (and (pair? e) (memq (car e) '(call curly)))
      (assigned-name (cadr e))
      e))

; local x, y=2, z => local x;local y;local z;y = 2
(define (expand-decls what binds)
  (if (not (list? binds))
      (error (string "invalid \"" what "\" declaration")))
  (let loop ((b       binds)
             (vars    '())
             (assigns '()))
    (if (null? b)
        (if (and (null? assigns)
                 (length= vars 1))
            `(,what ,(car vars))
            `(block
              ,.(map (lambda (x) `(,what ,x)) vars)
              ,.(reverse assigns)))
        (let ((x (car b)))
          (cond ((assignment-like? x)
                 (loop (cdr b)
                       (cons (assigned-name (cadr x)) vars)
                       (cons `(,(car x) ,(decl-var (cadr x)) ,(caddr x))
                             assigns)))
                ((and (pair? x) (eq? (car x) '|::|))
                 (loop (cdr b)
                       (cons (decl-var x) vars)
                       (cons x assigns)))
                ((symbol? x)
                 (loop (cdr b) (cons x vars) assigns))
                (else
                 (error (string "invalid syntax in \"" what "\" declaration"))))))))

(define (const-check-symbol s)
  (if (not (symbol? s))
      (error "expected identifier after \"const\"")
      s))

(define (qualified-const-expr binds __)
  (let ((vs (map (lambda (b)
                   (if (assignment? b)
                       (const-check-symbol (decl-var (cadr b)))
                       (error "expected assignment after \"const\"")))
                 binds)))
    `(block ,@(map (lambda (v) `(const ,v)) vs)
            ,(cadr __))))

(define (mem-jlgensym item lst)
  (cond ((atom? lst) #f)
        ((and (jlgensym? (car lst)) (eq? (car lst) item)) #t)
        (#t (mem-jlgensym item (cdr lst)))))

;; convert (lhss...) = (tuple ...) to assignments, eliminating the tuple
(define (tuple-to-assignments lhss0 x)
  (let loop ((lhss lhss0)
             (assigned lhss0)
             (rhss (cdr x))
             (stmts '())
             (after '())
             (elts  '()))
    (if (null? lhss)
        `(block ,@(reverse stmts)
                ,@(reverse after)
                (unnecessary-tuple (tuple ,@(reverse elts))))
        (let ((L (car lhss))
              (R (car rhss)))
          (if (and (symbol-like? L)
                   (or (not (pair? R)) (quoted? R) (equal? R '(null)))
                   ;; overwrite var immediately if it doesn't occur elsewhere
                   (not (contains (lambda (e) (eq-sym? e L)) (cdr rhss)))
                   (not (contains (lambda (e) (eq-sym? e R)) assigned)))
              (loop (cdr lhss)
                    (cons L assigned)
                    (cdr rhss)
                    (cons (make-assignment L R) stmts)
                    after
                    (cons R elts))
              (let ((temp (make-jlgensym)))
                (loop (cdr lhss)
                      (cons L assigned)
                      (cdr rhss)
                      (cons (make-assignment temp R) stmts)
                      (cons (make-assignment L temp) after)
                      (cons temp elts))))))))

;; convert (lhss...) = x to tuple indexing
(define (lower-tuple-assignment lhss x)
  (let ((t (make-jlgensym)))
    `(block
      (= ,t ,x)
      ,@(let loop ((lhs lhss)
                   (i   1))
          (if (null? lhs) '((null))
              (cons `(= ,(car lhs)
                        (call (top getfield) ,t ,i))
                    (loop (cdr lhs)
                          (+ i 1)))))
      ,t)))

(define (check-kw-args kw)
  (let ((invalid (filter (lambda (x) (not (or (kwarg? x)
                                              (vararg? x))))
                         kw)))
    (if (pair? invalid)
        (if (and (pair? (car invalid)) (eq? 'parameters (caar invalid)))
            (error "more than one semicolon in argument list")
            (cond ((symbol? (car invalid))
                   (error (string "keyword argument \"" (car invalid) "\" needs a default value")))
                  (else
                   (error (string "invalid keyword argument syntax \""
                                  (deparse (car invalid))
                                  "\" (expected assignment)"))))))))

(define (lower-kw-call f kw pa)
  (if (any (lambda (x) (and (pair? x) (eq? (car x) 'parameters)))
           kw)
      (error "more than one semicolon in argument list"))
  (receive
   (keys restkeys) (separate kwarg? kw)
   (let ((keyargs (apply append
                         (map (lambda (a)
                                (if (not (symbol? (cadr a)))
                                    (error (string "keyword argument is not a symbol: \""
                                                   (deparse (cadr a)) "\"")))
                                (if (vararg? (caddr a))
                                    (error "splicing with \"...\" cannot be used for a keyword argument value"))
                                `((quote ,(cadr a)) ,(caddr a)))
                              keys))))
     (if (null? restkeys)
         `(call (call (top kwfunc) ,f) (cell1d ,@keyargs) ,f ,@pa)
         (let ((container (make-jlgensym)))
           `(block
             (= ,container (cell1d ,@keyargs))
             ,@(map (lambda (rk)
                      (let* ((k (make-jlgensym))
                             (v (make-jlgensym))
                             (push-expr `(ccall 'jl_cell_1d_push2 Void
                                                (tuple Any Any Any)
                                                ,container
                                                (|::| ,k (top Symbol))
                                                ,v)))
                        (if (vararg? rk)
                            `(for (= (tuple ,k ,v) ,(cadr rk))
                                  ,push-expr)
                            `(block (= (tuple ,k ,v) ,rk)
                                    ,push-expr))))
                    restkeys)
             ,(if (not (null? keys))
                  `(call (call (top kwfunc) ,f) ,container ,f ,@pa)
                  (let* ((expr_stmts (remove-argument-side-effects `(call ,f ,@pa)))
                         (pa         (cddr (car expr_stmts)))
                         (stmts      (cdr expr_stmts)))
                    `(block
                      ,@stmts
                      (if (call (top isempty) ,container)
                          (call ,f ,@pa)
                          (call (call (top kwfunc) ,f) ,container ,f ,@pa)))))))))))

(define (expand-transposed-op e ops)
  (let ((a (caddr e))
        (b (cadddr e)))
    (cond ((ctrans? a)
           (if (ctrans? b)
               `(call ,(aref ops 0) #;Ac_mul_Bc ,(expand-forms (cadr a))
                      ,(expand-forms (cadr b)))
               `(call ,(aref ops 1) #;Ac_mul_B ,(expand-forms (cadr a))
                      ,(expand-forms b))))
          ((trans? a)
           (if (trans? b)
               `(call ,(aref ops 2) #;At_mul_Bt ,(expand-forms (cadr a))
                      ,(expand-forms (cadr b)))
               `(call ,(aref ops 3) #;At_mul_B ,(expand-forms (cadr a))
                      ,(expand-forms b))))
          ((ctrans? b)
           `(call ,(aref ops 4) #;A_mul_Bc ,(expand-forms a)
                  ,(expand-forms (cadr b))))
          ((trans? b)
           `(call ,(aref ops 5) #;A_mul_Bt ,(expand-forms a)
                  ,(expand-forms (cadr b))))
          (else
           `(call ,(cadr e) ,(expand-forms a) ,(expand-forms b))))))

(define (lower-update-op e)
  (expand-forms
   (expand-update-operator
    (let ((str (string (car e))))
      (symbol (string.sub str 0 (- (length str) 1))))
    (cadr e)
    (caddr e))))

(define (expand-for while lhs X body)
  ;; (for (= lhs X) body)
  (let ((coll  (make-jlgensym))
        (state (gensy)))
    `(scope-block
      (block (= ,coll ,(expand-forms X))
             (= ,state (call (top start) ,coll))
             ,(expand-forms
               `(,while
                 (call (top !) (call (top done) ,coll ,state))
                 (scope-block
                  (block
                   ;; NOTE: enable this to force loop-local var
                   #;,@(map (lambda (v) `(local ,v)) (lhs-vars lhs))
                   ,(lower-tuple-assignment (list lhs state)
                                            `(call (top next) ,coll ,state))
                   ,body))))))))

(define (map-expand-forms e) (map expand-forms e))

(define (expand-forms e)
  (if (atom? e)
      e
      ((get expand-table (car e) map-expand-forms) e)))

(define expand-table
  (table
   'quote identity
   'inert identity
   'top   identity
   'line  identity
   'module identity

   'lambda
   (lambda (e) (list* 'lambda (map expand-forms (cadr e)) (map expand-forms (cddr e))))

   'block
   (lambda (e)
     (if (null? (cdr e))
         '(block (null))
         (map expand-forms e)))

   '|.|
   (lambda (e)
     `(call (top getfield) ,(expand-forms (cadr e)) ,(expand-forms (caddr e))))

   'in
   (lambda (e)
     `(call in ,(expand-forms (cadr e)) ,(expand-forms (caddr e))))

   '=
   (lambda (e)
     (if (or (atom? (cadr e)) (jlgensym? (cadr e)))
         `(= ,(cadr e) ,(expand-forms (caddr e)))
         (case (car (cadr e))
           ((|.|)
            ;; a.b =
            (let ((a (cadr (cadr e)))
                  (b (caddr (cadr e)))
                  (rhs (expand-forms (caddr e))))
              (let ((aa (if (atom? a) a (make-jlgensym)))
                    (bb (if (or (atom? b) (quoted? b)) b (make-jlgensym)))
                    (rr (if (atom? rhs) rhs (make-jlgensym))))
                `(block
                  ,.(if (eq? aa a)   '() `((= ,aa ,(expand-forms a))))
                  ,.(if (eq? bb b)   '() `((= ,bb ,(expand-forms b))))
                  ,.(if (eq? rr rhs) '() `((= ,rr ,rhs)))
                  (call (top setfield!) ,aa ,bb
                        (call (top convert)
                              (call (top fieldtype) (call (top typeof) ,aa) ,bb)
                              ,rr))
                  ,rr))))

           ((tuple)
            ;; multiple assignment
            (let ((lhss (cdr (cadr e)))
                  (x    (caddr e)))
              (if (and (pair? x) (pair? lhss) (eq? (car x) 'tuple)
                       (length= lhss (length (cdr x))))
                  ;; (a, b, ...) = (x, y, ...)
                  (expand-forms
                   (tuple-to-assignments lhss x))
                  ;; (a, b, ...) = other
                  (let* ((xx  (if (and (symbol? x) (not (memq x lhss)))
                                  x (make-jlgensym)))
                         (ini (if (eq? x xx) '() `((= ,xx ,(expand-forms x)))))
                         (st  (gensy)))
                    `(block
                      ,@ini
                      (= ,st (call (top start) ,xx))
                      ,.(map (lambda (i lhs)
                               (expand-forms
                                (lower-tuple-assignment
                                 (list lhs st)
                                 `(call (top indexed_next)
                                        ,xx ,(+ i 1) ,st))))
                             (iota (length lhss))
                             lhss)
                      ,xx)))))

           ((typed_hcat)
            (error "invalid spacing in left side of indexed assignment"))
           ((typed_vcat)
            (error "unexpected \";\" in left side of indexed assignment"))

           ((ref)
            ;; (= (ref a . idxs) rhs)
            (let ((a    (cadr (cadr e)))
                  (idxs (cddr (cadr e)))
                  (rhs  (caddr e)))
              (let* ((reuse (and (pair? a)
                                 (contains (lambda (x)
                                             (or (eq? x 'end)
                                                 (and (pair? x)
                                                      (eq? (car x) ':))))
                                           idxs)))
                     (arr   (if reuse (make-jlgensym) a))
                     (stmts (if reuse `((= ,arr ,(expand-forms a))) '())))
                (let* ((rrhs (and (pair? rhs) (not (jlgensym? rhs)) (not (quoted? rhs))))
                       (r    (if rrhs (make-jlgensym) rhs))
                       (rini (if rrhs `((= ,r ,(expand-forms rhs))) '())))
                  (receive
                   (new-idxs stuff) (process-indexes arr idxs)
                   `(block
                     ,@stmts
                     ,.(map expand-forms stuff)
                     ,@rini
                     ,(expand-forms
                       `(call setindex! ,arr ,r ,@new-idxs))
                     ,r))))))

           ((|::|)
            ;; (= (|::| x T) rhs)
            (let ((x (cadr (cadr e)))
                  (T (caddr (cadr e)))
                  (rhs (caddr e)))
              (let ((e (remove-argument-side-effects x)))
                (expand-forms
                 `(block ,@(cdr e)
                         (|::| ,(car e) ,T)
                         (= ,(car e) ,rhs))))))

           ((vcat)
            ;; (= (vcat . args) rhs)
            (error "use \"(a, b) = ...\" to assign multiple values"))

           (else
            (error "invalid assignment location")))))

   'abstract
   (lambda (e)
     (let ((sig (cadr e)))
       (expand-forms
        (receive (name params super) (analyze-type-sig sig)
                 (abstract-type-def-expr name params super)))))

   'bitstype
   (lambda (e)
     (let ((n (cadr e))
           (sig (caddr e)))
       (expand-forms
        (receive (name params super) (analyze-type-sig sig)
                 (bits-def-expr n name params super)))))

   'comparison
   (lambda (e)
     (expand-forms (expand-compare-chain (cdr e))))

   'ref
   (lambda (e)
     (let ((args (cddr e)))
       (if (has-parameters? args)
         (error "unexpected semicolon in array expression")
         (expand-forms (partially-expand-ref e)))))

   'curly
   (lambda (e)
     (expand-forms `(call (top apply_type) ,@(cdr e))))

   'call
   (lambda (e)
     (if (length> e 2)
         (let ((f (cadr e)))
           (cond ((and (pair? (caddr e))
                       (eq? (car (caddr e)) 'parameters))
                  ;; (call f (parameters . kwargs) ...)
                  (expand-forms
                    (receive
                      (kws args) (separate kwarg? (cdddr e))
                      (lower-kw-call f (append kws (cdr (caddr e))) args))))
                 ((any kwarg? (cddr e))
                  ;; (call f ... (kw a b) ...)
                  (expand-forms
                   (receive
                    (kws args) (separate kwarg? (cddr e))
                    (lower-kw-call f kws args))))
                 ((any vararg? (cddr e))
                  ;; call with splat
                  (let ((argl (cddr e)))
                    ;; wrap sequences of non-... arguments in tuple()
                    (define (tuple-wrap a run)
                      (if (null? a)
                          (if (null? run) '()
                              (list `(call (top tuple) ,.(reverse run))))
                          (let ((x (car a)))
                            (if (and (length= x 2)
                                     (eq? (car x) '...))
                                (if (null? run)
                                    (list* (cadr x)
                                           (tuple-wrap (cdr a) '()))
                                    (list* `(call (top tuple) ,.(reverse run))
                                           (cadr x)
                                           (tuple-wrap (cdr a) '())))
                                (tuple-wrap (cdr a) (cons x run))))))
                    (expand-forms
                     `(call (top _apply) ,f ,@(tuple-wrap argl '())))))

                 ((and (eq? (cadr e) '*) (length= e 4))
                  (expand-transposed-op
                   e
                   #(Ac_mul_Bc Ac_mul_B At_mul_Bt At_mul_B A_mul_Bc A_mul_Bt)))
                 ((and (eq? (cadr e) '/) (length= e 4))
                  (expand-transposed-op
                   e
                   #(Ac_rdiv_Bc Ac_rdiv_B At_rdiv_Bt At_rdiv_B A_rdiv_Bc A_rdiv_Bt)))
                 ((and (eq? (cadr e) '\\) (length= e 4))
                  (expand-transposed-op
                   e
                   #(Ac_ldiv_Bc Ac_ldiv_B At_ldiv_Bt At_ldiv_B A_ldiv_Bc A_ldiv_Bt)))
                 (else
                  (map expand-forms e))))
         (map expand-forms e)))

   'tuple
   (lambda (e)
     (if (and (length> e 1) (pair? (cadr e)) (eq? (caadr e) 'parameters))
         (error "unexpected semicolon in tuple"))
     (if (any assignment? (cdr e))
         (error "assignment not allowed inside tuple"))
     (expand-forms `(call (top tuple) ,@(cdr e))))

   'dict
   (lambda (e)
     ;; TODO: deprecate
     `(call (top Dict)
            ,.(map expand-forms (cdr e))))

   'typed_dict
   (lambda (e)
     ;; TODO: deprecate
     (let ((atypes (cadr e))
           (args   (cddr e)))
       (if (and (length= atypes 3)
                (eq? (car atypes) '=>))
           `(call (call (top apply_type) (top Dict)
                        ,(expand-forms (cadr atypes))
                        ,(expand-forms (caddr atypes)))
                  ,.(map expand-forms args))
           (error (string "invalid \"typed_dict\" syntax " (deparse atypes))))))

   '=>
   (lambda (e) `(call => ,(expand-forms (cadr e)) ,(expand-forms (caddr e))))

   'cell1d
   (lambda (e)
     (let ((args (cdr e)))
       (cond ((has-parameters? args)
              (error "unexpected semicolon in array expression"))
             ((any vararg? args)
              (expand-forms
               `(call (top cell_1d) ,@args)))
             (else
              (let ((name (make-jlgensym)))
                `(block (= ,name (call (top Array) (top Any)
                                       ,(length args)))
                        ,.(map (lambda (i elt)
                                 `(call (top arrayset) ,name
                                        ,(expand-forms elt) ,(+ 1 i)))
                               (iota (length args))
                               args)
                        ,name))))))

   'cell2d
   (lambda (e)
     (let ((nr (cadr e))
           (nc (caddr e))
           (args (cdddr e)))
       (if (any vararg? args)
           (expand-forms
            `(call (top cell_2d) ,nr ,nc ,@args))
           (let ((name (make-jlgensym)))
             `(block (= ,name (call (top Array) (top Any)
                                    ,nr ,nc))
                     ,.(map (lambda (i elt)
                              `(call (top arrayset) ,name
                                     ,(expand-forms elt) ,(+ 1 i)))
                            (iota (* nr nc))
                            args)
                     ,name)))))

   'string
   (lambda (e) (expand-forms `(call (top string) ,@(cdr e))))

   '|::|
   (lambda (e)
     (if (length= e 2)
         (error "invalid \"::\" syntax"))
     (if (and (length= e 3) (not (symbol-like? (cadr e))))
         `(call (top typeassert)
                ,(expand-forms (cadr e)) ,(expand-forms (caddr e)))
         (map expand-forms e)))

   'while
   (lambda (e)
     `(scope-block
       (break-block loop-exit
                    (_while ,(expand-forms (cadr e))
                            (break-block loop-cont
                                         ,(expand-forms (caddr e)))))))

   'inner-while
   (lambda (e)
     `(scope-block
        (_while ,(expand-forms (cadr e))
                (break-block loop-cont
                             ,(expand-forms (caddr e))))))

   'break
   (lambda (e)
     (if (pair? (cdr e))
         e
         '(break loop-exit)))

   'continue (lambda (e) '(break loop-cont))

   'for
   (lambda (e)
     (let nest ((ranges (if (eq? (car (cadr e)) 'block)
                            (cdr (cadr e))
                            (list (cadr e))))
                (first  #t))
       (expand-for (if first 'while 'inner-while)
                   (cadr (car ranges))
                   (caddr (car ranges))
                   (if (null? (cdr ranges))
                       (caddr e)  ;; body
                       (nest (cdr ranges) #f)))))

   '+=     lower-update-op
   '-=     lower-update-op
   '*=     lower-update-op
   '.*=    lower-update-op
   '/=     lower-update-op
   './=    lower-update-op
   '//=    lower-update-op
   './/=   lower-update-op
   '|\\=|  lower-update-op
   '|.\\=| lower-update-op
   '|.+=|  lower-update-op
   '|.-=|  lower-update-op
   '^=     lower-update-op
   '.^=    lower-update-op
   '÷=     lower-update-op
   '.÷=    lower-update-op
   '%=     lower-update-op
   '.%=    lower-update-op
   '|\|=|  lower-update-op
   '&=     lower-update-op
   '$=     lower-update-op
   '<<=    lower-update-op
   '>>=    lower-update-op
   '>>>=   lower-update-op

   ':
   (lambda (e)
     (if (or (length= e 2)
             (and (length= e 3)
                  (eq? (caddr e) ':))
             (and (length= e 4)
                  (eq? (cadddr e) ':)))
         (error "invalid \":\" outside indexing"))
     `(call colon ,.(map expand-forms (cdr e))))

   'vect
   (lambda (e) (expand-forms `(call (top vect) ,@(cdr e))))

   'hcat
   (lambda (e) (expand-forms `(call hcat ,.(map expand-forms (cdr e)))))

   'vcat
   (lambda (e)
     (let ((a (cdr e)))
       (if (has-parameters? a)
         (error "unexpected semicolon in array expression")
         (expand-forms
           (if (any (lambda (x)
                      (and (pair? x) (eq? (car x) 'row)))
                    a)
             ;; convert nested hcat inside vcat to hvcat
             (let ((rows (map (lambda (x)
                               (if (and (pair? x) (eq? (car x) 'row))
                                   (cdr x)
                                   (list x)))
                             a)))
               `(call hvcat
                   (tuple ,.(map length rows))
                     ,.(apply append rows)))
             `(call vcat ,@a))))))

   'typed_hcat
   (lambda (e) `(call (top typed_hcat) ,(expand-forms (cadr e)) ,.(map expand-forms (cddr e))))

   'typed_vcat
   (lambda (e)
     (let ((t (cadr e))
           (a (cddr e)))
       (expand-forms
        (if (any (lambda (x)
             (and (pair? x) (eq? (car x) 'row)))
           a)
            ;; convert nested hcat inside vcat to hvcat
            (let ((rows (map (lambda (x)
                               (if (and (pair? x) (eq? (car x) 'row))
                                   (cdr x)
                                   (list x)))
                             a)))
              `(call (top typed_hvcat) ,t
                     (tuple ,.(map length rows))
                     ,.(apply append rows)))
            `(call (top typed_vcat) ,t ,@a)))))

   '|'|  (lambda (e) `(call ctranspose ,(expand-forms (cadr e))))
   '|.'| (lambda (e) `(call  transpose ,(expand-forms (cadr e))))

   'ccall
   (lambda (e)
     (if (length> e 3)
         (let ((name (cadr e))
               (RT   (caddr e))
               (argtypes (cadddr e))
               (args (cddddr e)))
           (begin
             (if (not (and (pair? argtypes)
                           (eq? (car argtypes) 'tuple)))
	       (if (and (pair? RT)
			(eq? (car RT) 'tuple))
                 (error "ccall argument types must be a tuple; try \"(T,)\" and check if you specified a correct return type")
                 (error "ccall argument types must be a tuple; try \"(T,)\"")))
             (expand-forms
              (lower-ccall name RT (cdr argtypes) args))))
         e))

   'comprehension
   (lambda (e)
     (expand-forms (lower-comprehension #f       (cadr e) (cddr e))))

   'typed_comprehension
   (lambda (e)
     (expand-forms (lower-comprehension (cadr e) (caddr e) (cdddr e))))

   'dict_comprehension
   (lambda (e)
     (expand-forms (lower-dict-comprehension (cadr e) (cddr e))))

   'typed_dict_comprehension
   (lambda (e)
     (expand-forms (lower-typed-dict-comprehension (cadr e) (caddr e) (cdddr e))))))

(define (lower-nd-comprehension atype expr ranges)
  (let ((result      (make-jlgensym))
        (ri          (gensy))
        (oneresult   (gensy)))
    ;; evaluate one expression to figure out type and size
    ;; compute just one value by inserting a break inside loops
    (define (evaluate-one ranges)
      (if (null? ranges)
          `(= ,oneresult ,expr)
          (if (eq? (car ranges) `:)
              (evaluate-one (cdr ranges))
              `(for ,(car ranges)
                    (block ,(evaluate-one (cdr ranges))
                           (break)) ))))

    ;; compute the dimensions of the result
    (define (compute-dims ranges oneresult-dim)
      (if (null? ranges)
          (list)
          (if (eq? (car ranges) `:)
              (cons `(call (top size) ,oneresult ,oneresult-dim)
                    (compute-dims (cdr ranges) (+ oneresult-dim 1)))
              (cons `(call (top length) ,(caddr (car ranges)))
                    (compute-dims (cdr ranges) oneresult-dim)) )))

    ;; construct loops to cycle over all dimensions of an n-d comprehension
    (define (construct-loops ranges iters oneresult-dim)
      (if (null? ranges)
          (if (null? iters)
              `(block (call (top setindex!) ,result ,expr ,ri)
                      (= ,ri (call (top +) ,ri) 1))
              `(block (call (top setindex!) ,result (ref ,expr ,@(reverse iters)) ,ri)
                      (= ,ri (call (top +) ,ri 1))) )
          (if (eq? (car ranges) `:)
              (let ((i (make-jlgensym)))
                `(for (= ,i (: 1 (call (top size) ,oneresult ,oneresult-dim)))
                      ,(construct-loops (cdr ranges) (cons i iters) (+ oneresult-dim 1)) ))
              `(for ,(car ranges)
                    ,(construct-loops (cdr ranges) iters oneresult-dim) ))))

    ;; Evaluate the comprehension
    `(scope-block
      (block
       (local ,oneresult)
       ,(evaluate-one ranges)
       (= ,result (call (top Array) ,(if atype atype `(call (top eltype) ,oneresult))
                        ,@(compute-dims ranges 1)))
       (= ,ri 1)
       ,(construct-loops (reverse ranges) (list) 1)
       ,result ))))

(define (lower-comprehension atype expr ranges)
  (if (any (lambda (x) (eq? x ':)) ranges)
      (lower-nd-comprehension atype expr ranges)
  (let ((result    (make-jlgensym))
        (ri        (gensy))
        (initlabl  (if atype #f (make-jlgensym)))
        (oneresult (make-jlgensym))
        (lengths   (map (lambda (x) (make-jlgensym)) ranges))
        (states    (map (lambda (x) (gensy)) ranges))
        (is        (map (lambda (x) (gensy)) ranges))
        (rv        (map (lambda (x) (make-jlgensym)) ranges)))

    ;; construct loops to cycle over all dimensions of an n-d comprehension
    (define (construct-loops ranges rv is states lengths)
      (if (null? ranges)
          `(block (= ,oneresult ,expr)
                  ,@(if atype '() `((type_goto ,initlabl ,oneresult)))
                  (inbounds false)
                  (call (top setindex!) ,result ,oneresult ,ri)
                  (inbounds pop)
                  (= ,ri (call (top +) ,ri 1)))
          `(block
            (= ,(car states) (call (top start) ,(car rv)))
            (local (:: ,(car is) (call (top typeof) ,(car lengths))))
            (= ,(car is) 0)
            (while (call (top !=) ,(car is) ,(car lengths))
                   (scope-block
                   (block
                    (= ,(car is) (call (top +) ,(car is) 1))
                    (= (tuple ,(cadr (car ranges)) ,(car states))
                       (call (top next) ,(car rv) ,(car states)))
                    ;; *** either this or force all for loop vars local
                    ,.(map (lambda (r) `(local ,r))
                           (lhs-vars (cadr (car ranges))))
                    ,(construct-loops (cdr ranges) (cdr rv) (cdr is) (cdr states) (cdr lengths))))))))

    ;; Evaluate the comprehension
    `(block
      ,.(map (lambda (v r) `(= ,v ,(caddr r))) rv ranges)
      ,.(map (lambda (v r) `(= ,v (call (top length) ,r))) lengths rv)
      (scope-block
       (block
        ,@(if atype '() `((label ,initlabl)))
        (= ,result (call (top Array)
                         ,(if atype atype `(static_typeof ,oneresult))
                         ,@lengths))
        (= ,ri 1)
        ,(construct-loops (reverse ranges) (reverse rv) is states (reverse lengths))
        ,result))))))

(define (lower-dict-comprehension expr ranges)
  (let ((result   (make-jlgensym))
        (initlabl (make-jlgensym))
        (onekey   (make-jlgensym))
        (oneval   (make-jlgensym))
        (rv         (map (lambda (x) (make-jlgensym)) ranges)))

    ;; construct loops to cycle over all dimensions of an n-d comprehension
    (define (construct-loops ranges)
      (if (null? ranges)
          `(block (= ,onekey ,(cadr expr))
                  (= ,oneval ,(caddr expr))
                  (type_goto ,initlabl ,onekey ,oneval)
                  (call (top setindex!) ,result ,oneval ,onekey))
          `(for ,(car ranges)
                (block
                 ;; *** either this or force all for loop vars local
                 ,.(map (lambda (r) `(local ,r))
                        (lhs-vars (cadr (car ranges))))
                 ,(construct-loops (cdr ranges))))))

    ;; Evaluate the comprehension
    (let ((loopranges
           (map (lambda (r v) `(= ,(cadr r) ,v)) ranges rv)))
      `(block
        ,.(map (lambda (v r) `(= ,v ,(caddr r))) rv ranges)
        (scope-block
         (block
          #;,@(map (lambda (r) `(local ,r))
          (apply append (map (lambda (r) (lhs-vars (cadr r))) ranges)))
          (label ,initlabl)
          (= ,result (call (curly (top Dict)
                                  (static_typeof ,onekey)
                                  (static_typeof ,oneval))))
          ,(construct-loops (reverse loopranges))
          ,result))))))

(define (lower-typed-dict-comprehension atypes expr ranges)
  (if (not (and (length= atypes 3)
                (eq? (car atypes) '=>)))
      (error "invalid \"typed_dict_comprehension\" syntax")
      (let ( (result (make-jlgensym))
             (rs (map (lambda (x) (make-jlgensym)) ranges)) )

        ;; construct loops to cycle over all dimensions of an n-d comprehension
        (define (construct-loops ranges rs)
          (if (null? ranges)
              `(call (top setindex!) ,result ,(caddr expr) ,(cadr expr))
              `(for (= ,(cadr (car ranges)) ,(car rs))
                    (block
                     ;; *** either this or force all for loop vars local
                     ,.(map (lambda (r) `(local ,r))
                            (lhs-vars (cadr (car ranges))))
                     ,(construct-loops (cdr ranges) (cdr rs))))))

        ;; Evaluate the comprehension
        `(block
          ,.(map make-assignment rs (map caddr ranges))
          (= ,result (call (curly (top Dict) ,(cadr atypes) ,(caddr atypes))))
          (scope-block
           (block
            #;,@(map (lambda (r) `(local ,r))
            (apply append (map (lambda (r) (lhs-vars (cadr r))) ranges)))
            ,(construct-loops (reverse ranges) (reverse rs))
            ,result))))))

(define (lhs-vars e)
  (cond ((symbol? e) (list e))
        ((and (pair? e) (eq? (car e) 'tuple))
         (apply append (map lhs-vars (cdr e))))
        (else '())))

; (op (op a b) c) => (a b c) etc.
(define (flatten-op op e)
  (if (not (pair? e)) e
      (apply append
             (map (lambda (x)
                    (if (and (pair? x) (eq? (car x) op))
                        (flatten-op op x)
                        (list x)))
                  (cdr e)))))

(define (expand-and e)
  (let ((e (flatten-op '&& e)))
    (let loop ((tail e))
      (if (null? tail)
          'true
          (if (null? (cdr tail))
              (car tail)
              `(if ,(car tail)
                   ,(loop (cdr tail))
                   false))))))

(define (expand-or e)
  (let ((e (flatten-op '|\|\|| e)))
    (let loop ((tail e))
      (if (null? tail)
          'false
          (if (null? (cdr tail))
              (car tail)
              (if (symbol-like? (car tail))
                  `(if ,(car tail) ,(car tail)
                       ,(loop (cdr tail)))
                  (let ((g (gensy)))
                    `(block (= ,g ,(car tail))
                            (if ,g ,g
                                ,(loop (cdr tail)))))))))))

;; in "return x()" inside a try block, "x()" is not really in tail position
;; since we need to pop the exception handler first. convert these cases
;; to "tmp = x(); return tmp"
(define (fix-try-block-returns e)
  (cond ((or (atom? e) (jlgensym? e) (quoted? e))  e)
        ((and (eq? (car e) 'return) (or (symbol-like? (cadr e)) (pair? (cadr e))))
         (let ((sym (make-jlgensym)))
           `(block (= ,sym ,(cadr e))
                   (return ,sym))))
        ((eq? (car e) 'lambda) e)
        (else
         (cons (car e)
               (map fix-try-block-returns (cdr e))))))

; conversion to "linear flow form"
;
; This pass removes control flow constructs from value position.
; A "control flow construct" is anything that would require a branch.
;  (block ... (value-expr ... control-expr ...) ...) =>
;  (block ... (= var control-expr) (value-expr ... var ...) ...)
; except the assignment is incorporated into control-expr, so that
; control exprs only occur in statement position.
;
; The conversion works by passing around the intended destination of
; the value being computed: #f for statement position, #t for value position,
; or a symbol if the value needs to be assigned to a particular variable.
; This is the "dest" argument to to-lff.
;
; This also keeps track of tail position, and converts the code so that
; everything in tail position is returned explicitly.
;
; The result is that every expression whose value is needed is either
; a function argument, an assignment RHS, or returned explicitly.
; In this form, expressions can be analyzed freely without fear of
; intervening branches. Similarly, control flow can be analyzed without
; worrying about implicit value locations (the "evaluation stack").
(define *lff-line* 0)
(define (to-LFF e)
  (set! *lff-line* 0)
  (with-exception-catcher
   (lambda (e)
     (if (and (> *lff-line* 0) (pair? e) (eq? (car e) 'error))
         (let ((msg (cadr e)))
           (raise `(error ,(string msg " at line " *lff-line*))))
         (raise e)))
   (lambda () (to-blk (to-lff e #t #t)))))

(define (to-blk r)
  (if (length= r 1) (car r) (cons 'block (reverse r))))

(define (blk-tail r) (reverse r))

;; apply to-lff to each subexpr and combine results
(define (map-to-lff e dest tail)
  (let ((r (map (lambda (arg) (to-lff arg #t #f))
                (cdr e))))
    (cond ((symbol-like? dest)
           (cons `(= ,dest ,(cons (car e) (map car r)))
                 (apply append (map cdr (reverse r)))))
          (else
           (let ((ex (cons (car e) (map car r))))
             (cons (if tail `(return ,ex) ex)
                   (apply append (map cdr (reverse r)))))))))

;; to-lff returns (new-ex . stmts) where stmts is a list of statements that
;; must run before new-ex is valid.
;;
;; If the input expression needed to be removed from its original context,
;; like the 'if' in "1+if(a,b,c)", then new-ex is a symbol holding the
;; result of the expression.
;;
;; If dest is a symbol or #f, new-ex can be a statement.
;;
;; We essentially maintain a stack of control-flow constructs that need to be
;; run in statement position as we walk around an expression. If we hit
;; statement context, we can dump the control-flow stuff there.
;; This expression walk is entirely within the "else" clause of the giant
;; case expression. Everything else deals with special forms.
(define (to-lff e dest tail)
  (if (effect-free? e)
      (cond ((symbol-like? dest)
             (if (and (pair? e) (eq? (car e) 'break))
                 ;; odd corner case: sometimes try/finally generates
                 ;; a (break ) as an assignment RHS
                 (to-lff e #f #f)
                 (cons `(= ,dest ,e) '())))
            (dest (cons (if tail `(return ,e) e)
                        '()))
            (else (cons e '())))

      (case (car e)
        ((call)  ;; ensure left-to-right evaluation of arguments
         (let ((assigned
                ;; vars assigned in each arg
                ;; start with cddr since each arg only considers subsequent ones
                (map (lambda (x) (expr-find-all assignment-like? x cadr))
                     (cddr e))))
           (if (every null? assigned)
               ;; no assignments
               (map-to-lff e dest tail)
               ;; has assignments
               (let each-arg ((ass  assigned)
                              (args (cdr e))
                              (tmp  '())
                              (newa '()))
                 ;; if an argument contains vars assigned in later arguments,
                 ;; lift out a temporary assignment for it.
                 (if (null? ass)
                     (if (null? tmp)
                         (map-to-lff e dest tail)
                         (to-lff `(block
                                   ,.(reverse tmp)
                                   (call ,.(reverse newa) ,(car args)))
                                 dest tail))
                     (if (expr-contains-p (lambda (v) (if (jlgensym? v)
                                            (any (lambda (vlist) (mem-jlgensym v vlist)) ass)
                                            (any (lambda (vlist) (memq v vlist)) ass)))
                                          (car args))
                         (let ((g (make-jlgensym)))
                           (each-arg (cdr ass) (cdr args)
                                     (cons `(= ,g ,(car args)) tmp)
                                     (cons g newa)))
                         (each-arg (cdr ass) (cdr args)
                                   tmp
                                   (cons (car args) newa))))))))

        ((=)
         (if (or (not (symbol-like? (cadr e)))
                 (eq? (cadr e) 'true)
                 (eq? (cadr e) 'false))
             (error (string "invalid assignment location \"" (deparse (cadr e)) "\"")))
         (let ((LHS (cadr e))
               (RHS (caddr e)))
           (cond ((not dest)
                  (to-lff RHS LHS #f))
                 #;((assignment? RHS)
                 (let ((r (to-lff RHS dest #f)))
                 (list* (if tail `(return ,(car r)) (car r))
                 `(= ,LHS ,(car r))
                 (cdr r))))
                 ((and (effect-free? RHS)
                       ;; need temp var for `x::Int = x` (issue #6896)
                       (not (eq? RHS (decl-var LHS))))
                  (cond ((symbol-like? dest)
                            (list `(= ,LHS ,RHS)
                                  `(= ,dest ,RHS)))
                        (dest  (list (if tail `(return ,RHS) RHS)
                                     `(= ,LHS ,RHS)))
                        (else  (list e))))
                 (else
                  (to-lff (let ((val (make-jlgensym)))
                            `(block (= ,val ,RHS)
                                    (= ,LHS ,val)
                                    ,val))
                          dest tail)))))

        ((if)
         (cond ((or (and tail (not (jlgensym? dest))) (eq? dest #f) (symbol? dest))
                (let ((r (to-lff (cadr e) #t #f)))
                  (cons `(if
                          ,(car r)
                          ,(to-blk (to-lff (caddr e) dest tail))
                          ,(if (length= e 4)
                               (to-blk (to-lff (cadddr e) dest tail))
                               (to-blk (to-lff '(null)  dest tail))))
                        (cdr r))))
               (else (let* ((g (gensy))
                            (stmts (cons g
                                         (cons `(local ,g) (to-lff e g tail)))))
                       (if (jlgensym? dest) (cons `(= ,dest ,g) stmts) stmts)))))

        ((line)
         (set! *lff-line* (cadr e))
         (cons e '()))

        ((trycatch)
         (cond ((and (eq? dest #t) (not tail))
                (let ((g (gensy)))
                  (list* g
                         `(local ,g)
                         (to-lff e g #f))))
               (else (let* ((g (if (jlgensym? dest) (gensy) dest))
                            (stmts (cons `(trycatch ,(fix-try-block-returns
                                                      (to-blk (to-lff (cadr e) g tail)))
                                                     ,(to-blk (to-lff (caddr e) g tail)))
                                         ())))
                       (if (jlgensym? dest) (cons `(= ,dest ,g) stmts) stmts)))))

        ((&&)
         (to-lff (expand-and e) dest tail))
        ((|\|\||)
         (to-lff (expand-or e) dest tail))

        ((block)
         (if (length= e 2)
             (to-lff (cadr e) dest tail)
             (let* ((val (last e))
		    (g (make-jlgensym))
                    (stmts
                     (let loop ((tl (cdr e)))
                       (if (null? tl) '()
                           (if (null? (cdr tl))
                               (cond ((or tail (eq? dest #f) (symbol-like? dest) (symbol-like? val))
                                      (blk-tail (to-lff (car tl) dest tail)))
                                     (else
                                      (blk-tail (to-lff (car tl) g tail))))
                               (cons (to-blk (to-lff (car tl) #f #f))
                                     (loop (cdr tl))))))))
               (if (and (eq? dest #t) (not tail))
                   (cons (if (symbol-like? val) val g) (reverse stmts))
                   (if (and tail (null? stmts))
                       (cons '(return (null))
                             '())
                       (cons (cons 'block stmts)
                             '()))))))

        ((return)
         (if (and dest (not tail))
             (error "misplaced return statement")
             (to-lff (cadr e) #t #t)))

        ((_while) (cond ((eq? dest #t)
                         (cons (if tail '(return (null)) '(null))
                               (to-lff e #f #f)))
                        (else
                         (let* ((r (to-lff (cadr e) #t #f))
                                (w (cons `(_while ,(to-blk (cdr r))
                                                  ,(car r)
                                                  ,(to-blk
                                                    (to-lff (caddr e) #f #f)))
                                         '())))
                           (if (symbol-like? dest)
                               (cons `(= ,dest (null)) w)
                               w)))))

        ((break-block)
         (let ((r (to-lff (caddr e) dest tail)))
           (if dest
               (cons (car r)
                     (list `(break-block ,(cadr e) ,(to-blk (cdr r)))))
               (cons `(break-block ,(cadr e) ,(car r))
                     (cdr r)))))

        ((scope-block)
         (if (and dest (not tail) (not (jlgensym? dest)))
             (let* ((g (make-jlgensym))
                    (r (to-lff (cadr e) g tail)))
               (cons (car (to-lff g dest tail))
                   (cons `(scope-block ,(to-blk r))
                         '())))
             (let ((r (to-lff (cadr e) dest tail)))
               (cons `(scope-block ,(to-blk r))
                     '()))))

        ;; move the break to the list of preceding statements. value is
        ;; null but this will never be observed.
        ((break) (cons '(null) (list e)))

        ((lambda)
         (let ((l `(lambda ,(cadr e)
                     ,(to-blk (to-lff (caddr e) #t #t)))))
           (if (symbol-like? dest)
               (cons `(= ,dest ,l) '())
               (cons (if tail `(return ,l) l) '()))))

        ((local global)
         (if dest
             (error (string "misplaced \"" (car e) "\" declaration")))
         (cons (to-blk (to-lff '(null) dest tail))
               (list e)))

        ((|::|)
         (if dest
             ;; convert to typeassert or decl based on whether it's in
             ;; value or statement position.
             (to-lff `(call (top typeassert) ,@(cdr e)) dest tail)
             (to-lff `(decl ,@(cdr e)) dest tail)))

        ((unnecessary-tuple)
         (if dest
             (to-lff (cadr e) dest tail)
             ;; remove if not in value position
             (to-lff '(null) dest tail)))

        ((method)
         (if dest
             (let ((ex (to-lff (or (method-expr-name e) '(null)) dest tail))
                   (fu (to-lff e #f #f)))
               (cons (car ex)
                     (append fu (cdr ex))))
             (let ((ex (if (length= e 2)
                           e
                           ;; leave the block in the type argument in place; its
                           ;; statements are lifted to the top level by cl-convert.
                           `(method ,(cadr e) ,(to-blk (to-lff (caddr e) #f #f))
                                    ,(car (to-lff (cadddr e) #f #f))
                                    ,(last e)))))
               (cons (if tail `(return ,ex) ex)
                     '()))))

        ((module) (cons e '()))
	;; TODO: something needs to be done here, but things seem to depend
	;; on the current somewhat-broken behavior in a fragile way.
	#;((toplevel)  ;; don't move things out of toplevel blocks
	 (let ((r (map-to-lff e dest tail)))
	   (let ((ex `(toplevel ,@(reverse (cdr r)) ,@((if tail cdadr cdr) (car r)))))
	     (cons (if tail `(return ,ex) ex) '()))))

        ((symbolicgoto symboliclabel)
         (cons (if tail '(return (null)) '(null))
               (map-to-lff e #f #f)))

        (else
         (map-to-lff e dest tail)))))

#|
future issue:
right now scope blocks need to be inside functions:

> (julia-expand '(block (call + 1 (scope-block (block (= a b) c)))))
(block (scope-block (local a) (local #:g13) (block (= a b) (= #:g13 c)))
       (return (call + 1 #:g13)))

> (julia-expand '(scope-block (call + 1 (scope-block (block (= a b) c)))))
(scope-block
 (local #:g15)
 (block (scope-block (local a) (block (= a b) (= #:g15 c)))
        (return (call + 1 #:g15))))

The first one gave something broken, but the second case works.
So far only the second case can actually occur.
|#

(define (check-dups locals)
  (if (and (pair? locals) (pair? (cdr locals)))
      (or (and (memq (car locals) (cdr locals))
               (error (string "local \"" (car locals) "\" declared twice")))
          (check-dups (cdr locals))))
  locals)

(define (find-assigned-vars e env)
  (if (or (not (pair? e)) (quoted? e))
      '()
      (case (car e)
        ((lambda scope-block module)  '())
        ((method)
         (let ((v (decl-var (method-expr-name e))))
           (append!
            (if (length= e 2) '() (find-assigned-vars (caddr e) env))
            (if (or (not (symbol? v)) (memq v env))
                '()
                (list v)))))
        ((=)
         (let ((v (decl-var (cadr e))))
	   (if (or (jlgensym? v) (memq v env))
	       '()
	       (list v))))
        (else
         (apply append! (map (lambda (x) (find-assigned-vars x env))
                             e))))))

(define (find-decls kind e)
  (if (or (not (pair? e)) (quoted? e))
      '()
      (cond ((memq (car e) '(lambda scope-block module))
             '())
            ((eq? (car e) kind)
             (list (decl-var (cadr e))))
            (else
             (apply append! (map (lambda (x) (find-decls kind x))
                                 e))))))

(define (find-local-decls  e) (find-decls 'local  e))
(define (find-global-decls e) (find-decls 'global e))

(define (find-locals e env glob)
  (delete-duplicates
   (append! (check-dups (find-local-decls e))
            ;; const decls on non-globals also introduce locals
            (diff (find-decls 'const e) glob)
            (find-assigned-vars e env))))

(define (remove-local-decls e)
  (cond ((or (not (pair? e)) (quoted? e)) e)
        ((or (eq? (car e) 'scope-block) (eq? (car e) 'lambda)) e)
        ((eq? (car e) 'block)
         (map remove-local-decls
              (filter (lambda (x) (not (and (pair? x) (eq? (car x) 'local))))
                      e)))
        (else
         (map remove-local-decls e))))

;; local variable identification
;; convert (scope-block x) to `(scope-block ,@locals ,x)
;; where locals is a list of (local x) expressions, derived from two sources:
;; 1. (local x) expressions inside this scope-block and lambda
;; 2. (const x) expressions in a scope-block where x is not declared global
;; 3. variables assigned inside this scope-block that don't exist in outer
;;    scopes
(define (add-local-decls e env implicitglobals)
  (if (or (not (pair? e)) (quoted? e)) e
      (cond ((eq? (car e) 'lambda)
             (let* ((env (append (lam:vars e) env))
                    (body (add-local-decls (caddr e) env
					   ;; don't propagate implicit globals
					   ;; issue #7234
					   '())))
               (list 'lambda (cadr e) body)))

            ((eq? (car e) 'scope-block)
             (let* ((iglo (find-decls 'implicit-global (cadr e)))
		    (glob (diff (find-global-decls (cadr e)) iglo))
                    (vars (find-locals
                           ;; being declared global prevents a variable
                           ;; assignment from introducing a local
                           (cadr e)
			   (append env glob implicitglobals iglo)
			   (append glob iglo)))
                    (body (add-local-decls (cadr e)
					   (append vars glob env)
					   (append iglo implicitglobals)))
		    (lineno (if (and (length> body 1)
				     (pair? (cadr body))
                                     (eq? 'line (car (cadr body))))
                                (list (cadr body))
                                '()))
                    (body (if (null? lineno)
                              body
                              `(,(car body) ,@(cddr body)))))
               (for-each (lambda (v)
                           (if (memq v vars)
                               (error (string "variable \"" v "\" declared both local and global"))))
                         glob)
               `(scope-block ,@lineno
                             ;; place local decls after initial line node
                             ,.(map (lambda (v) `(local ,v))
                                    vars)
                             ,(remove-local-decls body))))

	    ((eq? (car e) 'module)
	     (error "module expression not at top level"))

            (else
	     (map (lambda (x)
		    (add-local-decls x env implicitglobals))
		  e)))))

(define (identify-locals e) (add-local-decls e '() '()))

(define (declared-local-vars e)
  (map (lambda (x) (decl-var (cadr x)))
       (filter (lambda (x)
                 (and (pair? x)
                      (eq? (car x) 'local)))
               (cdr e))))

; e - expression
; renames - assoc list of (oldname . newname)
; this works on any tree format after identify-locals
(define (rename-vars e renames)
  (cond ((null? renames)  e)
        ((symbol? e)      (lookup e renames e))
        ((not (pair? e))  e)
        ((quoted? e)      e)
        (else
         (let (; remove vars bound by current expr from rename list
               (new-renames
                (without renames
                         (case (car e)
                           ((lambda)
                            (append (lambda-all-vars e)
                                    (find-global-decls (cadddr e))))
                           ((scope-block)
                            (append (declared-local-vars e)
                                    (find-global-decls (cadr e))))
                           (else '())))))
           (cons (car e)
                 (map (lambda (x)
                        (rename-vars x new-renames))
                      (cdr e)))))))

;; all vars used in e outside x
(define (vars-used-outside e x)
  (table.keys (free-vars- e (table) x)))

(define (flatten-lambda-scopes e)
  (cond ((or (atom? e) (quoted? e)) e)
        ((eq? (car e) 'lambda) (flatten-scopes e))
        (else (map flatten-lambda-scopes e))))

;; remove (scope-block) and (local), convert lambdas to the form
;; (lambda (argname...) (locals var...) body)
(define (flatten-scopes e)
  (define scope-block-vars '())
  (define (remove-scope-blocks e context usedv)
    (cond ((or (atom? e) (quoted? e)) e)
          ((eq? (car e) 'lambda) e)
          ((eq? (car e) 'scope-block)
           (let ((vars (declared-local-vars e))
                 (body (cons 'block (cdr e))));(car (last-pair e))))
             (let* ((outer    (append usedv (vars-used-outside context e)))
                    ;; only rename conflicted vars
                    (to-ren   (filter (lambda (v) (memq v outer)) vars))
                    (newnames (map named-gensy to-ren))
                    (bod      (rename-vars (remove-scope-blocks body e outer)
                                           (map cons to-ren newnames))))
               (set! scope-block-vars (nconc newnames scope-block-vars))
               (set! scope-block-vars (nconc (diff vars to-ren)
                                             scope-block-vars))
               bod)))
          (else (map (lambda (e) (remove-scope-blocks e context usedv))
                     e))))

  (cond ((not (pair? e))   e)
        ((quoted? e)       e)
        ((eq? (car e)      'lambda)
         (let* ((argnames  (lam:vars e))
                (body      (caddr e))
                (body2     (flatten-lambda-scopes body))
                (r-s-b     (remove-scope-blocks body2 body2 argnames)))
           (for-each (lambda (v)
                       (if (memq v argnames)
                           (error (string "local \"" v "\" conflicts with argument"))))
                     (declared-local-vars body))
           `(lambda ,(cadr e)
              (locals ,@scope-block-vars)
              ,r-s-b)))
        (else (map (lambda (x) (if (not (pair? x)) x
                                   (flatten-scopes x)))
                   e))))

(define (has-unmatched-symbolic-goto? e)
  (let ((label-refs (table))
        (label-defs (table)))
    (find-symbolic-label-refs e label-refs)
    (find-symbolic-label-defs e label-defs)
    (any not (map (lambda (k) (get label-defs k #f))
                  (table.keys label-refs)))))

(define (symbolic-label-handler-levels e levels handler-level)
  (if (or (not (pair? e)) (quoted? e))
      '()
      (case (car e)
        ((trycatch)
         (symbolic-label-handler-levels (cadr e) levels (+ handler-level 1)))
        ((symboliclabel)
         (put! levels (cadr e) handler-level))
        (else
         (map (lambda (x) (symbolic-label-handler-levels x levels handler-level)) e)))))

(define (find-symbolic-label-defs e tbl)
  (if (or (not (pair? e)) (quoted? e))
      '()
      (if (eq? (car e) 'symboliclabel)
          (put! tbl (cadr e) #t)
          (map (lambda (x) (find-symbolic-label-defs x tbl)) e))))

(define (find-symbolic-label-refs e tbl)
  (if (or (not (pair? e)) (quoted? e))
      '()
      (if (eq? (car e) 'symbolicgoto)
          (put! tbl (cadr e) #t)
          (map (lambda (x) (find-symbolic-label-refs x tbl)) e))))

(define (make-gensym-generator)
  (let ((jlgensym-counter 0))
    (lambda ()
      (begin0 `(jlgensym ,jlgensym-counter)
              (set! jlgensym-counter (+ 1 jlgensym-counter))))))

(define (renumber-jlgensym- e tbl next-jlgensym)
  (cond
   ((or (not (pair? e)) (quoted? e)) e)
   ((eq? (car e) 'lambda)
    (let* ((next  (make-gensym-generator))
	   (body  (renumber-jlgensym- (lam:body e) (table) next))
	   (count (cadr (next)))
	   (vi    (caddr e)))
      `(lambda ,(cadr e)
	 (,(car vi) ,(cadr vi) ,count ,(last vi))
	 ,body)))
   ((jlgensym? e)
    (let ((n (get tbl (cadr e) #f)))
      (if n n
          (let ((n (next-jlgensym))) (put! tbl (cadr e) n) n))))
   (else (map (lambda (x) (renumber-jlgensym- x tbl next-jlgensym)) e))))

(define (renumber-jlgensym e)
  (renumber-jlgensym- e #f error))

(define (lambda-all-vars e)
  (append (lam:vars e)
          (cdr (caddr e))))

(define (free-vars- e tab excl)
  (cond ((symbol? e) (put! tab e #t))
        ((or (atom? e) (quoted? e)) tab)
        ((eq? e excl) tab)
        ((eq? (car e) 'lambda)
         (let ((bound (lambda-all-vars e)))
           (for-each (lambda (v) (if (not (memq v bound)) (put! tab v #t)))
                     (free-vars (lam:body e))))
         tab)
        (else
         (for-each (lambda (x) (free-vars- x tab excl))
                   (cdr e))
         tab)))

(define *free-vars-secret-value* (list 0))
(define (free-vars e)
  (table.keys (free-vars- e (table) *free-vars-secret-value*)))

(define (analyze-vars-lambda e env captvars sp new-sp)
  (let* ((args (filter (lambda (v) (not (eq? (arg-name v) UNUSED)))
                       (lam:args e)))
	 (locl (cdr (caddr e)))
	 (allv (nconc (map arg-name args) locl))
	 (fv   (let* ((fv (diff (free-vars (lam:body e)) allv))
		      ;; add variables referenced in declared types for free vars
		      (dv (apply nconc (map (lambda (v)
					      (let ((vi (var-info-for v env)))
						(if vi (free-vars (vinfo:type vi)) '())))
					    fv))))
		 (append (diff dv fv) fv)))
	 (glo  (find-global-decls (lam:body e)))
	 ;; make var-info records for vars introduced by this lambda
	 (vi   (nconc
		(map (lambda (decl) (make-var-info (decl-var decl)))
		     args)
		(map make-var-info locl)))
         (capt-sp (filter (lambda (v) (and (memq v fv) (not (memq v glo))))
                          sp))
         ;; captured vars: vars from the environment that occur
         ;; in our set of free variables (fv).
         (cv    (append (filter (lambda (v) (and (memq (vinfo:name v) fv)
                                                 (not (memq (vinfo:name v) glo))))
                                env)
                        (map make-var-info capt-sp)))
	 (bod   (analyze-vars
		 (flatten-blocks (lam:body e))
		 (append vi
			 ;; new environment: add our vars
			 (filter (lambda (v)
				   (and (not (memq (vinfo:name v) allv))
					(not (memq (vinfo:name v) glo))))
				 env))
		 cv (delete-duplicates (append new-sp sp)))))
    ;; mark all the vars we capture as captured
    (for-each (lambda (v) (vinfo:set-capt! v #t))
	      cv)
    `(lambda ,(lam:args e)
       (,vi ,cv 0 ,(delete-duplicates (append new-sp capt-sp)))
       ,bod)))

;; convert each lambda's (locals ...) to
;;   (var-info-lst captured-var-infos gensyms static_params)
;; where var-info-lst is a list of var-info records
(define (analyze-vars e env captvars sp)
  (if (or (atom? e) (quoted? e))
      e
      (case (car e)
        ((=)
         (let ((vi (var-info-for (cadr e) env)))
           (if vi
               (begin
                 (if (vinfo:asgn vi)
                     (vinfo:set-sa! vi #f)
                     (vinfo:set-sa! vi #t))
                 (vinfo:set-asgn! vi #t)
                 (if (assq (car vi) captvars)
                     (vinfo:set-iasg! vi #t)))))
         `(= ,(cadr e) ,(analyze-vars (caddr e) env captvars sp)))
        ((call)
         (let ((vi (var-info-for (cadr e) env)))
           (if vi
               (vinfo:set-called! vi #t))
           (cons (car e)
                 (map (lambda (x) (analyze-vars x env captvars sp))
                      (cdr e)))))
        ((decl |::|)
         ; handle var::T declaration by storing the type in the var-info
         ; record. for non-symbols or globals, emit a type assertion.
         (let ((vi (var-info-for (cadr e) env)))
           (if vi
               (begin (if (not (eq? (vinfo:type vi) 'Any))
                          (error (string "multiple type declarations for \""
                                         (cadr e) "\"")))
                      (if (assq (cadr e) captvars)
                          (error (string "type of \"" (cadr e)
                                         "\" declared in inner scope")))
                      (vinfo:set-type! vi (caddr e))
                      '(null))
               `(call (top typeassert) ,(cadr e) ,(caddr e)))))
        ((lambda)
	 (analyze-vars-lambda e env captvars sp '()))
	((with-static-parameters)
	 ;; (with-static-parameters func_expr sp_1 sp_2 ...)
	 (assert (eq? (car (cadr e)) 'lambda))
	 (analyze-vars-lambda (cadr e) env captvars sp
			      (cddr e)))
        ((method)
         (let ((vi (var-info-for (method-expr-name e) env)))
           (if vi
               (begin
                 (vinfo:set-asgn! vi #t)
                 ;; note: method defs require a memory loc. (issue #7658)
                 (vinfo:set-sa! vi #f)
                 (if (assq (car vi) captvars)
                     (vinfo:set-iasg! vi #t)))))
	 (if (length= e 2)
	     `(method ,(cadr e))
	     `(method ,(cadr e)
		      ,(analyze-vars (caddr  e) env captvars sp)
		      ,(begin (assert (eq? (car (cadddr e)) 'lambda))
			      (analyze-vars-lambda (cadddr e) env captvars sp
						   (method-expr-static-parameters e)))
		      ,(caddddr e))))
	((module) e)
        (else (cons (car e)
                    (map (lambda (x) (analyze-vars x env captvars sp))
                         (cdr e)))))))

(define (analyze-variables e) (analyze-vars e '() '() '()))

;; template for generating a closure type with parameters
(define (type-for-closure-parameterized name P fields types super)
  (let ((n (length P)))
    `(thunk
      (lambda ()
        ((,@(map (lambda (p) `(,p Any 18)) P))
         () 0 ())
        (block (global ,name) (const ,name)
               ,@(map (lambda (p) `(= ,p (call (top TypeVar) ',p (top Any) true))) P)
               (composite_type ,name (call (top svec) ,@P)
                               (call (top svec) ,@(map (lambda (v) `',v) fields))
                               ,super
                               (call (top svec) ,@types) #f ,(length fields))
               (return (null)))))))

;; ... and without parameters
(define (type-for-closure name fields super)
  `(thunk (lambda ()
            (() () 0 ())
            (block (global ,name) (const ,name)
                   (composite_type ,name (call (top svec))
                                   (call (top svec) ,@(map (lambda (v) `',v) fields))
                                   ,super
                                   (call (top svec) ,@(map (lambda (v) 'Any) fields))
                                   #f ,(length fields))
                   (return (null))))))

(define (vinfo:not-capt vi)
  (list (car vi) (cadr vi) (logand (caddr vi) (lognot 5))))

(define (clear-capture-bits vinfos)
  (map vinfo:not-capt vinfos))

(define (convert-lambda lam fname interp)
  `(lambda ,(lam:args lam)
     (,(clear-capture-bits (car (lam:vinfo lam)))
      ()
      ,(caddr (lam:vinfo lam))
      ,(cadddr (lam:vinfo lam)))
     ,(add-box-inits-to-body
       lam
       (cl-convert (cadddr lam) fname lam (table) #f interp))))

(define (convert-for-type-decl rhs t)
  (if (eq? t 'Any)
      rhs
      `(call (top typeassert)
	     (call (top convert) ,t ,rhs)
	     ,t)))

(define (convert-assignment var rhs fname lam interp)
  (let ((vi (assq var (car  (lam:vinfo lam))))
	(cv (assq var (cadr (lam:vinfo lam)))))
    (let* ((vt  (or (and vi (vinfo:type vi))
		    (and cv (vinfo:type cv))
		    'Any))
	   (rhs (convert-for-type-decl rhs
				       (if (eq? vt 'Any)
					   vt
					   (cl-convert vt fname lam #f #f interp)))))
      (cond
       ((and cv (vinfo:asgn cv) (vinfo:capt cv))
	`(call (top setfield!)
               ,(if interp
                    `($ ,var)
                    `(call (top getfield) ,fname (inert ,var)))
	       (inert contents)
	       ,rhs))
       ((and vi (vinfo:asgn vi) (vinfo:capt vi))
	`(call (top setfield!) ,var (inert contents) ,rhs))
       (else
	`(= ,var ,rhs))))))

(define (arg-type-lowered a)
  (let ((t (arg-type a)))
    (if (vararg? t)
	`(call (top apply_type) Vararg ,(cadr t))
	t)))

;; replace leading (function) argument type with `typ`
(define (fix-function-arg-type te typ iskw namemap type-sp)
  (let* ((typapp (caddr te))
         (types  (pattern-replace
		  (pattern-set
		   (pattern-lambda (call (call (top (-/ getfield)) (-/ Core) (quote (-/ Typeof))) name)
				   (get namemap name __)))
		  (cdddr typapp)))
         (closure-type (if (null? type-sp)
                           typ
                           `(call (top apply_type) ,typ ,@type-sp)))
         (newtypes
          (if iskw
              `(,(car types) ,(cadr types) ,closure-type ,@(cdddr types))
              `(,closure-type ,@(cdr types)))))
    `(call (top svec) (call (top apply_type) Tuple ,@newtypes)
	   (call (top svec) ,@(append (cddr (cadddr te)) type-sp)))))

(define (lift-toplevel e)
  (if (atom? e) (cons e '())
      (let* ((rec (map lift-toplevel e))
	     (e2  (map car rec))
	     (tl  (apply append (map cdr rec))))
	(if (eq? (car e) 'toplevel-butlast)
	    (cons (last e2) (append tl (butlast (cdr e2))))
	    (cons e2 tl)))))

(define (add-box-inits-to-body lam body)
  (let ((args (map arg-name (lam:args lam)))
	(vis  (car (lam:vinfo lam)))
	(lnos (take-while (lambda (x) (and (pair? x) (eq? (car x) 'line)))
			  (cdr body))))
    ;; insert Box allocations for captured/assigned arguments
    `(,(car body)
      ,@lnos
      ,@(apply append
	       (map (lambda (arg)
		      (let ((vi (assq arg vis)))
			(if (and vi (vinfo:asgn vi) (vinfo:capt vi))
			    `((= ,arg (call (top Box) ,arg)))
			    '())))
		    args))
      ,@(list-tail body (+ 1 (length lnos))))))

;; clear capture bit for vars assigned once at the top
(define (lambda-optimize-vars! lam)
  (define (expr-uses-var ex v)
    (cond ((assignment? ex) (expr-contains-eq v (caddr ex)))
          ((eq? (car ex) 'method)
           (and (length> ex 2)
                (assq v (cadr (lam:vinfo (cadddr ex))))))
          (else #f)))
  (assert (eq? (car lam) 'lambda))
  (let ((vi (car (lam:vinfo lam))))
    (if (and (any vinfo:capt vi)
             (any vinfo:sa vi))
        (let* ((leading
                (filter (lambda (x) (and (pair? x) (or (eq? (car x) 'method)
                                                       (eq? (car x) '=))))
                        (take-while (lambda (e)
                                      (or (atom? e)
                                          (memq (car e) '(quote top line inert local
                                                                implicit-global global
                                                                const newvar = null method))))
                                    (lam:body lam))))
               (unused (map cadr leading))
               (def (table)))
          ;; TODO: reorder leading statements to put assignments where the RHS is
          ;; `simple-atom?` at the top.
          (for-each (lambda (e)
                      (set! unused (filter (lambda (v) (not (expr-uses-var e v)))
                                           unused))
                      (if (memq (cadr e) unused)
                          (put! def (cadr e) #t)))
                    leading)
          (for-each (lambda (v)
                      (if (and (vinfo:sa v) (has? def (car v)))
                          (set-car! (cddr v) (logand (caddr v) (lognot 5)))))
                    vi)))
    lam))

(define (is-var-boxed? v lam)
  (or (let ((vi (assq v (car (lam:vinfo lam)))))
	(and vi (vinfo:asgn vi) (vinfo:capt vi)))
      (let ((cv (assq v (cadr (lam:vinfo lam)))))
	(and cv (vinfo:asgn cv) (vinfo:capt cv)))))

(define (closure-convert e) (cl-convert e #f #f #f #f #f))

(define (toplevel-preserving? e)
  (and (pair? e) (memq (car e) '(if block body trycatch))))

(define (map-cl-convert exprs fname lam namemap toplevel interp)
  (if toplevel
      (let loop ((exprs exprs)
		 (stmts '()))
	(if (null? exprs)
	    (reverse! stmts)
	    (let* ((x (lift-toplevel (cl-convert (car exprs) fname lam namemap
						 (and toplevel (toplevel-preserving? (car exprs)))
						 interp))))
	      (loop (cdr exprs)
		    (cons (car x) (revappend (cdr x) stmts))))))
      (map (lambda (x) (cl-convert x fname lam namemap #f interp)) exprs)))

(define (cl-convert e fname lam namemap toplevel interp)
  (if (and (not lam)
	   (not (and (pair? e) (memq (car e) '(lambda method macro)))))
      (if (atom? e) e
	  (cons (car e) (map-cl-convert (cdr e) fname lam namemap toplevel interp)))
      (cond
       ((symbol? e)
	(let ((vi (assq e (car  (lam:vinfo lam))))
	      (cv (assq e (cadr (lam:vinfo lam)))))
	  (cond ((eq? e fname) e)
                ((memq e (lam:sp lam)) e)
		(cv
		 (let ((access (if interp
                                   `($ (call (top QuoteNode) ,e))
                                   `(call (top getfield) ,fname (inert ,e)))))
		   (if (and (vinfo:asgn cv) (vinfo:capt cv))
		       `(call (top getfield) ,access (inert contents))
		       access)))
		(vi
		 (if (and (vinfo:asgn vi) (vinfo:capt vi))
		     `(call (top getfield) ,e (inert contents))
		     e))
		(else e))))
       ((atom? e) e)
       (else
	(case (car e)
	  ((quote top line break inert) e)
	  ((=)
	   (let ((var (cadr e))
		 (rhs (cl-convert (caddr e) fname lam namemap toplevel interp)))
	     (convert-assignment var rhs fname lam interp)))
	  ((newvar)
	   (let ((vi (assq (cadr e) (car (lam:vinfo lam)))))
	     (if (and vi (vinfo:asgn vi) (vinfo:capt vi))
		 `(= ,(cadr e) (call (top Box)))
		 e)))
	  ((local)
	   (let ((vi (assq (cadr e) (car (lam:vinfo lam)))))
	     (if (and vi (vinfo:asgn vi) (vinfo:capt vi)
		      ;; avoid redundant box for vars with newvar nodes
		      (not (any (lambda (x) (and (length= x 2)
						 (eq? (car x) 'newvar) (eq? (cadr x) (cadr e))))
				(lam:body lam))))
		 `(= ,(cadr e) (call (top Box)))
		 `(newvar ,(cadr e)))))
	  ((const)
	   (if (or (assq (cadr e) (car  (lam:vinfo lam)))
		   (assq (cadr e) (cadr (lam:vinfo lam))))
	       '(null)
	       e))
	  ((method)
           (let* ((name  (method-expr-name e))
                  (short (length= e 2))  ;; function f end
                  (lam2  (if short #f (cadddr e)))
                  (vis   (if short '(() () ()) (lam:vinfo lam2)))
                  (cvs   (map car (cadr vis)))
                  (local? (and lam (symbol? name)
                               (or (assq name (car  (lam:vinfo lam)))
                                   (assq name (cadr (lam:vinfo lam))))))
                  (sig      (and (not short) (caddr e)))
                  (sp-inits (if (or short (not (eq? (car sig) 'block)))
                                '()
                                (map-cl-convert (butlast (cdr sig))
                                                fname lam namemap toplevel interp)))
                  (sig      (and sig (if (eq? (car sig) 'block)
                                         (last sig)
                                         sig))))
             (if local?
                 (begin (if (memq name (lam:args lam))
                            (error (string "cannot add method to function argument " name)))
                        (if (eqv? (string.char (string name) 0) #\@)
                            (error "macro definition not allowed inside a local scope"))))
             (if (not local?) ;; not a local function; will not be closure converted to a new type
                 (cond (short e)
                       ((null? cvs)
                        `(toplevel-butlast
                          ,@sp-inits
                          (method ,name ,(cl-convert sig fname lam namemap toplevel interp)
                                  (lambda ,(cadr lam2)
                                    (,(clear-capture-bits (car vis))
                                     ,@(cdr vis))
                                    ,(add-box-inits-to-body
                                      lam2
                                      (cl-convert (cadddr lam2) 'anon lam2 (table) #f interp)))
                                  ,(last e))))
                       (else
                        (let* ((exprs     (lift-toplevel (convert-lambda lam2 '|#anon| #t)))
                               (top-stmts (cdr exprs))
                               (newlam    (to-goto-form (renumber-jlgensym (car exprs))))
                               (vi        (lam:vinfo newlam))
                               ;; insert `list` expression heads to make the lambda vinfo
                               ;; lists quotable
                               (newlam `(lambda (list ,@(cadr newlam))
                                          (list (list ,@(map (lambda (l) (cons 'list l))
                                                             (car vi)))
                                                (list ,@(cadr vi)) ,(caddr vi) (list ,@(cadddr vi)))
                                          ,@(cdddr newlam))))
                          `(toplevel-butlast
                            ,@top-stmts
                            ,@sp-inits
                            (method ,name ,(cl-convert sig fname lam namemap toplevel interp)
                                    ,(julia-expand-macros `(quote ,newlam))
                                    ,(last e))))))
                 ;; local case - lift to a new type at top level
                 (let* ((exists (get namemap name #f))
                        (tname  (or exists
                                    (and name
                                         (symbol (string "#" name "#" (current-julia-module-counter))))))
                        (alldefs (expr-find-all
                                  (lambda (ex) (and (eq? (car ex) 'method)
                                                    (not (eq? ex e))
                                                    (length> ex 2)
                                                    (eq? (method-expr-name ex) name)))
                                  (lam:body lam)
                                  identity
                                  (lambda (x) (and (pair? x) (not (eq? (car x) 'lambda))))))
                        (cvs   (delete-duplicates
                                (apply append  ;; merge captured vars from all definitions
                                       cvs
                                       (map (lambda (methdef)
                                              (map car (cadr (lam:vinfo (cadddr methdef)))))
                                            alldefs))))
                        (sps   (delete-duplicates  ;; static params from all definitions
                                (apply append
                                       (lam:sp lam2)
                                       (map (lambda (methdef) (lam:sp (cadddr methdef)))
                                            alldefs))))
                        (capt-sp (intersect cvs sps))
                        (capt-vars (diff cvs capt-sp))
                        (method-sp (map (lambda (s) (make-jlgensym)) capt-sp))
                        (typedef  ;; expression to define the type
                         (let* ((fieldtypes (map (lambda (v)
						   (if (is-var-boxed? v lam)
						       'Any ;; TODO
						       (gensy)))
						 capt-vars))
				(para (append capt-sp
                                              (filter (lambda (v) (not (eq? v 'Any))) fieldtypes))))
			   (if (null? para)
			       (type-for-closure tname capt-vars '(top Function))
			       (type-for-closure-parameterized tname para capt-vars fieldtypes '(top Function)))))
                        (mk-closure  ;; expression to make the closure
                         (let* ((var-exprs (map (lambda (v)
                                                  (let ((cv (assq v (cadr (lam:vinfo lam)))))
                                                    (if cv
                                                        (if interp
                                                            `($ (call (top QuoteNode) ,v))
                                                            `(call (top getfield) ,fname (inert ,v)))
                                                        v)))
                                                capt-vars))
                                (P (append
                                    capt-sp
                                    (filter identity (map (lambda (v ve)
                                                            (if (is-var-boxed? v lam)
                                                                #f
                                                                `(call (top typeof) ,ve)))
                                                          capt-vars var-exprs)))))
                           `(new ,(if (null? P)
                                      tname
                                      `(call (top apply_type) ,tname ,@P))
                                 ,@var-exprs)))
                        (iskw ;; TODO jb/functions need more robust version of this
                         (contains (lambda (x) (eq? x 'kwftype)) sig)))
                   `(toplevel-butlast
                     ,@(if exists
                           '()
                           (list
                            (begin (and name (put! namemap name tname))
                                   typedef)))
                     ,@sp-inits
                     ,@(map (lambda (gs tvar) (make-assignment gs `(call (top TypeVar) ',tvar (top Any) true)))
                            method-sp capt-sp)
                     ,@(if short '()
                           `((method #f
                                     ,(fix-function-arg-type sig tname iskw namemap method-sp)
                                     ,(convert-lambda lam2
                                                      (if iskw
                                                          (caddr (lam:args lam2))
                                                          (car (lam:args lam2)))
                                                      #f)
                                     ,(last e))))
                     ,(if exists
                          '(null)
                          (convert-assignment name mk-closure fname lam interp)))))))
	  ((lambda)  ;; should only happen inside (thunk ...)
	   `(lambda ,(cadr e)
	      (,(clear-capture-bits (car (lam:vinfo e)))
	       () ,@(cddr (lam:vinfo e)))
	      (block
	       ,@(map-cl-convert (cdr (lam:body e)) 'anon
				 (lambda-optimize-vars! e)
				 (table)
                                 (null? (cadr e)) ;; only toplevel thunks have 0 args
                                 interp))))
	  (else (cons (car e)
		      (map-cl-convert (cdr e) fname lam namemap toplevel interp))))))))

(define (not-bool e)
  (cond ((memq e '(true #t))  'false)
	((memq e '(false #f)) 'true)
	(else                 `(call (top !) ,e))))

;; remove if, _while, block, break-block, and break
;; replaced with goto and gotoifnot
;; TODO: remove type-assignment-affecting expressions from conditional branch.
;;       needed because there's no program location after the condition
;;       is evaluated but before the branch's successors.
;;       pulling a complex condition out to a temporary variable creates
;;       such a location (the assignment to the variable).
(define (goto-form e)
  (cond ((or (not (pair? e)) (quoted? e)) e)
        ((eq? (car e) 'lambda)
         `(lambda ,(cadr e) ,(caddr e)
                  ,(compile-body (cadddr e) (append (car (caddr e))
                                                    (cadr (caddr e))))))
        (else (cons (car e)
                    (map goto-form (cdr e))))))

(define (compile-body e vi)
  (let ((code '())
        (label-counter 0)
        (label-map (table))
        (label-decl (table))
        (label-level (table))
        (handler-level 0))
    (symbolic-label-handler-levels e label-level 0)
    (define (emit c)
      (set! code (cons c code)))
    (define (make-label)
      (begin0 label-counter
              (set! label-counter (+ 1 label-counter))))
    (define (mark-label l) (emit `(label ,l)))
    (define (make&mark-label)
      (if (and (pair? code) (pair? (car code)) (eq? (caar code) 'label))
          ;; use current label if there is one
          (cadr (car code))
          (let ((l (make-label)))
            (mark-label l)
            l)))
    (define (compile e break-labels)
      (if (or (not (pair? e)) (equal? e '(null)))
          ;; atom has no effect, but keep symbols for undefined-var checking
          (if (symbol? e) (emit e) #f)
          (case (car e)
            ((call)  (emit (goto-form e)))
            ((if) (let ((test     `(gotoifnot ,(goto-form (cadr e)) _))
                        (end-jump `(goto _))
                        (tail     (and (pair? (caddr e))
                                       (eq? (car (caddr e)) 'return))))
                    (emit test)
                    (compile (caddr e) break-labels)
                    (if (and (not tail)
                             (not (equal? (cadddr e) '(null))))
                        (emit end-jump))
                    (set-car! (cddr test) (make&mark-label))
                    (compile (cadddr e) break-labels)
                    (if (not tail)
                        (set-car! (cdr end-jump) (make&mark-label)))))
            ((block body) (for-each (lambda (x) (compile x break-labels))
                                    (cdr e)))
            ((_while)
             (let ((test-blk (cadr e))
                   (endl (make-label)))
               (if (or (atom? test-blk) (equal? test-blk '(block)))
                   ;; if condition is simple, compile it twice in order
                   ;; to generate a single branch per iteration.
                   (let ((topl (make-label)))
                     (compile test-blk break-labels)
                     (emit `(gotoifnot ,(goto-form (caddr e)) ,endl))
                     (mark-label topl)
                     (compile (cadddr e) break-labels)
                     (compile test-blk break-labels)
                     (emit `(gotoifnot ,(not-bool (goto-form (caddr e))) ,topl))
                     (mark-label endl))

                   (let ((topl (make&mark-label)))
                     (compile test-blk break-labels)
                     (emit `(gotoifnot ,(goto-form (caddr e)) ,endl))
                     (compile (cadddr e) break-labels)
                     (emit `(goto ,topl))
                     (mark-label endl)))))

            ((break-block) (let ((endl (make-label)))
                             (compile (caddr e)
                                      (cons (list (cadr e) endl handler-level)
                                            break-labels))
                             (mark-label endl)))
            ((break) (let ((labl (assq (cadr e) break-labels)))
                       (if (not labl)
                           (error "break or continue outside loop")
                           (begin
                             (if (> handler-level (caddr labl))
                                 (emit `(leave
                                         ,(- handler-level (caddr labl)))))
                             (emit `(goto ,(cadr labl)))))))
            ((return) (begin
                        (if (> handler-level 0)
                            (emit `(leave ,handler-level)))
                        (emit (goto-form e))))
            ((label) (let ((m (get label-map (cadr e) #f)))
                       (if m
                           (emit `(label ,m))
                           (let ((l (make&mark-label)))
                             (put! label-map (cadr e) l)))
                       (put! label-decl (cadr e) #t)))
            ((symboliclabel) (let ((m (get label-map (cadr e) #f)))
                               (if m
                                   (if (get label-decl (cadr e) #f)
                                       (error (string "label \"" (cadr e) "\" defined multiple times"))
                                       (emit `(label ,m)))
                                   (let ((l (make&mark-label)))
                                     (put! label-map (cadr e) l)))
                               (put! label-decl (cadr e) #t)))
            ((symbolicgoto) (let ((m (get label-map (cadr e) #f))
                                  (target-level (get label-level (cadr e) #f)))
                              (cond
                               ((not target-level)
                                (error (string "label \"" (cadr e) "\" referenced but not defined")))
                               ((> target-level handler-level)
                                (error (string "cannot goto label \"" (cadr e) "\" inside try/catch block")))
                               ((< target-level handler-level)
                                (emit `(leave ,(- handler-level target-level)))))
                              (if m
                                  (emit `(goto ,m))
                                  (let ((l (make-label)))
                                    (put! label-map (cadr e) l)
                                    (emit `(goto ,l))))))
            ((type_goto) (let((m (get label-map (cadr e) #f)))
                           (if m
                               (emit `(type_goto ,m ,@(cddr e)))
                               (let ((l (make-label)))
                                 (put! label-map (cadr e) l)
                                 (emit `(type_goto ,l ,@(cddr e)))))))
            ;; exception handlers are lowered using
            ;; (enter L) - push handler with catch block at label L
            ;; (leave n) - pop N exception handlers
            ;; (the_exception) - get the thrown object
            ((trycatch)
             (let ((catch (make-label))
                   (endl  (make-label)))
               (emit `(enter ,catch))
               (set! handler-level (+ handler-level 1))
               (compile (cadr e) break-labels)
               (set! handler-level (- handler-level 1))
               (if (not (and (pair? (car code)) (eq? (caar code) 'return)))
                   ;; try ends in return, no need to handle flow off end of it
                   (begin (emit `(leave 1))
                          (emit `(goto ,endl)))
                   (set! endl #f))
               (mark-label catch)
               (emit `(leave 1))
               (compile (caddr e) break-labels)
               (if endl
                   (mark-label endl))
               ))

            ((global) ; remove global declarations
             (let ((vname (cadr e)))
               (if (var-info-for vname vi)
                   ; issue #7264
                   (error (string "`global " vname "`: " vname " is local variable in the enclosing scope"))
                   #f)))
            ((implicit-global) #f)
            ((jlgensym) #f)
	    ((local) #f)
            ((newvar)
             ;; avoid duplicate newvar nodes
             (if (not (and (pair? code) (equal? (car code) e)))
                 (emit e)
                 #f))
            ((method)
             ;; fix residual blocks in method def type sig
             (if (and (length> e 2) (eq? (car (caddr e)) 'block))
                 (let ((sig (caddr e)))
                   (for-each (lambda (x) (emit (goto-form x)))
                             (butlast (cdr sig)))
                   (emit (goto-form `(method ,(cadr e) ,(last sig)
                                             ,@(cdddr e)))))
                 (emit (goto-form e))))
            (else  (emit (goto-form e))))))
    (compile e '())
    (let* ((stmts (reverse! code))
	   (di    (definitely-initialized-vars stmts vi)))
      (cons 'body (filter (lambda (e)
			    (not (and (pair? e) (eq? (car e) 'newvar)
				      (has? di (cadr e)))))
			  stmts)))))

(define to-goto-form goto-form)

;; find newvar nodes that are unnecessary because (1) the variable is not
;; captured, and (2) the variable is assigned before any branches.
;; this is used to remove newvar nodes that are not needed for re-initializing
;; variables to undefined (see issue #11065). it doesn't look for variable
;; *uses*, because any variables used-before-def that also pass this test
;; are *always* used undefined, and therefore don't need to be *re*-initialized.
(define (definitely-initialized-vars stmts vi)
  (let ((vars (table))
	(di   (table)))
    (let loop ((stmts stmts))
      (if (null? stmts)
	  di
	  (begin
	    (let ((e (car stmts)))
	      (cond ((and (pair? e) (eq? (car e) 'newvar))
		     (let ((vinf (var-info-for (cadr e) vi)))
		       (if (and vinf (not (vinfo:capt vinf)))
			   (put! vars (cadr e) #t))))
		    ((and (pair? e) (eq? (car e) '=))
		     (if (has? vars (cadr e))
			 (begin (del! vars (cadr e))
				(put! di (cadr e) #t))))
		    ((and (pair? e) (memq (car e) '(goto gotoifnot)))
		     (set! vars (table)))))
	    (loop (cdr stmts)))))))

;; expander entry point

(define (julia-expand1 ex)
  (to-goto-form
   (renumber-jlgensym
    (closure-convert
     (analyze-variables
      (flatten-scopes
       (identify-locals ex)))))))

(define (julia-expand01 ex)
  (to-LFF
   (expand-forms
    (expand-binding-forms ex))))

(define (julia-expand0 ex)
  (let ((e (julia-expand-macros ex)))
    (if (and (pair? e) (eq? (car e) 'toplevel))
        `(toplevel ,.(map julia-expand01 (cdr e)))
        (julia-expand01 e))))

(define (julia-expand ex)
  (julia-expand1 (julia-expand0 ex)))