suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust object-name on classes and interfaces to drop the prefix

Browse Source 
Before this commit, things like this:

  (define c% (class object% (super-new)))
  (object-name c%)

would produce

   'class:c%

but now classes and interfaces will be more like procedures and, in
the example above, just produce:

   'c%

The underlying goal is to make error messages generated from contracts
like

  (is-a?/c frame%)

have "(is-a?/c frame%)" in the message, instead of "(is-a?/c
class:frame%)"
This commit is contained in:
Robby Findler 2012-12-22 14:54:57 -06:00
parent 3ab14bbafe
commit b112a7ef0a
2 changed files with 51 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/racket/private/class-internal.rkt
View File

@ -2074,8 +2074,8 @@
(let ([s (class-name super)])
(and s
(not (eq? super object%))
(if (symbol? s)
(format "derived-from-~a" s)
(if (symbol? s) ;; how can 's' not be a symbol at this point?
(string->symbol (format "derived-from-~a" s))
s))))]
;; Combine method lists
[public-names (append pubment-names public-final-names public-normal-names abstract-names)]
@ -2212,14 +2212,13 @@
;; ---- Make the class and its interface ----
(let* ([class-make (if name
(make-naming-constructor
struct:class
(string->symbol (format "class:~a" name)))
(make-naming-constructor struct:class name "class")
make-class)]
[interface-make (if name
(make-naming-constructor
struct:interface
(string->symbol (format "interface:~a" name)))
(string->symbol (format "interface:~a" name))
#f)
make-interface)]
[method-names (append (reverse public-names) super-method-ids)]
[field-names (append public-field-names super-field-ids)]
@ -2904,9 +2903,7 @@ An example
(hash-copy (class-field-ht cls)))]
[init (class-init cls)]
[class-make (if name
(make-naming-constructor
struct:class
(string->symbol (format "class:~a" name)))
(make-naming-constructor struct:class name "class")
make-class)]
[c (class-make name
pos
@ -3692,9 +3689,9 @@ An example
;; Check for [conflicting] implementation requirements
(let ([class (get-implement-requirement supers 'interface #:intf-name name)]
[interface-make (if name
(make-naming-constructor
struct:interface
(string->symbol (format "interface:~a" name)))
(make-naming-constructor struct:interface
name
"interface")
make-interface)])
;; Add supervars to table:
(for-each
@ -3750,15 +3747,23 @@ An example
;; object%
;;--------------------------------------------------------------------
(define (make-naming-constructor type name)
(let-values ([(struct: make- ? -accessor -mutator)
(make-struct-type name type 0 0 #f null insp)])
make-))
(define (make-naming-constructor type name prefix)
(define (writeer obj port mode)
(write-string "#<" port)
(when prefix
(write-string prefix port)
(write-string ":" port))
(write-string (symbol->string name) port)
(write-string ">" port))
(define props (list (cons prop:custom-write writeer)))
(define-values (struct: make- ? -accessor -mutator)
(make-struct-type name type 0 0 #f props insp))
make-)
(define object<%> ((make-naming-constructor struct:interface 'interface:object%)
(define object<%> ((make-naming-constructor struct:interface 'interface:object% "interface")
'object% null #f null (make-immutable-hash) #f null))
(setup-all-implemented! object<%>)
(define object% ((make-naming-constructor struct:class 'class:object%)
(define object% ((make-naming-constructor struct:class 'object% "class")
'object%
0 (vector #f)
object<%>
@ -3904,9 +3909,7 @@ An example
[field-pub-width (class-field-pub-width cls)]
[field-ht (class-field-ht cls)]
[class-make (if name
(make-naming-constructor
struct:class
(string->symbol (format "class:~a" name)))
(make-naming-constructor struct:class name "class")
make-class)]
[c (class-make name
(class-pos cls)
@ -4856,9 +4859,7 @@ An example
(class-field-ht cls)
(hash-copy (class-field-ht cls)))]
[class-make (if name
(make-naming-constructor
struct:class
(string->symbol (format "class:~a" name)))
(make-naming-constructor struct:class name "class")
make-class)]
[c (class-make name
(class-pos cls)

27
collects/tests/racket/object.rktl
View File

@ -1576,11 +1576,36 @@
(test-call supercall-tail-method))
;; ----------------------------------------
;; Private field names
;; names
(let ([c% (class object% (define foo (lambda () 10)) (define/public (get) foo) (super-new))])
(test 'foo object-name (send (new c%) get)))
(let ([w-s (λ (x)
(define sp (open-output-string))
(write x sp)
(get-output-string sp))])
(test 'object% object-name object%)
(test "#<class:object%>" w-s object%)
(test 'c% object-name (let ([c% (class object% (super-new))]) c%))
(test "#<class:c%>" w-s (let ([c% (class object% (super-new))]) c%))
(test 'i<%> object-name (let ([i<%> (interface ())]) i<%>))
(test "#<interface:i<%>>" w-s (let ([i<%> (interface ())]) i<%>))
(test 'interface:object% object-name (class->interface object%))
(test "#<interface:object%>" w-s (class->interface object%))
(test 'interface:c% object-name (let ([c% (class object% (super-new))])
(class->interface c%)))
(test "#<interface:c%>" w-s (let ([c% (class object% (super-new))])
(class->interface c%)))
)
;; ----------------------------------------
;; Implementing printable<%>