suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added support for unsafe struct operations to Typed Scheme.

Browse Source 
original commit: 7d1040283ed325c93fb5499649a0aba5cfadfab7
This commit is contained in:
Vincent St-Amour 2010-06-22 13:22:39 -04:00
parent 9cbdbd8ed7
commit 1d48090ecb
6 changed files with 137 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt Normal file
View File

@ -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")

13
collects/tests/typed-scheme/fail/unsafe-struct.rkt Normal file
View File

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

26
collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt Normal file
View File

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

14
collects/tests/typed-scheme/succeed/unsafe-struct.rkt Normal file
View File

@ -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")

5
collects/typed-scheme/private/base-env.rkt
View File

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

61
collects/typed-scheme/typecheck/tc-app.rkt
View File

@ -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)])