diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt index 1bc891e..1b6a775 100644 --- a/tapl/mlish.rkt +++ b/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 diff --git a/tapl/stx-utils.rkt b/tapl/stx-utils.rkt index e07801c..596c3ac 100644 --- a/tapl/stx-utils.rkt +++ b/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) diff --git a/tapl/typecheck.rkt b/tapl/typecheck.rkt index b59d1bf..1391e15 100644 --- a/tapl/typecheck.rkt +++ b/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=?])