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

added object-method-arity-includes

Browse Source 
svn: r1123
This commit is contained in:
Matthew Flatt 2005-10-22 01:56:45 +00:00
parent 574dd38e96
commit f3a67ccb9a
2 changed files with 20 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mzlib/class.ss
View File

@ -26,6 +26,7 @@
generic make-generic send-generic generic make-generic send-generic
is-a? subclass? implementation? interface-extension? is-a? subclass? implementation? interface-extension?
object-interface object-info object->vector object-interface object-info object->vector
object-method-arity-includes?
method-in-interface? interface->method-names class->interface class-info method-in-interface? interface->method-names class->interface class-info
(struct exn:fail:object ()) (struct exn:fail:object ())
make-primitive-class make-primitive-class

19
collects/mzlib/private/class-internal.ss
View File

@ -2708,6 +2708,24 @@
(unless (object? o) (unless (object? o)
(raise-type-error 'object-interface "object" o)) (raise-type-error 'object-interface "object" o))
(class-self-interface (object-ref (unwrap-object o)))) (class-self-interface (object-ref (unwrap-object o))))
(define (object-method-arity-includes? o name cnt)
(unless (object? o)
(raise-type-error 'object-method-arity-includes? "object" o))
(unless (symbol? name)
(raise-type-error 'object-method-arity-includes? "symbol" name))
(unless (and (integer? cnt)
(exact? cnt)
(not (negative? cnt)))
(raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt))
(let loop ([o o])
(let* ([c (object-ref o)]
[pos (hash-table-get (class-method-ht c) name (lambda () #f))])
(cond
[pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
(add1 cnt))]
[(wrapper-object? o) (loop (wrapper-object-wrapped o))]
[else #f]))))
(define (implementation? v i) (define (implementation? v i)
(unless (interface? i) (unless (interface? i)
@ -3198,6 +3216,7 @@
(rename generic/form generic) (rename make-generic/proc make-generic) send-generic (rename generic/form generic) (rename make-generic/proc make-generic) send-generic
is-a? subclass? implementation? interface-extension? is-a? subclass? implementation? interface-extension?
object-interface object-info object->vector object-interface object-info object->vector
object-method-arity-includes?
method-in-interface? interface->method-names class->interface class-info method-in-interface? interface->method-names class->interface class-info
(struct exn:fail:object ()) (struct exn:fail:object ())
make-primitive-class)) make-primitive-class))