factor/library/generic/methods.factor

66 lines
1.6 KiB
Factor
Raw Normal View History

2006-08-02 02:49:23 -04:00
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: generic
2006-08-02 15:17:13 -04:00
USING: arrays definitions errors hashtables help kernel
sequences words namespaces ;
2006-08-02 02:49:23 -04:00
2006-08-02 03:49:13 -04:00
PREDICATE: array method-spec
dup length 2 = [
first2 generic? >r class? r> and
] [
drop f
] if ;
TUPLE: method def loc ;
M: f method-def ;
M: f method-loc ;
M: quotation method-def ;
M: quotation method-loc drop f ;
2006-08-16 21:55:53 -04:00
: method ( class generic -- method/f )
"methods" word-prop hash ;
2006-08-02 03:10:09 -04:00
2006-08-16 21:55:53 -04:00
: methods ( generic -- assoc )
2006-08-02 02:49:23 -04:00
"methods" word-prop hash>alist
2006-08-02 03:49:13 -04:00
[ [ first ] 2apply class-compare ] sort
[ first2 method-def 2array ] map ;
2006-08-02 02:49:23 -04:00
2006-08-16 21:55:53 -04:00
: order ( generic -- seq )
2006-08-02 02:49:23 -04:00
"methods" word-prop hash-keys [ class-compare ] sort ;
TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
dup generic? [ <check-method> throw ] unless
over class? [ <check-method> throw ] unless ;
2006-08-15 16:29:35 -04:00
: with-methods ( word quot -- )
2006-08-02 02:49:23 -04:00
swap [ "methods" word-prop swap call ] keep ?make-generic ;
inline
2006-08-02 03:49:13 -04:00
: define-method ( method class generic -- )
2006-08-02 02:49:23 -04:00
>r bootstrap-word r> check-method
[ set-hash ] with-methods ;
2006-08-16 21:55:53 -04:00
: implementors ( class -- seq )
2006-08-02 02:49:23 -04:00
[ "methods" word-prop ?hash* nip ] word-subset-with ;
2006-08-02 15:17:13 -04:00
2006-08-25 00:02:30 -04:00
M: method-spec where*
dup first2 method method-loc [ ] [ second where* ] ?if ;
2006-08-02 15:17:13 -04:00
2006-08-02 16:53:26 -04:00
M: method-spec subdefs drop f ;
2006-08-02 15:17:13 -04:00
M: generic subdefs
2006-09-16 16:31:40 -04:00
dup "methods" word-prop hash-keys natural-sort
[ swap 2array ] map-with ;
2006-08-02 15:17:13 -04:00
M: class subdefs
[
dup "constructor" word-prop [ , ] when*
dup implementors natural-sort [ 2array , ] each-with
] { } make ;
2006-08-02 15:17:13 -04:00
M: method-spec forget
first2 [ remove-hash ] with-methods ;