From 1d48090ecb15b059e58f9d179c493b72b6c449eb Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 22 Jun 2010 13:22:39 -0400 Subject: [PATCH] Added support for unsafe struct operations to Typed Scheme. original commit: 7d1040283ed325c93fb5499649a0aba5cfadfab7 --- .../fail/unsafe-struct-parent.rkt | 19 ++++++ .../tests/typed-scheme/fail/unsafe-struct.rkt | 13 ++++ .../succeed/unsafe-struct-parent.rkt | 26 ++++++++ .../typed-scheme/succeed/unsafe-struct.rkt | 14 +++++ collects/typed-scheme/private/base-env.rkt | 5 ++ collects/typed-scheme/typecheck/tc-app.rkt | 61 ++++++++++++++++++- 6 files changed, 137 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt create mode 100644 collects/tests/typed-scheme/fail/unsafe-struct.rkt create mode 100644 collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt create mode 100644 collects/tests/typed-scheme/succeed/unsafe-struct.rkt diff --git a/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt b/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt new file mode 100644 index 00000000..e4734368 --- /dev/null +++ b/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt @@ -0,0 +1,19 @@ +#; +(exn-pred 7) +#lang typed/scheme +(require racket/unsafe/ops) + +(define-struct: foo ((x : Integer) (y : String))) +(define-struct: (bar foo) ((z : Float))) + +(define a (make-foo 1 "1")) +(define b (make-bar 2 "2" 2.0)) + +(+ (unsafe-struct-ref a 1) 2) +(+ (unsafe-struct-ref b 1) 2) + +(unsafe-struct-set! a 0 "2") +(unsafe-struct-set! a 1 2) +(unsafe-struct-set! b 0 3.0) +(unsafe-struct-set! b 1 3) +(unsafe-struct-set! b 2 "3") diff --git a/collects/tests/typed-scheme/fail/unsafe-struct.rkt b/collects/tests/typed-scheme/fail/unsafe-struct.rkt new file mode 100644 index 00000000..a185937b --- /dev/null +++ b/collects/tests/typed-scheme/fail/unsafe-struct.rkt @@ -0,0 +1,13 @@ +#; +(exn-pred 3) +#lang typed/scheme +(require racket/unsafe/ops) + +(define-struct: x ((a : Integer) (b : String)) #:mutable) + +(define x1 (make-x 1 "1")) + +(+ (unsafe-struct-ref x1 1) 1) + +(unsafe-struct-set! x1 0 "2") +(unsafe-struct-set! x1 1 1) diff --git a/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt b/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt new file mode 100644 index 00000000..82ecf767 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt @@ -0,0 +1,26 @@ +#lang typed/scheme +(require racket/unsafe/ops) + +(define-struct: foo ((x : Integer) (y : String))) +(define-struct: (bar foo) ((z : Float))) + +(define a (make-foo 1 "1")) +(define b (make-bar 2 "2" 2.0)) + +(= (+ (unsafe-struct-ref a 0) 2) 3) +(string=? (string-append (unsafe-struct-ref a 1) "\n") "1\n") +(= (+ (unsafe-struct-ref b 0) 2) 4) +(string=? (string-append (unsafe-struct-ref b 1) "\n") "2\n") +(= (+ (unsafe-struct-ref b 2) 2.0) 4.0) + +(unsafe-struct-set! a 0 2) +(unsafe-struct-set! a 1 "2") +(unsafe-struct-set! b 0 3) +(unsafe-struct-set! b 1 "3") +(unsafe-struct-set! b 2 3.0) + +(= (+ (unsafe-struct-ref a 0) 2) 4) +(string=? (string-append (unsafe-struct-ref a 1) "\n") "2\n") +(= (+ (unsafe-struct-ref b 0) 2) 5) +(string=? (string-append (unsafe-struct-ref b 1) "\n") "3\n") +(= (+ (unsafe-struct-ref b 2) 2.0) 5.0) diff --git a/collects/tests/typed-scheme/succeed/unsafe-struct.rkt b/collects/tests/typed-scheme/succeed/unsafe-struct.rkt new file mode 100644 index 00000000..df6bff14 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/unsafe-struct.rkt @@ -0,0 +1,14 @@ +#lang typed/scheme +(require racket/unsafe/ops) + +(define-struct: x ((a : Integer) (b : String)) #:mutable) + +(define x1 (make-x 1 "1")) + +(= (+ (unsafe-struct-ref x1 0) 2) 3) +(string=? (string-append (unsafe-struct-ref x1 1) "\n") "1\n") + +(unsafe-struct-set! x1 0 2) +(unsafe-struct-set! x1 1 "2") +(= (+ (unsafe-struct-ref x1 0) 2) 4) +(string=? (string-append (unsafe-struct-ref x1 1) "\n") "2\n") diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 27a7bdc9..aca51a68 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -411,6 +411,11 @@ [call-with-escape-continuation (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] [struct->vector (Univ . -> . (-vec Univ))] +[unsafe-struct-ref top-func] +[unsafe-struct*-ref top-func] +[unsafe-struct-set! top-func] +[unsafe-struct*-set! top-func] + ;; parameter stuff [parameterization-key Sym] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index cfa4fb9c..109cb371 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -445,7 +445,8 @@ values apply k:apply not list list* call-with-values do-make-object make-object cons map andmap ormap reverse extend-parameterization vector-ref unsafe-vector-ref unsafe-vector*-ref - vector-set! unsafe-vector-set! unsafe-vector*-set!) + vector-set! unsafe-vector-set! unsafe-vector*-set! + unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set!) [(#%plain-app extend-parameterization pmz args ...) (let loop ([args (syntax->list #'(args ...))]) (if (null? args) (ret Univ) @@ -460,6 +461,64 @@ [(tc-result1: t) (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) (loop (cddr args))]))))] + ;; unsafe struct operations + [(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr) + (let ([e-t (single-value #'e)]) + (match (single-value #'s) + [(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _) + (? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _)))))) + (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) + (match e-t + [(tc-result1: (Value: (? number? i))) i] + [_ #f]))]) + (cond [(not ival) + (check-below e-t -Nat) + (if expected + (check-below (ret (apply Un flds)) expected) + (ret (apply Un flds)))] + [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds)))) + (if expected + (check-below (ret (list-ref flds ival)) expected) + (ret (list-ref flds ival)))] + [(not (and (integer? ival) (exact? ival))) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)] + [(< ival 0) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)] + [(not (<= ival (sub1 (length flds)))) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))] + [s-ty + (let ([arg-tys (list s-ty e-t)]) + (tc/funapp #'op #'(s e) (single-value #'op) arg-tys expected))]))] + [(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr) + (let ([e-t (single-value #'e)]) + (match (single-value #'s) + [(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _) + (? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _)))))) + (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) + (match e-t + [(tc-result1: (Value: (? number? i))) i] + [_ #f]))]) + (cond [(not ival) + (tc-error/expr #:stx #'e + #:return (or expected (ret -Void)) + "expected statically known index for unsafe struct mutation, but got ~a" (match e-t [(tc-result1: t) t]))] + [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds)))) + (tc-expr/check #'val (ret (list-ref flds ival))) + (if expected + (check-below (ret -Void) expected) + (ret -Void))] + [(not (and (integer? ival) (exact? ival))) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for unsafe struct mutation, but got ~a" ival)] + [(< ival 0) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)] + [(not (<= ival (sub1 (length flds)))) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))] + [s-ty + (let ([arg-tys (list s-ty e-t (single-value #'val))]) + (tc/funapp #'op #'(s e val) (single-value #'op) arg-tys expected))]))] ;; vector-ref on het vectors [(#%plain-app (~and op (~or (~literal vector-ref) (~literal unsafe-vector-ref) (~literal unsafe-vector*-ref))) v e:expr) (let ([e-t (single-value #'e)])