From a82794a71910cfaea3471a95db65e8d101a95557 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 8 Apr 2008 19:12:48 -0500
Subject: [PATCH] Fixing error reporting
---
extra/multi-methods/multi-methods.factor | 35 ++++++++------------
extra/multi-methods/tests/definitions.factor | 5 +--
extra/multi-methods/tests/syntax.factor | 8 ++++-
3 files changed, 22 insertions(+), 26 deletions(-)
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index 0276e1422c..8f9e34b1fb 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/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
- [ >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
diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor
index 60ddd32875..fea8f0c402 100644
--- a/extra/multi-methods/tests/definitions.factor
+++ b/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
diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor
index 5e2e86d04b..597a1cebeb 100644
--- a/extra/multi-methods/tests/syntax.factor
+++ b/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 ;