Clean up generic words a little bit
parent
4af765629a
commit
1dbd54293c
|
@ -11,7 +11,7 @@ SYMBOL: generic-1
|
|||
[
|
||||
generic-1 T{ combination-1 } define-generic
|
||||
|
||||
[ ] <method> object \ generic-1 define-method
|
||||
[ ] object \ generic-1 define-method
|
||||
] with-compilation-unit
|
||||
|
||||
[ ] [
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax generic.math generic.standard
|
||||
words classes definitions kernel alien combinators sequences
|
||||
math ;
|
||||
math quotations ;
|
||||
IN: generic
|
||||
|
||||
ARTICLE: "method-order" "Method precedence"
|
||||
|
@ -154,7 +154,7 @@ HELP: with-methods
|
|||
$low-level-note ;
|
||||
|
||||
HELP: define-method
|
||||
{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } }
|
||||
{ $values { "method" quotation } { "class" class } { "generic" generic } }
|
||||
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
|
||||
|
||||
HELP: implementors
|
||||
|
|
|
@ -39,11 +39,6 @@ TUPLE: method loc def ;
|
|||
: <method> ( def -- method )
|
||||
{ set-method-def } \ method construct ;
|
||||
|
||||
M: f method-def ;
|
||||
M: f method-loc ;
|
||||
M: quotation method-def ;
|
||||
M: quotation method-loc drop f ;
|
||||
|
||||
: method ( class generic -- method/f )
|
||||
"methods" word-prop at ;
|
||||
|
||||
|
@ -55,7 +50,7 @@ PREDICATE: pair method-spec
|
|||
|
||||
: sort-methods ( assoc -- newassoc )
|
||||
[ keys sort-classes ] keep
|
||||
[ dupd at method-def 2array ] curry map ;
|
||||
[ dupd at method-def ] curry { } map>assoc ;
|
||||
|
||||
: methods ( word -- assoc )
|
||||
"methods" word-prop sort-methods ;
|
||||
|
@ -72,18 +67,19 @@ TUPLE: check-method class generic ;
|
|||
inline
|
||||
|
||||
: define-method ( method class generic -- )
|
||||
>r bootstrap-word r> check-method
|
||||
>r >r <method> r> bootstrap-word r> check-method
|
||||
[ set-at ] with-methods ;
|
||||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
dup first2 method method-loc [ ] [ second where ] ?if ;
|
||||
dup first2 method [ method-loc ] [ second where ] ?if ;
|
||||
|
||||
M: method-spec set-where first2 method set-method-loc ;
|
||||
|
||||
M: method-spec definer drop \ M: \ ; ;
|
||||
|
||||
M: method-spec definition first2 method method-def ;
|
||||
M: method-spec definition
|
||||
first2 method dup [ method-def ] when ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
check-method [ delete-at ] with-methods ;
|
||||
|
|
|
@ -39,8 +39,8 @@ TUPLE: no-math-method left right generic ;
|
|||
\ no-math-method construct-boa throw ;
|
||||
|
||||
: applicable-method ( generic class -- quot )
|
||||
over method method-def
|
||||
[ ] [ [ no-math-method ] curry [ ] like ] ?if ;
|
||||
over method
|
||||
[ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ;
|
||||
|
||||
: object-method ( generic -- quot )
|
||||
object bootstrap-word applicable-method ;
|
||||
|
|
|
@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ;
|
|||
C: <slot-spec> slot-spec
|
||||
|
||||
: define-typecheck ( class generic quot -- )
|
||||
<method> over define-simple-generic -rot define-method ;
|
||||
over define-simple-generic -rot define-method ;
|
||||
|
||||
: define-slot-word ( class slot word quot -- )
|
||||
rot >fixnum add* define-typecheck ;
|
||||
|
|
|
@ -126,7 +126,7 @@ IN: bootstrap.syntax
|
|||
f set-word
|
||||
location >r
|
||||
scan-word bootstrap-word scan-word
|
||||
[ parse-definition <method> -rot define-method ] 2keep
|
||||
[ parse-definition -rot define-method ] 2keep
|
||||
2array r> remember-definition
|
||||
] define-syntax
|
||||
|
||||
|
|
Loading…
Reference in New Issue