Another attempt at size reduction
parent
c8f227ccf7
commit
817510cdb9
|
@ -165,3 +165,19 @@ HELP: (call-next-method)
|
|||
{ $values { "method" method-body } }
|
||||
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
|
||||
{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
|
||||
|
||||
HELP: no-next-method
|
||||
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
|
||||
{ $examples
|
||||
"The following code throws this error:"
|
||||
{ $code
|
||||
"GENERIC: error-test ( object -- )"
|
||||
""
|
||||
"M: number error-test 3 + call-next-method ;"
|
||||
""
|
||||
"M: integer error-test recip call-next-method ;"
|
||||
""
|
||||
"123 error-test"
|
||||
}
|
||||
"This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
|
||||
} ;
|
||||
|
|
|
@ -58,8 +58,10 @@ GENERIC: next-method-quot* ( class generic combination -- quot )
|
|||
] bi next-method-quot*
|
||||
] cache ;
|
||||
|
||||
ERROR: no-next-method method ;
|
||||
|
||||
: (call-next-method) ( method -- )
|
||||
next-method-quot call ;
|
||||
dup next-method-quot [ call ] [ no-next-method ] ?if ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
|
|
|
@ -33,22 +33,6 @@ HELP: define-simple-generic
|
|||
|
||||
{ standard-combination hook-combination } related-words
|
||||
|
||||
HELP: no-next-method
|
||||
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
|
||||
{ $examples
|
||||
"The following code throws this error:"
|
||||
{ $code
|
||||
"GENERIC: error-test ( object -- )"
|
||||
""
|
||||
"M: number error-test 3 + call-next-method ;"
|
||||
""
|
||||
"M: integer error-test recip call-next-method ;"
|
||||
""
|
||||
"123 error-test"
|
||||
}
|
||||
"This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
|
||||
} ;
|
||||
|
||||
HELP: inconsistent-next-method
|
||||
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
|
||||
{ $examples
|
||||
|
|
|
@ -79,17 +79,15 @@ ERROR: no-method object generic ;
|
|||
|
||||
ERROR: inconsistent-next-method class generic ;
|
||||
|
||||
ERROR: no-next-method class generic ;
|
||||
|
||||
: single-next-method-quot ( class generic -- quot )
|
||||
[
|
||||
2dup next-method [
|
||||
: single-next-method-quot ( class generic -- quot/f )
|
||||
2dup next-method dup [
|
||||
[
|
||||
pick "predicate" word-prop %
|
||||
1quotation ,
|
||||
[ inconsistent-next-method ] 2curry ,
|
||||
\ if ,
|
||||
] [ [ no-next-method ] 2curry % ] if*
|
||||
] [ ] make ;
|
||||
] [ ] make
|
||||
] [ 3drop f ] if ;
|
||||
|
||||
: single-effective-method ( obj word -- method )
|
||||
[ [ order [ instance? ] with find-last nip ] keep method ]
|
||||
|
@ -127,7 +125,8 @@ M: standard-combination method-declaration
|
|||
|
||||
M: standard-combination next-method-quot*
|
||||
[
|
||||
single-next-method-quot picker prepend
|
||||
single-next-method-quot
|
||||
dup [ picker prepend ] when
|
||||
] with-standard ;
|
||||
|
||||
M: standard-generic effective-method
|
||||
|
@ -142,9 +141,12 @@ PREDICATE: hook-generic < generic
|
|||
|
||||
: with-hook ( combination quot -- quot' )
|
||||
0 (dispatch#) [
|
||||
dip var>> [ get ] curry prepend
|
||||
[ hook-combination ] dip with-variable
|
||||
] with-variable ; inline
|
||||
|
||||
: prepend-hook-var ( quot -- quot' )
|
||||
hook-combination get var>> [ get ] curry prepend ;
|
||||
|
||||
M: hook-combination dispatch# drop 0 ;
|
||||
|
||||
M: hook-combination method-declaration 2drop [ ] ;
|
||||
|
@ -156,13 +158,18 @@ M: hook-generic effective-method
|
|||
single-effective-method ;
|
||||
|
||||
M: hook-combination make-default-method
|
||||
[ error-method ] with-hook ;
|
||||
[ error-method prepend-hook-var ] with-hook ;
|
||||
|
||||
M: hook-combination perform-combination
|
||||
[ drop ] [ [ single-combination ] with-hook ] 2bi define ;
|
||||
[ drop ] [
|
||||
[ single-combination prepend-hook-var ] with-hook
|
||||
] 2bi define ;
|
||||
|
||||
M: hook-combination next-method-quot*
|
||||
[ single-next-method-quot ] with-hook ;
|
||||
[
|
||||
single-next-method-quot
|
||||
dup [ prepend-hook-var ] when
|
||||
] with-hook ;
|
||||
|
||||
M: simple-generic definer drop \ GENERIC: f ;
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
slava@slava-pestovs-macbook-pro.local.14895
|
Loading…
Reference in New Issue