From: Doug Coleman Date: Thu, 13 Aug 2015 10:20:39 +0000 (-0700) Subject: basis: ERROR: changes. X-Git-Tag: unmaintained~2096 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=b6be8685c3b3a252544c03e9ebc7e88edd97e795 basis: ERROR: changes. --- diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 4e0e4c111f..710c918604 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -55,12 +55,12 @@ UNION: c-type-name c-type-word pointer ; : resolve-typedef ( name -- c-type ) - dup void? [ no-c-type ] when + dup void? [ throw-no-c-type ] when dup c-type-name? [ lookup-c-type ] when ; M: word lookup-c-type dup "c-type" word-prop resolve-typedef - [ ] [ no-c-type ] ?if ; + [ ] [ throw-no-c-type ] ?if ; GENERIC: c-type-class ( name -- class ) diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index 789094fb8b..ba510f7ef3 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -79,7 +79,7 @@ M: bad-byte-array-length summary : cast-array ( byte-array c-type -- array ) [ binary-object ] dip [ heap-size /mod 0 = ] keep swap - [ ] [ bad-byte-array-length ] if ; inline + [ ] [ throw-bad-byte-array-length ] if ; inline : malloc-array ( n c-type -- array ) [ heap-size calloc ] [ ] 2bi ; inline diff --git a/basis/alien/endian/endian.factor b/basis/alien/endian/endian.factor index a7593c05b7..1847f6294b 100644 --- a/basis/alien/endian/endian.factor +++ b/basis/alien/endian/endian.factor @@ -15,7 +15,7 @@ ERROR: invalid-signed-conversion n ; { 2 [ [ c:short c:short deref ] ] } { 4 [ [ int int deref ] ] } { 8 [ [ longlong longlong deref ] ] } - [ invalid-signed-conversion ] + [ throw-invalid-signed-conversion ] } case ; inline MACRO: byte-reverse ( n signed? -- quot ) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 843f0410aa..507273eda2 100755 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -15,7 +15,7 @@ ERROR: bad-array-type ; : parse-array-type ( name -- c-type ) "[" split unclip - [ [ "]" ?tail [ bad-array-type ] unless parse-datum ] map ] + [ [ "]" ?tail [ throw-bad-array-type ] unless parse-datum ] map ] [ (parse-c-type) ] bi* prefix ; diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 500784ef7f..db1ffc75bd 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -24,7 +24,7 @@ CONSTANT: alphabet : base64>ch ( ch -- ch ) $[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth - [ malformed-base64 ] unless* ; inline + [ throw-malformed-base64 ] unless* ; inline : (write-lines) ( column byte-array -- column' ) output-stream get dup '[ @@ -84,7 +84,7 @@ PRIVATE> 4 "\n\r" pick read-ignoring dup length { { 0 [ 2drop ] } { 4 [ decode4 (decode-base64) ] } - [ malformed-base64 ] + [ throw-malformed-base64 ] } case ; PRIVATE> diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor index 590449d77c..423b1a2809 100644 --- a/basis/biassocs/biassocs.factor +++ b/basis/biassocs/biassocs.factor @@ -29,7 +29,7 @@ M: no-biassoc-deletion summary drop "biassocs do not support deletion" ; M: biassoc delete-at - no-biassoc-deletion ; + throw-no-biassoc-deletion ; M: biassoc >alist from>> >alist ; diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 55fec5bba3..4068c5e2cc 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -47,7 +47,7 @@ PRIVATE> ERROR: bad-array-length n ; : ( n -- bit-array ) - dup 0 < [ bad-array-length ] when + dup 0 < [ throw-bad-array-length ] when dup bits>bytes bit-array boa ; inline diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor index 2b4fb129ee..a4c24f0bdc 100644 --- a/basis/bit-sets/bit-sets.factor +++ b/basis/bit-sets/bit-sets.factor @@ -32,7 +32,7 @@ M: bit-set delete ERROR: check-bit-set-failed ; : check-bit-set ( bit-set -- bit-set ) - dup bit-set? [ check-bit-set-failed ] unless ; inline + dup bit-set? [ throw-check-bit-set-failed ] unless ; inline : bit-set-map ( seq1 seq2 quot -- seq ) [ drop [ length ] bi@ [ assert= ] keep ] diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index adbebea3a7..9ece2a2cc5 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -20,7 +20,7 @@ ERROR: invalid-widthed bits #bits ; dup 0 < [ neg ] when log2 <= ] if-zero ] - } 2|| [ invalid-widthed ] when ; + } 2|| [ throw-invalid-widthed ] when ; : ( bits #bits -- widthed ) check-widthed @@ -85,11 +85,11 @@ GENERIC: poke ( value n bitstream -- ) > ] dip < ] } 2|| - [ not-enough-bits ] when ; + [ throw-not-enough-widthed-bits ] when ; : widthed-bits ( widthed n -- bits ) check-widthed-bits @@ -161,7 +161,7 @@ ERROR: not-enough-bits n bit-reader ; ] if ; :: (peek) ( n bs endian> subseq-endian -- bits ) - n bs enough-bits? [ n bs not-enough-bits ] unless + n bs enough-bits? [ n bs throw-not-enough-bits ] unless bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd + bs bytes>> subseq endian> execute( seq -- x ) n bs subseq-endian execute( bignum n bs -- bits ) ; diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index dda459e595..ddf5471fe2 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -365,7 +365,7 @@ ERROR: not-in-image vocabulary word ; : fixup-word ( word -- offset ) transfer-word dup lookup-object - [ ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?if ; + [ ] [ [ vocabulary>> ] [ name>> ] bi throw-not-in-image ] ?if ; : fixup-words ( -- ) bootstrapping-image get [ dup word? [ fixup-word ] when ] map! drop ; @@ -437,7 +437,7 @@ M: byte-array ' ERROR: tuple-removed class ; : require-tuple-layout ( word -- layout ) - dup tuple-layout [ ] [ tuple-removed ] ?if ; + dup tuple-layout [ ] [ throw-tuple-removed ] ?if ; : (emit-tuple) ( tuple -- pointer ) [ tuple-slots ] diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 25f2b963b4..585389a571 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -11,7 +11,7 @@ ERROR: box-full box ; : >box ( value box -- ) dup occupied>> - [ box-full ] [ t >>occupied value<< ] if ; inline + [ throw-box-full ] [ t >>occupied value<< ] if ; inline ERROR: box-empty box ; diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor index 41444b54e6..a59c1762ca 100644 --- a/basis/byte-arrays/hex/hex.factor +++ b/basis/byte-arrays/hex/hex.factor @@ -9,6 +9,6 @@ ERROR: odd-length-hex-string string ; SYNTAX: HEX{ "}" parse-tokens concat [ blank? ] reject - dup length even? [ odd-length-hex-string ] unless + dup length even? [ throw-odd-length-hex-string ] unless 2 [ hex> ] B{ } map-as suffix! ; diff --git a/basis/cairo/cairo.factor b/basis/cairo/cairo.factor index d3edd9022a..9ed9d3bdce 100644 --- a/basis/cairo/cairo.factor +++ b/basis/cairo/cairo.factor @@ -10,7 +10,7 @@ ERROR: cairo-error n message ; : (check-cairo) ( cairo_status_t -- ) dup CAIRO_STATUS_SUCCESS = - [ drop ] [ [ ] [ cairo_status_to_string ] bi cairo-error ] if ; + [ drop ] [ [ ] [ cairo_status_to_string ] bi throw-cairo-error ] if ; : check-cairo ( cairo -- ) cairo_status (check-cairo) ; diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index cee2358f67..9ed39ec7d6 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -57,7 +57,7 @@ M: not-a-month summary @@ -93,7 +93,7 @@ CONSTANT: month-abbreviations-hash : month-abbreviation-index ( string -- n ) month-abbreviations-hash ?at - [ not-a-month-abbreviation ] unless ; + [ throw-not-a-month-abbreviation ] unless ; CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index a7f2c589a0..bc07f6e9ee 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -202,7 +202,7 @@ M: timestamp year. ( timestamp -- ) ERROR: invalid-timestamp-format ; : check-timestamp ( obj/f -- obj ) - [ invalid-timestamp-format ] unless* ; + [ throw-invalid-timestamp-format ] unless* ; : read-token ( seps -- token ) [ read-until ] keep member? check-timestamp drop ; diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index 41c8537d45..c8eab9a95e 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -33,7 +33,7 @@ M: evp-md-context dispose* : digest-named ( name -- md ) dup EVP_get_digestbyname - [ ] [ unknown-digest ] ?if ; + [ ] [ throw-unknown-digest ] ?if ; : set-digest ( name ctx -- ) handle>> swap digest-named f EVP_DigestInit_ex ssl-error ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 63c3fd159c..dc742c72c0 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -285,7 +285,7 @@ M: struct binary-zero? binary-object uchar [ 0 = ] all? ; inlin :: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- ) slot-specs check-struct-slots - slot-specs empty? [ struct-must-have-slots ] when + slot-specs empty? [ throw-struct-must-have-slots ] when class redefine-struct-tuple-class slot-specs offsets-quot call :> unaligned-size slot-specs alignment-quot call :> alignment @@ -376,7 +376,7 @@ PRIVATE> scan-token { { ";" [ f ] } { "{" [ parse-struct-slot suffix! t ] } - [ invalid-struct-slot ] + [ throw-invalid-struct-slot ] } case ; : parse-struct-definition ( -- class slots ) @@ -413,7 +413,7 @@ SYNTAX: S@ scan-token { { ";" [ f ] } { "{" [ parse-struct-slot` t ] } - [ invalid-struct-slot ] + [ throw-invalid-struct-slot ] } case ; PRIVATE> diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 0b641b5c01..058062d900 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -67,7 +67,7 @@ ERROR: no-objc-method name ; objc-methods get at ; : lookup-method ( selector -- method ) - dup ?lookup-method [ ] [ no-objc-method ] ?if ; + dup ?lookup-method [ ] [ throw-no-objc-method ] ?if ; : lookup-sender ( name -- method ) lookup-method message-senders get at ; @@ -196,7 +196,7 @@ ERROR: no-objc-type name ; : decode-type ( ch -- ctype ) 1string dup objc>alien-types get at - [ ] [ no-objc-type ] ?if ; + [ ] [ throw-no-objc-type ] ?if ; : (parse-objc-type) ( i string -- ctype ) [ [ 1 + ] dip ] [ nth ] 2bi { diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index dccb43d026..2c2dd1ce1a 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -58,7 +58,7 @@ ERROR: invalid-plist-object object ; { NSArray [ (plist-NSArray>) ] } { NSDictionary [ (plist-NSDictionary>) ] } { NSObject [ ] } - [ invalid-plist-object ] + [ throw-invalid-plist-object ] } objc-class-case ; : read-plist ( path -- assoc ) diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index ad489a51a2..60eefab882 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -28,6 +28,6 @@ PRIVATE> ERROR: no-such-color name ; : named-color ( name -- color ) - dup colors at [ ] [ no-such-color ] ?if ; + dup colors at [ ] [ throw-no-such-color ] ?if ; SYNTAX: COLOR: scan-token named-color suffix! ; diff --git a/basis/combinators/random/random.factor b/basis/combinators/random/random.factor index 661ed3f08d..5422a9c679 100644 --- a/basis/combinators/random/random.factor +++ b/basis/combinators/random/random.factor @@ -35,7 +35,7 @@ M: bad-probabilities summary dup good-probabilities? [ [ dup pair? [ prepare-pair ] [ with-drop ] if ] map cond>quot - ] [ bad-probabilities ] if ; + ] [ throw-bad-probabilities ] if ; MACRO: (casep) ( assoc -- quot ) (casep>quot) ; diff --git a/basis/combinators/short-circuit/smart/smart.factor b/basis/combinators/short-circuit/smart/smart.factor index 7264a07917..b2f2a6e1de 100644 --- a/basis/combinators/short-circuit/smart/smart.factor +++ b/basis/combinators/short-circuit/smart/smart.factor @@ -8,7 +8,7 @@ ERROR: cannot-determine-arity ; : arity ( quots -- n ) first infer - dup terminated?>> [ cannot-determine-arity ] when + dup terminated?>> [ throw-cannot-determine-arity ] when effect-height neg 1 + ; PRIVATE> diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 9243af28d2..b1462a76fa 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -67,7 +67,7 @@ ERROR: vreg-not-new vreg ; :: set-ac ( vreg ac -- ) #! Set alias class of newly-seen vreg. - vreg vregs>acs get key? [ vreg vreg-not-new ] when + vreg vregs>acs get key? [ vreg throw-vreg-not-new ] when ac vreg vregs>acs get set-at vreg ac ac>vregs push ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 23c5b25b6d..9416033400 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -7,7 +7,7 @@ ERROR: bad-successors ; : check-successors ( bb -- ) dup successors>> [ predecessors>> member-eq? ] with all? - [ bad-successors ] unless ; + [ throw-bad-successors ] unless ; : check-cfg ( cfg -- ) [ check-successors ] each-basic-block ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 24b7e05bdc..aaace50e56 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -28,7 +28,7 @@ ERROR: inline-intrinsics-not-supported word quot ; : enable-intrinsics ( alist -- ) [ - over inline? [ inline-intrinsics-not-supported ] when + over inline? [ throw-inline-intrinsics-not-supported ] when "intrinsic" set-word-prop ] assoc-each ; diff --git a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor index 94fa2778f2..779f4f55e8 100644 --- a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor +++ b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor @@ -121,7 +121,7 @@ MACRO: if-literals-match ( quots -- quot ) ! node literals quot [ _ firstn ] dip call drop - ] [ 2drop bad-simd-intrinsic ] if + ] [ 2drop throw-bad-simd-intrinsic ] if ] ; CONSTANT: [unary] [ ds-drop ds-pop ] diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 81924ad4cc..778fd0a1ec 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -12,7 +12,7 @@ ERROR: bad-live-ranges interval ; : check-ranges ( live-interval -- ) check-allocation? get [ dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all? - [ drop ] [ bad-live-ranges ] if + [ drop ] [ throw-bad-live-ranges ] if ] [ drop ] if ; : trim-before-ranges ( live-interval -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index bbcb6154f6..1914c13cf0 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -40,10 +40,12 @@ ERROR: splitting-atomic-interval ; : check-split ( live-interval n -- ) check-allocation? get [ - [ [ start>> ] dip > [ splitting-too-early ] when ] - [ [ end>> ] dip < [ splitting-too-late ] when ] - [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ] - 2tri + [ [ start>> ] dip > [ throw-splitting-too-early ] when ] + [ [ end>> ] dip < [ throw-splitting-too-late ] when ] + [ + drop [ end>> ] [ start>> ] bi = + [ throw-splitting-atomic-interval ] when + ] 2tri ] [ 2drop ] if ; inline : split-before ( before -- before' ) diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index 0ab2b9060b..664956d776 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -71,7 +71,7 @@ ERROR: register-already-used live-interval ; : check-activate ( live-interval -- ) check-allocation? get [ dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member? - [ register-already-used ] [ drop ] if + [ throw-register-already-used ] [ drop ] if ] [ drop ] if ; : activate ( n live-interval -- keep? ) diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 81cbfa4cf7..c85278c1f6 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -28,7 +28,9 @@ SYMBOL: pending-interval-assoc ERROR: not-spilled-error vreg ; : vreg>spill-slot ( vreg -- spill-slot ) - dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ; + dup vreg>reg dup spill-slot? + [ nip ] + [ drop leader throw-not-spilled-error ] if ; : vregs>regs ( vregs -- assoc ) [ dup vreg>reg ] H{ } map>assoc ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index f7f54cde10..305bc9777f 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -172,7 +172,7 @@ M: hairy-clobber-insn compute-live-intervals* ( insn -- ) ERROR: bad-live-interval live-interval ; : check-start ( live-interval -- ) - dup start>> -1 = [ bad-live-interval ] [ drop ] if ; + dup start>> -1 = [ throw-bad-live-interval ] [ drop ] if ; : finish-live-intervals ( live-intervals -- ) [ diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index cf61de5ef3..dda239d642 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -18,7 +18,7 @@ ERROR: bad-numbering bb ; : check-block-numbering ( bb -- ) dup instructions>> [ insn#>> ] map sift [ <= ] monotonic? - [ drop ] [ bad-numbering ] if ; + [ drop ] [ throw-bad-numbering ] if ; : check-numbering ( cfg -- ) check-numbering? get diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index c6b630b79e..4b29c16b74 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -16,7 +16,7 @@ SYMBOL: representations ERROR: bad-vreg vreg ; : rep-of ( vreg -- rep ) - representations get ?at [ bad-vreg ] unless ; + representations get ?at [ throw-bad-vreg ] unless ; : set-rep-of ( rep vreg -- ) representations get set-at ; diff --git a/basis/compiler/cfg/representations/conversion/conversion.factor b/basis/compiler/cfg/representations/conversion/conversion.factor index e01a030495..01b447a3fe 100644 --- a/basis/compiler/cfg/representations/conversion/conversion.factor +++ b/basis/compiler/cfg/representations/conversion/conversion.factor @@ -77,7 +77,7 @@ M: scalar-rep int>rep ( dst src rep -- ) ! it is allowed... otherwise bail out. [ drop 2dup [ reg-class-of ] bi@ eq? - [ drop ##copy, ] [ bad-conversion ] if + [ drop ##copy, ] [ throw-bad-conversion ] if ] } case ] diff --git a/basis/compiler/cfg/ssa/destruction/coalescing/coalescing.factor b/basis/compiler/cfg/ssa/destruction/coalescing/coalescing.factor index c9e88cd83d..e9b6f682ce 100644 --- a/basis/compiler/cfg/ssa/destruction/coalescing/coalescing.factor +++ b/basis/compiler/cfg/ssa/destruction/coalescing/coalescing.factor @@ -27,7 +27,7 @@ ERROR: vregs-shouldn't-interfere vreg1 vreg2 ; : try-eliminate-copy ( follower leader must? -- ) -rot leaders 2dup = [ 3drop ] [ 2dup vregs-interfere? [ - drop rot [ vregs-shouldn't-interfere ] [ 2drop ] if + drop rot [ throw-vregs-shouldn't-interfere ] [ 2drop ] if ] [ -rot coalesce-vregs drop ] if ] if ; diff --git a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor index 73d7a492e2..e3982983ad 100644 --- a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor @@ -68,6 +68,6 @@ ERROR: bad-kill-index vreg bb ; 2dup live-out? [ 2drop 1/0. ] [ 2dup kill-indices get at at* [ 2nip ] [ drop 2dup live-in? - [ bad-kill-index ] [ 2drop -1/0. ] if + [ throw-bad-kill-index ] [ 2drop -1/0. ] if ] if ] if ; diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index 210c978772..985c4a32ce 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -24,7 +24,7 @@ ERROR: bad-peek dst loc ; : insert-peeks ( from to -- ) [ inserting-peeks ] keep - [ dup n>> 0 < [ bad-peek ] [ ##peek, ] if ] each-insertion ; + [ dup n>> 0 < [ throw-bad-peek ] [ ##peek, ] if ] each-insertion ; : insert-replaces ( from to -- ) [ inserting-replaces ] keep diff --git a/basis/compiler/cfg/stacks/padding/padding.factor b/basis/compiler/cfg/stacks/padding/padding.factor index 78bd22dad0..79d8448834 100644 --- a/basis/compiler/cfg/stacks/padding/padding.factor +++ b/basis/compiler/cfg/stacks/padding/padding.factor @@ -42,7 +42,7 @@ CONSTANT: initial-state { { 0 { } } { 0 { } } } [ register-write ] apply-stack-op ; : ensure-no-vacant ( state -- ) - [ second ] map dup { { } { } } = [ drop ] [ vacant-when-calling ] if ; + [ second ] map dup { { } { } } = [ drop ] [ throw-vacant-when-calling ] if ; : all-live ( state -- state' ) [ first { } 2array ] map ; @@ -68,7 +68,7 @@ ERROR: vacant-peek insn ; : underflowable-peek? ( state peek -- ? ) 2dup loc>> >loc< swap [ 0 1 ? swap nth ] dip classify-read - dup 2 = [ drop vacant-peek ] [ 2nip 1 = ] if ; + dup 2 = [ drop throw-vacant-peek ] [ 2nip 1 = ] if ; M: ##peek visit-insn ( state insn -- state ) dup loc>> n>> 0 >= t assert= diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index 1409925f9a..2c61621762 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -61,13 +61,15 @@ ERROR: no-such-library name message ; M: no-such-library summary drop "Library not found" ; -: no-such-library-error ( name message word -- ) \ no-such-library set-linkage-error ; +: no-such-library-error ( name message word -- ) + \ no-such-library set-linkage-error ; ERROR: no-such-symbol name message ; M: no-such-symbol summary drop "Symbol not found" ; -: no-such-symbol-error ( name message word -- ) \ no-such-symbol set-linkage-error ; +: no-such-symbol-error ( name message word -- ) + \ no-such-symbol set-linkage-error ; ERROR: not-compiled word error ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 78a6b5ee7a..95ae1674c5 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -319,7 +319,7 @@ ERROR: bug-in-fixnum* x y a b ; 32 random-bits >fixnum 32 random-bits >fixnum 2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup = - [ 4drop ] [ bug-in-fixnum* ] if + [ 4drop ] [ throw-bug-in-fixnum* ] if ] times ] unit-test diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 03249db124..bc616fe8c8 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -11,8 +11,12 @@ IN: compiler.tree.checker ERROR: check-use-error value message ; : check-use ( value uses -- ) - [ empty? [ "No use" check-use-error ] [ drop ] if ] - [ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ; + [ empty? [ "No use" throw-check-use-error ] [ drop ] if ] + [ + all-unique? + [ drop ] + [ "Uses not all unique" throw-check-use-error ] if + ] 2bi ; : check-def-use ( -- ) def-use get [ uses>> check-use ] assoc-each ; @@ -58,7 +62,7 @@ ERROR: check-node-error node error ; [ node-defs-values check-values ] [ check-node* ] tri - ] [ check-node-error ] recover ; + ] [ throw-check-node-error ] recover ; SYMBOL: datastack SYMBOL: retainstack diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index d572ba0965..786e276def 100644 --- a/basis/compiler/tree/def-use/def-use.factor +++ b/basis/compiler/tree/def-use/def-use.factor @@ -18,7 +18,7 @@ TUPLE: definition value node uses ; ERROR: no-def-error value ; : (def-of) ( value def-use -- definition ) - ?at [ no-def-error ] unless ; inline + ?at [ throw-no-def-error ] unless ; inline : def-of ( value -- definition ) def-use get (def-of) ; @@ -27,7 +27,7 @@ ERROR: multiple-defs-error ; : (def-value) ( node value def-use -- ) 2dup key? [ - multiple-defs-error + throw-multiple-defs-error ] [ [ [ ] keep ] dip set-at ] if ; inline diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index b4166044a9..7b7149c6ff 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -9,7 +9,6 @@ IN: compression.inflate [ dup 261 - 4 /i - dup 5 > [ bad-zlib-data ] when + dup 5 > [ throw-bad-zlib-data ] when bitstream bs:read 2array ] when ] unless @@ -114,7 +113,7 @@ CONSTANT: dist-table dup 3 > [ dup 2 - 2 /i dup 13 > - [ bad-zlib-data ] when + [ throw-bad-zlib-data ] when bitstream bs:read 2array ] when 2array ] when dup 256 = not @@ -158,7 +157,7 @@ CONSTANT: dist-table { 0 [ inflate-raw ] } { 1 [ inflate-static ] } { 2 [ inflate-dynamic ] } - { 3 [ bad-zlib-data f ] } + { 3 [ throw-bad-zlib-data f ] } } case ] [ produce ] keep call suffix concat ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 79a8b02e4e..efe026a58e 100755 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -30,7 +30,7 @@ ERROR: code-size-zero ; : ( input code-size class -- obj ) new - swap [ code-size-zero ] when-zero >>code-size + swap [ throw-code-size-zero ] when-zero >>code-size dup code-size>> >>initial-code-size dup code-size>> 1 - 2^ >>clear-code dup clear-code>> 1 + >>end-of-information-code @@ -38,8 +38,6 @@ ERROR: code-size-zero ; BV{ } clone >>output reset-lzw-uncompress ; -ERROR: not-in-table value ; - : lookup-old-code ( lzw -- vector ) [ old-code>> ] [ table>> ] bi nth ; diff --git a/basis/compression/snappy/snappy.factor b/basis/compression/snappy/snappy.factor index 590c9d4b71..f368ebec3b 100644 --- a/basis/compression/snappy/snappy.factor +++ b/basis/compression/snappy/snappy.factor @@ -9,7 +9,7 @@ ERROR: snappy-error error ; outs ( n -- byte-array size_t* ) [ ] [ size_t ] bi ; diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor index 533d55bb68..a82352327d 100644 --- a/basis/compression/zlib/zlib.factor +++ b/basis/compression/zlib/zlib.factor @@ -20,13 +20,13 @@ ERROR: zlib-failed n string ; "stream error" "data error" "memory error" "buffer error" "zlib version error" } ?nth - ] if zlib-failed ; + ] if throw-zlib-failed ; : zlib-error ( n -- ) dup { { compression.zlib.ffi:Z_OK [ drop ] } { compression.zlib.ffi:Z_STREAM_END [ drop ] } - [ dup zlib-error-message zlib-failed ] + [ dup zlib-error-message throw-zlib-failed ] } case ; : compressed-size ( byte-array -- n ) diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 48a685efda..ca72e47e8f 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -28,7 +28,7 @@ ERROR: timed-out-error timer ; : wait ( queue timeout status -- ) over [ [ queue-timeout ] dip suspend - [ timed-out-error ] [ stop-timer ] if + [ throw-timed-out-error ] [ stop-timer ] if ] [ [ drop queue ] dip suspend drop ] if ; inline diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor index c5d1d57985..0a5891d7e2 100755 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/basis/concurrency/count-downs/count-downs.factor @@ -14,7 +14,7 @@ TUPLE: count-down-tuple n promise ; ERROR: invalid-count-down-count count ; : ( n -- count-down ) - dup 0 < [ invalid-count-down-count ] when + dup 0 < [ throw-invalid-count-down-count ] when \ count-down-tuple boa dup count-down-check ; @@ -22,7 +22,7 @@ ERROR: count-down-already-done ; : count-down ( count-down -- ) dup n>> dup zero? - [ count-down-already-done ] + [ throw-count-down-already-done ] [ 1 - >>n count-down-check ] if ; : await-timeout ( count-down timeout -- ) diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index dc3e810871..e685f243f6 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -56,7 +56,7 @@ M: cannot-send-synchronous-to-self summary : send-synchronous ( message thread -- reply ) dup self eq? [ - cannot-send-synchronous-to-self + throw-cannot-send-synchronous-to-self ] [ [ dup ] dip send '[ _ synchronous-reply? ] receive-if diff --git a/basis/concurrency/promises/promises.factor b/basis/concurrency/promises/promises.factor index f47ee05c75..44e98e2f1a 100644 --- a/basis/concurrency/promises/promises.factor +++ b/basis/concurrency/promises/promises.factor @@ -15,7 +15,7 @@ ERROR: promise-already-fulfilled promise ; : fulfill ( value promise -- ) dup promise-fulfilled? [ - promise-already-fulfilled + throw-promise-already-fulfilled ] [ mailbox>> mailbox-put ] if ; diff --git a/basis/concurrency/semaphores/semaphores.factor b/basis/concurrency/semaphores/semaphores.factor index 392b7557d6..fae9cc576c 100644 --- a/basis/concurrency/semaphores/semaphores.factor +++ b/basis/concurrency/semaphores/semaphores.factor @@ -12,7 +12,7 @@ M: negative-count-semaphore summary drop "Cannot have semaphore with negative count" ; : ( n -- semaphore ) - dup 0 < [ negative-count-semaphore ] when + dup 0 < [ throw-negative-count-semaphore ] when semaphore boa ; : wait-to-acquire ( semaphore timeout -- ) diff --git a/basis/core-foundation/launch-services/launch-services.factor b/basis/core-foundation/launch-services/launch-services.factor index 77a984e75a..9e75dd8680 100644 --- a/basis/core-foundation/launch-services/launch-services.factor +++ b/basis/core-foundation/launch-services/launch-services.factor @@ -113,7 +113,7 @@ CONSTANT: kLSUnknownCreator f ERROR: core-foundation-error n ; : cf-error ( n -- ) - dup 0 = [ drop ] [ core-foundation-error ] if ; + dup 0 = [ drop ] [ throw-core-foundation-error ] if ; : fsref>string ( fsref -- string ) MAXPATHLEN [ ] [ ] bi diff --git a/basis/core-foundation/numbers/numbers.factor b/basis/core-foundation/numbers/numbers.factor index bdeb3bf017..08ce305c7a 100644 --- a/basis/core-foundation/numbers/numbers.factor +++ b/basis/core-foundation/numbers/numbers.factor @@ -67,5 +67,5 @@ ERROR: unsupported-number-type type ; { kCFNumberLongType [ long (CFNumber>number) ] } { kCFNumberLongLongType [ longlong (CFNumber>number) ] } { kCFNumberDoubleType [ double (CFNumber>number) ] } - [ unsupported-number-type ] + [ throw-unsupported-number-type ] } case ; diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index 98b6c4a189..c4f20998e8 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -45,7 +45,7 @@ MEMO: make-attributes ( open-font color -- hashtable ) [ [ dup selection? [ string>> ] when - dup string? [ not-a-string ] unless + dup string? [ throw-not-a-string ] unless ] 2dip make-attributes &CFRelease CTLineCreateWithAttributedString diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 6426af85cd..b21aeada62 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -234,14 +234,14 @@ M: operand MOV 0x88 2-operand ; ERROR: bad-movabs-operands dst src ; GENERIC: MOVABS ( dst src -- ) -M: object MOVABS bad-movabs-operands ; +M: object MOVABS throw-bad-movabs-operands ; M: register MOVABS { { AL [ 0xa2 , cell, ] } { AX [ 0x66 , 0xa3 , cell, ] } { EAX [ 0xa3 , cell, ] } { RAX [ 0x48 , 0xa3 , cell, ] } - [ swap bad-movabs-operands ] + [ swap throw-bad-movabs-operands ] } case ; M: integer MOVABS swap { @@ -249,7 +249,7 @@ M: integer MOVABS { AX [ 0x66 , 0xa1 , cell, ] } { EAX [ 0xa1 , cell, ] } { RAX [ 0x48 , 0xa1 , cell, ] } - [ swap bad-movabs-operands ] + [ swap throw-bad-movabs-operands ] } case ; : LEA ( dst src -- ) swap 0x8d 2-operand ; @@ -481,7 +481,7 @@ ERROR: bad-x87-operands ; :: x87-st0-op ( src opcode reg -- ) src register? [ src opcode reg (x87-op) ] - [ bad-x87-operands ] if ; + [ throw-bad-x87-operands ] if ; :: x87-m-st0/n-op ( dst src opcode reg -- ) { @@ -494,7 +494,7 @@ ERROR: bad-x87-operands ; { [ src ST0 = dst register? and ] [ dst opcode 4 + reg (x87-op) ] } - [ bad-x87-operands ] + [ throw-bad-x87-operands ] } cond ; PRIVATE> diff --git a/basis/cpu/x86/assembler/operands/operands.factor b/basis/cpu/x86/assembler/operands/operands.factor index 2a2faa4039..6368405e65 100644 --- a/basis/cpu/x86/assembler/operands/operands.factor +++ b/basis/cpu/x86/assembler/operands/operands.factor @@ -66,7 +66,7 @@ M: indirect extended? base>> extended? ; ERROR: bad-index indirect ; : check-ESP ( indirect -- indirect ) - dup index>> { ESP RSP } member-eq? [ bad-index ] when ; + dup index>> { ESP RSP } member-eq? [ throw-bad-index ] when ; : canonicalize ( indirect -- indirect ) #! Modify the indirect to work around certain addressing mode diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 7f350d17ee..2b18514288 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -37,7 +37,7 @@ M: postgresql-result-null summary ( obj -- str ) drop "PQexec returned f." ; : postgresql-result-ok? ( res -- ? ) - [ postgresql-result-null ] unless* + [ throw-postgresql-result-null ] unless* PQresultStatus PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ; diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 12acded9c0..837cd414f5 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -278,7 +278,7 @@ M: postgresql-db-connection compound ( string object -- string' ) { "default" [ first number>string " " glue ] } { "varchar" [ first number>string "(" ")" surround append ] } { "references" [ >reference-string ] } - [ drop no-compound-found ] + [ drop throw-no-compound-found ] } case ; M: postgresql-db-connection parse-db-error diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index fb3a7e107a..5b7a91eefb 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -158,7 +158,7 @@ M: db-connection ( tuple class -- statement ) [ "select " 0% [ dupd filter-ignores ] dip - over empty? [ all-slots-ignored ] when + over empty? [ throw-all-slots-ignored ] when over [ ", " 0% ] [ dup column-name>> 0% 2, ] interleave diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 9005b48f17..8131e18d3c 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -100,7 +100,7 @@ ERROR: sqlite-last-id-fail ; : last-insert-id ( -- id ) db-connection get handle>> sqlite3_last_insert_rowid - dup zero? [ sqlite-last-id-fail ] when ; + dup zero? [ throw-sqlite-last-id-fail ] when ; M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- ) execute-statement last-insert-id swap set-primary-key ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 0bdb2978ee..ac010e5a66 100644 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -78,7 +78,7 @@ ERROR: no-slots-named class seq ; [ keys ] [ all-slots [ name>> ] map ] bi* diff ] 2bi - [ drop ] [ no-slots-named ] if-empty ; + [ drop ] [ throw-no-slots-named ] if-empty ; : define-persistent ( class table columns -- ) pick dupd @@ -103,7 +103,7 @@ ERROR: no-defined-persistent object ; : ensure-defined-persistent ( object -- object ) dup { [ class? ] [ "db-table" word-prop ] } 1&& [ - no-defined-persistent + throw-no-defined-persistent ] unless ; : create-table ( class -- ) diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 5fb86e5ea9..5b92512d60 100644 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -38,7 +38,7 @@ SYMBOL: IGNORE ERROR: not-persistent class ; : db-table-name ( class -- object ) - dup "db-table" word-prop [ ] [ not-persistent ] ?if ; + dup "db-table" word-prop [ ] [ throw-not-persistent ] ?if ; : db-columns ( class -- object ) superclasses-of [ "db-columns" word-prop ] map concat ; @@ -117,13 +117,13 @@ ERROR: unknown-modifier modifier ; : lookup-modifier ( obj -- string ) { { [ dup array? ] [ unclip lookup-modifier swap compound ] } - [ persistent-table ?at [ unknown-modifier ] unless third ] + [ persistent-table ?at [ throw-unknown-modifier ] unless third ] } cond ; ERROR: no-sql-type type ; : (lookup-type) ( obj -- string ) - persistent-table ?at [ no-sql-type ] unless ; + persistent-table ?at [ throw-no-sql-type ] unless ; : lookup-type ( obj -- string ) dup array? [ @@ -152,5 +152,5 @@ ERROR: no-column column ; first2 [ [ db-table-name " " glue ] [ db-columns ] bi ] dip swap [ column-name>> = ] with find nip - [ no-column ] unless* + [ throw-no-column ] unless* column-name>> "(" ")" surround append ; diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 6a18de6c0e..1faf570e97 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -38,7 +38,7 @@ M: tuple-class group-words : check-broadcast-group ( group -- group ) dup group-words [ first stack-effect out>> empty? ] all? - [ broadcast-words-must-have-no-outputs ] unless ; + [ throw-broadcast-words-must-have-no-outputs ] unless ; ! Consultation @@ -160,7 +160,7 @@ ERROR: not-a-generic word ; : check-generic ( generic -- ) dup array? [ first ] when - dup generic? [ drop ] [ not-a-generic ] if ; + dup generic? [ drop ] [ throw-not-a-generic ] if ; PRIVATE> diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor index 8ecde83a14..79fc81c5b5 100644 --- a/basis/deques/deques.factor +++ b/basis/deques/deques.factor @@ -18,13 +18,13 @@ GENERIC: deque-empty? ( deque -- ? ) ERROR: empty-deque ; : peek-front ( deque -- obj ) - peek-front* [ drop empty-deque ] unless ; + peek-front* [ drop throw-empty-deque ] unless ; : ?peek-front ( deque -- obj/f ) peek-front* [ drop f ] unless ; : peek-back ( deque -- obj ) - peek-back* [ drop empty-deque ] unless ; + peek-back* [ drop throw-empty-deque ] unless ; : ?peek-back ( deque -- obj/f ) peek-back* [ drop f ] unless ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index fe21dfe4df..85b7484247 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -37,7 +37,7 @@ M: object editor-detached? t ; ERROR: invalid-location file line ; : edit-location ( file line -- ) - over [ invalid-location ] unless + over [ throw-invalid-location ] unless [ absolute-path ] dip editor-command [ run-and-wait-for-editor ] when* ; @@ -66,7 +66,7 @@ PRIVATE> GENERIC: edit ( object -- ) M: object edit - dup where [ first2 edit-location ] [ cannot-find-source ] ?if ; + dup where [ first2 edit-location ] [ throw-cannot-find-source ] ?if ; M: string edit edit-vocab ; diff --git a/basis/editors/jedit/jedit.factor b/basis/editors/jedit/jedit.factor index 7a2b8114ed..26d20375dc 100644 --- a/basis/editors/jedit/jedit.factor +++ b/basis/editors/jedit/jedit.factor @@ -8,8 +8,6 @@ IN: editors.jedit SINGLETON: jedit jedit editor-class set-global -ERROR: jedit-not-found ; - HOOK: find-jedit-path os ( -- path ) M: object find-jedit-path f ; diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index f36b042622..2cc26266dc 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -72,7 +72,7 @@ fmt-E = digits "E" => [[ first '[ _ format-scientific >upper ] ]] fmt-f = digits "f" => [[ first '[ _ format-decimal ] ]] fmt-x = "x" => [[ [ >hex ] ]] fmt-X = "X" => [[ [ >hex >upper ] ]] -unknown = (.)* => [[ unknown-printf-directive ]] +unknown = (.)* => [[ throw-unknown-printf-directive ]] strings_ = fmt-c|fmt-C|fmt-s|fmt-S|fmt-u strings = pad width strings_ => [[ compose-all ]] diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index cca4aef3b5..2b447fa4db 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -15,7 +15,7 @@ GENERIC: fry ( quot -- quot' ) : check-fry ( quot -- quot ) dup { load-local load-locals get-local drop-locals } intersect - [ >r/r>-in-fry-error ] unless-empty ; + [ throw->r/r>-in-fry-error ] unless-empty ; PREDICATE: fry-specifier < word { _ @ } member-eq? ; diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index c94d5a273a..b676798fb0 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -28,7 +28,7 @@ IN: ftp.client ERROR: ftp-error got expected ; : ftp-assert ( ftp-response n -- ) - 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ; + 2dup [ n>> ] dip = [ 2drop ] [ throw-ftp-error ] if ; : ftp-command ( string -- ftp-response ) ftp-send read-response ; diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 6dacaf72cc..f3d4b70889 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -111,7 +111,7 @@ ERROR: type-error type ; >upper { { "IMAGE" [ "Binary" ] } { "I" [ "Binary" ] } - [ type-error ] + [ throw-type-error ] } case ; : handle-TYPE ( obj -- ) @@ -287,9 +287,6 @@ M: ftp-disconnect handle-passive-command ( stream obj -- ) "" not-a-plain-file ] if* ; -ERROR: not-a-directory ; -ERROR: no-directory-permissions ; - : directory-change-success ( -- ) "Directory successully changed." 250 server-response ; diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor index 4f2568b636..76f9e675c4 100644 --- a/basis/furnace/asides/asides.factor +++ b/basis/furnace/asides/asides.factor @@ -77,7 +77,7 @@ M: asides call-responder* ERROR: end-aside-in-get-error ; : move-on ( id -- response ) - post-request? [ end-aside-in-get-error ] unless + post-request? [ throw-end-aside-in-get-error ] unless dup method>> { { "GET" [ url>> ] } { "HEAD" [ url>> ] } diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 57a6919ae9..0826bf9e7b 100644 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -16,7 +16,7 @@ ERROR: no-such-word name vocab ; : string>word ( string -- word ) ":" split1 swap 2dup lookup-word dup - [ 2nip ] [ drop no-such-word ] if ; + [ 2nip ] [ drop throw-no-such-word ] if ; : strings>words ( seq -- seq' ) [ string>word ] map ; @@ -32,7 +32,7 @@ ERROR: no-such-responder responder ; : base-path ( string -- seq ) dup responder-nesting get [ second class-of superclasses-of [ name>> = ] with any? ] with find nip - [ first ] [ no-such-responder ] ?if ; + [ first ] [ throw-no-such-responder ] ?if ; : resolve-base-path ( string -- string' ) "$" ?head [ diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index e46587f5ba..a4395aaaf8 100644 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -50,7 +50,7 @@ ERROR: game-input-not-open ; reset-mouse ; : close-game-input ( -- ) game-input-opened [ - dup zero? [ game-input-not-open ] when + dup zero? [ throw-game-input-not-open ] when 1 - ] change-global game-input-opened? [ diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 91b42d5a83..49be966f0e 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -28,7 +28,7 @@ ERROR: nonpositive-npick n ; MACRO: npick ( n -- quot ) { - { [ dup 0 <= ] [ nonpositive-npick ] } + { [ dup 0 <= ] [ throw-nonpositive-npick ] } { [ dup 1 = ] [ drop [ dup ] ] } [ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ] } cond ; diff --git a/basis/gobject-introspection/gobject-introspection.factor b/basis/gobject-introspection/gobject-introspection.factor index 3d380cb68b..61646275c8 100755 --- a/basis/gobject-introspection/gobject-introspection.factor +++ b/basis/gobject-introspection/gobject-introspection.factor @@ -39,7 +39,7 @@ M: gir-not-found summary current-vocab-dirs custom-gir-dirs system-gir-dirs 3append sift :> paths paths [ path append-path exists? ] find nip - [ path append-path ] [ path paths gir-not-found ] if* + [ path append-path ] [ path paths throw-gir-not-found ] if* ] if ; : define-gir-vocab ( path -- ) diff --git a/basis/gobject-introspection/types/types.factor b/basis/gobject-introspection/types/types.factor index cd244cf9aa..1d975523a4 100644 --- a/basis/gobject-introspection/types/types.factor +++ b/basis/gobject-introspection/types/types.factor @@ -79,7 +79,7 @@ ERROR: unknown-type-error type ; : get-type-info ( data-type -- info ) qualified-type-name dup type-infos get-global at - [ ] [ unknown-type-error ] ?if ; + [ ] [ throw-unknown-type-error ] ?if ; : find-type-info ( data-type -- info/f ) qualified-type-name type-infos get-global at ; @@ -105,8 +105,8 @@ ERROR: deferred-type-error ; << void* lookup-c-type clone - [ drop deferred-type-error ] >>unboxer-quot - [ drop deferred-type-error ] >>boxer-quot + [ drop throw-deferred-type-error ] >>unboxer-quot + [ drop throw-deferred-type-error ] >>boxer-quot object >>boxed-class "deferred-type" create-word-in typedef >> diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index 233d793483..00cc454ee9 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -57,7 +57,7 @@ M: abstract-clumps group@ TUPLE: chunking-seq { seq read-only } { n read-only } ; : check-groups ( seq n -- seq n ) - dup 0 <= [ groups-error ] when ; inline + dup 0 <= [ throw-groups-error ] when ; inline : new-groups ( seq n class -- groups ) [ check-groups ] dip boa ; inline diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index b92bfe3668..3f41c1bc26 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -24,7 +24,7 @@ TUPLE: heap { data vector } ; ERROR: not-a-heap object ; : check-heap ( heap -- heap ) - dup heap? [ not-a-heap ] unless ; inline + dup heap? [ throw-not-a-heap ] unless ; inline TUPLE: entry value key heap index ; @@ -164,7 +164,7 @@ M: bad-heap-delete summary index ( entry heap -- n ) - over heap>> eq? [ bad-heap-delete ] unless + over heap>> eq? [ throw-bad-heap-delete ] unless index>> { fixnum } declare ; inline PRIVATE> diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor index 0133e3b7c8..b94aa677d7 100644 --- a/basis/help/lint/checks/checks.factor +++ b/basis/help/lint/checks/checks.factor @@ -30,7 +30,7 @@ SYMBOL: vocab-articles last assert= ] vocabs-quot get call( quot -- ) ] leaks members length [ - "%d disposable(s) leaked in example" sprintf simple-lint-error + "%d disposable(s) leaked in example" sprintf throw-simple-lint-error ] unless-zero ; : check-examples ( element -- ) @@ -88,7 +88,7 @@ SYMBOL: vocab-articles [ effect-values ] [ extract-values ] bi* 2dup sequence= [ 2drop ] [ "$values don't match stack effect; expected %u, got %u" sprintf - simple-lint-error + throw-simple-lint-error ] if ] if ; @@ -96,17 +96,17 @@ SYMBOL: vocab-articles [ effect-effects ] [ extract-value-effects ] bi* [ 2dup and [ = ] [ 2drop t ] if ] 2all? [ "$quotation stack effects in $values don't match" - simple-lint-error + throw-simple-lint-error ] unless ; : check-nulls ( element -- ) \ $values swap elements null swap deep-member? - [ "$values should not contain null" simple-lint-error ] when ; + [ "$values should not contain null" throw-simple-lint-error ] when ; : check-see-also ( element -- ) \ $see-also swap elements [ rest all-unique? ] all? - [ "$see-also are not unique" simple-lint-error ] unless ; + [ "$see-also are not unique" throw-simple-lint-error ] unless ; : vocab-exists? ( name -- ? ) [ lookup-vocab ] [ all-vocabs-list get member? ] bi or ; @@ -116,7 +116,7 @@ SYMBOL: vocab-articles second vocab-exists? [ "$vocab-link to non-existent vocabulary" - simple-lint-error + throw-simple-lint-error ] unless ] each ; @@ -127,23 +127,23 @@ SYMBOL: vocab-articles [ "\n\t" intersects? [ "Paragraph text should not contain \\n or \\t" - simple-lint-error + throw-simple-lint-error ] when ] [ " " swap subseq? [ "Paragraph text should not contain double spaces" - simple-lint-error + throw-simple-lint-error ] when ] bi ; : check-whitespace ( str1 str2 -- ) [ " " tail? ] [ " " head? ] bi* or - [ "Missing whitespace between strings" simple-lint-error ] unless ; + [ "Missing whitespace between strings" throw-simple-lint-error ] unless ; : check-bogus-nl ( element -- ) { { $nl } { { $nl } } } [ head? ] with any? [ "Simple element should not begin with a paragraph break" - simple-lint-error + throw-simple-lint-error ] when ; : extract-slots ( elements -- seq ) @@ -158,18 +158,18 @@ SYMBOL: vocab-articles ] [ extract-slots ] bi* [ swap member? ] with reject [ ", " join "Described $slot does not exist: " prepend - simple-lint-error + throw-simple-lint-error ] unless-empty ] [ nip empty? not [ "A word that is not a class has a $class-description" - simple-lint-error + throw-simple-lint-error ] when ] if ; : check-article-title ( article -- ) article-title first LETTER? - [ "Article title must begin with a capital letter" simple-lint-error ] unless ; + [ "Article title must begin with a capital letter" throw-simple-lint-error ] unless ; : check-elements ( element -- ) { @@ -184,7 +184,7 @@ SYMBOL: vocab-articles swap '[ _ elements [ rest { { } { "" } } member? - [ "Empty $description" simple-lint-error ] when + [ "Empty $description" throw-simple-lint-error ] when ] each ] each ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 61b16ab746..799e45f45b 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -210,11 +210,11 @@ M: word link-long-text ERROR: number-of-arguments found required ; : check-first ( seq -- first ) - dup length 1 = [ length 1 number-of-arguments ] unless + dup length 1 = [ length 1 throw-number-of-arguments ] unless first-unsafe ; : check-first2 ( seq -- first second ) - dup length 2 = [ length 2 number-of-arguments ] unless + dup length 2 = [ length 2 throw-number-of-arguments ] unless first2-unsafe ; PRIVATE> diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor index 74c14e1f87..505cd67344 100644 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -15,7 +15,7 @@ ERROR: article-expects-name-and-title got ; SYNTAX: ARTICLE: location [ \ ; parse-until >array - dup length 2 < [ article-expects-name-and-title ] when + dup length 2 < [ throw-article-expects-name-and-title ] when [ first2 ] [ 2 tail ] bi
over add-article >link ] dip remember-definition ; diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index 995fcbca52..3f80275fc5 100644 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -63,7 +63,7 @@ M: no-article summary drop "Help article does not exist" ; : lookup-article ( name -- article ) - articles get ?at [ no-article ] unless ; + articles get ?at [ throw-no-article ] unless ; M: object valid-article? articles get key? ; M: object article-title lookup-article article-title ; diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index b5b41603d2..3e84da8286 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -70,7 +70,7 @@ M: object specializer-declaration class-of ; ERROR: cannot-specialize word specializer ; : set-specializer ( word specializer -- ) - over inline-recursive? [ cannot-specialize ] when + over inline-recursive? [ throw-cannot-specialize ] when "specializer" set-word-prop ; SYNTAX: HINTS: diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 1c7c73c90f..5338c6d387 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -75,7 +75,7 @@ SYMBOL: string-context? ERROR: tag-not-allowed-here ; : check-tag ( -- ) - string-context? get [ tag-not-allowed-here ] when ; + string-context? get [ throw-tag-not-allowed-here ] when ; : compile-tag ( tag -- ) check-tag diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index fd48d81ecd..f6b890c693 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -39,10 +39,10 @@ M: no-boilerplate error. SYMBOL: title : set-title ( string -- ) - title get [ >box ] [ no-boilerplate ] if* ; + title get [ >box ] [ throw-no-boilerplate ] if* ; : get-title ( -- string ) - title get [ value>> ] [ no-boilerplate ] if* ; + title get [ value>> ] [ throw-no-boilerplate ] if* ; : write-title ( -- ) get-title write ; diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index b1a9daed1f..902d066b7f 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -93,7 +93,7 @@ SYMBOL: redirects response "location" header redirect-url response code>> 307 = [ "GET" >>method ] unless quot (with-http-request) - ] [ too-many-redirects ] if ; inline recursive + ] [ throw-too-many-redirects ] if ; inline recursive : read-chunk-size ( -- n ) read-crlf ";" split1 drop [ blank? ] trim-tail diff --git a/basis/http/server/requests/requests.factor b/basis/http/server/requests/requests.factor index 8348c029ff..42804604e9 100644 --- a/basis/http/server/requests/requests.factor +++ b/basis/http/server/requests/requests.factor @@ -17,10 +17,10 @@ ERROR: content-length-missing < request-error ; ERROR: bad-request-line < request-error parse-error ; : check-absolute ( url -- ) - path>> dup "/" head? [ drop ] [ invalid-path ] if ; inline + path>> dup "/" head? [ drop ] [ throw-invalid-path ] if ; inline : parse-request-line-safe ( string -- triple ) - [ parse-request-line ] [ nip bad-request-line ] recover ; + [ parse-request-line ] [ nip throw-bad-request-line ] recover ; : read-request-line ( request -- request ) read-?crlf [ dup "" = ] [ drop read-?crlf ] while @@ -36,7 +36,7 @@ upload-limit [ 200,000,000 ] initialize : parse-multipart-form-data ( string -- separator ) ";" split1 nip - "=" split1 nip [ no-boundary ] unless* ; + "=" split1 nip [ throw-no-boundary ] unless* ; : maybe-limit-input ( content-length -- ) unlimited-input upload-limit get [ min ] when* limited-input ; @@ -49,10 +49,10 @@ upload-limit [ 200,000,000 ] initialize "content-length" header [ dup string>number [ nip dup 0 upload-limit get between? [ - invalid-content-length + throw-invalid-content-length ] unless - ] [ invalid-content-length ] if* - ] [ content-length-missing ] if* ; + ] [ throw-invalid-content-length ] if* + ] [ throw-content-length-missing ] if* ; : parse-content ( request content-type -- post-data ) dup -rot over parse-content-length-safe swap diff --git a/basis/images/loader/gdiplus/gdiplus.factor b/basis/images/loader/gdiplus/gdiplus.factor index 6ed16ba3c3..de87bf87c9 100644 --- a/basis/images/loader/gdiplus/gdiplus.factor +++ b/basis/images/loader/gdiplus/gdiplus.factor @@ -58,7 +58,7 @@ os windows? [ ERROR: unsupported-pixel-format component-order ; : check-pixel-format ( image -- ) - component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ; + component-order>> dup BGRA = [ drop ] [ throw-unsupported-pixel-format ] if ; : image>gdi+-bitmap ( image -- bitmap ) dup check-pixel-format diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 1496ae00ae..e48a238f80 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -13,7 +13,7 @@ SYMBOL: types types [ H{ } clone ] initialize : (image-class) ( type -- class ) - >lower types get ?at [ unknown-image-extension ] unless ; + >lower types get ?at [ throw-unknown-image-extension ] unless ; : image-class ( path -- class ) file-extension (image-class) ; diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index a089fa3972..9412eaf577 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -34,7 +34,7 @@ ALIAS: value third-unsafe ERROR: not-an-interval-map obj ; : check-interval-map ( map -- map ) - dup interval-map? [ not-an-interval-map ] unless ; inline + dup interval-map? [ throw-not-an-interval-map ] unless ; inline PRIVATE> diff --git a/basis/interval-sets/interval-sets.factor b/basis/interval-sets/interval-sets.factor index 6668a3c910..3ef65ab55e 100644 --- a/basis/interval-sets/interval-sets.factor +++ b/basis/interval-sets/interval-sets.factor @@ -14,7 +14,7 @@ TUPLE: interval-set { array uint-array read-only } ; ERROR: not-an-interval-set obj ; : check-interval-set ( map -- map ) - dup interval-set? [ not-an-interval-set ] unless ; inline + dup interval-set? [ throw-not-an-interval-set ] unless ; inline PRIVATE> diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 896b0d920a..6fcf7a59f1 100644 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -12,7 +12,7 @@ IN: inverse ERROR: fail ; M: fail summary drop "Matching failed" ; -: assure ( ? -- ) [ fail ] unless ; inline +: assure ( ? -- ) [ throw-fail ] unless ; inline : =/fail ( obj1 obj2 -- ) = assure ; inline @@ -32,14 +32,10 @@ M: fail summary drop "Matching failed" ; [ dupd "pop-length" set-word-prop ] dip "pop-inverse" set-word-prop ; -ERROR: no-inverse word ; -M: no-inverse summary - drop "The word cannot be used in pattern matching" ; - ERROR: bad-math-inverse ; : next ( revquot -- revquot* first ) - [ bad-math-inverse ] + [ throw-bad-math-inverse ] [ unclip-slice ] if-empty ; : constant-word? ( word -- ? ) @@ -48,7 +44,7 @@ ERROR: bad-math-inverse ; [ in>> empty? ] bi and ; : assure-constant ( constant -- quot ) - dup word? [ bad-math-inverse ] when 1quotation ; + dup word? [ throw-bad-math-inverse ] when 1quotation ; : swap-inverse ( math-inverse revquot -- revquot* quot ) next assure-constant rot second '[ @ swap @ ] ; @@ -173,7 +169,7 @@ ERROR: missing-literal ; \ ? 2 [ [ assert-literal ] bi@ - [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ] + [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ throw-fail ] if ] if ] 2curry ] define-pop-inverse @@ -259,7 +255,7 @@ DEFER: __ : empty-inverse ( class -- quot ) deconstruct-pred - [ tuple-slots [ ] any? [ fail ] when ] + [ tuple-slots [ ] any? [ throw-fail ] when ] compose ; \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 2468c53e58..30a349ec23 100755 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -75,7 +75,7 @@ M: unix wait-for-fd ( handle event -- ) { +input+ [ add-input-callback ] } { +output+ [ add-output-callback ] } } case - "I/O" suspend [ io-timeout ] when + "I/O" suspend [ throw-io-timeout ] when ] if ; : wait-for-port ( port event -- ) @@ -86,7 +86,7 @@ M: unix wait-for-fd ( handle event -- ) ERROR: not-a-buffered-port port ; : check-buffered-port ( port -- port ) - dup buffered-port? [ not-a-buffered-port ] unless ; inline + dup buffered-port? [ throw-not-a-buffered-port ] unless ; inline M: fd refill [ check-buffered-port buffer>> ] [ fd>> ] bi* diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index e0df575bf0..80f9f7cd15 100644 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -103,13 +103,13 @@ PRIVATE> ERROR: file-not-found path bfs? quot ; : find-file-throws ( path bfs? quot -- path ) - 3dup find-file [ 2nip nip ] [ file-not-found ] if* ; inline + 3dup find-file [ 2nip nip ] [ throw-file-not-found ] if* ; inline ERROR: sequence-expected obj ; : ensure-sequence-of-directories ( obj -- seq ) dup string? [ 1array ] when - dup sequence? [ sequence-expected ] unless ; + dup sequence? [ throw-sequence-expected ] unless ; ! Can't make this generic# on string/sequence because of combinators : find-in-directories ( directories bfs? quot -- path'/f ) diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 6446dc269f..644535dbd5 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -80,8 +80,6 @@ M: linux file-systems resolve-symlinks parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; -ERROR: file-system-not-found ; - M: linux file-system-info ( path -- file-system-info ) normalize-path [ diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index fc651c366b..0f1266c1a9 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -147,7 +147,7 @@ ERROR: not-absolute-path ; [ length 2 >= ] [ second CHAR: : = ] [ first Letter? ] - } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ; + } 1&& [ 2 head "\\" append ] [ throw-not-absolute-path ] if ; master-completion-port set-global H{ } clone pending-overlapped set-global ; -ERROR: invalid-file-size n ; - : (handle>file-size) ( handle -- n/f ) 0 ulonglong [ GetFileSizeEx ] keep swap [ drop f ] [ drop ulonglong deref ] if-zero ; @@ -124,7 +122,7 @@ ERROR: invalid-file-size n ; ERROR: seek-before-start n ; : set-seek-ptr ( n handle -- ) - [ dup 0 < [ seek-before-start ] when ] dip ptr<< ; + [ dup 0 < [ throw-seek-before-start ] when ] dip ptr<< ; M: windows tell-handle ( handle -- n ) ptr>> ; diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index c93309177d..216085a163 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -116,7 +116,7 @@ M: process-already-started error. process>> . ; M: process >process - dup process-started? [ process-already-started ] when + dup process-started? [ throw-process-already-started ] when clone ; M: object >process swap >>command ; @@ -135,7 +135,7 @@ M: process-was-killed error. : (wait-for-process) ( process -- status ) dup handle>> [ self over processes get at push "process" suspend drop ] when - dup killed>> [ process-was-killed ] [ status>> ] if ; + dup killed>> [ throw process-was-killed ] [ status>> ] if ; : wait-for-process ( process -- status ) [ (wait-for-process) ] with-timeout ; @@ -158,7 +158,7 @@ M: process-failed error. ] [ process>> . ] bi ; : check-success ( process status -- ) - 0 = [ drop ] [ process-failed ] if ; + 0 = [ drop ] [ throw-process-failed ] if ; : wait-for-success ( process -- ) dup wait-for-process check-success ; @@ -290,7 +290,7 @@ M: output-process-error error. [ +closed+ or ] change-stdin utf8 (process-reader) [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout - 0 = [ 2drop ] [ output-process-error ] if ; + 0 = [ 2drop ] [ throw-output-process-error ] if ; > ] with-destructors - ] [ launch-error ] recover ; + ] [ throw-launch-error ] recover ; diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 67c245d956..352d0558f4 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -16,7 +16,7 @@ HOOK: (mapped-file-r/w) os ( path length -- address handle ) : prepare-mapped-file ( path quot -- mapped-file path' length ) [ [ normalize-path ] [ file-info size>> ] bi - [ dup 0 <= [ bad-mmap-size ] [ 2drop ] if ] + [ dup 0 <= [ throw-bad-mmap-size ] [ 2drop ] if ] [ nip mapped-file new-disposable swap >>length ] ] dip 2tri [ >>address ] [ >>handle ] bi* ; inline diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 208e023e08..0ff1a1465a 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -45,7 +45,7 @@ M: input-port stream-read1 ERROR: not-a-c-ptr object ; : check-c-ptr ( c-ptr -- c-ptr ) - dup c-ptr? [ not-a-c-ptr ] unless ; inline + dup c-ptr? [ throw-not-a-c-ptr ] unless ; inline string ( x509name -- string ) NID_commonName 256 @@ -312,8 +315,8 @@ M: ssl-handle dispose* SSL_get_peer_certificate [ [ alternative-dns-names ] [ subject-name ] bi suffix 2dup [ subject-names-match? ] with any? - [ 2drop ] [ subject-name-verify-error ] if - ] [ certificate-missing-error ] if* ; + [ 2drop ] [ throw-subject-name-verify-error ] if + ] [ throw-certificate-missing-error ] if* ; M: openssl check-certificate ( host ssl -- ) current-secure-context config>> verify>> [ @@ -324,20 +327,20 @@ M: openssl check-certificate ( host ssl -- ) ] [ 2drop ] if ; : check-buffer ( port -- port ) - dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ; + dup buffer>> buffer-empty? [ throw-upgrade-buffers-full ] unless ; : input/output-ports ( -- input output ) input-stream output-stream [ get underlying-port check-buffer ] bi@ - 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ; + 2dup [ handle>> ] bi@ eq? [ throw-upgrade-on-non-socket ] unless ; : make-input/output-secure ( input output -- ) - dup handle>> non-ssl-socket? [ upgrade-on-non-socket ] unless + dup handle>> non-ssl-socket? [ throw-upgrade-on-non-socket ] unless [ ] change-handle handle>> >>handle drop ; : (send-secure-handshake) ( output -- ) - remote-address get [ upgrade-on-non-socket ] unless* + remote-address get [ throw-upgrade-on-non-socket ] unless* secure-connection ; M: openssl send-secure-handshake diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index ff01ecf037..43220f4f0f 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -78,12 +78,12 @@ ERROR: bad-ipv4-component string ; : parse-ipv4 ( string -- seq ) [ f ] [ - "." split dup length 4 = [ malformed-ipv4 ] unless - [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as + "." split dup length 4 = [ throw-malformed-ipv4 ] unless + [ dup string>number [ ] [ throw-bad-ipv4-component ] ?if ] B{ } map-as ] if-empty ; : check-ipv4 ( string -- ) - [ parse-ipv4 drop ] [ invalid-ipv4 ] recover ; + [ parse-ipv4 drop ] [ throw-invalid-ipv4 ] recover ; PRIVATE> @@ -93,7 +93,7 @@ M: ipv4 inet-ntop ( data addrspec -- str ) drop 4 memory>byte-array [ number>string ] { } map-as "." join ; M: ipv4 inet-pton ( str addrspec -- data ) - drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ; + drop [ parse-ipv4 ] [ throw-invalid-ipv4 ] recover ; M: ipv4 address-size drop 4 ; @@ -146,7 +146,7 @@ ERROR: bad-ipv4-embedded-prefix obj ; ERROR: more-than-8-components ; : parse-ipv6-component ( seq -- seq' ) - [ dup hex> [ nip ] [ bad-ipv6-component ] if* ] { } map-as ; + [ dup hex> [ nip ] [ throw-bad-ipv6-component ] if* ] { } map-as ; : parse-ipv6 ( string -- seq ) [ f ] [ @@ -159,7 +159,7 @@ ERROR: more-than-8-components ; ] if-empty ; : check-ipv6 ( string -- ) - [ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ invalid-ipv6 ] recover ; + [ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ throw-invalid-ipv6 ] recover ; PRIVATE> @@ -172,7 +172,7 @@ M: ipv6 inet-ntop ( data addrspec -- str ) : pad-ipv6 ( string1 string2 -- seq ) 2dup [ length ] bi@ + 8 swap - - dup 0 < [ more-than-8-components ] when + dup 0 < [ throw-more-than-8-components ] when glue ; : ipv6-bytes ( seq -- bytes ) @@ -183,7 +183,7 @@ PRIVATE> M: ipv6 inet-pton ( str addrspec -- data ) drop [ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ] - [ invalid-ipv6 ] + [ throw-invalid-ipv6 ] recover ; M: ipv6 address-size drop 16 ; @@ -293,7 +293,7 @@ ERROR: invalid-port object ; pick class-of byte-array assert= ; : check-connectionless-port ( port -- port ) - dup { [ datagram-port? ] [ raw-port? ] } 1|| [ invalid-port ] unless ; + dup { [ datagram-port? ] [ raw-port? ] } 1|| [ throw-invalid-port ] unless ; : check-send ( packet addrspec port -- packet addrspec port ) check-connectionless-port check-disposed check-port ; @@ -411,7 +411,7 @@ C: inet M: string resolve-host f prepare-addrinfo f void* [ getaddrinfo [ - dup addrinfo-error-string addrinfo-error + dup addrinfo-error-string throw-addrinfo-error ] unless-zero ] keep void* deref addrinfo memory>struct [ parse-addrinfo-list ] keep freeaddrinfo ; @@ -452,7 +452,7 @@ M: invalid-inet-server summary drop "Cannot use with ; use or instead" ; M: inet (server) - invalid-inet-server ; + throw-invalid-inet-server ; ERROR: invalid-local-address addrspec ; @@ -463,7 +463,7 @@ M: invalid-local-address summary [ [ ] [ inet4? ] [ inet6? ] tri or [ bind-local-address ] - [ invalid-local-address ] if + [ throw-invalid-local-address ] if ] dip with-variable ; inline : protocol-port ( protocol -- port ) diff --git a/basis/io/streams/duplex/duplex.factor b/basis/io/streams/duplex/duplex.factor index ddc5974bde..118f01e5cc 100644 --- a/basis/io/streams/duplex/duplex.factor +++ b/basis/io/streams/duplex/duplex.factor @@ -46,4 +46,4 @@ ERROR: invalid-duplex-stream ; M: duplex-stream underlying-handle >duplex-stream< [ underlying-handle ] bi@ - [ = [ invalid-duplex-stream ] when ] keep ; + [ = [ throw-invalid-duplex-stream ] when ] keep ; diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index 1455c8fa8c..087281667a 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -62,11 +62,11 @@ ERROR: limit-exceeded n stream ; : check-count-bounds ( n stream -- n stream ) dup [ count>> ] [ limit>> ] bi > - [ limit-exceeded ] when ; + [ throw-limit-exceeded ] when ; : check-current-bounds ( n stream -- n stream ) dup [ current>> ] [ start>> ] bi < - [ limit-exceeded ] when ; + [ throw-limit-exceeded ] when ; : adjust-limited-read ( n stream -- n stream ) dup start>> [ diff --git a/basis/io/streams/throwing/throwing.factor b/basis/io/streams/throwing/throwing.factor index 1d53d14d3a..a7c340e1f1 100644 --- a/basis/io/streams/throwing/throwing.factor +++ b/basis/io/streams/throwing/throwing.factor @@ -17,15 +17,15 @@ M: throws-on-eof-stream dispose stream>> dispose ; M:: throws-on-eof-stream stream-read1 ( stream -- obj ) stream stream>> stream-read1 - [ 1 stream \ read1 stream-exhausted ] unless* ; + [ 1 stream \ read1 throw-stream-exhausted ] unless* ; M:: throws-on-eof-stream stream-read-unsafe ( n buf stream -- count ) n buf stream stream>> stream-read-unsafe - dup n = [ n stream \ stream-read-unsafe stream-exhausted ] unless ; + dup n = [ n stream \ stream-read-unsafe throw-stream-exhausted ] unless ; M:: throws-on-eof-stream stream-read-partial-unsafe ( n buf stream -- count ) n buf stream stream>> stream-read-partial-unsafe - [ n stream \ stream-read-partial-unsafe stream-exhausted ] when-zero ; + [ n stream \ stream-read-partial-unsafe throw-stream-exhausted ] when-zero ; M: throws-on-eof-stream stream-tell stream>> stream-tell ; @@ -41,7 +41,7 @@ M: throws-on-eof-stream stream-length M: throws-on-eof-stream stream-read-until [ stream>> stream-read-until ] - [ '[ length _ \ read-until stream-exhausted ] unless* ] bi ; + [ '[ length _ \ read-until throw-stream-exhausted ] unless* ] bi ; : stream-throw-on-eof ( ..a stream quot: ( ..a stream' -- ..b ) -- ..b ) [ ] dip with-input-stream* ; inline diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 742d8773f5..4fc83930ba 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -22,7 +22,7 @@ ERROR: not-a-json-number string ; ] dip ; : json-expect ( token stream -- ) - [ dup length ] [ stream-read ] bi* = [ json-error ] unless ; inline + [ dup length ] [ stream-read ] bi* = [ throw-json-error ] unless ; inline DEFER: (read-json-string) @@ -54,7 +54,7 @@ DEFER: (read-json-string) { CHAR: t [ CHAR: \t ] } { CHAR: u [ over read-json-escape-unicode ] } [ ] - } case [ suffix! (read-json-string) ] [ json-error ] if* ; + } case [ suffix! (read-json-string) ] [ throw-json-error ] if* ; : (read-json-string) ( stream accum -- accum ) { sbuf } declare @@ -72,7 +72,7 @@ DEFER: (read-json-string) [ length 1 - ] keep [ nth-unsafe ] [ shorten ] 2bi ; inline : check-length ( seq n -- seq ) - [ dup length ] [ >= ] bi* [ json-error ] unless ; inline + [ dup length ] [ >= ] bi* [ throw-json-error ] unless ; inline : v-over-push ( accum -- accum ) { vector } declare 2 check-length diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 5490070397..3d1bf3494e 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -45,7 +45,7 @@ M: object strerror strerror_unsafe ; ERROR: libc-error errno message ; -: (throw-errno) ( errno -- * ) dup strerror libc-error ; +: (throw-errno) ( errno -- * ) dup strerror throw-libc-error ; : throw-errno ( -- * ) errno (throw-errno) ; @@ -72,7 +72,7 @@ M: bad-ptr summary drop "Memory allocation failed" ; : check-ptr ( c-ptr -- c-ptr ) - [ bad-ptr ] unless* ; + [ throw-bad-ptr ] unless* ; ERROR: realloc-error ptr size ; @@ -100,7 +100,7 @@ PRIVATE> : realloc ( alien size -- newalien ) [ >c-ptr ] dip - over malloc-exists? [ realloc-error ] unless + over malloc-exists? [ throw-realloc-error ] unless [ drop ] [ (realloc) check-ptr ] 2bi [ delete-malloc ] [ add-malloc ] bi* ; diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index a95de5ffea..1545fc66a0 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -6,7 +6,7 @@ locals.errors ; IN: locals SYNTAX: :> - in-lambda? get [ :>-outside-lambda-error ] unless + in-lambda? get [ throw-:>-outside-lambda-error ] unless scan-token parse-def suffix! ; SYNTAX: [| parse-lambda append! ; diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index 3036bcb7cb..dfb1d43aef 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -14,7 +14,7 @@ SYMBOL: in-lambda? ERROR: invalid-local-name name ; : check-local-name ( name -- name ) - dup { "]" "]!" } member? [ invalid-local-name ] when ; + dup { "]" "]!" } member? [ throw-invalid-local-name ] when ; : make-local ( name -- word ) check-local-name "!" ?tail [ @@ -79,7 +79,7 @@ M: lambda-parser parse-quotation ( -- quotation ) : (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect ) with-lambda-scope [ nip "lambda" set-word-prop ] - [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] + [ nip rewrite-closures dup length 1 = [ first ] [ throw-bad-rewrite ] if ] [ drop nip ] 3tri ; inline : parse-locals-definition ( word reader-quot -- word quot effect ) diff --git a/basis/locals/rewrite/point-free/point-free.factor b/basis/locals/rewrite/point-free/point-free.factor index 283a3bbd5a..b823cd2735 100644 --- a/basis/locals/rewrite/point-free/point-free.factor +++ b/basis/locals/rewrite/point-free/point-free.factor @@ -10,7 +10,7 @@ IN: locals.rewrite.point-free : local-index ( args obj -- n ) 2dup '[ unquote _ eq? ] find drop - [ 2nip ] [ bad-local ] if* ; + [ 2nip ] [ throw-bad-local ] if* ; : read-local-quot ( args obj -- quot ) local-index neg [ get-local ] curry ; diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index 6689f959e7..11dc896d83 100644 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -73,14 +73,14 @@ M: quotation rewrite-element rewrite-sugar* ; M: lambda rewrite-element rewrite-sugar* ; -M: let rewrite-element let-form-in-literal-error ; +M: let rewrite-element throw-let-form-in-literal-error ; M: local rewrite-element , ; M: local-reader rewrite-element , ; M: local-writer rewrite-element - local-writer-in-literal-error ; + throw-local-writer-in-literal-error ; M: word rewrite-element , ; diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index 7b2d8205ca..fe0a8b9255 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -26,7 +26,7 @@ log-level [ DEBUG ] initialize ERROR: undefined-log-level ; : log-level<=> ( log-level log-level -- <=> ) - [ log-levels at* [ undefined-log-level ] unless ] compare ; + [ log-levels at* [ throw-undefined-log-level ] unless ] compare ; : log? ( log-level -- ? ) log-level get log-level<=> +lt+ = not ; @@ -40,7 +40,7 @@ ERROR: bad-log-message-parameters msg word level ; : check-log-message ( msg word level -- msg word level ) 3dup [ string? ] [ word? ] [ word? ] tri* and and - [ bad-log-message-parameters ] unless ; inline + [ throw-bad-log-message-parameters ] unless ; inline : log-message ( msg word level -- ) check-log-message diff --git a/basis/match/match.factor b/basis/match/match.factor index 489fa83a38..b5735b834f 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -51,7 +51,7 @@ M: no-match-cond summary drop "Fall-through in match-cond" ; MACRO: match-cond ( assoc -- quot ) - dup ?first callable? [ unclip ] [ [ no-match-cond ] ] if + dup ?first callable? [ unclip ] [ [ throw-no-match-cond ] ] if [ first2 [ [ dupd match ] curry ] dip diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 658d3586e0..8fd652b8d9 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -29,7 +29,7 @@ IN: math.bitwise ERROR: bit-range-error x high low ; : bit-range ( x high low -- y ) - 2dup { [ nip 0 < ] [ < ] } 2|| [ bit-range-error ] when + 2dup { [ nip 0 < ] [ < ] } 2|| [ throw-bit-range-error ] when [ nip neg shift ] [ - 1 + ] 2bi bits ; inline : bitroll ( x s w -- y ) diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index f57523dd02..0de7db33a0 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -38,7 +38,7 @@ IN: syntax ERROR: malformed-complex obj ; : parse-complex ( seq -- complex ) - dup length 2 = [ first2-unsafe rect> ] [ malformed-complex ] if ; + dup length 2 = [ first2-unsafe rect> ] [ throw-malformed-complex ] if ; SYNTAX: C{ \ } [ parse-complex ] parse-literal ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 22e07db984..b0fd43deb3 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -116,7 +116,7 @@ ERROR: non-trivial-divisor n ; : mod-inv ( x n -- y ) [ nip ] [ gcd 1 = ] 2bi [ dup 0 < [ + ] [ nip ] if ] - [ non-trivial-divisor ] if ; foldable + [ throw-non-trivial-divisor ] if ; foldable : ^mod ( x y n -- z ) over 0 < diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index d1894108c0..a41d803410 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -174,7 +174,7 @@ ERROR: negative-power-matrix m n ; [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; : m^n ( m n -- n ) - dup 0 >= [ (m^n) ] [ negative-power-matrix ] if ; + dup 0 >= [ (m^n) ] [ throw-negative-power-matrix ] if ; : stitch ( m -- m' ) [ ] [ [ append ] 2map ] map-reduce ; diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 0789086044..339ef5fb50 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -19,7 +19,7 @@ ERROR: bad-integer-op word ; M: word integer-op-input-classes dup "input-classes" word-prop - [ ] [ bad-integer-op ] ?if ; + [ ] [ throw-bad-integer-op ] ?if ; : generic-variant ( op -- generic-op/f ) dup "derived-from" word-prop [ first ] [ ] ?if ; diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index b2ce6945f2..2c4bb9ed8f 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -46,7 +46,7 @@ ERROR: negative-power-polynomial p n ; make-bits { 1 } [ [ over p* ] when [ p-sq ] dip ] reduce nip ; : p^ ( p n -- p^n ) - dup 0 >= [ (p^) ] [ negative-power-polynomial ] if ; + dup 0 >= [ (p^) ] [ throw-negative-power-polynomial ] if ; ] } 1&& - [ invalid-lucas-lehmer-candidate ] unless ; + [ throw-invalid-lucas-lehmer-candidate ] unless ; PRIVATE> diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 8ed1675ca7..1e9e0691c3 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -88,7 +88,7 @@ PRIVATE> ERROR: no-relative-prime n ; : find-relative-prime* ( n guess -- p ) - [ dup 1 <= [ no-relative-prime ] when ] + [ dup 1 <= [ throw-no-relative-prime ] when ] [ >odd dup 1 <= [ drop 3 ] when ] bi* [ 2dup coprime? ] [ 2 + ] until nip ; @@ -98,6 +98,6 @@ ERROR: no-relative-prime n ; ERROR: too-few-primes n numbits ; : unique-primes ( n numbits -- seq ) - 2dup 2^ estimated-primes > [ too-few-primes ] when + 2dup 2^ estimated-primes > [ throw-too-few-primes ] when 2dup [ random-prime ] curry replicate dup all-unique? [ 2nip ] [ drop unique-primes ] if ; diff --git a/basis/math/vectors/conversion/conversion-tests.factor b/basis/math/vectors/conversion/conversion-tests.factor index 85416f294e..42109be718 100644 --- a/basis/math/vectors/conversion/conversion-tests.factor +++ b/basis/math/vectors/conversion/conversion-tests.factor @@ -21,7 +21,7 @@ MACRO:: test-vconvert ( from-type to-type -- quot ) inputs narray [ quot with-datastack ] [ [ [ declaration declare quot call ] compile-call ] with-datastack ] bi - 2dup = [ optimized-vconvert-inconsistent ] unless + 2dup = [ throw-optimized-vconvert-inconsistent ] unless drop outputs firstn ] ; diff --git a/basis/math/vectors/conversion/conversion.factor b/basis/math/vectors/conversion/conversion.factor index 3c88471076..47a9acd702 100644 --- a/basis/math/vectors/conversion/conversion.factor +++ b/basis/math/vectors/conversion/conversion.factor @@ -18,7 +18,7 @@ ERROR: bad-vconvert-input value expected-type ; { uchar ushort uint ulonglong } member-eq? ; : check-vconvert-type ( value expected-type -- value ) - 2dup instance? [ drop ] [ bad-vconvert-input ] if ; inline + 2dup instance? [ drop ] [ throw-bad-vconvert-input ] if ; inline :: [vconvert] ( from-element to-element from-size to-size from-type to-type -- quot ) { @@ -46,7 +46,7 @@ ERROR: bad-vconvert-input value expected-type ; [ steps 1 = not ] [ from-element to-element [ float-type? ] bi@ xor ] [ from-element unsigned-type? to-element unsigned-type? not and ] - } 0|| [ from-type to-type bad-vconvert ] when ; + } 0|| [ from-type to-type throw-bad-vconvert ] when ; :: ([vpack-unsigned]) ( from-type to-type -- quot ) from-type new simd-rep @@ -75,7 +75,7 @@ ERROR: bad-vconvert-input value expected-type ; [ steps 1 = not ] [ from-element to-element [ float-type? ] bi@ xor ] [ from-element unsigned-type? not to-element unsigned-type? and ] - } 0|| [ from-type to-type bad-vconvert ] when ; + } 0|| [ from-type to-type throw-bad-vconvert ] when ; :: ([vunpack]) ( from-type to-type -- quot ) from-type new simd-rep @@ -98,7 +98,7 @@ MACRO:: vconvert ( from-type to-type -- quot ) from-element heap-size :> from-size to-element heap-size :> to-size - from-length to-length = [ from-type to-type bad-vconvert ] unless + from-length to-length = [ from-type to-type throw-bad-vconvert ] unless from-element to-element from-size to-size from-type to-type { { [ from-size to-size < ] [ [vunpack] ] } diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index 1714cfb0c8..90ccfcaf09 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -9,7 +9,6 @@ QUALIFIED-WITH: alien.c-types c IN: math.vectors.simd ERROR: bad-simd-length got expected ; - ERROR: bad-simd-vector obj ; << @@ -139,7 +138,7 @@ M: simd-128 byte-length drop 16 ; inline M: simd-128 new-sequence 2dup length = [ nip [ 16 (byte-array) ] make-underlying ] - [ length bad-simd-length ] if ; inline + [ length throw-bad-simd-length ] if ; inline M: simd-128 equal? dup simd-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline @@ -322,7 +321,7 @@ c: A >>boxed-class { A-rep alien-vector A boa } >quotation >>getter { - [ dup simd-128? [ bad-simd-vector ] unless underlying>> ] 2dip + [ dup simd-128? [ throw-bad-simd-vector ] unless underlying>> ] 2dip A-rep set-alien-vector } >quotation >>setter 16 >>size diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index d2797f1a6f..20082a35c0 100644 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -29,16 +29,12 @@ C: mime-variable swap >>mime-separator H{ } clone >>mime-parts ; -ERROR: bad-header bytes ; - : mime-write ( sequence -- ) >byte-array write ; : parse-headers ( string -- hashtable ) string-lines harvest [ parse-header-line ] map >hashtable ; -ERROR: end-of-stream multipart ; - : fill-bytes ( multipart -- multipart ) buffer-size read [ '[ _ B{ } append-as ] change-bytes ] @@ -120,7 +116,7 @@ ERROR: unknown-content-disposition multipart ; [ dup mime-separator>> dump-string >>name-content ] dip >>name dup save-mime-part ] [ - unknown-content-disposition + throw-unknown-content-disposition ] if* ] if* ; @@ -132,7 +128,7 @@ ERROR: no-content-disposition multipart ; parse-content-disposition-form-data >>content-disposition parse-form-data ] } - [ no-content-disposition ] + [ throw-no-content-disposition ] } case ; : read-assert-sequence= ( sequence -- ) diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index 00c6232e76..9562f0b406 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -21,8 +21,8 @@ ERROR: read-only-slot slot ; : check-set-slot ( val slot -- val offset ) { - { [ dup not ] [ no-such-slot ] } - { [ dup read-only>> ] [ read-only-slot ] } + { [ dup not ] [ throw-no-such-slot ] } + { [ dup read-only>> ] [ throw-read-only-slot ] } { [ 2dup class>> instance? not ] [ class>> bad-slot-value ] } [ offset>> ] } cond ; inline diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 1c2c1d462d..a374290ad7 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -28,7 +28,7 @@ ERROR: text-found-before-eol string ; : parse-here ( -- str ) [ lexer get - dup rest-of-line [ text-found-before-eol ] unless-empty + dup rest-of-line [ throw-text-found-before-eol ] unless-empty (parse-here) ] "" make but-last ; @@ -71,7 +71,7 @@ SYNTAX: STRING: begin-text lexer (parse-til-line-begins) ] if ] [ - begin-text bad-heredoc + begin-text throw-bad-heredoc ] if ; : parse-til-line-begins ( begin-text lexer -- seq ) diff --git a/basis/nibble-arrays/nibble-arrays.factor b/basis/nibble-arrays/nibble-arrays.factor index d519d4f5bc..0a9e4cd7b0 100644 --- a/basis/nibble-arrays/nibble-arrays.factor +++ b/basis/nibble-arrays/nibble-arrays.factor @@ -33,7 +33,7 @@ PRIVATE> ERROR: bad-array-length n ; : ( n -- nibble-array ) - dup 0 < [ bad-array-length ] when + dup 0 < [ throw-bad-array-length ] when dup nibbles>bytes nibble-array boa ; inline M: nibble-array length length>> ; diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 15d225bd04..5d6ea92ff5 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -8,7 +8,7 @@ ERROR: unknown-gl-platform ; { [ os windows? ] [ "opengl.gl.windows" ] } { [ os macosx? ] [ "opengl.gl.macosx" ] } { [ os unix? ] [ "opengl.gl.gtk" ] } - [ unknown-gl-platform ] + [ throw-unknown-gl-platform ] } cond use-vocab >> SYMBOL: +gl-function-counter+ diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index f44b1fa22b..d94f7e4f02 100644 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -148,7 +148,7 @@ M: XBGR fix-internal-component-order drop RGBA ; : image-internal-format ( component-order component-type -- internal-format ) 2dup [ fix-internal-component-order ] dip 2array image-internal-formats at - [ 2nip ] [ unsupported-component-order ] if* ; + [ 2nip ] [ throw-unsupported-component-order ] if* ; : reversed-type? ( component-type -- ? ) { u-9-9-9-e5-components float-11-11-10-components } member? ; @@ -167,7 +167,7 @@ M: XBGR fix-internal-component-order drop RGBA ; { RGBA [ drop GL_RGBA_INTEGER ] } { BGRX [ drop GL_BGRA_INTEGER ] } { RGBX [ drop GL_RGBA_INTEGER ] } - [ swap unsupported-component-order ] + [ swap throw-unsupported-component-order ] } case ] [ swap { @@ -189,22 +189,22 @@ M: XBGR fix-internal-component-order drop RGBA ; { INTENSITY [ drop GL_INTENSITY ] } { DEPTH [ drop GL_DEPTH_COMPONENT ] } { DEPTH-STENCIL [ drop GL_DEPTH_STENCIL ] } - [ swap unsupported-component-order ] + [ swap throw-unsupported-component-order ] } case ] if ; GENERIC: (component-type>type) ( component-order component-type -- gl-type ) -M: object (component-type>type) unsupported-component-order ; +M: object (component-type>type) throw-unsupported-component-order ; : four-channel-alpha-first? ( component-order component-type -- ? ) over component-count 4 = [ drop alpha-channel-precedes-colors? ] - [ unsupported-component-order ] if ; + [ throw-unsupported-component-order ] if ; : not-alpha-first ( component-order component-type -- ) over alpha-channel-precedes-colors? - [ unsupported-component-order ] + [ throw-unsupported-component-order ] [ 2drop ] if ; M: ubyte-components (component-type>type) @@ -237,19 +237,23 @@ M: u-10-10-10-2-components (component-type>type) M: u-24-components (component-type>type) over DEPTH = - [ 2drop GL_UNSIGNED_INT ] [ unsupported-component-order ] if ; + [ 2drop GL_UNSIGNED_INT ] + [ throw-unsupported-component-order ] if ; M: u-24-8-components (component-type>type) over DEPTH-STENCIL = - [ 2drop GL_UNSIGNED_INT_24_8 ] [ unsupported-component-order ] if ; + [ 2drop GL_UNSIGNED_INT_24_8 ] + [ throw-unsupported-component-order ] if ; M: u-9-9-9-e5-components (component-type>type) over BGR = - [ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ] [ unsupported-component-order ] if ; + [ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ] + [ throw-unsupported-component-order ] if ; M: float-11-11-10-components (component-type>type) over BGR = - [ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ] [ unsupported-component-order ] if ; + [ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ] + [ throw-unsupported-component-order ] if ; : image-data-format ( component-order component-type -- gl-format gl-type ) [ (component-order>format) ] [ (component-type>type) ] 2bi ; diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 8fe0e9f8a9..25ab4386d8 100644 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -142,7 +142,7 @@ ERROR: packed-read-fail str bytes ; : read-packed-bytes ( str -- bytes ) dup packed-length [ read dup length ] keep = - [ nip ] [ packed-read-fail ] if ; inline + [ nip ] [ throw-packed-read-fail ] if ; inline PRIVATE> diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 49ad57ac1b..d5ff45c206 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -18,7 +18,7 @@ ERROR: no-rule rule parser ; > (transform) [ - swap symbol>> dup get parser? [ redefined-rule ] [ set ] if + swap symbol>> dup get parser? [ throw-redefined-rule ] [ set ] if ] keep ; M: ebnf-sequence (transform) ( ast -- parser ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index f08f0359f9..5294f82038 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -618,7 +618,7 @@ SYNTAX: PEG: def call compile :> compiled-def [ dup compiled-def compiled-parse - [ ast>> ] [ word parse-failed ] ?if + [ ast>> ] [ word throw-parse-failed ] ?if ] word swap effect define-declared ] with-compilation-unit diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 862eed1aa9..bf2e93fa71 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -161,7 +161,7 @@ PRIVATE> M: persistent-vector ppop ( pvec -- pvec' ) dup count>> { - { 0 [ empty-error ] } + { 0 [ throw-empty-error ] } { 1 [ drop T{ persistent-vector } ] } [ [ diff --git a/basis/random/random.factor b/basis/random/random.factor index 2584412bcd..5bbf186494 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -35,9 +35,9 @@ ERROR: no-random-number-generator ; M: no-random-number-generator summary drop "Random number generator is not defined." ; -M: f random-bytes* ( n obj -- * ) no-random-number-generator ; +M: f random-bytes* ( n obj -- * ) throw-no-random-number-generator ; -M: f random-32* ( obj -- * ) no-random-number-generator ; +M: f random-32* ( obj -- * ) throw-no-random-number-generator ; : random-32 ( -- n ) random-generator get random-32* ; @@ -127,7 +127,7 @@ M: hash-set random ERROR: too-many-samples seq n ; : sample ( seq n -- seq' ) - 2dup [ length ] dip < [ too-many-samples ] when + 2dup [ length ] dip < [ throw-too-many-samples ] when [ [ length iota >array ] dip [ randomize-n-last ] keep tail-slice* ] [ drop ] 2bi nths-unsafe ; diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index bda828a7b5..3b20527f5f 100755 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -31,7 +31,10 @@ ERROR: acquire-crypto-context-failed provider type error ; : attempt-crypto-context ( provider type -- handle ) [ acquire-crypto-context ] - [ drop [ create-crypto-context ] [ acquire-crypto-context-failed ] recover ] recover ; + [ + drop [ create-crypto-context ] + [ throw-acquire-crypto-context-failed ] recover + ] recover ; : initialize-crypto-context ( crypto-context -- crypto-context ) dup [ provider>> ] [ type>> ] bi attempt-crypto-context >>handle ; diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 01cff98901..fb9336c404 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -13,7 +13,7 @@ IN: regexp.parser ERROR: bad-number ; : ensure-number ( n -- n ) - [ bad-number ] unless* ; + [ throw-bad-number ] unless* ; :: at-error ( key assoc quot: ( key -- replacement ) -- value ) key assoc at* [ drop key quot call ] unless ; inline @@ -45,13 +45,13 @@ MEMO: simple-category-table ( -- table ) { [ "script=" ?head ] [ dup simple-script-table at [ ] - [ "script=" prepend bad-class ] ?if + [ "script=" prepend throw-bad-class ] ?if ] } - [ bad-class ] + [ throw-bad-class ] } cond ; : unicode-class ( name -- class ) - dup parse-unicode-class [ ] [ bad-class ] ?if ; + dup parse-unicode-class [ ] [ throw-bad-class ] ?if ; : name>class ( name -- class ) >string simple { @@ -106,7 +106,7 @@ MEMO: simple-category-table ( -- table ) ERROR: nonexistent-option name ; : ch>option ( ch -- singleton ) - dup options-assoc at [ ] [ nonexistent-option ] ?if ; + dup options-assoc at [ ] [ throw-nonexistent-option ] ?if ; : option>ch ( option -- string ) options-assoc value-at ; @@ -198,7 +198,7 @@ Number = (!(","|"}").)* => [[ string>number ensure-number ]] Times = "," Number:n "}" => [[ 0 n ]] | Number:n ",}" => [[ n ]] | Number:n "}" => [[ n n ]] - | "}" => [[ bad-number ]] + | "}" => [[ throw-bad-number ]] | Number:n "," Number:m "}" => [[ n m ]] Repeated = Element:e "{" Times:t => [[ e t ]] diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index 346226bf4e..a5791d7ac7 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -18,7 +18,7 @@ CONSTANT: roman-values ERROR: roman-range-error n ; : roman-range-check ( n -- n ) - dup 1 10000 between? [ roman-range-error ] unless ; + dup 1 10000 between? [ throw-roman-range-error ] unless ; : roman-digit-index ( ch -- n ) 1string roman-digits index ; inline diff --git a/basis/sequences/unrolled/unrolled.factor b/basis/sequences/unrolled/unrolled.factor index ad28dde00d..4d83294dd0 100644 --- a/basis/sequences/unrolled/unrolled.factor +++ b/basis/sequences/unrolled/unrolled.factor @@ -34,11 +34,11 @@ ERROR: unrolled-2bounds-error [ 2over unrolled-bounds-error ] when ; inline + 2over swap length > [ 2over throw-unrolled-bounds-error ] when ; inline :: unrolled-2bounds-check ( xseq yseq len quot -- xseq yseq len quot ) { [ len xseq length > ] [ len yseq length > ] } 0|| - [ xseq yseq len unrolled-2bounds-error ] + [ xseq yseq len throw-unrolled-2bounds-error ] [ xseq yseq len quot ] if ; inline : (unrolled-each) ( seq len quot -- len quot ) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 48ea2c1814..47429b823d 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -69,7 +69,7 @@ ERROR: bad-email-address email ; : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. dup "\r\n>" intersects? - [ bad-email-address ] when ; + [ throw-bad-email-address ] when ; : mail-from ( fromaddr -- ) validate-address @@ -130,17 +130,17 @@ ERROR: smtp-transaction-failed < smtp-error ; : check-response ( response -- ) dup code>> { { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] } - { [ dup 400 499 between? ] [ drop smtp-server-busy ] } - { [ dup 500 = ] [ drop smtp-syntax-error ] } - { [ dup 501 = ] [ drop smtp-command-not-implemented ] } - { [ dup 500 509 between? ] [ drop smtp-syntax-error ] } - { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] } - { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] } - { [ dup 551 = ] [ drop smtp-user-not-local ] } - { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] } - { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] } - { [ dup 554 = ] [ drop smtp-transaction-failed ] } - [ drop smtp-error ] + { [ dup 400 499 between? ] [ drop throw-smtp-server-busy ] } + { [ dup 500 = ] [ drop throw-smtp-syntax-error ] } + { [ dup 501 = ] [ drop throw-smtp-command-not-implemented ] } + { [ dup 500 509 between? ] [ drop throw-smtp-syntax-error ] } + { [ dup 530 539 between? ] [ drop throw-smtp-bad-authentication ] } + { [ dup 550 = ] [ drop throw-smtp-mailbox-unavailable ] } + { [ dup 551 = ] [ drop throw-smtp-user-not-local ] } + { [ dup 552 = ] [ drop throw-smtp-exceeded-storage-allocation ] } + { [ dup 553 = ] [ drop throw-smtp-bad-mailbox-name ] } + { [ dup 554 = ] [ drop throw-smtp-transaction-failed ] } + [ drop throw-smtp-error ] } cond ; : get-ok ( -- ) receive-response check-response ; @@ -168,7 +168,7 @@ ERROR: invalid-header-string string ; : validate-header ( string -- string' ) dup "\r\n" intersects? - [ invalid-header-string ] when ; + [ throw-invalid-header-string ] when ; : write-header ( key value -- ) [ validate-header write ] diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 7976a5c148..5e593c4fab 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -136,35 +136,35 @@ ERROR: specialized-array-vocab-not-loaded c-type ; M: c-type-word c-array-constructor underlying-type dup [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup-word - [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable + [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable M: pointer c-array-constructor drop void* c-array-constructor ; M: c-type-word c-(array)-constructor underlying-type dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup-word - [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable + [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable M: pointer c-(array)-constructor drop void* c-(array)-constructor ; M: c-type-word c-direct-array-constructor underlying-type dup [ name>> "" surround ] [ specialized-array-vocab ] bi lookup-word - [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable + [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ; M: c-type-word c-array-type underlying-type dup [ name>> "-array" append ] [ specialized-array-vocab ] bi lookup-word - [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable + [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable M: pointer c-array-type drop void* c-array-type ; M: c-type-word c-array-type? underlying-type dup [ name>> "-array?" append ] [ specialized-array-vocab ] bi lookup-word - [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable + [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable M: pointer c-array-type? drop void* c-array-type? ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 5426b773b2..8f97d38f92 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -297,7 +297,7 @@ DEFER: an-inline-word ERROR: custom-error ; { T{ effect f { } { } t } } [ - [ custom-error ] infer + [ throw-custom-error ] infer ] unit-test : funny-throw ( a -- * ) throw ; inline @@ -307,7 +307,7 @@ ERROR: custom-error ; ] unit-test { T{ effect f { } { } t } } [ - [ custom-error inference-error ] infer + [ throw-custom-error inference-error ] infer ] unit-test { T{ effect f { "x" } { "x" "x" } t } } [ diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index dd71e63ffb..7fd3bd6b14 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -33,7 +33,7 @@ PREDICATE: annotated < word "unannotated-def" word-prop >boolean ; - [ n buf stream word invalid-stream-read-unsafe ] + [ n buf stream word throw-invalid-stream-read-unsafe ] [ n buf stream ] if ] if ; inline :: check-stream-read-unsafe-after ( count n buf stream word -- count ) count n > - [ count n buf stream word invalid-stream-read-unsafe-return ] + [ count n buf stream word throw-invalid-stream-read-unsafe-return ] [ count ] if ; : (assert-stream-read-unsafe) ( word -- ) diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 1523cd5f98..8d830e6ba4 100644 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -25,7 +25,7 @@ ERROR: can't-deploy-library-file library ; : copy-library ( dir library -- ) dup find-library-file [ swap over file-name append-path copy-file ] - [ can't-deploy-library-file ] ?if ; + [ throw-can't-deploy-library-file ] ?if ; : copy-libraries ( manifest name dir -- ) append-path swap libraries>> [ copy-library ] with each ; diff --git a/basis/tools/deploy/shaker/strip-specialized-arrays.factor b/basis/tools/deploy/shaker/strip-specialized-arrays.factor index 195a3db976..7b402ab436 100644 --- a/basis/tools/deploy/shaker/strip-specialized-arrays.factor +++ b/basis/tools/deploy/shaker/strip-specialized-arrays.factor @@ -2,4 +2,4 @@ IN: specialized-arrays ERROR: cannot-define-array-in-deployed-app type ; -: define-array-vocab ( type -- ) cannot-define-array-in-deployed-app ; +: define-array-vocab ( type -- ) throw-cannot-define-array-in-deployed-app ; diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index 05e16ca10f..367aa21fff 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -23,7 +23,7 @@ ERROR: image-too-big actual-size max-size ; cpu ppc? [ 100000 + ] when os windows? [ 160000 + ] when ] bi* - 2dup <= [ 2drop ] [ image-too-big ] if ; + 2dup <= [ 2drop ] [ throw-image-too-big ] if ; : deploy-test-command ( -- args ) os macosx? diff --git a/basis/tools/deploy/windows/ico/ico.factor b/basis/tools/deploy/windows/ico/ico.factor index e656597a38..adf2bdd600 100755 --- a/basis/tools/deploy/windows/ico/ico.factor +++ b/basis/tools/deploy/windows/ico/ico.factor @@ -58,10 +58,10 @@ ERROR: unsupported-ico-format bytes format ; : check-ico-type ( bytes -- bytes ) dup "PNG" head? [ - "PNG" unsupported-ico-format + "PNG" throw-unsupported-ico-format ] when dup B{ 0 0 } head? [ - "UNKNOWN" unsupported-ico-format + "UNKNOWN" throw-unsupported-ico-format ] unless ; PRIVATE> diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 185791883f..01d6c325ba 100644 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -66,7 +66,7 @@ M: object file-spec>string ( file-listing spec -- string ) { +file-date+ [ file-info>> modified>> listing-date ] } { +file-time+ [ file-info>> modified>> listing-time ] } { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] } - [ unknown-file-spec ] + [ throw-unknown-file-spec ] } case ; : list-files-fast ( listing-tool -- array ) diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor index b937b25b93..f6349e091e 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -15,7 +15,7 @@ M: bad-tr summary : tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline : check-tr ( from to -- ) - [ [ ascii? ] all? ] both? [ bad-tr ] unless ; + [ [ ascii? ] all? ] both? [ throw-bad-tr ] unless ; : compute-tr ( quot from to -- mapping ) [ 128 iota ] 3dip zip diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 869f8bf5a1..6e995a813d 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -33,8 +33,8 @@ MACRO: write-tuple ( class -- quot ) : check-final ( class -- ) { - { [ dup tuple-class? not ] [ not-a-tuple ] } - { [ dup final-class? not ] [ not-final ] } + { [ dup tuple-class? not ] [ throw-not-a-tuple ] } + { [ dup final-class? not ] [ throw-not-final ] } [ drop ] } cond ; diff --git a/basis/typed/namespaces/namespaces.factor b/basis/typed/namespaces/namespaces.factor index f86ad952a3..5b371ea0d6 100644 --- a/basis/typed/namespaces/namespaces.factor +++ b/basis/typed/namespaces/namespaces.factor @@ -19,7 +19,7 @@ PRIVATE> :: (typed-get) ( name type getter: ( name -- value ) -- value ) name getter call :> value - value type instance? [ name value type variable-type-error ] unless + value type instance? [ name value type throw-variable-type-error ] unless value type declare1 ; inline : typed-get ( name type -- value ) @@ -29,7 +29,7 @@ PRIVATE> [ get-global ] (typed-get) ; inline :: (typed-set) ( value name type setter: ( value name -- ) -- ) - value type instance? [ name value type variable-type-error ] unless + value type instance? [ name value type throw-variable-type-error ] unless value name setter call ; inline : typed-set ( value name type -- ) diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index 4a14e5d3b7..c835713606 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -69,14 +69,14 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ; :: typed-inputs ( quot word types -- quot' ) types unboxed-types :> unboxed-types - [ input-mismatch-error ] word types make-unboxer + [ throw-input-mismatch-error ] word types make-unboxer unboxed-types quot '[ _ declare @ ] compose ; ! typed outputs :: typed-outputs ( quot word types -- quot' ) - [ output-mismatch-error ] word types make-unboxer + [ throw-output-mismatch-error ] word types make-unboxer quot prepose ; DEFER: make-boxer @@ -143,7 +143,7 @@ MACRO: typed ( quot word effect -- quot' ) dup { [ effect-in-types typed-stack-effect? ] [ effect-out-types typed-stack-effect? ] - } 1|| [ (typed-def) ] [ nip no-types-specified ] if ; + } 1|| [ (typed-def) ] [ nip throw-no-types-specified ] if ; M: typed-word subwords [ call-next-method ] diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index 38fb92e1f0..b9204f5853 100644 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -30,7 +30,7 @@ M: label string<< ( string label -- ) { { [ dup string-array? ] [ ] } { [ dup string? ] [ ?string-lines ] } - [ not-a-string ] + [ throw-not-a-string ] } cond ] dip [ text<< ] [ relayout ] bi ; inline diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index f4b494fa3f..961f9bc766 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -103,7 +103,7 @@ ERROR: no-world-found ; : find-gl-context ( gadget -- ) find-world dup - [ set-gl-context ] [ no-world-found ] if ; + [ set-gl-context ] [ throw-no-world-found ] if ; : (request-focus) ( child world ? -- ) pick parent>> pick eq? [ diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index caca019cbc..1f05c667f0 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -52,7 +52,7 @@ TUPLE: pixel-format < disposable world handle ; : ( world attributes -- pixel-format ) 2dup (make-pixel-format) [ pixel-format new-disposable swap >>handle swap >>world ] - [ invalid-pixel-format-attributes ] + [ throw-invalid-pixel-format-attributes ] ?if ; M: pixel-format dispose* diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index e51ccc40c4..9138a2f533 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -62,7 +62,7 @@ PRIVATE> ERROR: no-group string ; : ?group-id ( string -- id ) - dup group-struct [ nip gr_gid>> ] [ no-group ] if* ; + dup group-struct [ nip gr_gid>> ] [ throw-no-group ] if* ; >vendor-id ] } { "wp" [ "yes" = >>wp? ] } { "TLB size" [ >>tlb-size ] } - [ unknown-cpuinfo-line ] + [ throw-unknown-cpuinfo-line ] } case ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 4364fd40d0..76b0663479 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -32,7 +32,7 @@ MACRO:: unix-system-call ( quot -- quot ) failed [ n narray errno dup strerror - word unix-system-call-error + word throw-unix-system-call-error ] [ n ndrop ret @@ -51,7 +51,7 @@ MACRO:: unix-system-call-allow-eintr ( quot -- quot ) errno EINTR = [ n narray errno dup strerror - word unix-system-call-error + word throw-unix-system-call-error ] unless ] [ n ndrop diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index ee2e592c1f..a3c4432d89 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -71,7 +71,7 @@ M: string user-passwd ( string -- passwd/f ) ERROR: no-user string ; : ?user-id ( string -- id/f ) - dup user-passwd [ nip uid>> ] [ no-user ] if* ; + dup user-passwd [ nip uid>> ] [ throw-no-user ] if* ; : real-user-id ( -- id ) unix.ffi:getuid ; inline @@ -132,6 +132,6 @@ M: string set-effective-user ( string -- ) ERROR: no-such-user obj ; : user-home ( name/uid -- path ) - dup user-passwd [ nip dir>> ] [ no-such-user ] if* ; + dup user-passwd [ nip dir>> ] [ throw-no-such-user ] if* ; os macosx? [ "unix.users.macosx" require ] when diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor index bfb8e07e4f..000782743f 100644 --- a/basis/unrolled-lists/unrolled-lists.factor +++ b/basis/unrolled-lists/unrolled-lists.factor @@ -85,7 +85,7 @@ M: unrolled-list peek-front* drop ; inline M: unrolled-list pop-front* - dup front>> [ empty-unrolled-list ] unless* + dup front>> [ throw-empty-unrolled-list ] unless* over front-pos>> unroll-factor 1 - eq? [ pop-front/new ] [ pop-front/existing ] if ; @@ -131,7 +131,7 @@ M: unrolled-list peek-back* drop ; inline M: unrolled-list pop-back* - dup back>> [ empty-unrolled-list ] unless* + dup back>> [ throw-empty-unrolled-list ] unless* over back-pos>> 1 eq? [ pop-back/new ] [ pop-back/existing ] if ; diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index f149f499d9..a1f26d43eb 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -30,7 +30,7 @@ ERROR: malformed-port ; : parse-host ( string -- host/f port/f ) [ ":" split1-last [ url-decode ] - [ dup [ string>number [ malformed-port ] unless* ] when ] bi* + [ dup [ string>number [ throw-malformed-port ] unless* ] when ] bi* ] [ f f ] if* ; GENERIC: >url ( obj -- url ) diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor index 79870b483f..97e9b29ccc 100644 --- a/basis/vlists/vlists.factor +++ b/basis/vlists/vlists.factor @@ -33,7 +33,7 @@ M: vlist ppush ERROR: empty-vlist-error ; M: vlist ppop - [ empty-vlist-error ] + [ throw-empty-vlist-error ] [ [ length>> 1 - ] [ vector>> ] bi vlist boa ] if-empty ; M: vlist clone diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor index 96b8723e68..7172c461cb 100644 --- a/basis/vocabs/hierarchy/hierarchy.factor +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -34,7 +34,7 @@ M: vocab-prefix vocab-name name>> ; ERROR: vocab-root-required root ; : ensure-vocab-root ( root -- root ) - dup vocab-roots get member? [ vocab-root-required ] unless ; + dup vocab-roots get member? [ throw-vocab-root-required ] unless ; : ensure-vocab-root/prefix ( root prefix -- root prefix ) [ ensure-vocab-root ] [ check-vocab-name ] bi* ; diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor index 15abd924d8..d69e02ab8d 100644 --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -94,7 +94,7 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ERROR: null-com-release ; : com-release ( interface -- ) - [ IUnknown::Release drop ] [ null-com-release ] if* ; inline + [ IUnknown::Release drop ] [ throw-null-com-release ] if* ; inline : with-com-interface ( interface quot -- ) over [ com-release ] curry [ ] cleanup ; inline diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index f6cf51d3d4..85a1fbb00a 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -31,7 +31,7 @@ ERROR: no-com-interface interface ; : find-com-interface-definition ( name -- definition ) [ dup +com-interface-definitions+ get-global at* - [ nip ] [ drop no-com-interface ] if + [ nip ] [ drop throw-no-com-interface ] if ] [ f ] if* ; : save-com-interface-definition ( definition -- ) diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index fca62c85be..43b0052b18 100755 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -723,7 +723,7 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK 0x000000FF ERROR: windows-error n string ; : (win32-error) ( n -- ) - [ dup win32-error-string windows-error ] unless-zero ; + [ dup win32-error-string throw-windows-error ] unless-zero ; : win32-error ( -- ) GetLastError (win32-error) ; @@ -737,7 +737,7 @@ ERROR: windows-error n string ; dup ERROR_SUCCESS = [ drop ] [ - dup n>win32-error-string windows-error + dup n>win32-error-string throw-windows-error ] if ; : throw-win32-error ( -- * ) diff --git a/basis/windows/gdiplus/gdiplus.factor b/basis/windows/gdiplus/gdiplus.factor index a43ce235ba..5398dd4706 100644 --- a/basis/windows/gdiplus/gdiplus.factor +++ b/basis/windows/gdiplus/gdiplus.factor @@ -1628,7 +1628,7 @@ FUNCTION: GpStatus GdipTestControl ( GpTestControlEnum x, void* x ) ERROR: gdi+-error status ; : check-gdi+-status ( GpStatus -- ) - dup Ok = [ drop ] [ gdi+-error ] if ; + dup Ok = [ drop ] [ throw-gdi+-error ] if ; CONSTANT: standard-gdi+-startup-input S{ GdiplusStartupInput diff --git a/basis/windows/iphlpapi/iphlpapi.factor b/basis/windows/iphlpapi/iphlpapi.factor index e3f2da7b18..422d83fbc1 100644 --- a/basis/windows/iphlpapi/iphlpapi.factor +++ b/basis/windows/iphlpapi/iphlpapi.factor @@ -141,7 +141,7 @@ ERROR: unknown-sockaddr-length sockaddr length ; dup iSockaddrLength>> { { 16 [ lpSockaddr>> sockaddr-in memory>struct ] } { 28 [ lpSockaddr>> sockaddr-in6 memory>struct ] } - [ unknown-sockaddr-length ] + [ throw-unknown-sockaddr-length ] } case ; TYPEDEF: SOCKET_ADDRESS* PSOCKET_ADDRESS diff --git a/basis/windows/registry/registry.factor b/basis/windows/registry/registry.factor index 968b52fbe4..65d64b85fb 100644 --- a/basis/windows/registry/registry.factor +++ b/basis/windows/registry/registry.factor @@ -19,7 +19,7 @@ CONSTANT: registry-value-max-length 16384 drop ] [ [ key subkey mode ] dip n>win32-error-string - open-key-failed + throw-open-key-failed ] if ] keep HKEY deref ; @@ -36,7 +36,7 @@ CONSTANT: registry-value-max-length 16384 hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes ] dip n>win32-error-string - create-key-failed + throw-create-key-failed ] unless ; : create-key ( hkey lsubkey -- hkey ) diff --git a/basis/windows/winmm/winmm.factor b/basis/windows/winmm/winmm.factor index db6a18e69b..fa87ad9001 100644 --- a/basis/windows/winmm/winmm.factor +++ b/basis/windows/winmm/winmm.factor @@ -20,7 +20,7 @@ ALIAS: mciSendString mciSendStringW ERROR: mci-error n ; : check-mci-error ( n -- ) - [ mci-error ] unless-zero ; + [ throw-mci-error ] unless-zero ; : open-command ( path -- ) "open \"%s\" type mpegvideo alias MediaFile" sprintf f 0 f diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 163b5f9e9d..59a2651263 100644 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -447,7 +447,7 @@ ERROR: winsock-exception n string ; maybe-winsock-exception [ throw ] when* ; : (throw-winsock-error) ( n -- * ) - [ ] [ n>win32-error-string ] bi winsock-exception ; + [ ] [ n>win32-error-string ] bi throw-winsock-exception ; : throw-winsock-error ( -- * ) WSAGetLastError (throw-winsock-error) ; diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 36bc349e11..86a67afd17 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -125,7 +125,7 @@ TAG: boolean xml>item children>string { { "1" [ t ] } { "0" [ f ] } - [ "Bad boolean" server-error ] + [ "Bad boolean" throw-server-error ] } case ; : unstruct-member ( tag -- ) @@ -167,7 +167,7 @@ TAG: array xml>item dup first-child-tag main>> "fault" = [ parse-fault ] [ parse-rpc-response ] if - ] [ "Bad main tag name" server-error ] if + ] [ "Bad main tag name" throw-server-error ] if ] if ; alist swap '[ _ no-tag ] suffix '[ dup main>> _ case ] ; + >alist swap '[ _ throw-no-tag ] suffix '[ dup main>> _ case ] ; : define-tags ( word effect -- ) [ dup dup "xtable" word-prop compile-tags ] dip define-declared ; diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index 67faefff33..473d5305ea 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -87,8 +87,6 @@ DEFER: finalize-rule-set ] with-variable ] with each ; -ERROR: mutually-recursive-rulesets ruleset ; - : finalize-rule-set ( ruleset -- ) dup finalized?>> [ drop ] [ t >>finalized?