diff --git a/pkgs/racket-test-core/tests/racket/struct.rktl b/pkgs/racket-test-core/tests/racket/struct.rktl index ffbdf1f1c1..806e358ee3 100644 --- a/pkgs/racket-test-core/tests/racket/struct.rktl +++ b/pkgs/racket-test-core/tests/racket/struct.rktl @@ -1292,6 +1292,49 @@ (struct a (x y) #:super struct:b) (test 8 procedure-arity a)) +;; ---------------------------------------- +;; Make sure that non-typical `make-sytruct-type` patterns are +;; not transformed incorrectly by the compiler + +(test '(1 2) 'not-acc/ref + (let-values ([(struct:s make-s s? a b) + (let-values ([(struct:s make s? -ref -set!) (make-struct-type 's #f 3 0 #f)]) + (values struct:s + make + s? + 1 + 2))]) + (list a b))) + +(define-syntax (try-failing-extra stx) + (syntax-case stx () + [(_ expr rx) + (with-syntax ([expr (syntax-local-introduce #'expr)]) + #'(err/rt-test (let-values ([(struct:s make-s s? bad) + (let-values ([(struct:s make s? -ref -set!) (make-struct-type 's #f 3 0 #f)]) + (values struct:s + make + s? + expr))]) + bad-ref) + exn:fail:contract? + rx))])) + +(try-failing-extra (make-struct-field-accessor -ref 3 'name) + #rx"index too large") +(try-failing-extra (make-struct-field-mutator -set! 3 'name) + #rx"index too large") + +(try-failing-extra (make-struct-field-accessor -ref -1 'name) + #rx"make-struct-field-accessor: contract violation") +(try-failing-extra (make-struct-field-mutator -set! -1 'name) + #rx"make-struct-field-mutator: contract violation") + +(try-failing-extra (make-struct-field-accessor -set! 0 'name) + #rx"make-struct-field-accessor: contract violation") +(try-failing-extra (make-struct-field-mutator -ref 0 'name) + #rx"make-struct-field-mutator: contract violation") + ;; ---------------------------------------- (report-errs) diff --git a/racket/src/expander/compile/side-effect.rkt b/racket/src/expander/compile/side-effect.rkt index 4f8824c938..846b25d577 100644 --- a/racket/src/expander/compile/side-effect.rkt +++ b/racket/src/expander/compile/side-effect.rkt @@ -401,7 +401,9 @@ (lookup-defn defns (correlated-e (list-ref l 1)))))) (and (known-struct-op? a) (eq? (known-struct-op-type a) type) - ((field-count-expr-to-field-count (list-ref l 2)) . < . (known-struct-op-field-count a)) + (let ([c (field-count-expr-to-field-count (list-ref l 2))]) + (and c + (c . < . (known-struct-op-field-count a)))) (or (= (length l) 3) (quoted? symbol? (list-ref l 3))))) ;; ---------------------------------------- diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 811428720a..5bd6967d2f 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -36541,7 +36541,8 @@ static const char *startup_source = " #f)))" "(if(known-struct-op? a_0)" "(if(eq?(known-struct-op-type a_0) type_0)" -"(if(<(field-count-expr-to-field-count(list-ref l_0 2))(known-struct-op-field-count a_0))" +"(if(let-values(((c_0)(field-count-expr-to-field-count(list-ref l_0 2))))" +"(if c_0(< c_0(known-struct-op-field-count a_0)) #f))" "(let-values(((or-part_0)(=(length l_0) 3)))" "(if or-part_0 or-part_0(quoted? symbol?(list-ref l_0 3))))" " #f)" @@ -51254,14 +51255,29 @@ static const char *startup_source = "(if(absolute-path? collects-path_0)" "(let-values()" "(let-values(((exec_0)" +"(call-in-original-directory" +"(lambda()" "(path->complete-path" "(find-executable-path(find-system-path 'exec-file))" -"(find-system-path 'orig-dir))))" +"(find-system-path 'orig-dir))))))" "(let-values(((base_0 name_0 dir?_0)(split-path exec_0)))" "(simplify-path(path->complete-path collects-path_0 base_0)))))" "(let-values()" -"(let-values(((p_0)(find-executable-path(find-system-path 'exec-file) collects-path_0 #t)))" +"(let-values(((p_0)" +"(call-in-original-directory" +"(lambda()(find-executable-path(find-system-path 'exec-file) collects-path_0 #t)))))" "(if p_0(simplify-path p_0) #f))))))))" +"(define-values" +"(call-in-original-directory)" +"(lambda(thunk_0)" +"(begin" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-directory" +"(find-system-path 'orig-dir))" +"(thunk_0)))))" "(define-values(relative-path-string?)(lambda(s_0)(begin(if(path-string? s_0)(relative-path? s_0) #f))))" "(define-values" "(check-collection)" diff --git a/racket/src/schemify/struct-convert.rkt b/racket/src/schemify/struct-convert.rkt index 02497d957a..4ba313cd79 100644 --- a/racket/src/schemify/struct-convert.rkt +++ b/racket/src/schemify/struct-convert.rkt @@ -24,9 +24,25 @@ (define sti (and (wrap-eq? struct: struct:2) (wrap-eq? make make2) (wrap-eq? ?1 ?2) + (for/and ([acc/mut (in-list acc/muts)] + [make-acc/mut (in-list make-acc/muts)]) + (match make-acc/mut + [`(make-struct-field-accessor ,ref-id ,pos ',field-name) + (and (wrap-eq? ref-id -ref) + (symbol? field-name) + (exact-nonnegative-integer? pos))] + [`(make-struct-field-mutator ,set-id ,pos ',field-name) + (and (wrap-eq? set-id -set!) + (symbol? field-name) + (exact-nonnegative-integer? pos))] + [`,_ #f])) (make-struct-type-info mk prim-knowns knowns imports mutated))) (cond [(and sti + ;; make sure all accessor/mutator positions are in range: + (for/and ([make-acc/mut (in-list make-acc/muts)]) + (match make-acc/mut + [`(,_ ,_ ,pos ,_) (pos . < . (struct-type-info-immediate-field-count sti))])) ;; make sure `struct:` isn't used too early, since we're ;; reordering it's definition with respect to some arguments ;; of `make-struct-type`: