|
1460 | 1460 | (if (length= e 3)
|
1461 | 1461 | `(const ,(cadr e) ,(expand-forms (caddr e)))
|
1462 | 1462 | (let ((arg (cadr e)))
|
1463 |
| - (case (car arg) |
1464 |
| - ((global) (let ((asgn (cadr arg))) |
1465 |
| - (check-assignment asgn) |
1466 |
| - `(block |
1467 |
| - ,.(map (lambda (v) `(global ,v)) |
1468 |
| - (lhs-bound-names (cadr asgn))) |
1469 |
| - ,(expand-assignment asgn #t)))) |
1470 |
| - ((=) (check-assignment arg) |
1471 |
| - (expand-assignment arg #t)) |
1472 |
| - (else (error "expected assignment after \"const\"")))))) |
| 1463 | + (cond |
| 1464 | + ((symbol? arg) |
| 1465 | + ;; Undefined constant: Expr(:const, :a) (not available in surface syntax) |
| 1466 | + `(block ,e (latestworld))) |
| 1467 | + ((eq? (car arg) 'global) |
| 1468 | + (let ((asgn (cadr arg))) |
| 1469 | + (check-assignment asgn) |
| 1470 | + `(block |
| 1471 | + ,.(map (lambda (v) `(global ,v)) |
| 1472 | + (lhs-bound-names (cadr asgn))) |
| 1473 | + ,(expand-assignment asgn #t)))) |
| 1474 | + ((eq? (car arg) '=) |
| 1475 | + (check-assignment arg) |
| 1476 | + (expand-assignment arg #t)) |
| 1477 | + (else |
| 1478 | + (error "expected assignment after \"const\"")))))) |
1473 | 1479 |
|
1474 | 1480 | (define (expand-atomic-decl e)
|
1475 | 1481 | (error "unimplemented or unsupported atomic declaration"))
|
|
3100 | 3106 | (set! vars (cons (cadr e) vars)))
|
3101 | 3107 | ((= const)
|
3102 | 3108 | (let ((v (decl-var (cadr e))))
|
3103 |
| - (find-assigned-vars- (caddr e)) |
| 3109 | + (unless (and (eq? (car e) 'const) (null? (cddr e))) |
| 3110 | + (find-assigned-vars- (caddr e))) |
3104 | 3111 | (if (or (ssavalue? v) (globalref? v) (underscore-symbol? v))
|
3105 | 3112 | '()
|
3106 | 3113 | (set! vars (cons v vars)))))
|
|
3522 | 3529 | (vinfo:set-sa! vi #f)
|
3523 | 3530 | (vinfo:set-sa! vi #t))
|
3524 | 3531 | (vinfo:set-asgn! vi #t))))
|
3525 |
| - (analyze-vars (caddr e) env captvars sp tab)) |
| 3532 | + (unless (null? (cddr e)) |
| 3533 | + (analyze-vars (caddr e) env captvars sp tab))) |
3526 | 3534 | ((call)
|
3527 | 3535 | (let ((vi (get tab (cadr e) #f)))
|
3528 | 3536 | (if vi
|
@@ -4126,8 +4134,6 @@ f(x) = yt(x)
|
4126 | 4134 | '(null)
|
4127 | 4135 | `(newvar ,(cadr e))))))
|
4128 | 4136 | ((const)
|
4129 |
| - ;; Check we've expanded surface `const` (1 argument form) |
4130 |
| - (assert (and (length= e 3))) |
4131 | 4137 | (when (globalref? (cadr e))
|
4132 | 4138 | (put! globals (cadr e) #f))
|
4133 | 4139 | e)
|
@@ -4696,10 +4702,15 @@ f(x) = yt(x)
|
4696 | 4702 | (list cnd))))))
|
4697 | 4703 | tests))
|
4698 | 4704 | (define (emit-assignment-or-setglobal lhs rhs (op '=))
|
4699 |
| - ;; (const (globalref _ _) _) does not use setglobal! |
4700 |
| - (if (and (globalref? lhs) (eq? op '=)) |
4701 |
| - (emit `(call (top setglobal!) ,(cadr lhs) (inert ,(caddr lhs)) ,rhs)) |
4702 |
| - (emit `(,op ,lhs ,rhs)))) |
| 4705 | + ;; (= (globalref _ _) _) => setglobal! |
| 4706 | + ;; (const (globalref _ _) _) => declare_const |
| 4707 | + (cond ((and (globalref? lhs) (eq? op '=)) |
| 4708 | + (emit `(call (core setglobal!) ,(cadr lhs) (inert ,(caddr lhs)) ,rhs))) |
| 4709 | + ((and (globalref? lhs) (eq? op 'const)) |
| 4710 | + (emit `(call (core declare_const) ,(cadr lhs) (inert ,(caddr lhs)) ,rhs))) |
| 4711 | + (else |
| 4712 | + (assert (eq? op '=)) |
| 4713 | + (emit `(= ,lhs ,rhs))))) |
4703 | 4714 | (define (emit-assignment lhs rhs (op '=))
|
4704 | 4715 | (if rhs
|
4705 | 4716 | (if (valid-ir-rvalue? lhs rhs)
|
@@ -4780,21 +4791,26 @@ f(x) = yt(x)
|
4780 | 4791 | (when (pair? (cadr lam))
|
4781 | 4792 | (error (string "`global const` declaration not allowed inside function" (format-loc current-loc)))))
|
4782 | 4793 | (let ((lhs (cadr e)))
|
4783 |
| - (if (and (symbol? lhs) (underscore-symbol? lhs)) |
4784 |
| - (compile (caddr e) break-labels value tail) |
4785 |
| - (let* ((rhs (compile (caddr e) break-labels #t #f)) |
4786 |
| - (lhs (if (and arg-map (symbol? lhs)) |
4787 |
| - (get arg-map lhs lhs) |
4788 |
| - lhs))) |
4789 |
| - (if (and value rhs) |
4790 |
| - (let ((rr (if (or (atom? rhs) (ssavalue? rhs) (eq? (car rhs) 'null)) |
4791 |
| - rhs (make-ssavalue)))) |
4792 |
| - (if (not (eq? rr rhs)) |
4793 |
| - (emit `(= ,rr ,rhs))) |
4794 |
| - (emit-assignment-or-setglobal lhs rr (car e)) |
4795 |
| - (if tail (emit-return tail rr)) |
4796 |
| - rr) |
4797 |
| - (emit-assignment lhs rhs (car e))))))) |
| 4794 | + (cond ((and (symbol? lhs) (underscore-symbol? lhs)) |
| 4795 | + (compile (caddr e) break-labels value tail)) |
| 4796 | + ((and (eq? (car e) 'const) (null? (cddr e)) (globalref? (cadr e))) |
| 4797 | + ;; No RHS - make undefined constant |
| 4798 | + (let ((lhs (cadr e))) |
| 4799 | + (emit `(call (core declare_const) ,(cadr lhs) (inert ,(caddr lhs)))))) |
| 4800 | + (else |
| 4801 | + (let* ((rhs (compile (caddr e) break-labels #t #f)) |
| 4802 | + (lhs (if (and arg-map (symbol? lhs)) |
| 4803 | + (get arg-map lhs lhs) |
| 4804 | + lhs))) |
| 4805 | + (if (and value rhs) |
| 4806 | + (let ((rr (if (or (atom? rhs) (ssavalue? rhs) (eq? (car rhs) 'null)) |
| 4807 | + rhs (make-ssavalue)))) |
| 4808 | + (if (not (eq? rr rhs)) |
| 4809 | + (emit `(= ,rr ,rhs))) |
| 4810 | + (emit-assignment-or-setglobal lhs rr (car e)) |
| 4811 | + (if tail (emit-return tail rr)) |
| 4812 | + rr) |
| 4813 | + (emit-assignment lhs rhs (car e)))))))) |
4798 | 4814 | ((block)
|
4799 | 4815 | (let* ((last-fname filename)
|
4800 | 4816 | (fnm (first-non-meta e))
|
|
0 commit comments