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

racket/class: new error message convention

Browse Source
This commit is contained in:
Matthew Flatt 2012-05-26 21:04:55 -06:00
parent 0456d5e4e5
commit 8ab87a9fcc
3 changed files with 235 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -262,9 +262,9 @@
(define (validate-local-member orig s) (define (validate-local-member orig s)
(if (symbol? s) (if (symbol? s)
s s
(error 'local-member-name (obj-error 'local-member-name
"used before its definition: ~a" "used before its definition"
orig))) "name" (as-write orig))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; field info creation/access ;; field info creation/access
@ -1422,7 +1422,7 @@
;; store a dummy method body that should never be called for abstracts ;; store a dummy method body that should never be called for abstracts
[(abstract-method ...) (map (lambda (abs) [(abstract-method ...) (map (lambda (abs)
#'(lambda (this . rest) #'(lambda (this . rest)
(obj-error 'class "Cannot call abstract method"))) (obj-error 'class "cannot call abstract method")))
(map car abstracts))] (map car abstracts))]
[mappings mappings] [mappings mappings]
@ -1847,7 +1847,10 @@
(define (check-member-key id v) (define (check-member-key id v)
(unless (member-name-key? v) (unless (member-name-key? v)
(error 'define-local-member-name "not a member key for ~a: ~e" id v)) (obj-error 'define-local-member-name
"value is not a member key"
"value" v
"local name" (as-write id)))
(member-key-id v)) (member-key-id v))
(define-syntax (member-name-key stx) (define-syntax (member-name-key stx)
@ -1991,9 +1994,9 @@
;; -- Check superclass -- ;; -- Check superclass --
(unless (class? super) (unless (class? super)
(obj-error 'class* "superclass expression ~e returned a non-class: ~a" (obj-error 'class* "superclass expression result is not a class"
super "result" super
(for-class name))) #:class-name name))
(when any-localized? (when any-localized?
(check-still-unique name (check-still-unique name
@ -2039,17 +2042,17 @@
(for-each (for-each
(lambda (intf) (lambda (intf)
(unless (interface? intf) (unless (interface? intf)
(obj-error 'class* "interface expression returned a non-interface: ~a~a" (obj-error 'class* "interface expression result is not an interface"
intf "result" intf
(for-class name)))) #:class-name name)))
interfaces) interfaces)
;; -- Check inspectors --- ;; -- Check inspectors ---
(when inspector (when inspector
(unless (inspector? inspector) (unless (inspector? inspector)
(obj-error 'class* "inspect class result is not an inspector or #f: ~a~a" (obj-error 'class* "class `inspect' result is not an inspector or #f"
inspector "result" inspector
(for-class name)))) #:class-name name)))
;; -- Match method and field names to indices -- ;; -- Match method and field names to indices --
(let ([method-ht (if no-new-methods? (let ([method-ht (if no-new-methods?
@ -2069,28 +2072,28 @@
(for ([id (in-list public-names)] (for ([id (in-list public-names)]
[p (in-naturals (class-method-width super))]) [p (in-naturals (class-method-width super))])
(when (hash-ref method-ht id #f) (when (hash-ref method-ht id #f)
(obj-error 'class* "superclass ~e already contains method: ~a~a" (obj-error 'class* "superclass already contains method"
super "superclass" super
id "method name" (as-write id)
(for-class name))) #:class-name name))
(hash-set! method-ht id p))) (hash-set! method-ht id p)))
;; Keep check here for early failure, will add to hashtable later in this function. ;; Keep check here for early failure, will add to hashtable later in this function.
(unless no-new-fields? (unless no-new-fields?
(for ([id (in-list public-field-names)]) (for ([id (in-list public-field-names)])
(when (hash-ref field-ht id #f) (when (hash-ref field-ht id #f)
(obj-error 'class* "superclass ~e already contains field: ~a~a" (obj-error 'class* "superclass already contains field"
super "superclass" super
id "field name" (as-write id)
(for-class name))))) #:class-name name))))
;; Check that superclass has expected fields ;; Check that superclass has expected fields
(for-each (lambda (id) (for-each (lambda (id)
(unless (hash-ref field-ht id #f) (unless (hash-ref field-ht id #f)
(obj-error 'class* "superclass ~e does not provide field: ~a~a" (obj-error 'class* "superclass does not provide field"
super "superclass" super
id "field name" (as-write id)
(for-class name)))) (and name "class") name)))
inherit-field-names) inherit-field-names)
;; Check that superclass has expected methods, and get indices ;; Check that superclass has expected methods, and get indices
@ -2102,11 +2105,11 @@
method-ht id method-ht id
(lambda () (lambda ()
(obj-error 'class* (obj-error 'class*
"~a does not provide an expected method for ~a: ~a~a" (format "~a does not provide an expected method for ~a"
(if (eq? method-ht super-method-ht) "superclass" "class") (if (eq? method-ht super-method-ht) "superclass" "class")
what what)
id (format "~a name" what) (as-write id)
(for-class name))))) #:class-name name))))
ids))] ids))]
[method-width (+ (class-method-width super) (length public-names))] [method-width (+ (class-method-width super) (length public-names))]
[field-width (+ (class-field-width super) num-fields)] [field-width (+ (class-field-width super) num-fields)]
@ -2132,29 +2135,26 @@
(lambda (var) (lambda (var)
(unless (hash-ref method-ht var #f) (unless (hash-ref method-ht var #f)
(obj-error 'class* (obj-error 'class*
"interface-required method missing: ~a~a~a" "missing interface-required method"
var "method name" (as-write var)
(for-class name) (and name "class name") (as-write name)
(for-intf (interface-name intf))))) (and (interface-name intf) "interface name") (as-write (interface-name intf)))))
(interface-public-ids intf))) (interface-public-ids intf)))
interfaces) interfaces)
(let ([c (get-implement-requirement interfaces 'class* (for-class name))]) (let ([c (get-implement-requirement interfaces 'class* #:class-name name)])
(when (and c (not (subclass? super c))) (when (and c (not (subclass? super c)))
(obj-error 'class* (obj-error 'class*
"interface-required implementation not satisfied~a~a" "interface-required implementation not satisfied"
(for-class name) (and name "class name") (as-write name)
(let ([r (class-name c)]) (and (class-name c) "required class name") (as-write (class-name c)))))
(if r
(format " required class: ~a" r)
"")))))
;; -- For serialization, check that the superclass is compatible -- ;; -- For serialization, check that the superclass is compatible --
(when deserialize-id (when deserialize-id
(unless (class-serializer super) (unless (class-serializer super)
(obj-error 'class* (obj-error 'class*
"superclass is not serialiazable, not transparent, and does not implement externalizable<%>: ~e~a" "superclass is not serialiazable, not transparent, and does not implement externalizable<%>"
super "superclass" super
(for-class name)))) #:class-name name)))
;; ---- Make the class and its interface ---- ;; ---- Make the class and its interface ----
(let* ([class-make (if name (let* ([class-make (if name
@ -2299,11 +2299,11 @@
(not (vector-ref vec (sub1 (vector-length vec))))) (not (vector-ref vec (sub1 (vector-length vec)))))
(obj-error 'class* (obj-error 'class*
(string-append (string-append
"superclass ~e method for override, overment, inherit/super, " "superclass method for override, overment, inherit/super, "
"or rename-super is not overrideable: ~a~a") "or rename-super is not overrideable")
super "superclass" super
mname "method name" (as-write mname)
(for-class name)))) #:class-name name)))
(vector-ref (class-super-methods super) index)) (vector-ref (class-super-methods super) index))
rename-super-indices rename-super-indices
rename-super-names)] rename-super-names)]
@ -2332,11 +2332,11 @@
(unless aug-ok? (unless aug-ok?
(obj-error 'class* (obj-error 'class*
(string-append (string-append
"superclass ~e method for augride, augment, inherit/inner, " "superclass method for augride, augment, inherit/inner, "
"or rename-inner method is not augmentable: ~a~a") "or rename-inner method is not augmentable")
super "superclass" super
mname "method name" (as-write mname)
(for-class name))))))]) #:class-name name)))))])
(for-each (check-aug #f) (for-each (check-aug #f)
augride-normal-names augride-normal-names
(get-indices method-ht "augride" augride-normal-names)) (get-indices method-ht "augride" augride-normal-names))
@ -2420,9 +2420,9 @@
(for-each (lambda (index method id) (for-each (lambda (index method id)
(when (eq? 'final (vector-ref meth-flags index)) (when (eq? 'final (vector-ref meth-flags index))
(obj-error 'class* (obj-error 'class*
"cannot override or augment final method: ~a~a" "cannot override or augment final method"
id "method name" (as-write id)
(for-class name))) #:class-name name))
(let ([v (vector-ref beta-methods index)]) (let ([v (vector-ref beta-methods index)])
(if (zero? (vector-length v)) (if (zero? (vector-length v))
;; Normal mode - set vtable entry ;; Normal mode - set vtable entry
@ -2548,8 +2548,9 @@
o))) o)))
(if (interface-extension? i externalizable<%>) (if (interface-extension? i externalizable<%>)
(lambda () (lambda ()
(error 'deserialize "cannot deserialize instance with cycles~a" (obj-error 'deserialize
(for-class name))) "cannot deserialize instance with cycles"
#:class-name name))
(lambda () (lambda ()
(let ([o (object-make)]) (let ([o (object-make)])
(values o (values o
@ -2654,9 +2655,9 @@ An example
(lambda () (lambda ()
(hash-set! ht s #t) (hash-set! ht s #t)
#f)) #f))
(obj-error 'class* "external ~a mapped to overlapping keys~a" (obj-error 'class* (format "external ~a mapped to overlapping keys"
what what)
(for-class name)))) #:class-name name)))
syms))) syms)))
(define (get-properties intfs) (define (get-properties intfs)
@ -3591,17 +3592,17 @@ An example
(lambda (intf) (lambda (intf)
(unless (interface? intf) (unless (interface? intf)
(obj-error 'interface (obj-error 'interface
"superinterface expression returned a non-interface: ~e~a" "superinterface expression result is not an interface"
intf "result" intf
(for-intf name)))) #:intf-name name)))
supers) supers)
(for-each (for-each
(lambda (p) (lambda (p)
(unless (struct-type-property? p) (unless (struct-type-property? p)
(obj-error 'interface (obj-error 'interface
"property expression returned a non-property: ~e~a" "property expression result is not a property"
p "result" p
(for-intf name)))) #:intf-name name)))
props) props)
(let ([ht (make-hasheq)]) (let ([ht (make-hasheq)])
(for-each (for-each
@ -3615,13 +3616,10 @@ An example
(lambda (var) (lambda (var)
(when (and (hash-ref ht var #f) (when (and (hash-ref ht var #f)
(not (hash-ref ctcs var #f))) (not (hash-ref ctcs var #f)))
(obj-error 'interface "variable already in superinterface: ~a~a~a" (obj-error 'interface "variable already in superinterface"
var "variable name" (as-write var)
(for-intf name) (and (interface-name super) "already in") (as-write (interface-name super))
(let ([r (interface-name super)]) #:intf-name name)))
(if r
(format " already in: ~a" r)
"")))))
(interface-public-ids super))) (interface-public-ids super)))
supers) supers)
;; merge properties: ;; merge properties:
@ -3638,7 +3636,7 @@ An example
(hash-set! prop-ht g (vector g p v)))) (hash-set! prop-ht g (vector g p v))))
props vals) props vals)
;; Check for [conflicting] implementation requirements ;; Check for [conflicting] implementation requirements
(let ([class (get-implement-requirement supers 'interface (for-intf name))] (let ([class (get-implement-requirement supers 'interface #:intf-name name)]
[interface-make (if name [interface-make (if name
(make-naming-constructor (make-naming-constructor
struct:interface struct:interface
@ -3672,7 +3670,9 @@ An example
(interface-supers i)) (interface-supers i))
(set-interface-all-implemented! i ht))) (set-interface-all-implemented! i ht)))
(define (get-implement-requirement interfaces where for) (define (get-implement-requirement interfaces where
#:class-name [class-name #f]
#:intf-name [intf-name #f])
(let loop ([class #f] (let loop ([class #f]
[supers interfaces]) [supers interfaces])
(if (null? supers) (if (null? supers)
@ -3687,8 +3687,9 @@ An example
[else [else
(obj-error (obj-error
where where
"conflicting class implementation requirements in superinterfaces~a" "conflicting class implementation requirements in superinterfaces"
for)]) #:class-name class-name
#:intf-name intf-name)])
(cdr supers)))))) (cdr supers))))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
@ -3943,9 +3944,9 @@ An example
;; make sure the class isn't abstract ;; make sure the class isn't abstract
(unless (null? (class-abstract-ids class)) (unless (null? (class-abstract-ids class))
(obj-error 'instantiate (obj-error 'instantiate
"cannot instantiate class ~a with abstract methods ~a" "cannot instantiate class with abstract methods"
class "class" class
(class-abstract-ids class))) "abstract methods" (as-write-list (class-abstract-ids class))))
;; Generate correct class by concretizing methods w/interface ctcs ;; Generate correct class by concretizing methods w/interface ctcs
(let* ([class (fetch-concrete-class class blame)] (let* ([class (fetch-concrete-class class blame)]
[o ((class-make-object class))]) [o ((class-make-object class))])
@ -3974,9 +3975,9 @@ An example
(if explict-named-args? (if explict-named-args?
(obj-error (obj-error
'instantiate 'instantiate
"class has only by-position initializers, but given by-name arguments:~a~a" "class has only by-position initializers, but given by-name arguments"
(make-named-arg-string named-args) "arguments" (as-lines (make-named-arg-string named-args))
(for-class (class-name c))) #:class-name (class-name c))
;; If args were implicit from subclass, should report as unused: ;; If args were implicit from subclass, should report as unused:
(unused-args-error o named-args)))) (unused-args-error o named-args))))
;; Merge by-pos into named args: ;; Merge by-pos into named args:
@ -4003,13 +4004,15 @@ An example
c inited? leftovers ; merely passed through to continue-make-super c inited? leftovers ; merely passed through to continue-make-super
named-args) named-args)
(unless (unbox inited?) (unless (unbox inited?)
(obj-error 'instantiate "superclass initialization not invoked by initialization~a" (obj-error 'instantiate
(for-class (class-name c)))))))))) "superclass initialization not invoked by initialization"
#:class-name (class-name c)))))))))
(define (continue-make-super o c inited? leftovers by-pos-args new-named-args) (define (continue-make-super o c inited? leftovers by-pos-args new-named-args)
(when (unbox inited?) (when (unbox inited?)
(obj-error 'instantiate "superclass already initialized by class initialization~a" (obj-error 'instantiate
(for-class (class-name c)))) "superclass already initialized by class initialization"
#:class-name (class-name c)))
(set-box! inited? #t) (set-box! inited? #t)
(let ([named-args (if (eq? 'list (class-init-mode c)) (let ([named-args (if (eq? 'list (class-init-mode c))
;; all old args must have been used up ;; all old args must have been used up
@ -4049,9 +4052,9 @@ An example
named-args))] named-args))]
[else [else
(obj-error 'instantiate (obj-error 'instantiate
"too many initialization arguments:~a~a" "too many initialization arguments"
(make-pos-arg-string by-pos-args) "arguments" (as-lines (make-pos-arg-string by-pos-args))
(for-class (class-name c)))]))] #:class-name (class-name c))]))]
[else (cons (cons (car nl) (car al)) [else (cons (cons (car nl) (car al))
(do-merge (cdr al) (cdr nl) ic named-args by-pos-args c))])) (do-merge (cdr al) (cdr nl) ic named-args by-pos-args c))]))
@ -4090,26 +4093,31 @@ An example
args)))) args))))
(define (make-named-arg-string args) (define (make-named-arg-string args)
(let loop ([args args][count 0]) (apply
(cond string-append
[(null? args) ""] (let loop ([args args][count 0])
[(= count 3) " ..."] (cond
[(null? args) null]
[(= count 3) '("\n ...")]
[else (let ([rest (loop (cdr args) (add1 count))]) [else (let ([rest (loop (cdr args) (add1 count))])
(format " (~a ~e)~a" (cons (format "\n [~a ~e]"
(caar args) (caar args)
(cdar args) (cdar args))
rest))]))) rest))]))))
(define (unused-args-error this args) (define (unused-args-error this args)
(let ([arg-string (make-named-arg-string args)]) (let ([arg-string (make-named-arg-string args)])
(obj-error 'instantiate "unused initialization arguments:~a~a" (obj-error 'instantiate "unused initialization arguments"
arg-string "unused arguments" (as-lines arg-string)
(for-class/which "instantiated" (class-name (object-ref this)))))) #:class-name (class-name (object-ref this))
#:which-class "instantiated ")))
(define (missing-argument-error class-name name) (define (missing-argument-error class-name name)
(obj-error 'instantiate "no argument for required init variable: ~a~a" (obj-error 'instantiate
name "no argument for required init variable"
(if class-name (format " in class: ~a" class-name) ""))) "init variable name" (as-write name)
#:class-name class-name
#:which-class "instantiated "))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; methods and fields ;; methods and fields
@ -4214,11 +4222,13 @@ An example
(let ([pos (hash-ref (class-method-ht cls) name #f)]) (let ([pos (hash-ref (class-method-ht cls) name #f)])
(if pos (if pos
(vector-ref (class-methods cls) pos) (vector-ref (class-methods cls) pos)
(obj-error who "no such method: ~a~a" (obj-error who
name "no such method"
(for-class (class-name cls))))) "method name" (as-write name)
(obj-error who "target is not an object: ~e for method: ~a" #:class-name (class-name cls))))
in-object name)))) (obj-error who "target is not an object"
"target" in-object
"method name" (as-write name)))))
(define-values (make-class-field-accessor make-class-field-mutator) (define-values (make-class-field-accessor make-class-field-mutator)
(let ([check-and-get-index (let ([check-and-get-index
@ -4229,9 +4239,9 @@ An example
(raise-argument-error who "symbol?" name)) (raise-argument-error who "symbol?" name))
(hash-ref (class-field-ht class) name (hash-ref (class-field-ht class) name
(lambda () (lambda ()
(obj-error who "no such field: ~a~a" (obj-error who "no such field"
name "field-name" (as-write name)
(for-class (class-name class))))))]) #:class-name (class-name class)))))])
(values (λ (class name) (values (λ (class name)
(let* ([fi (check-and-get-index 'class-field-accessor class name)] (let* ([fi (check-and-get-index 'class-field-accessor class name)]
[ref (field-info-external-ref fi)]) [ref (field-info-external-ref fi)])
@ -4262,9 +4272,9 @@ An example
(if (interface? class) (if (interface? class)
(let ([intf class]) (let ([intf class])
(unless (method-in-interface? name intf) (unless (method-in-interface? name intf)
(obj-error 'make-generic "no such method: ~a~a" (obj-error 'make-generic "no such method"
name "method name" (as-write name)
(for-intf (interface-name intf)))) #:intf-name (interface-name intf)))
(lambda (obj) (lambda (obj)
(unless (is-a? obj intf) (unless (is-a? obj intf)
(raise-type-error (raise-type-error
@ -4274,9 +4284,9 @@ An example
(find-method/who 'make-generic obj name))) (find-method/who 'make-generic obj name)))
(let* ([pos (hash-ref (class-method-ht class) name (let* ([pos (hash-ref (class-method-ht class) name
(lambda () (lambda ()
(obj-error 'make-generic "no such method: ~a~a" (obj-error 'make-generic "no such method"
name "method name" (as-write name)
(for-class (class-name class)))))] #:class-name (class-name class))))]
[instance? (class-object? class)] [instance? (class-object? class)]
[dynamic-generic [dynamic-generic
(lambda (obj) (lambda (obj)
@ -4356,19 +4366,18 @@ An example
(define (set-field!/proc id obj val) (define (set-field!/proc id obj val)
(unless (object? obj) (unless (object? obj)
(raise-mismatch-error (raise-argument-error 'set-field!
'set-field! "object?"
"expected an object, got " obj))
obj))
(let* ([cls (object-ref obj)] (let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)] [field-ht (class-field-ht cls)]
[fi (hash-ref field-ht id #f)]) [fi (hash-ref field-ht id #f)])
(if fi (if fi
((field-info-external-set! fi) obj val) ((field-info-external-set! fi) obj val)
(raise-mismatch-error (obj-error 'get-field
'get-field "given object does not have the requested field"
(format "expected an object that has a field named ~s, got " id) "field name" (as-write id)
obj)))) "object" obj))))
(define-syntax (get-field stx) (define-syntax (get-field stx)
(syntax-case stx () (syntax-case stx ()
@ -4383,19 +4392,18 @@ An example
(define (get-field/proc id obj) (define (get-field/proc id obj)
(unless (object? obj) (unless (object? obj)
(raise-mismatch-error (raise-argument-error 'get-field
'get-field "object?"
"expected an object, got " obj))
obj))
(let* ([cls (object-ref obj)] (let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)] [field-ht (class-field-ht cls)]
[fi (hash-ref field-ht id #f)]) [fi (hash-ref field-ht id #f)])
(if fi (if fi
((field-info-external-ref fi) obj) ((field-info-external-ref fi) obj)
(raise-mismatch-error (obj-error 'get-field
'get-field "given object does not have the requested field"
(format "expected an object that has a field named ~s, got " id) "field name" (as-write id)
obj)))) "object" obj))))
(define-syntax (field-bound? stx) (define-syntax (field-bound? stx)
(syntax-case stx () (syntax-case stx ()
@ -4410,10 +4418,9 @@ An example
(define (field-bound?/proc id obj) (define (field-bound?/proc id obj)
(unless (object? obj) (unless (object? obj)
(raise-mismatch-error (raise-argument-error 'field-bound?
'field-bound? "object?"
"expected an object, got " obj))
obj))
(let loop ([obj obj]) (let loop ([obj obj])
(let* ([cls (object-ref obj)] (let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)]) [field-ht (class-field-ht cls)])
@ -4422,10 +4429,9 @@ An example
(define (field-names obj) (define (field-names obj)
(unless (object? obj) (unless (object? obj)
(raise-mismatch-error (raise-argument-error 'field-names
'field-names "object?"
"expected an object, got " obj))
obj))
(let loop ([obj obj]) (let loop ([obj obj])
(let* ([cls (object-ref obj)] (let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)] [field-ht (class-field-ht cls)]
@ -4611,7 +4617,8 @@ An example
(if (zero? (class-pos next)) (if (zero? (class-pos next))
(loop #f #t) (loop #f #t)
(loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t))))) (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t)))))
(raise-mismatch-error 'class-info "current inspector cannot inspect class: " c))) (raise-arguments-error 'class-info "current inspector cannot inspect class"
"class" c)))
(define object->vector (define object->vector
(opt-lambda (in-o [opaque-v '...]) (opt-lambda (in-o [opaque-v '...])
@ -4876,9 +4883,60 @@ An example
(define-struct (exn:fail:object exn:fail) () #:inspector insp) (define-struct (exn:fail:object exn:fail) () #:inspector insp)
(define (obj-error where . msg) (struct as-write (content))
(struct as-write-list (content))
(struct as-value-list (content))
(struct as-lines (content))
(define (obj-error where
msg
#:class-name [class-name #f]
#:intf-name [intf-name #f]
#:which-class [which-class ""]
. fields)
(define all-fields
(append fields
(if class-name
(list (string-append which-class "class name")
(as-write class-name))
null)
(if intf-name
(list "interface name"
(as-write intf-name))
null)))
(raise (make-exn:fail:object (raise (make-exn:fail:object
(string-append (format "~a: " where) (apply format msg)) (format "~a: ~a~a" where msg
(apply
string-append
(let loop ([fields all-fields])
(cond
[(null? fields) null]
[else
(define field (car fields))
(define val (cadr fields))
(list*
"\n "
field
(if (or (as-write-list? val)
(as-lines? val))
":"
": ")
(cond
[(or (as-write-list? val)
(as-value-list? val))
(apply string-append
(for/list ([v (in-list (as-write-list-content val))])
(format (if (as-write-list? val)
"\n ~s"
"\n ~e")
v)))]
[(as-write? val)
(format "~s" (as-write-content val))]
[(as-lines? val)
(as-lines-content val)]
[else
(format "~e" val)])
(loop (cddr fields)))]))))
(current-continuation-marks)))) (current-continuation-marks))))
(define (for-class name) (define (for-class name)
@ -4896,28 +4954,33 @@ An example
(define (check-mixin-super mixin-name super% from-ids) (define (check-mixin-super mixin-name super% from-ids)
(let ([mixin-name (or mixin-name 'mixin)]) (let ([mixin-name (or mixin-name 'mixin)])
(unless (class? super%) (unless (class? super%)
(error mixin-name "argument is not a class: ~e" super%)) (obj-error mixin-name
"argument is not a class"
"argument" super%))
(for-each (lambda (from-id) (for-each (lambda (from-id)
(unless (implementation? super% from-id) (unless (implementation? super% from-id)
(error mixin-name "argument does not implement ~e: ~e" from-id super%))) (obj-error mixin-name
"argument class does not implement method"
"argument" super%
"method name" (as-write from-id))))
from-ids))) from-ids)))
(define (check-mixin-from-interfaces all-from) (define (check-mixin-from-interfaces all-from)
(for-each (lambda (from-id) (for-each (lambda (from-id)
(unless (interface? from-id) (unless (interface? from-id)
(error 'mixin (obj-error 'mixin
"expected from-interface, got: ~e; others ~e" "given value for from-interface is not an interface"
from-id "given" from-id
all-from))) "all given" (as-value-list all-from))))
all-from)) all-from))
(define (check-mixin-to-interfaces all-to) (define (check-mixin-to-interfaces all-to)
(for-each (lambda (to-id) (for-each (lambda (to-id)
(unless (interface? to-id) (unless (interface? to-id)
(error 'mixin (obj-error 'mixin
"expected to-interface, got: ~e; others ~e" "given values for from-interface is not an interface"
to-id "given" to-id
all-to))) "all given" (as-value-list all-to))))
all-to)) all-to))
@ -4925,9 +4988,10 @@ An example
(for-each (for-each
(lambda (x) (lambda (x)
(unless (ormap (lambda (i) (method-in-interface? x i)) from-ids) (unless (ormap (lambda (i) (method-in-interface? x i)) from-ids)
(error 'mixin (obj-error 'mixin
"method `~a' was referenced in definition, but is not in any of the from-interfaces: ~e" "method was referenced in definition, but is not in any of the from-interfaces"
x from-ids))) "method name" (as-write x)
"from-interfaces" (as-write-list from-ids))))
xs)) xs))
(define-syntax (mixin stx) (define-syntax (mixin stx)

2
collects/scribblings/reference/class.scrbl
View File

@ -1196,7 +1196,7 @@ Extracts the field with (external) name @racket[id] from the value of
@racket[obj-expr]. @racket[obj-expr].
If @racket[obj-expr] does not produce an object, the If @racket[obj-expr] does not produce an object, the
@exnraise[exn:fail:contract]. If the object has no @racket[id] method, @exnraise[exn:fail:contract]. If the object has no @racket[id] field,
the @exnraise[exn:fail:object].} the @exnraise[exn:fail:object].}
@defform[(set-field! id obj-expr expr)]{ @defform[(set-field! id obj-expr expr)]{

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

@ -1232,17 +1232,17 @@
(syntax-test #'(get-field 1 b)) (syntax-test #'(get-field 1 b))
(syntax-test #'(get-field a b c)) (syntax-test #'(get-field a b c))
(error-test #'(get-field x 1) exn:application:mismatch?) (error-test #'(get-field x 1) exn:fail:contract?)
(error-test #'(get-field x (new object%)) exn:application:mismatch?) (error-test #'(get-field x (new object%)) exn:fail:object?)
(error-test #'(get-field x (new (class object% (define x 1) (super-new)))) (error-test #'(get-field x (new (class object% (define x 1) (super-new))))
exn:application:mismatch?) exn:fail:object?)
(error-test #'(let ([o (let () (error-test #'(let ([o (let ()
(define-local-member-name f) (define-local-member-name f)
(new (class object% (new (class object%
(field [f 0]) (field [f 0])
(super-new))))]) (super-new))))])
(get-field f o)) (get-field f o))
exn:application:mismatch?) exn:fail:object?)
(test 0 'get-field1 (get-field x (new (class object% (field [x 0]) (super-new))))) (test 0 'get-field1 (get-field x (new (class object% (field [x 0]) (super-new)))))
(test 0 'get-field2 (let () (test 0 'get-field2 (let ()
(define-local-member-name f) (define-local-member-name f)
@ -1259,16 +1259,17 @@
(syntax-test #'(set-field! 1 b c)) (syntax-test #'(set-field! 1 b c))
(syntax-test #'(set-field! a b c d)) (syntax-test #'(set-field! a b c d))
(error-test #'(set-field! x 1 2) exn:application:mismatch?) (error-test #'(set-field! x 1 2))
(error-test #'(set-field! x (new object%) 2) exn:application:mismatch?) (error-test #'(set-field! x (new object%) 2) exn:fail:object?)
(error-test #'(set-field! x (new (class object% (define x 1) (super-new))) 2) (error-test #'(set-field! x (new (class object% (define x 1) (super-new))) 2)
exn:application:mismatch?) exn:fail:object?)
(error-test #'(let ([o (let () (error-test #'(let ([o (let ()
(define-local-member-name f) (define-local-member-name f)
(new (class object% (new (class object%
(field [f 0]) (field [f 0])
(super-new))))]) (super-new))))])
(set-field! f o 2))) (set-field! f o 2))
exn:fail:object?)
(test 1 'set-field!1 (let ([o (new (class object% (field [x 0]) (super-new)))]) (test 1 'set-field!1 (let ([o (new (class object% (field [x 0]) (super-new)))])
(set-field! x o 1) (set-field! x o 1)
(get-field x o))) (get-field x o)))