mark syntax properties as preserved

tapl/mlish.rkt

@@ -173,10 +173,10 @@
    ;; - currently cannot do it here; to do the check here, need all types of
    ;;  top-lvl fns, since they can call each other
    #:with (~and ty_fn_expected (~∀ _ (~ext-stlc:→ _ ... out_expected))) 
-          (syntax-property 
-              ((current-type-eval) #'(∀ Ys (ext-stlc:→ τ+orig ...)))
-            'orig
-            (list #'(→ τ+orig ...)))
+          (set-stx-prop/preserved 
+           ((current-type-eval) #'(∀ Ys (ext-stlc:→ τ+orig ...)))
+           'orig
+           (list #'(→ τ+orig ...)))
    #`(begin
       (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected)))
       (define g
@@ -302,7 +302,7 @@
               #:with ([e_arg- τ_arg] ...)
                      (stx-map
                       (λ (e τ_e)
-                        (infer+erase (syntax-property e 'expected-type τ_e)))
+                        (infer+erase (set-stx-prop/preserved e 'expected-type τ_e)))
                       #'(e_arg ...) #'(τ_in.norm (... ...)))
               #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in.norm (... ...)))
                            (mk-app-err-msg (syntax/loc stx (#%app C e_arg ...))
@@ -311,10 +311,10 @@
               (⊢ (StructName e_arg- ...) : (Name τ_X (... ...)))]
              [(C . args) ; no type annotations, must infer instantiation
               #:with StructName/ty 
-                     (syntax-property
-                       (⊢ StructName : (∀ (X ...) (ext-stlc:→ τ ... (Name X ...))))
-                       'orig
-                       (list #'C))
+                     (set-stx-prop/preserved
+                      (⊢ StructName : (∀ (X ...) (ext-stlc:→ τ ... (Name X ...))))
+                      'orig
+                      (list #'C))
               ; stx/loc transfers expected-type
               (syntax/loc stx (mlish:#%app StructName/ty . args))]))
          ...)]))
@@ -631,7 +631,7 @@
 
 (define-syntax → ; wrapping →
   (syntax-parser
-    [(_ . rst) (syntax-property #'(∀ () (ext-stlc:→ . rst)) 'orig (list #'(→ . rst)))]))
+    [(_ . rst) (set-stx-prop/preserved #'(∀ () (ext-stlc:→ . rst)) 'orig (list #'(→ . rst)))]))
 ; special arrow that computes free vars; for use with tests
 ; (because we can't write explicit forall
 (define-syntax →/test 
@@ -721,7 +721,7 @@
                                    (stx-map get-orig #'tys-solved) #'Xs old-orig
                                    (lambda (x y) 
                                     (equal? (syntax->datum x) (syntax->datum y))))))
-                          (syntax-property tyin 'orig (list new-orig)))
+                          (set-stx-prop/preserved tyin 'orig (list new-orig)))
                        #'(τ_in ...)))
        (⊢ (#%app e_fn- e_arg- ...) : τ_out)])])]
   [(_ e_fn . e_args) ; err case; e_fn is not a function

tapl/stx-utils.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require syntax/stx racket/list)
+(require syntax/stx racket/list version/utils)
 (provide (all-defined-out))
 
 (define (stx-cadr stx) (stx-car (stx-cdr stx)))
@@ -68,6 +68,11 @@
 (define (generate-temporariesss stx)
   (stx-map generate-temporariess stx))
 
+(define (set-stx-prop/preserved stx prop val)
+  (if (version<=? "6.5.0.4" (version))
+      (syntax-property stx prop val #t)
+      (syntax-property stx prop val)))
+
 ;; based on make-variable-like-transformer from syntax/transformer,
 ;; but using (#%app id ...) instead of ((#%expression id) ...)
 (define (make-variable-like-transformer ref-stx)

tapl/typecheck.rkt

@@ -142,7 +142,7 @@
     [(_ e stx) (add-expected-ty #'e (get-expected-type #'stx))]))
 (define-for-syntax (add-expected-ty e ty)
   (if (and (syntax? ty) (syntax-e ty))
-      (syntax-property e 'expected-type ((current-type-eval) ty))
+      (set-stx-prop/preserved e 'expected-type ((current-type-eval) ty))
       e))
 
 ;; type assignment
@@ -160,15 +160,15 @@
   ;; - syntax-local-introduce fixes marks on types
   ;;   which didnt get marked bc they were syntax properties
   (define (assign-type e τ #:tag [tag 'type])
-    (syntax-property e tag (syntax-local-introduce ((current-type-eval) τ))))
+    (set-stx-prop/preserved e tag (syntax-local-introduce ((current-type-eval) τ))))
 
   (define (add-expected-type e τ)
     (if (and (syntax? τ) (syntax-e τ))
-        (syntax-property e 'expected-type τ) ; dont type-eval?, ie expand?
+        (set-stx-prop/preserved e 'expected-type τ) ; dont type-eval?, ie expand?
         e))
   (define (get-expected-type e)
     (syntax-property e 'expected-type))
-  (define (add-env e env) (syntax-property e 'env env))
+  (define (add-env e env) (set-stx-prop/preserved e 'env env))
   (define (get-env e) (syntax-property e 'env))
   
   ;; typeof : Syntax -> Type or #f
@@ -293,7 +293,7 @@
        (expand/df
         #`(λ (tv ...)
             (let-syntax ([tv (make-rename-transformer
-                              (syntax-property
+                              (set-stx-prop/preserved
                                (assign-type
                                 (assign-type #'tv #'k)
                                 #'ok #:tag '#,tag)
@@ -399,7 +399,7 @@
   ; used to report error msgs
   (define (add-orig stx orig)
     (define origs (or (syntax-property orig 'orig) null))
-    (syntax-property stx 'orig (cons orig origs)))
+    (set-stx-prop/preserved stx 'orig (cons orig origs)))
   (define (get-orig τ)
     (car (reverse (or (syntax-property τ 'orig) (list τ)))))
   (define (type->str ty)
@@ -685,7 +685,7 @@
     (or (and (pair? t)
              (identifier? (car t)) (identifier? (cdr t))
              (free-identifier=? (car t) (cdr t))
-             (syntax-property stx 'type (car t)))
+             (set-stx-prop/preserved stx 'type (car t)))
         stx))
   ; subst τ for y in e, if (bound-id=? x y)
   (define (subst τ x e [cmp bound-identifier=?])