diff --git a/racket/src/cs/rumble/box.ss b/racket/src/cs/rumble/box.ss index 8a0f14b6bb..9cb3a0055b 100644 --- a/racket/src/cs/rumble/box.ss +++ b/racket/src/cs/rumble/box.ss @@ -17,7 +17,7 @@ (define (unbox b) (if (#%box? b) (#3%unbox b) - (pariah (impersonate-unbox b)))) + (impersonate-unbox b))) (define (unsafe-unbox b) ;; must handle impersonators @@ -38,7 +38,7 @@ (define (set-box! b v) (if (#%mutable-box? b) (#3%set-box! b v) - (pariah (impersonate-set-box! b v)))) + (impersonate-set-box! b v))) (define (unsafe-set-box! b v) ;; must handle impersonators @@ -51,12 +51,12 @@ ;; in schemified: (define (unbox/check-undefined b name) - (check-not-unsafe-undefined (#3%unbox b) name)) + (check-not-unsafe-undefined (#%unbox b) name)) ;; in schemified: (define (set-box!/check-undefined b v name) - (check-not-unsafe-undefined/assign (unbox b) name) - (#3%set-box! b v)) + (check-not-unsafe-undefined/assign (#%unbox b) name) + (#%set-box! b v)) (define/who (chaperone-box b ref set . props) (check who box? b) @@ -83,51 +83,53 @@ (make-box-impersonator val b props ref set))) (define (impersonate-unbox orig) - (if (and (impersonator? orig) - (#%box? (impersonator-val orig))) - (let loop ([o orig]) - (cond - [(#%box? o) (#%unbox o)] - [(box-chaperone? o) - (let* ([val (loop (impersonator-next o))] - [new-val ((box-chaperone-ref o) o val)]) - (unless (chaperone-of? new-val val) - (raise-arguments-error 'unbox - "chaperone produced a result that is not a chaperone of the original result" - "chaperone result" new-val - "original result" val)) - new-val)] - [(box-impersonator? o) - (let ([val (loop (impersonator-next o))]) - ((box-impersonator-ref o) o val))] - [else (loop (impersonator-next o))])) - ;; Let primitive report the error: - (#2%unbox orig))) + (pariah + (if (and (impersonator? orig) + (#%box? (impersonator-val orig))) + (let loop ([o orig]) + (cond + [(#%box? o) (#%unbox o)] + [(box-chaperone? o) + (let* ([val (loop (impersonator-next o))] + [new-val ((box-chaperone-ref o) o val)]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'unbox + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + new-val)] + [(box-impersonator? o) + (let ([val (loop (impersonator-next o))]) + ((box-impersonator-ref o) o val))] + [else (loop (impersonator-next o))])) + ;; Let primitive report the error: + (#2%unbox orig)))) (define (impersonate-set-box! orig val) - (cond - [(not (and (impersonator? orig) - (mutable-box? (impersonator-val orig)))) - ;; Let primitive report the error: - (#2%set-box! orig val)] - [else - (let loop ([o orig] [val val]) - (cond - [(#%box? o) (#2%set-box! o val)] - [else - (let ([next (impersonator-next o)]) - (cond - [(box-chaperone? o) - (let ([new-val ((box-chaperone-set o) next val)]) - (unless (chaperone-of? new-val val) - (raise-arguments-error 'set-box! - "chaperone produced a result that is not a chaperone of the original result" - "chaperone result" new-val - "original result" val)) - (loop next val))] - [(box-impersonator? o) - (loop next ((box-impersonator-set o) next val))] - [else (loop next val)]))]))])) + (pariah + (cond + [(not (and (impersonator? orig) + (mutable-box? (impersonator-val orig)))) + ;; Let primitive report the error: + (#2%set-box! orig val)] + [else + (let loop ([o orig] [val val]) + (cond + [(#%box? o) (#2%set-box! o val)] + [else + (let ([next (impersonator-next o)]) + (cond + [(box-chaperone? o) + (let ([new-val ((box-chaperone-set o) next val)]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'set-box! + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + (loop next val))] + [(box-impersonator? o) + (loop next ((box-impersonator-set o) next val))] + [else (loop next val)]))]))]))) (define (set-box-impersonator-hash!) (record-type-hash-procedure (record-type-descriptor box-chaperone) diff --git a/racket/src/cs/rumble/inline.ss b/racket/src/cs/rumble/inline.ss index afc438daf9..65ac006eac 100644 --- a/racket/src/cs/rumble/inline.ss +++ b/racket/src/cs/rumble/inline.ss @@ -25,12 +25,12 @@ (#3%vector-length v)) (define-inline (vector-ref v i) - (#%vector? v) - (#2%vector-ref v i)) + (#%$vector-ref-check? v i) + (#3%vector-ref v i)) (define-inline (vector-set! v i n) - (#%vector? v) - (#2%vector-set! v i n)) + (#%$vector-set!-check? v i) + (#3%vector-set! v i n)) (define-inline (unbox b) (#%box? b) diff --git a/racket/src/cs/rumble/vector.ss b/racket/src/cs/rumble/vector.ss index 7f2f3c87bc..02330c8574 100644 --- a/racket/src/cs/rumble/vector.ss +++ b/racket/src/cs/rumble/vector.ss @@ -142,7 +142,7 @@ (define (vector-length vec) (if (#%vector? vec) (#3%vector-length vec) - (pariah (impersonate-vector-length vec)))) + (impersonate-vector-length vec))) (define (unsafe-vector-length vec) (vector-length vec)) @@ -156,29 +156,30 @@ (raise-argument-error 'vector*-length "(and/c vector? (not impersonator?))" vec)) (define (impersonate-vector-length vec) - (if (and (impersonator? vec) - (#%vector? (impersonator-val vec))) - (cond - [(vector-unsafe-chaperone? vec) - (#%vector-length (vector-unsafe-chaperone-vec vec))] - [(vector-unsafe-impersonator? vec) - (#%vector-length (vector-unsafe-impersonator-vec vec))] - [else - (#%vector-length (impersonator-val vec))]) - ;; Let primitive report the error: - (#2%vector-length vec))) + (pariah + (if (and (impersonator? vec) + (#%vector? (impersonator-val vec))) + (cond + [(vector-unsafe-chaperone? vec) + (#%vector-length (vector-unsafe-chaperone-vec vec))] + [(vector-unsafe-impersonator? vec) + (#%vector-length (vector-unsafe-impersonator-vec vec))] + [else + (#%vector-length (impersonator-val vec))]) + ;; Let primitive report the error: + (#2%vector-length vec)))) ;; ---------------------------------------- (define (vector-ref vec idx) - (if (#%vector? vec) - (#2%vector-ref vec idx) - (pariah (impersonate-vector-ref vec idx)))) + (if (#%$vector-ref-check? vec idx) + (#3%vector-ref vec idx) + (impersonate-vector-ref vec idx))) (define (unsafe-vector-ref vec idx) (if (#%vector? vec) (#3%vector-ref vec idx) - (pariah (impersonate-vector-ref vec idx)))) + (impersonate-vector-ref vec idx))) (define/who (vector*-ref vec idx) (if (#%$vector-ref-check? vec idx) @@ -197,48 +198,49 @@ (check-range who "vector" vec idx #f (fx- (#%vector-length vec) 1))) (define (impersonate-vector-ref orig idx) - (if (and (impersonator? orig) - (#%vector? (impersonator-val orig))) - (let loop ([o orig]) - (cond - [(#%vector? o) (#2%vector-ref o idx)] - [(vector-chaperone? o) - (let* ([o-next (impersonator-next o)] - [val (loop o-next)] - [new-val (if (vector*-chaperone? o) - ((vector-chaperone-ref o) orig o-next idx val) - ((vector-chaperone-ref o) o-next idx val))]) - (unless (chaperone-of? new-val val) - (raise-arguments-error 'vector-ref - "chaperone produced a result that is not a chaperone of the original result" - "chaperone result" new-val - "original result" val)) - new-val)] - [(vector-impersonator? o) - (let* ([o-next (impersonator-next o)] - [val (loop o-next)]) - (if (vector*-impersonator? o) - ((vector-impersonator-ref o) orig o-next idx val) - ((vector-impersonator-ref o) o-next idx val)))] - [(vector-unsafe-impersonator? o) - (vector-ref (vector-unsafe-impersonator-vec o) idx)] - [(vector-unsafe-chaperone? o) - (vector-ref (vector-unsafe-chaperone-vec o) idx)] - [else (loop (impersonator-next o))])) - ;; Let primitive report the error: - (#2%vector-ref orig idx))) + (pariah + (if (and (impersonator? orig) + (#%vector? (impersonator-val orig))) + (let loop ([o orig]) + (cond + [(#%vector? o) (#2%vector-ref o idx)] + [(vector-chaperone? o) + (let* ([o-next (impersonator-next o)] + [val (loop o-next)] + [new-val (if (vector*-chaperone? o) + ((vector-chaperone-ref o) orig o-next idx val) + ((vector-chaperone-ref o) o-next idx val))]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'vector-ref + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + new-val)] + [(vector-impersonator? o) + (let* ([o-next (impersonator-next o)] + [val (loop o-next)]) + (if (vector*-impersonator? o) + ((vector-impersonator-ref o) orig o-next idx val) + ((vector-impersonator-ref o) o-next idx val)))] + [(vector-unsafe-impersonator? o) + (vector-ref (vector-unsafe-impersonator-vec o) idx)] + [(vector-unsafe-chaperone? o) + (vector-ref (vector-unsafe-chaperone-vec o) idx)] + [else (loop (impersonator-next o))])) + ;; Let primitive report the error: + (#2%vector-ref orig idx)))) ;; ---------------------------------------- (define (vector-set! vec idx val) - (if (#%vector? vec) - (#2%vector-set! vec idx val) - (pariah (impersonate-vector-set! vec idx val)))) + (if (#%$vector-set!-check? vec idx) + (#3%vector-set! vec idx val) + (impersonate-vector-set! vec idx val))) (define (unsafe-vector-set! vec idx val) (if (#%vector? vec) (#3%vector-set! vec idx val) - (pariah (impersonate-vector-set! vec idx val)))) + (impersonate-vector-set! vec idx val))) (define/who (vector*-set! vec idx val) (if (#%$vector-set!-check? vec idx) @@ -246,42 +248,43 @@ (bad-vector*-op who #t vec idx))) (define (impersonate-vector-set! orig idx val) - (cond - [(not (and (impersonator? orig) - (mutable-vector? (impersonator-val orig)))) - ;; Let primitive report the error: - (#2%vector-set! orig idx val)] - [(or (not (exact-nonnegative-integer? idx)) - (>= idx (vector-length (impersonator-val orig)))) - ;; Let primitive report the index error: - (#2%vector-set! (impersonator-val orig) idx val)] - [else - (let loop ([o orig] [val val]) - (cond - [(#%vector? o) (#2%vector-set! o idx val)] - [else - (let ([next (impersonator-next o)]) - (cond - [(vector-chaperone? o) - (let ([new-val (if (vector*-chaperone? o) - ((vector-chaperone-set o) orig next idx val) - ((vector-chaperone-set o) next idx val))]) - (unless (chaperone-of? new-val val) - (raise-arguments-error 'vector-set! - "chaperone produced a result that is not a chaperone of the original result" - "chaperone result" new-val - "original result" val)) - (loop next val))] - [(vector-impersonator? o) - (loop next - (if (vector*-impersonator? o) - ((vector-impersonator-set o) orig next idx val) - ((vector-impersonator-set o) next idx val)))] - [(vector-unsafe-impersonator? o) - (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)] - [(vector-unsafe-chaperone? o) - (#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)] - [else (loop next val)]))]))])) + (pariah + (cond + [(not (and (impersonator? orig) + (mutable-vector? (impersonator-val orig)))) + ;; Let primitive report the error: + (#2%vector-set! orig idx val)] + [(or (not (exact-nonnegative-integer? idx)) + (>= idx (vector-length (impersonator-val orig)))) + ;; Let primitive report the index error: + (#2%vector-set! (impersonator-val orig) idx val)] + [else + (let loop ([o orig] [val val]) + (cond + [(#%vector? o) (#2%vector-set! o idx val)] + [else + (let ([next (impersonator-next o)]) + (cond + [(vector-chaperone? o) + (let ([new-val (if (vector*-chaperone? o) + ((vector-chaperone-set o) orig next idx val) + ((vector-chaperone-set o) next idx val))]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'vector-set! + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + (loop next val))] + [(vector-impersonator? o) + (loop next + (if (vector*-impersonator? o) + ((vector-impersonator-set o) orig next idx val) + ((vector-impersonator-set o) next idx val)))] + [(vector-unsafe-impersonator? o) + (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)] + [(vector-unsafe-chaperone? o) + (#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)] + [else (loop next val)]))]))]))) ;; ---------------------------------------- diff --git a/racket/src/schemify/lift.rkt b/racket/src/schemify/lift.rkt index 9d14809905..58ba7346f1 100644 --- a/racket/src/schemify/lift.rkt +++ b/racket/src/schemify/lift.rkt @@ -551,7 +551,7 @@ [(indirected? info) (reannotate v (if (indirected-check? info) `(unbox/check-undefined ,v ',v) - `(unbox ,v)))] + `(unsafe-unbox* ,v)))] [else v])]))) (define (convert-lifted-calls-in-seq vs lifts frees empties)