cs: fix handling of non-typical make-struct-type forms

Some checks were missing to guard the transformation of a `struct`
expansion into a Chez Scheme `define-record-type` expansion.

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)

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

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

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`: