From 15c0e34bedcb8f8239e59491b12407de7ea5371b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Dec 2019 08:39:56 -0700 Subject: [PATCH] cs: fix default constructor name and initial accessor/mutator name --- .../racket-test-core/tests/racket/struct.rktl | 9 ++++ racket/src/cs/rumble/procedure.ss | 32 +++++++++------ racket/src/cs/rumble/struct.ss | 41 +++++++++++-------- 3 files changed, 53 insertions(+), 29 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/struct.rktl b/pkgs/racket-test-core/tests/racket/struct.rktl index b7b3b735f3..e93aa05c71 100644 --- a/pkgs/racket-test-core/tests/racket/struct.rktl +++ b/pkgs/racket-test-core/tests/racket/struct.rktl @@ -1358,4 +1358,13 @@ ;; ---------------------------------------- +(let () + (define-values (s cns pred ref set) (make-struct-type 'thing #f 1 1 #f)) + (test 'make-thing object-name cns) + (test 'thing? object-name pred) + (test 'thing-ref object-name ref) + (test 'thing-set! object-name set)) + +;; ---------------------------------------- + (report-errs) diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index 61357036a6..20653c493b 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/racket/src/cs/rumble/procedure.ss @@ -151,19 +151,25 @@ (reduced-arity-procedure-name f)) => (lambda (name) name)] [(record? f) - (let* ([v (struct-property-ref prop:procedure (record-rtd f) #f)]) - (cond - [(fixnum? v) - (let ([v (unsafe-struct-ref f v)]) - (cond - [(procedure? v) (object-name v)] - [else (struct-object-name f)]))] - [(eq? v 'unsafe) - (extract-procedure-name - (if (chaperone? f) - (unsafe-procedure-chaperone-replace-proc f) - (unsafe-procedure-impersonator-replace-proc f)))] - [else (struct-object-name f)]))] + (cond + [(position-based-accessor? f) + (position-based-accessor-name f)] + [(position-based-mutator? f) + (position-based-mutator-name f)] + [else + (let* ([v (struct-property-ref prop:procedure (record-rtd f) #f)]) + (cond + [(fixnum? v) + (let ([v (unsafe-struct-ref f v)]) + (cond + [(procedure? v) (object-name v)] + [else (struct-object-name f)]))] + [(eq? v 'unsafe) + (extract-procedure-name + (if (chaperone? f) + (unsafe-procedure-chaperone-replace-proc f) + (unsafe-procedure-impersonator-replace-proc f)))] + [else (struct-object-name f)]))])] [else #f])) (define/who procedure-arity-includes? diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index 8643d0d77b..9c8395f217 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -375,6 +375,13 @@ (define-record position-based-accessor (rtd offset field-count)) (define-record position-based-mutator (rtd offset field-count)) +(define (position-based-accessor-name f) + (let ([rtd (position-based-accessor-rtd f)]) + (string->symbol (string-append (symbol->string (record-type-name rtd)) "-ref")))) +(define (position-based-mutator-name f) + (let ([rtd (position-based-mutator-rtd f)]) + (string->symbol (string-append (symbol->string (record-type-name rtd)) "-set!")))) + ;; Register other procedures in hash tables; avoid wrapping to ;; avoid making the procedures slower (define struct-constructors (make-ephemeron-eq-hashtable)) @@ -447,19 +454,19 @@ (define make-struct-type (case-lambda [(name parent-rtd init-count auto-count) - (make-struct-type name parent-rtd init-count auto-count #f '() (current-inspector) #f '() #f name)] + (make-struct-type name parent-rtd init-count auto-count #f '() (current-inspector) #f '() #f #f)] [(name parent-rtd init-count auto-count auto-val) - (make-struct-type name parent-rtd init-count auto-count auto-val '() (current-inspector) #f '() #f name)] + (make-struct-type name parent-rtd init-count auto-count auto-val '() (current-inspector) #f '() #f #f)] [(name parent-rtd init-count auto-count auto-val props) - (make-struct-type name parent-rtd init-count auto-count auto-val props (current-inspector) #f '() #f name)] + (make-struct-type name parent-rtd init-count auto-count auto-val props (current-inspector) #f '() #f #f)] [(name parent-rtd init-count auto-count auto-val props insp) - (make-struct-type name parent-rtd init-count auto-count auto-val props insp #f '() #f name)] + (make-struct-type name parent-rtd init-count auto-count auto-val props insp #f '() #f #f)] [(name parent-rtd init-count auto-count auto-val props insp proc-spec) - (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec '() #f name)] + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec '() #f #f)] [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables) - (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables #f name)] + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables #f #f)] [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard) - (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard name)] + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard #f)] [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard constructor-name) (let* ([install-props! (check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count @@ -482,7 +489,9 @@ [auto-field-adder (and (positive? auto*-count) (let ([pfa (get-field-info-auto-adder parent-fi)]) (lambda (args) - (args-insert args init-count auto-count auto-val pfa))))]) + (args-insert args init-count auto-count auto-val pfa))))] + [constructor-name (or constructor-name + (string->symbol (string-append "make-" (symbol->string name))))]) (when (or parent-rtd* auto-field-adder) (let ([field-info (make-field-info init*-count auto*-count auto-field-adder)]) (putprop (record-type-uid rtd) 'field-info field-info))) @@ -498,9 +507,9 @@ (lambda args (apply c (reverse (auto-field-adder (reverse args))))) init*-count)) - (or constructor-name name))) + constructor-name)) rtd - (or constructor-name name))] + constructor-name)] [pred (procedure-rename (lambda (v) (or (record? v rtd) @@ -519,17 +528,17 @@ (define struct-type-install-properties! (case-lambda [(rtd name init-count auto-count parent-rtd) - (struct-type-install-properties! rtd name init-count auto-count parent-rtd '() (current-inspector) #f '() #f name #f)] + (struct-type-install-properties! rtd name init-count auto-count parent-rtd '() (current-inspector) #f '() #f #f #f)] [(rtd name init-count auto-count parent-rtd props) - (struct-type-install-properties! rtd name init-count auto-count parent-rtd props (current-inspector) #f '() #f name #f)] + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props (current-inspector) #f '() #f #f #f)] [(rtd name init-count auto-count parent-rtd props insp) - (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp #f '() #f name #f)] + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp #f '() #f #f #f)] [(rtd name init-count auto-count parent-rtd props insp proc-spec) - (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec '() #f name #f)] + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec '() #f #f #f)] [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables) - (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables #f name #f)] + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables #f #f #f)] [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard) - (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard name #f)] + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard #f #f)] [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name) (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name #f)] [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name install-props!)