Skip to content

Commit 00ecd8b

Browse files
xal-0xal-0
committed
Factor out expand-table '= lambda into expand-assignment
1 parent 5f86cef commit 00ecd8b

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
@@ -1521,6 +1521,115 @@
15211521
(else
15221522
(error (string "invalid syntax in \"" what "\" declaration"))))))))
15231523

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

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

26052606
'abstract
26062607
(lambda (e)

0 commit comments

Comments
 (0)