Fixing error reporting

db4
Slava Pestov 2008-04-08 19:12:48 -05:00
parent 2cebf7e9e5
commit a82794a719
3 changed files with 22 additions and 26 deletions

View File

@ -117,9 +117,18 @@ SYMBOL: total
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: argument-count ( methods -- n )
keys 0 [ length max ] reduce ;
ERROR: no-method arguments generic ;
: make-default-method ( methods generic -- quot )
>r argument-count r> [ >r narray r> no-method ] 2curry ;
: multi-dispatch-quot ( methods generic -- quot )
"default-multi-method" word-prop 1quotation swap
[ >r multi-predicate r> ] assoc-map reverse alist>quot ;
[ make-default-method ]
[ drop [ >r multi-predicate r> ] assoc-map reverse ]
2bi alist>quot ;
! Generic words
PREDICATE: generic < word
@ -178,11 +187,6 @@ M: method-body crossref?
drop [ <method> dup ] 2keep reveal-method
] if ;
TUPLE: no-method arguments generic ;
: no-method ( argument-count generic -- * )
>r narray r> \ no-method construct-boa throw ; inline
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
@ -196,18 +200,8 @@ M: no-method error.
dup arguments>> [ class ] map niceify-method .
nl
"Available methods: " print
generic>> methods keys
[ niceify-method ] map stack. ;
: make-default-method ( generic -- quot )
[ 0 swap no-method ] curry ;
: <default-method> ( generic -- method )
[ { } swap <method> ] keep
[ drop ] [ make-default-method define ] 2bi ;
: define-default-method ( generic -- )
dup <default-method> "default-multi-method" set-word-prop ;
generic>> methods canonicalize-specializers drop sort-methods
keys [ niceify-method ] map stack. ;
: forget-method ( specializer generic -- )
[ delete-at ] with-methods ;
@ -221,9 +215,8 @@ M: no-method error.
drop
] [
[ H{ } clone "multi-methods" set-word-prop ]
[ define-default-method ]
[ update-generic ]
tri
bi
] if ;
! Syntax

View File

@ -4,7 +4,6 @@ kernel strings words compiler.units quotations ;
\ GENERIC: must-infer
\ create-method-in must-infer
\ define-default-method must-infer
DEFER: fake
\ fake H{ } clone "multi-methods" set-word-prop
@ -17,11 +16,9 @@ DEFER: fake
[ t ] [ { } \ fake <method> method-body? ] unit-test
[
[ ] [ \ fake define-default-method ] unit-test
[ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test
[ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test
[ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
[ t ] [ \ fake make-generic quotation? ] unit-test

View File

@ -1,7 +1,7 @@
IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system
kernel strings definitions prettyprint debugger arrays
hashtables continuations classes assocs ;
hashtables continuations classes assocs accessors ;
GENERIC: first-test
@ -25,6 +25,7 @@ METHOD: beats? { thing thing } f ;
[ { } 3 play ] must-fail
[ t ] [ error get no-method? ] unit-test
[ ] [ error get error. ] unit-test
[ { { } 3 } ] [ error get arguments>> ] unit-test
[ t ] [ paper scissors play ] unit-test
[ f ] [ scissors paper play ] unit-test
@ -45,6 +46,11 @@ METHOD: hook-test { hashtable { some-var number } } assoc-size ;
5.0 some-var set
[ 0 ] [ H{ } hook-test ] unit-test
"error" some-var set
[ H{ } hook-test ] must-fail
[ t ] [ error get no-method? ] unit-test
[ { H{ } "error" } ] [ error get arguments>> ] unit-test
MIXIN: busted
TUPLE: busted-1 ;