|  | 
| 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