|
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