Fixing error reporting

extra/multi-methods/multi-methods.factor

@@ -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
+    [ make-default-method ]
-    [ >r multi-predicate r> ] assoc-map reverse alist>quot ;
+    [ 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
+    generic>> methods canonicalize-specializers drop sort-methods
-    [ niceify-method ] map stack. ;
+    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 ;
 
 : 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

extra/multi-methods/tests/definitions.factor

@@ -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
 

extra/multi-methods/tests/syntax.factor

@@ -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 ;