Merge tag 'v8.5' into upstream

Leave deleted files deleted.
Take the suggestions for files created in renamed directory.

Importing the tarball will clean up any discrepency.

2 files changed, 132 insertions, 63 deletions

diff --git a/src/schemify/interpret.rkt b/src/schemify/interpret.rkt
index cfaf3debed..d528f439be 100644
--- a/src/schemify/interpret.rkt
+++ b/src/schemify/interpret.rkt
@@ -39,7 +39,7 @@
 (define variable-ref/no-check (lambda (var) (unbox var)))
 (define variable-set! (lambda (var v) (set-box! var v)))
 (define variable-set!/define (lambda (var v) (set-box! var v)))
-(define make-interp-procedure* (lambda (proc mask name) proc))
+(define make-interp-procedure* (lambda (proc mask name+realm) proc))
 
 (define (interpreter-link! prims
                            strip
@@ -56,7 +56,7 @@
   (set! variable-set!/define var-set!/def)
   (set! make-interp-procedure* make-proc))
 
-(define (interpretable-jitified-linklet linklet-e serializable?)
+(define (interpretable-jitified-linklet linklet-e serializable? realm)
   ;; Return a compiled linklet as an expression for the linklet body.
   
   ;; Conceptually, the run-time environment is implemented as a list,
@@ -207,7 +207,7 @@
        (define rev-cmap (for/hasheq ([(i pos) (in-hash cmap)]) (values (- -1 pos) i)))
        (vector 'lambda
                (count->mask count rest?)
-               (extract-procedure-wrap-data e)
+               (extract-procedure-wrap-data e realm)
                (for/vector #:length (hash-count cmap) ([i (in-range (hash-count cmap))])
                  (stack->pos (hash-ref rev-cmap i) stk-i))
                (add-boxes/remove-unused new-body ids mutated body-env body-stk-i))]
@@ -217,7 +217,7 @@
                       (compile-expr `(lambda ,ids . ,body) env stack-depth stk-i tail? mutated)))
        (define mask (for/fold ([mask 0]) ([lam (in-list lams)])
                       (bitwise-ior mask (interp-match lam [#(lambda ,mask) mask]))))
-       (list->vector (list* 'case-lambda mask (extract-procedure-wrap-data e) lams))]
+       (list->vector (list* 'case-lambda mask (extract-procedure-wrap-data e realm) lams))]
       [`(let ([,ids ,rhss] ...) . ,body)
        (define len (length ids))
        (define body-env
@@ -579,7 +579,7 @@
          [else
           (vector 'enbox pos e)])]))
 
-  (define (extract-procedure-wrap-data e)
+  (define (extract-procedure-wrap-data e realm)
     ;; Get name and method-arity information
     (define encoded-name (wrap-property e 'inferred-name))
     (define name
@@ -597,9 +597,10 @@
                (string->symbol (substring s 1 (string-length s)))]
               [else encoded-name])])]
         [else encoded-name]))
+    (define name+realm (if realm (cons name realm) name))
     (if (wrap-property e 'method-arity-error)
-        (box name)
-        name))
+        (box name+realm)
+        name+realm))
 
   (define (begins->list e)
     ;; Convert an expression to a list of expressions, trying to
diff --git a/src/schemify/struct-convert.rkt b/src/schemify/struct-convert.rkt
index 2093ada347..1d469cc8e1 100644
--- a/src/schemify/struct-convert.rkt
+++ b/src/schemify/struct-convert.rkt
@@ -1,5 +1,6 @@
 #lang racket/base
-(require "match.rkt"
+(require racket/symbol
+         "match.rkt"
          "wrap.rkt"
          "struct-type-info.rkt"
          "mutated-state.rkt"
@@ -29,15 +30,41 @@
                       (wrap-eq? ?1 ?2)
                       (for/and ([acc/mut (in-list acc/muts)]
                                 [make-acc/mut (in-list make-acc/muts)])
+                        (define (ok-contract? contract)
+                          (match contract
+                            [`',sym (symbol? sym)]
+                            [`,_ (or (not contract) (string? contract))]))
                         (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-accessor ,ref-id ,pos ',field/proc-name ,contract)
+                           (and (wrap-eq? ref-id -ref)
+                                (symbol? field/proc-name)
+                                (exact-nonnegative-integer? pos)
+                                (ok-contract? contract))]
+                          [`(make-struct-field-accessor ,ref-id ,pos ',field/proc-name ,contract ',realm)
+                           (and (wrap-eq? ref-id -ref)
+                                (symbol? field/proc-name)
+                                (exact-nonnegative-integer? pos)
+                                (ok-contract? contract)
+                                (symbol? realm))]
                           [`(make-struct-field-mutator ,set-id ,pos ',field-name)
                            (and (wrap-eq? set-id -set!)
                                 (symbol? field-name)
                                 (exact-nonnegative-integer? pos))]
+                          [`(make-struct-field-mutator ,set-id ,pos ',field/proc-name ,contract)
+                           (and (wrap-eq? set-id -set!)
+                                (symbol? field/proc-name)
+                                (exact-nonnegative-integer? pos)
+                                (ok-contract? contract))]
+                          [`(make-struct-field-mutator ,set-id ,pos ',field/proc-name ,contract ',realm)
+                           (and (wrap-eq? set-id -set!)
+                                (symbol? field/proc-name)
+                                (exact-nonnegative-integer? pos)
+                                (ok-contract? contract)
+                                (symbol? realm))]
                           [`,_ #f]))
                       (make-struct-type-info mk prim-knowns knowns imports mutated)))
      (cond
@@ -45,7 +72,7 @@
              ;; 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))]))
+                 [`(,_ ,_ ,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`:
@@ -56,7 +83,9 @@
                  (null? (struct-type-info-rest sti))
                  (not (set!ed-mutated-state? (hash-ref mutated (unwrap struct:s) #f)))))
         (define can-impersonate? (not (struct-type-info-authentic? sti)))
-        (define raw-s? (if can-impersonate? (deterministic-gensym (unwrap s?)) s?))
+        (define generate-check? (or can-impersonate?
+                                    (not (aim? target 'system))))
+        (define raw-s? (if generate-check? (deterministic-gensym (unwrap s?)) s?))
         (define system-opaque? (and (aim? target 'system)
                                     (or (not exports)
                                         (eq? 'no (hash-ref exports (unwrap struct:s) 'no)))))
@@ -132,72 +161,108 @@
                                   c
                                   `(#%struct-constructor ,c ,(arithmetic-shift 1 (struct-type-info-field-count sti))))))
            (define ,raw-s? ,(let ([p (name-procedure
-                                      "" (struct-type-info-name sti) "" '|| "?"
+                                      (build-name "" (struct-type-info-name sti) "" '|| "?")
                                       `(record-predicate ,struct:s))])
-                              (if (or can-impersonate?
+                              (if (or generate-check?
                                       system-opaque?)
                                   p
                                   `(#%struct-predicate ,p))))
-           ,@(if can-impersonate?
+           ,@(if generate-check?
                  `((define ,s? ,(let ([p (name-procedure
-                                          "" (struct-type-info-name sti) "" '|| "?"
-                                          `(lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))])
+                                          (build-name "" (struct-type-info-name sti) "" '|| "?")
+                                          `(lambda (v)
+                                             ,(if can-impersonate?
+                                                  `(if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))
+                                                  `(,raw-s? v))))])
                                   (if system-opaque?
                                       p
                                       `(#%struct-predicate ,p)))))
                  null)
            ,@(for/list ([acc/mut (in-list acc/muts)]
                         [make-acc/mut (in-list make-acc/muts)])
-               (define raw-acc/mut (if can-impersonate? (deterministic-gensym (unwrap acc/mut)) acc/mut))
-               (match make-acc/mut
-                 [`(make-struct-field-accessor ,(? (lambda (v) (wrap-eq? v -ref))) ,pos ',field-name)
-                  (define raw-def `(define ,raw-acc/mut
-                                     ,(let ([p (name-procedure
-                                                "" (struct-type-info-name sti) "-" field-name ""
-                                                `(record-accessor ,struct:s ,pos))])
-                                        (if (or can-impersonate?
-                                                system-opaque?)
-                                            p
-                                            `(#%struct-field-accessor ,p ,struct:s ,pos)))))
-                  (if can-impersonate?
+               (define raw-acc/mut (if generate-check? (deterministic-gensym (unwrap acc/mut)) acc/mut))
+               (define (make-err-args field/proc-name proc-name contract realm)
+                 (cond
+                   [(and (not contract) (eq? realm 'racket))
+                    `(',field/proc-name)]
+                   [else
+                    (let ([contract (or contract
+                                        `',(string->symbol
+                                            (string-append-immutable
+                                             (symbol->immutable-string (struct-type-info-name sti))
+                                             "?")))])
+                      `(',proc-name ,contract ',realm))]))
+               (define (build-accessor pos field/proc-name contract realm)
+                 (define proc-name (if contract
+                                       field/proc-name
+                                       (build-name "" (struct-type-info-name sti) "-" field/proc-name "")))
+                 (define raw-def `(define ,raw-acc/mut
+                                    ,(let ([p (name-procedure
+                                               proc-name
+                                               `(record-accessor ,struct:s ,pos))])
+                                       (if (or generate-check?
+                                               system-opaque?)
+                                           p
+                                           `(#%struct-field-accessor ,p ,struct:s ,pos)))))
+                 (define (err-args) (make-err-args field/proc-name proc-name contract realm))
+                 (if generate-check?
                       `(begin
                          ,raw-def
                          (define ,acc/mut
                            ,(let ([p (name-procedure
-                                      "" (struct-type-info-name sti) "-" field-name ""
+                                      proc-name
                                       `(lambda (s) (if (,raw-s? s)
                                                        (,raw-acc/mut s)
-                                                       ($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s
-                                                                                ',(struct-type-info-name sti) ',field-name)))))])
+                                                       ,(if can-impersonate?
+                                                            `($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s ,@(err-args)))
+                                                            `(#%struct-ref-error s ,@(err-args))))))])
                               (if system-opaque?
                                   p
                                   `(#%struct-field-accessor ,p ,struct:s ,pos)))))
-                      raw-def)]
-                 [`(make-struct-field-mutator ,(? (lambda (v) (wrap-eq? v -set!))) ,pos ',field-name)
-                  (define raw-def `(define ,raw-acc/mut
-                                     ,(let ([p (name-procedure
-                                                "set-" (struct-type-info-name sti) "-" field-name "!"
-                                                `(record-mutator ,struct:s ,pos))])
-                                        (if (or can-impersonate?
-                                                system-opaque?)
-                                            p
-                                            `(#%struct-field-mutator ,p ,struct:s ,pos)))))
-                  (define abs-pos (+ pos (- (struct-type-info-field-count sti)
-                                            (struct-type-info-immediate-field-count sti))))
-                  (if can-impersonate?
-                      `(begin
-                         ,raw-def
-                         (define ,acc/mut
-                            ,(let ([p (name-procedure
-                                       "set-" (struct-type-info-name sti) "-" field-name "!"
-                                       `(lambda (s v) (if (,raw-s? s)
-                                                          (,raw-acc/mut s v)
-                                                          ($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v
-                                                                                    ',(struct-type-info-name sti) ',field-name)))))])
-                               (if system-opaque?
-                                   p
-                                   `(#%struct-field-mutator ,p ,struct:s ,pos)))))
-                      raw-def)]
+                      raw-def))
+               (define (build-mutator pos field/proc-name contract realm)
+                 (define proc-name (if contract
+                                       field/proc-name
+                                       (build-name "set-" (struct-type-info-name sti) "-" field/proc-name "!")))
+                 (define raw-def `(define ,raw-acc/mut
+                                      ,(let ([p (name-procedure
+                                                 proc-name
+                                                 `(record-mutator ,struct:s ,pos))])
+                                         (if (or generate-check?
+                                                 system-opaque?)
+                                             p
+                                             `(#%struct-field-mutator ,p ,struct:s ,pos)))))
+                 (define abs-pos (+ pos (- (struct-type-info-field-count sti)
+                                           (struct-type-info-immediate-field-count sti))))
+                 (define (err-args) (make-err-args field/proc-name proc-name contract realm))
+                 (if generate-check?
+                     `(begin
+                        ,raw-def
+                        (define ,acc/mut
+                          ,(let ([p (name-procedure
+                                     proc-name
+                                     `(lambda (s v) (if (,raw-s? s)
+                                                        (,raw-acc/mut s v)
+                                                        ,(if can-impersonate?
+                                                             `($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v ,@(err-args)))
+                                                             `(#%struct-set!-error s ,@(err-args))))))])
+                             (if system-opaque?
+                                 p
+                                 `(#%struct-field-mutator ,p ,struct:s ,pos)))))
+                     raw-def))
+               (match make-acc/mut
+                 [`(make-struct-field-accessor ,_ ,pos ',field-name)
+                  (build-accessor pos field-name #f 'racket)]
+                 [`(make-struct-field-accessor ,_ ,pos ',field/proc-name ,contract)
+                  (build-accessor pos field/proc-name contract 'racket)]
+                 [`(make-struct-field-accessor ,_ ,pos ',field/proc-name ,contract ',realm)
+                  (build-accessor pos field/proc-name contract realm)]
+                 [`(make-struct-field-mutator ,_ ,pos ',field-name)
+                  (build-mutator pos field-name #f 'racket)]
+                 [`(make-struct-field-mutator ,_ ,pos ',field-name ,contract)
+                  (build-mutator pos field-name contract 'racket)]
+                 [`(make-struct-field-mutator ,_ ,pos ',field-name ,contract ',realm)
+                  (build-mutator pos field-name contract realm)]
                  [`,_ (error "oops")])))]
        [else #f])]
     [`,_ #f]))
@@ -249,12 +314,15 @@
   (for/list ([e (in-list l)])
     (schemify e knowns)))
 
-(define (name-procedure pre st sep fld post proc-expr)
+(define (name-procedure proc-name proc-expr)
   (wrap-property-set proc-expr
                      'inferred-name
-                     (string->symbol
-                      (string-append pre
-                                     (symbol->string st)
-                                     sep
-                                     (symbol->string fld)
-                                     post))))
+                     proc-name))
+
+(define (build-name pre st sep fld post)
+  (string->symbol
+   (string-append-immutable pre
+                            (symbol->immutable-string st)
+                            sep
+                            (symbol->immutable-string fld)
+                            post)))