use ERROR: in several places instead of throwing strings

Doug Coleman 2009-08-11 23:09:02 -05:00
parent e5b9fabc65
commit dc79446250
5 changed files with 15 additions and 5 deletions

View File

@ -202,9 +202,11 @@ M: anonymous-complement (classes-intersect?)
: class= ( first second -- ? ) : class= ( first second -- ? )
[ class<= ] [ swap class<= ] 2bi and ; [ class<= ] [ swap class<= ] 2bi and ;
ERROR: topological-sort-failed ;
: largest-class ( seq -- n elt ) : largest-class ( seq -- n elt )
dup [ [ class< ] with any? not ] curry find-last dup [ [ class< ] with any? not ] curry find-last
[ "Topological sort failed" throw ] unless* ; [ topological-sort-failed ] unless* ;
: sort-classes ( seq -- newseq ) : sort-classes ( seq -- newseq )
[ name>> ] sort-with >vector [ name>> ] sort-with >vector

View File

@ -24,9 +24,11 @@ ERROR: bad-effect ;
: parse-effect-tokens ( end -- tokens ) : parse-effect-tokens ( end -- tokens )
[ parse-effect-token dup ] curry [ ] produce nip ; [ parse-effect-token dup ] curry [ ] produce nip ;
ERROR: stack-effect-omits-dashes effect ;
: parse-effect ( end -- effect ) : parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup parse-effect-tokens { "--" } split1 dup
[ <effect> ] [ "Stack effect declaration must contain --" throw ] if ; [ <effect> ] [ drop stack-effect-omits-dashes ] if ;
: complete-effect ( -- effect ) : complete-effect ( -- effect )
"(" expect ")" parse-effect ; "(" expect ")" parse-effect ;

View File

@ -208,9 +208,11 @@ SYMBOL: predicate-engines
: keep-going? ( assoc -- ? ) : keep-going? ( assoc -- ? )
assumed get swap second first class<= ; assumed get swap second first class<= ;
ERROR: unreachable ;
: prune-redundant-predicates ( assoc -- default assoc' ) : prune-redundant-predicates ( assoc -- default assoc' )
{ {
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } { [ dup empty? ] [ drop [ unreachable ] { } ] }
{ [ dup length 1 = ] [ first second { } ] } { [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
[ [ first second ] [ rest-slice ] bi ] [ [ first second ] [ rest-slice ] bi ]

View File

@ -48,9 +48,11 @@ GENERIC: (log2) ( x -- n ) foldable
PRIVATE> PRIVATE>
ERROR: log2-expects-positive x ;
: log2 ( x -- n ) : log2 ( x -- n )
dup 0 <= [ dup 0 <= [
"log2 expects positive inputs" throw log2-expects-positive
] [ ] [
(log2) (log2)
] if ; inline ] if ; inline

View File

@ -281,9 +281,11 @@ INSTANCE: repetition immutable-sequence
<PRIVATE <PRIVATE
ERROR: integer-length-expected obj ;
: check-length ( n -- n ) : check-length ( n -- n )
#! Ricing. #! Ricing.
dup integer? [ "length not an integer" throw ] unless ; inline dup integer? [ integer-length-expected ] unless ; inline
: ((copy)) ( dst i src j n -- dst i src j n ) : ((copy)) ( dst i src j n -- dst i src j n )
dup -roll [ dup -roll [