commit 44c63e4171da2352f80daf6530a1eb7fbe2dd81f
parent 92d2fe585a15404d2e11e0d25167a81b81f88f1e
Author: AlexKnauth <alexander@knauth.org>
Date: Thu, 28 Apr 2016 16:46:30 -0400
mark syntax properties as preserved
Diffstat:
3 files changed, 24 insertions(+), 19 deletions(-)
diff --git 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
@@ -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
@@ -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=?])
