Skip to content

Commit 6043569

Browse files
xal-0xal-0
committed
Factor out expand-table '= lambda into expand-assignment
1 parent 378373e commit 6043569

File tree

1 file changed

+110
-109
lines changed

1 file changed

+110
-109
lines changed

‎src/julia-syntax.scm‎

Lines changed: 110 additions & 109 deletions
Original file line numberDiff line numberDiff line change
@@ -1527,6 +1527,115 @@
15271527
(else
15281528
(error (string "invalid syntax in \"" what "\" declaration"))))))))
15291529

1530+
(define (expand-assignment e (const? #f))
1531+
(define lhs (cadr e))
1532+
(define (function-lhs? lhs)
1533+
(and (pair? lhs)
1534+
(or (eq? (car lhs) 'call)
1535+
(eq? (car lhs) 'where)
1536+
(and (eq? (car lhs) '|::|)
1537+
(pair? (cadr lhs))
1538+
(eq? (car (cadr lhs)) 'call)))))
1539+
(define (assignment-to-function lhs e) ;; convert '= expr to 'function expr
1540+
(cons 'function (cdr e)))
1541+
(cond
1542+
((function-lhs? lhs)
1543+
(expand-forms (assignment-to-function lhs e)))
1544+
((and (pair? lhs)
1545+
(eq? (car lhs) 'curly))
1546+
(expand-unionall-def (cadr e) (caddr e)))
1547+
((assignment? (caddr e))
1548+
;; chain of assignments - convert a=b=c to `b=c; a=c`
1549+
(let loop ((lhss (list lhs))
1550+
(rhs (caddr e)))
1551+
(if (and (assignment? rhs) (not (function-lhs? (cadr rhs))))
1552+
(loop (cons (cadr rhs) lhss) (caddr rhs))
1553+
(let ((rr (if (symbol-like? rhs) rhs (make-ssavalue))))
1554+
(expand-forms
1555+
`(block ,.(if (eq? rr rhs) '() `((= ,rr ,(if (assignment? rhs)
1556+
(assignment-to-function (cadr rhs) rhs)
1557+
rhs))))
1558+
,@(map (lambda (l) `(= ,l ,rr))
1559+
lhss)
1560+
(unnecessary ,rr)))))))
1561+
((or (and (symbol-like? lhs) (valid-name? lhs))
1562+
(globalref? lhs))
1563+
(sink-assignment lhs (expand-forms (caddr e))))
1564+
((atom? lhs)
1565+
(error (string "invalid assignment location \"" (deparse lhs) "\"")))
1566+
(else
1567+
(case (car lhs)
1568+
((|.|)
1569+
;; a.b =
1570+
(let* ((a (cadr lhs))
1571+
(b (caddr lhs))
1572+
(rhs (caddr e)))
1573+
(if (and (length= b 2) (eq? (car b) 'tuple))
1574+
(error (string "invalid syntax \""
1575+
(string (deparse a) ".(" (deparse (cadr b)) ") = ...") "\"")))
1576+
(let ((aa (if (symbol-like? a) a (make-ssavalue)))
1577+
(bb (if (or (atom? b) (symbol-like? b) (and (pair? b) (quoted? b)))
1578+
b (make-ssavalue)))
1579+
(rr (if (or (symbol-like? rhs) (atom? rhs)) rhs (make-ssavalue))))
1580+
`(block
1581+
,.(if (eq? aa a) '() (list (sink-assignment aa (expand-forms a))))
1582+
,.(if (eq? bb b) '() (list (sink-assignment bb (expand-forms b))))
1583+
,.(if (eq? rr rhs) '() (list (sink-assignment rr (expand-forms rhs))))
1584+
(call (top setproperty!) ,aa ,bb ,rr)
1585+
(unnecessary ,rr)))))
1586+
((tuple)
1587+
(let ((lhss (cdr lhs))
1588+
(x (caddr e)))
1589+
(if (has-parameters? lhss)
1590+
;; property destructuring
1591+
(expand-property-destruct lhss x)
1592+
;; multiple assignment
1593+
(expand-tuple-destruct lhss x))))
1594+
((typed_hcat)
1595+
(error "invalid spacing in left side of indexed assignment"))
1596+
((typed_vcat typed_ncat)
1597+
(error "unexpected \";\" in left side of indexed assignment"))
1598+
((ref)
1599+
;; (= (ref a . idxs) rhs)
1600+
(let ((a (cadr lhs))
1601+
(idxs (cddr lhs))
1602+
(rhs (caddr e)))
1603+
(let* ((reuse (and (pair? a)
1604+
(contains (lambda (x) (eq? x 'end))
1605+
idxs)))
1606+
(arr (if reuse (make-ssavalue) a))
1607+
(stmts (if reuse `((= ,arr ,(expand-forms a))) '()))
1608+
(rrhs (and (pair? rhs) (not (ssavalue? rhs)) (not (quoted? rhs))))
1609+
(r (if rrhs (make-ssavalue) rhs))
1610+
(rini (if rrhs (list (sink-assignment r (expand-forms rhs))) '())))
1611+
(receive
1612+
(new-idxs stuff) (process-indices arr idxs)
1613+
`(block
1614+
,@stmts
1615+
,.(map expand-forms stuff)
1616+
,@rini
1617+
,(expand-forms
1618+
`(call (top setindex!) ,arr ,r ,@new-idxs))
1619+
(unnecessary ,r))))))
1620+
((|::|)
1621+
;; (= (|::| T) rhs) is an error
1622+
(if (null? (cddr lhs))
1623+
(error (string "invalid assignment location \"" (deparse lhs) "\"")))
1624+
;; (= (|::| x T) rhs)
1625+
(let ((x (cadr lhs))
1626+
(T (caddr lhs))
1627+
(rhs (caddr e)))
1628+
(let ((e (remove-argument-side-effects x)))
1629+
(expand-forms
1630+
`(block ,@(cdr e)
1631+
(decl ,(car e) ,T)
1632+
(= ,(car e) ,rhs))))))
1633+
((vcat ncat)
1634+
;; (= (vcat . args) rhs)
1635+
(error "use \"(a, b) = ...\" to assign multiple values"))
1636+
(else
1637+
(error (string "invalid assignment location \"" (deparse lhs) "\"")))))))
1638+
15301639
;; convert (lhss...) = (tuple ...) to assignments, eliminating the tuple
15311640
(define (tuple-to-assignments lhss0 x wrap)
15321641
(let loop ((lhss lhss0)
@@ -2498,115 +2607,7 @@
24982607
'global expand-local-or-global-decl
24992608
'local-def expand-local-or-global-decl
25002609

2501-
'=
2502-
(lambda (e)
2503-
(define lhs (cadr e))
2504-
(define (function-lhs? lhs)
2505-
(and (pair? lhs)
2506-
(or (eq? (car lhs) 'call)
2507-
(eq? (car lhs) 'where)
2508-
(and (eq? (car lhs) '|::|)
2509-
(pair? (cadr lhs))
2510-
(eq? (car (cadr lhs)) 'call)))))
2511-
(define (assignment-to-function lhs e) ;; convert '= expr to 'function expr
2512-
(cons 'function (cdr e)))
2513-
(cond
2514-
((function-lhs? lhs)
2515-
(expand-forms (assignment-to-function lhs e)))
2516-
((and (pair? lhs)
2517-
(eq? (car lhs) 'curly))
2518-
(expand-unionall-def (cadr e) (caddr e)))
2519-
((assignment? (caddr e))
2520-
;; chain of assignments - convert a=b=c to `b=c; a=c`
2521-
(let loop ((lhss (list lhs))
2522-
(rhs (caddr e)))
2523-
(if (and (assignment? rhs) (not (function-lhs? (cadr rhs))))
2524-
(loop (cons (cadr rhs) lhss) (caddr rhs))
2525-
(let ((rr (if (symbol-like? rhs) rhs (make-ssavalue))))
2526-
(expand-forms
2527-
`(block ,.(if (eq? rr rhs) '() `((= ,rr ,(if (assignment? rhs)
2528-
(assignment-to-function (cadr rhs) rhs)
2529-
rhs))))
2530-
,@(map (lambda (l) `(= ,l ,rr))
2531-
lhss)
2532-
(unnecessary ,rr)))))))
2533-
((or (and (symbol-like? lhs) (valid-name? lhs))
2534-
(globalref? lhs))
2535-
(sink-assignment lhs (expand-forms (caddr e))))
2536-
((atom? lhs)
2537-
(error (string "invalid assignment location \"" (deparse lhs) "\"")))
2538-
(else
2539-
(case (car lhs)
2540-
((|.|)
2541-
;; a.b =
2542-
(let* ((a (cadr lhs))
2543-
(b (caddr lhs))
2544-
(rhs (caddr e)))
2545-
(if (and (length= b 2) (eq? (car b) 'tuple))
2546-
(error (string "invalid syntax \""
2547-
(string (deparse a) ".(" (deparse (cadr b)) ") = ...") "\"")))
2548-
(let ((aa (if (symbol-like? a) a (make-ssavalue)))
2549-
(bb (if (or (atom? b) (symbol-like? b) (and (pair? b) (quoted? b)))
2550-
b (make-ssavalue)))
2551-
(rr (if (or (symbol-like? rhs) (atom? rhs)) rhs (make-ssavalue))))
2552-
`(block
2553-
,.(if (eq? aa a) '() (list (sink-assignment aa (expand-forms a))))
2554-
,.(if (eq? bb b) '() (list (sink-assignment bb (expand-forms b))))
2555-
,.(if (eq? rr rhs) '() (list (sink-assignment rr (expand-forms rhs))))
2556-
(call (top setproperty!) ,aa ,bb ,rr)
2557-
(unnecessary ,rr)))))
2558-
((tuple)
2559-
(let ((lhss (cdr lhs))
2560-
(x (caddr e)))
2561-
(if (has-parameters? lhss)
2562-
;; property destructuring
2563-
(expand-property-destruct lhss x)
2564-
;; multiple assignment
2565-
(expand-tuple-destruct lhss x))))
2566-
((typed_hcat)
2567-
(error "invalid spacing in left side of indexed assignment"))
2568-
((typed_vcat typed_ncat)
2569-
(error "unexpected \";\" in left side of indexed assignment"))
2570-
((ref)
2571-
;; (= (ref a . idxs) rhs)
2572-
(let ((a (cadr lhs))
2573-
(idxs (cddr lhs))
2574-
(rhs (caddr e)))
2575-
(let* ((reuse (and (pair? a)
2576-
(contains (lambda (x) (eq? x 'end))
2577-
idxs)))
2578-
(arr (if reuse (make-ssavalue) a))
2579-
(stmts (if reuse `((= ,arr ,(expand-forms a))) '()))
2580-
(rrhs (and (pair? rhs) (not (ssavalue? rhs)) (not (quoted? rhs))))
2581-
(r (if rrhs (make-ssavalue) rhs))
2582-
(rini (if rrhs (list (sink-assignment r (expand-forms rhs))) '())))
2583-
(receive
2584-
(new-idxs stuff) (process-indices arr idxs)
2585-
`(block
2586-
,@stmts
2587-
,.(map expand-forms stuff)
2588-
,@rini
2589-
,(expand-forms
2590-
`(call (top setindex!) ,arr ,r ,@new-idxs))
2591-
(unnecessary ,r))))))
2592-
((|::|)
2593-
;; (= (|::| T) rhs) is an error
2594-
(if (null? (cddr lhs))
2595-
(error (string "invalid assignment location \"" (deparse lhs) "\"")))
2596-
;; (= (|::| x T) rhs)
2597-
(let ((x (cadr lhs))
2598-
(T (caddr lhs))
2599-
(rhs (caddr e)))
2600-
(let ((e (remove-argument-side-effects x)))
2601-
(expand-forms
2602-
`(block ,@(cdr e)
2603-
(decl ,(car e) ,T)
2604-
(= ,(car e) ,rhs))))))
2605-
((vcat ncat)
2606-
;; (= (vcat . args) rhs)
2607-
(error "use \"(a, b) = ...\" to assign multiple values"))
2608-
(else
2609-
(error (string "invalid assignment location \"" (deparse lhs) "\"")))))))
2610+
'= expand-assignment
26102611

26112612
'abstract
26122613
(lambda (e)

0 commit comments

Comments
 (0)