extra: use throw-foo for ERROR: change
parent
809d372243
commit
66147f27b4
|
@ -13,9 +13,9 @@ ERROR: invalid-demangle-args name ;
|
|||
: demangle-error ( name status -- )
|
||||
{
|
||||
{ 0 [ drop ] }
|
||||
{ -1 [ drop demangle-memory-allocation-failure ] }
|
||||
{ -2 [ invalid-mangled-name ] }
|
||||
{ -3 [ invalid-demangle-args ] }
|
||||
{ -1 [ drop throw-demangle-memory-allocation-failure ] }
|
||||
{ -2 [ throw-invalid-mangled-name ] }
|
||||
{ -3 [ throw-invalid-demangle-args ] }
|
||||
} case ;
|
||||
|
||||
: mangled-name? ( name -- ? )
|
||||
|
|
|
@ -102,12 +102,12 @@ CONSTANT: fortran>c-types H{
|
|||
dims>> [ product 2array ] when* ;
|
||||
|
||||
MACRO: size-case-type ( cases -- quot )
|
||||
[ invalid-fortran-type ] suffix
|
||||
[ throw-invalid-fortran-type ] suffix
|
||||
'[ [ size>> _ case ] [ append-dimensions ] bi ] ;
|
||||
|
||||
: simple-type ( type base-c-type -- c-type )
|
||||
swap
|
||||
[ dup size>> [ invalid-fortran-type ] [ drop ] if ]
|
||||
[ dup size>> [ throw-invalid-fortran-type ] [ drop ] if ]
|
||||
[ append-dimensions ] bi ;
|
||||
|
||||
: new-fortran-type ( out? dims size class -- type )
|
||||
|
@ -150,7 +150,7 @@ M: misc-type (fortran-type>c-type)
|
|||
|
||||
: fix-character-type ( character-type -- character-type' )
|
||||
clone dup size>>
|
||||
[ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
|
||||
[ dup dims>> [ throw-invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
|
||||
[ dup dims>> [ ] [ f >>dims ] if ] if
|
||||
dup single-char? [ f >>dims ] when ;
|
||||
|
||||
|
@ -212,7 +212,7 @@ M: integer-type (fortran-arg>c-args)
|
|||
{ 2 [ [ c:short <ref> ] [ drop ] ] }
|
||||
{ 4 [ [ c:int <ref> ] [ drop ] ] }
|
||||
{ 8 [ [ c:longlong <ref> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
[ throw-invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
|
@ -225,7 +225,7 @@ M: real-type (fortran-arg>c-args)
|
|||
{ f [ [ c:float <ref> ] [ drop ] ] }
|
||||
{ 4 [ [ c:float <ref> ] [ drop ] ] }
|
||||
{ 8 [ [ c:double <ref> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
[ throw-invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
|
@ -235,7 +235,7 @@ M: real-complex-type (fortran-arg>c-args)
|
|||
{ f [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 8 [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 16 [ [ <complex-double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
[ throw-invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
|
@ -266,7 +266,7 @@ M: integer-type (fortran-result>)
|
|||
{ 2 [ { [ c:short deref ] } ] }
|
||||
{ 4 [ { [ c:int deref ] } ] }
|
||||
{ 8 [ { [ c:longlong deref ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
[ throw-invalid-fortran-type ]
|
||||
} case
|
||||
] result?dims ;
|
||||
|
||||
|
@ -278,7 +278,7 @@ M: real-type (fortran-result>)
|
|||
{ f [ { [ c:float deref ] } ] }
|
||||
{ 4 [ { [ c:float deref ] } ] }
|
||||
{ 8 [ { [ c:double deref ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
[ throw-invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
M: real-complex-type (fortran-result>)
|
||||
|
@ -286,7 +286,7 @@ M: real-complex-type (fortran-result>)
|
|||
{ f [ { [ *complex-float ] } ] }
|
||||
{ 8 [ { [ *complex-float ] } ] }
|
||||
{ 16 [ { [ *complex-double ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
[ throw-invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
M: double-precision-type (fortran-result>)
|
||||
|
|
|
@ -47,7 +47,7 @@ M: sequence shape array-replace wrap-shape ;
|
|||
ERROR: no-negative-shape-components shape ;
|
||||
|
||||
: check-shape-domain ( seq -- seq )
|
||||
dup [ 0 < ] any? [ no-negative-shape-components ] when ;
|
||||
dup [ 0 < ] any? [ throw-no-negative-shape-components ] when ;
|
||||
|
||||
GENERIC: shape-capacity ( shape -- n )
|
||||
|
||||
|
@ -68,20 +68,20 @@ ERROR: no-abnormally-shaped-arrays underlying shape ;
|
|||
GENERIC: check-underlying-shape ( underlying shape -- underlying shape )
|
||||
|
||||
M: abnormal-shape check-underlying-shape
|
||||
no-abnormally-shaped-arrays ;
|
||||
throw-no-abnormally-shaped-arrays ;
|
||||
|
||||
M: uniform-shape check-underlying-shape
|
||||
shape>> check-underlying-shape ;
|
||||
|
||||
M: sequence check-underlying-shape
|
||||
2dup [ length ] [ shape-capacity ] bi*
|
||||
= [ underlying-shape-mismatch ] unless ; inline
|
||||
= [ throw-underlying-shape-mismatch ] unless ; inline
|
||||
|
||||
ERROR: shape-mismatch shaped0 shaped1 ;
|
||||
|
||||
: check-shape ( shaped-array shaped-array -- shaped-array shaped-array )
|
||||
2dup [ shape>> ] bi@
|
||||
sequence= [ shape-mismatch ] unless ;
|
||||
sequence= [ throw-shape-mismatch ] unless ;
|
||||
|
||||
TUPLE: shaped-array underlying shape ;
|
||||
TUPLE: row-array < shaped-array ;
|
||||
|
|
|
@ -76,7 +76,7 @@ ERROR: unsupported-tag-encoding id ;
|
|||
elements get id>> 31 bitand
|
||||
dup elements get tag<<
|
||||
31 < [
|
||||
get-id unsupported-tag-encoding
|
||||
get-id throw-unsupported-tag-encoding
|
||||
] unless ;
|
||||
|
||||
: set-tagclass ( -- )
|
||||
|
|
|
@ -19,5 +19,5 @@ ERROR: format-unsupported-by-openal audio ;
|
|||
{ { 1 16 } [ drop AL_FORMAT_MONO16 ] }
|
||||
{ { 2 8 } [ drop AL_FORMAT_STEREO8 ] }
|
||||
{ { 2 16 } [ drop AL_FORMAT_STEREO16 ] }
|
||||
[ drop format-unsupported-by-openal ]
|
||||
[ drop throw-format-unsupported-by-openal ]
|
||||
} case ;
|
||||
|
|
|
@ -8,7 +8,7 @@ ERROR: invalid-audio-file ;
|
|||
: ensured-read ( count -- output/f )
|
||||
[ read ] keep over length = [ drop f ] unless ;
|
||||
: ensured-read* ( count -- output )
|
||||
ensured-read [ invalid-audio-file ] unless* ;
|
||||
ensured-read [ throw-invalid-audio-file ] unless* ;
|
||||
|
||||
: read-chunk ( -- byte-array/f )
|
||||
4 ensured-read [ 4 ensured-read* dup endian> ensured-read* 3append ] [ f ] if* ;
|
||||
|
|
|
@ -94,11 +94,11 @@ ERROR: audio-context-not-available device-name ;
|
|||
:: <audio-engine> ( device-name voice-count -- engine )
|
||||
[
|
||||
device-name alcOpenDevice :> al-device
|
||||
al-device [ device-name audio-device-not-found ] unless
|
||||
al-device [ device-name throw-audio-device-not-found ] unless
|
||||
al-device |alcCloseDevice* drop
|
||||
|
||||
al-device f alcCreateContext :> al-context
|
||||
al-context [ device-name audio-context-not-available ] unless
|
||||
al-context [ device-name throw-audio-context-not-available ] unless
|
||||
al-context |alcDestroyContext drop
|
||||
|
||||
al-context alcSuspendContext
|
||||
|
|
|
@ -14,7 +14,7 @@ audio-types [ H{ } clone ] initialize
|
|||
: read-audio ( path -- audio )
|
||||
dup file-extension >lower audio-types get ?at
|
||||
[ call( path -- audio ) ]
|
||||
[ unknown-audio-extension ] if ;
|
||||
[ throw-unknown-audio-extension ] if ;
|
||||
|
||||
"audio.wav" require
|
||||
"audio.aiff" require
|
||||
|
|
|
@ -48,7 +48,7 @@ ERROR: no-vorbis-in-ogg ;
|
|||
stream>> read-bytes-into ; inline
|
||||
|
||||
: ?ogg-error ( n -- )
|
||||
dup 0 < [ ogg-error ] [ drop ] if ; inline
|
||||
dup 0 < [ throw-ogg-error ] [ drop ] if ; inline
|
||||
|
||||
: confirm-buffer ( len vorbis-stream -- ? )
|
||||
'[ _ sync-state>> swap ogg_sync_wrote ?ogg-error ] keep zero? not ; inline
|
||||
|
@ -119,11 +119,11 @@ ERROR: no-vorbis-in-ogg ;
|
|||
#vorbis-headers>> 1 2 between? not ; inline
|
||||
|
||||
: ?vorbis-error ( code -- )
|
||||
[ vorbis-error ] unless-zero ; inline
|
||||
[ throw-vorbis-error ] unless-zero ; inline
|
||||
|
||||
: get-remaining-vorbis-header-packet ( player -- ? )
|
||||
[ stream-state>> ] [ packet>> ] bi ogg_stream_packetout {
|
||||
{ [ dup 0 < ] [ vorbis-error ] }
|
||||
{ [ dup 0 < ] [ throw-vorbis-error ] }
|
||||
{ [ dup zero? ] [ drop f ] }
|
||||
[ drop t ]
|
||||
} cond ;
|
||||
|
@ -153,7 +153,7 @@ ERROR: no-vorbis-in-ogg ;
|
|||
|
||||
: initialize-decoder ( vorbis-stream -- )
|
||||
dup #vorbis-headers>> zero?
|
||||
[ no-vorbis-in-ogg ]
|
||||
[ throw-no-vorbis-in-ogg ]
|
||||
[ init-vorbis-codec ] if ;
|
||||
|
||||
: get-pending-decoded-audio ( vorbis-stream -- pcm len )
|
||||
|
|
|
@ -13,7 +13,7 @@ ERROR: amb-failure ;
|
|||
M: amb-failure summary drop "Backtracking failure" ;
|
||||
|
||||
: fail ( -- )
|
||||
failure get [ continue ] [ amb-failure ] if* ;
|
||||
failure get [ continue ] [ throw-amb-failure ] if* ;
|
||||
|
||||
: must-be-true ( ? -- )
|
||||
[ fail ] unless ;
|
||||
|
|
|
@ -18,7 +18,7 @@ CONSTANT: alphabet
|
|||
|
||||
: base85>ch ( ch -- ch )
|
||||
$[ alphabet alphabet-inverse ] nth
|
||||
[ malformed-base85 ] unless* ; inline
|
||||
[ throw-malformed-base85 ] unless* ; inline
|
||||
|
||||
: encode4 ( seq -- seq' )
|
||||
be> 5 [ 85 /mod ch>base85 ] B{ } replicate-as reverse! nip ; inline
|
||||
|
@ -48,7 +48,7 @@ PRIVATE>
|
|||
5 "\n\r" pick read-ignoring dup length {
|
||||
{ 0 [ 2drop ] }
|
||||
{ 5 [ decode5 (decode-base85) ] }
|
||||
[ malformed-base85 ]
|
||||
[ throw-malformed-base85 ]
|
||||
} case ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
@ -38,7 +38,7 @@ TUPLE: meeting-place count mailbox ;
|
|||
{ { yellow blue } [ red ] }
|
||||
{ { blue red } [ yellow ] }
|
||||
{ { blue yellow } [ red ] }
|
||||
[ bad-color-pair ]
|
||||
[ throw-bad-color-pair ]
|
||||
} case
|
||||
] if ;
|
||||
|
||||
|
|
|
@ -21,7 +21,7 @@ TUPLE: tcp-echo < threaded-server #times #bytes ;
|
|||
ERROR: incorrect-#bytes ;
|
||||
|
||||
: check-bytes ( bytes n -- bytes )
|
||||
over length = [ incorrect-#bytes ] unless ;
|
||||
over length = [ throw-incorrect-#bytes ] unless ;
|
||||
|
||||
: read-n ( n -- bytes )
|
||||
[ read ] [ check-bytes ] bi ;
|
||||
|
@ -46,7 +46,7 @@ M: tcp-echo handle-client*
|
|||
<tcp-echo> [
|
||||
\ threaded-server get server>address binary [
|
||||
#times [ #bytes read-write ] times
|
||||
contents empty? [ incorrect-#bytes ] unless
|
||||
contents empty? [ throw-incorrect-#bytes ] unless
|
||||
] with-client
|
||||
] with-threaded-server ;
|
||||
|
||||
|
|
|
@ -19,7 +19,7 @@ ERROR: bad-response json status ;
|
|||
: check-status ( json -- json )
|
||||
dup "status_code" of 200 = [
|
||||
dup "status_txt" of
|
||||
bad-response
|
||||
throw-bad-response
|
||||
] unless ;
|
||||
|
||||
: json-data ( url -- json )
|
||||
|
|
|
@ -49,7 +49,7 @@ TUPLE: bloom-filter
|
|||
{ capacity fixnum read-only }
|
||||
{ count fixnum } ;
|
||||
|
||||
ERROR: invalid-size ;
|
||||
ERROR: invalid-size size ;
|
||||
ERROR: invalid-error-rate error-rate ;
|
||||
ERROR: invalid-capacity capacity ;
|
||||
|
||||
|
@ -73,7 +73,7 @@ ERROR: invalid-capacity capacity ;
|
|||
! If the number of hashes isn't positive, we haven't found
|
||||
! anything smaller than the identity configuration.
|
||||
: check-hashes ( 2seq -- 2seq )
|
||||
dup first 0 <= [ invalid-size ] when ;
|
||||
dup first 0 <= [ throw-invalid-size ] when ;
|
||||
|
||||
! The consensus on the tradeoff between increasing the number of
|
||||
! bits and increasing the number of hash functions seems to be
|
||||
|
@ -90,11 +90,11 @@ ERROR: invalid-capacity capacity ;
|
|||
] reduce check-hashes first2 ;
|
||||
|
||||
: check-capacity ( capacity -- capacity )
|
||||
dup 0 <= [ invalid-capacity ] when ;
|
||||
dup 0 <= [ throw-invalid-capacity ] when ;
|
||||
|
||||
: check-error-rate ( error-rate -- error-rate )
|
||||
dup [ 0 after? ] [ 1 before? ] bi and
|
||||
[ invalid-error-rate ] unless ;
|
||||
[ throw-invalid-error-rate ] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -60,7 +60,7 @@ DEFER: read-elements
|
|||
{ T_Binary_Function [ read-sized-string ] }
|
||||
{ T_Binary_MD5 [ read >string ] }
|
||||
{ T_Binary_UUID [ read >string ] }
|
||||
[ "unknown binary sub-type" unknown-bson-type ]
|
||||
[ "unknown binary sub-type" throw-unknown-bson-type ]
|
||||
} case ; inline
|
||||
|
||||
TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
|
||||
|
@ -90,7 +90,7 @@ TYPED: element-data-read ( type: integer -- object )
|
|||
{ T_Code [ read-int32 read-sized-string ] }
|
||||
{ T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc <mongo-scoped-code> ] }
|
||||
{ T_NULL [ f ] }
|
||||
[ "type unknown" unknown-bson-type ]
|
||||
[ "type unknown" throw-unknown-bson-type ]
|
||||
} case ; inline recursive
|
||||
|
||||
TYPED: (read-object) ( type: integer name: string -- )
|
||||
|
|
|
@ -81,7 +81,7 @@ ERROR: header-file-missing path ;
|
|||
skip-whitespace/comments advance dup previous {
|
||||
{ CHAR: < [ CHAR: > take-until-object read-standard-include ] }
|
||||
{ CHAR: " [ CHAR: " take-until-object read-local-include ] }
|
||||
[ bad-include-line ]
|
||||
[ throw-bad-include-line ]
|
||||
} case ;
|
||||
|
||||
: (readlns) ( -- )
|
||||
|
@ -155,7 +155,7 @@ ERROR: header-file-missing path ;
|
|||
{ "else" [ handle-else ] }
|
||||
{ "pragma" [ handle-pragma ] }
|
||||
{ "include_next" [ handle-include-next ] }
|
||||
[ unknown-c-preprocessor ]
|
||||
[ throw-unknown-c-preprocessor ]
|
||||
} case ;
|
||||
|
||||
: parse-directive-line ( preprocessor-state sequence-parser -- )
|
||||
|
|
|
@ -44,7 +44,7 @@ ERROR: no-cairo-t ;
|
|||
<PRIVATE
|
||||
|
||||
: draw-hello-world ( gadget -- )
|
||||
cairo-t>> [ no-cairo-t ] unless*
|
||||
cairo-t>> [ throw-no-cairo-t ] unless*
|
||||
{
|
||||
[
|
||||
"Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
|
||||
|
|
|
@ -26,9 +26,9 @@ ERROR: repeated-constructor-parameters class effect ;
|
|||
ERROR: unknown-constructor-parameters class effect unknown ;
|
||||
|
||||
: ensure-constructor-parameters ( class effect -- class effect )
|
||||
dup in>> all-unique? [ repeated-constructor-parameters ] unless
|
||||
dup in>> all-unique? [ throw-repeated-constructor-parameters ] unless
|
||||
2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
|
||||
[ unknown-constructor-parameters ] unless-empty ;
|
||||
[ throw-unknown-constructor-parameters ] unless-empty ;
|
||||
|
||||
: constructor-boa-quot ( constructor-word class effect -- word quot )
|
||||
in>> swap '[ _ _ slots>boa ] ; inline
|
||||
|
|
|
@ -488,7 +488,7 @@ ERROR: undefined-8080-opcode n ;
|
|||
dup instruction-cycles nth [
|
||||
nip
|
||||
] [
|
||||
undefined-8080-opcode
|
||||
throw-undefined-8080-opcode
|
||||
] if* ;
|
||||
|
||||
: process-interrupts ( cpu -- )
|
||||
|
|
|
@ -147,9 +147,9 @@ SINGLETON: aes-256-key
|
|||
M: aes-128-key key-expand-round ( temp i -- temp' )
|
||||
4 /mod 0 = swap and [ (add-rcon) ] when* ;
|
||||
|
||||
ERROR: aes-192-256-not-implemented* ;
|
||||
ERROR: aes-192-256-not-implemented ;
|
||||
M: aes-256-key key-expand-round ( temp i -- temp' )
|
||||
aes-192-256-not-implemented* ;
|
||||
throw-aes-192-256-not-implemented ;
|
||||
|
||||
: (key-sched-round) ( output temp i -- output' )
|
||||
key-expand-round
|
||||
|
|
|
@ -8,5 +8,5 @@ IN: crypto.xor
|
|||
ERROR: empty-xor-key ;
|
||||
|
||||
: xor-crypt ( seq key -- seq' )
|
||||
[ empty-xor-key ] when-empty
|
||||
[ throw-empty-xor-key ] when-empty
|
||||
[ dup length iota ] dip '[ _ mod-nth bitxor ] 2map ;
|
||||
|
|
|
@ -13,7 +13,7 @@ IN: cuda
|
|||
ERROR: cuda-error-state code ;
|
||||
|
||||
: cuda-error ( code -- )
|
||||
dup CUDA_SUCCESS = [ drop ] [ cuda-error-state ] if ;
|
||||
dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error-state ] if ;
|
||||
|
||||
: cuda-version ( -- n )
|
||||
{ c:int } [ cuDriverGetVersion cuda-error ] with-out-parameters ;
|
||||
|
|
|
@ -86,10 +86,10 @@ PRIVATE>
|
|||
ERROR: no-cuda-library name ;
|
||||
|
||||
: lookup-cuda-library ( name -- cuda-library )
|
||||
cuda-libraries get ?at [ no-cuda-library ] unless ;
|
||||
cuda-libraries get ?at [ throw-no-cuda-library ] unless ;
|
||||
|
||||
: remove-cuda-library ( name -- library )
|
||||
cuda-libraries get ?delete-at [ no-cuda-library ] unless ;
|
||||
cuda-libraries get ?delete-at [ throw-no-cuda-library ] unless ;
|
||||
|
||||
: unload-cuda-library ( name -- )
|
||||
remove-cuda-library handle>> unload-module ;
|
||||
|
@ -189,7 +189,7 @@ TUPLE: cuda-library name abi path handle ;
|
|||
ERROR: bad-cuda-abi abi ;
|
||||
|
||||
: check-cuda-abi ( abi -- abi )
|
||||
dup cuda-abi? [ bad-cuda-abi ] unless ; inline
|
||||
dup cuda-abi? [ throw-bad-cuda-abi ] unless ; inline
|
||||
|
||||
: <cuda-library> ( name abi path -- obj )
|
||||
\ cuda-library new
|
||||
|
|
|
@ -26,6 +26,6 @@ ERROR: nvcc-failed n path ;
|
|||
path normalize-path :> path2
|
||||
path2 parent-directory [
|
||||
path2 nvcc-command
|
||||
run-process wait-for-process [ path2 nvcc-failed ] unless-zero
|
||||
run-process wait-for-process [ path2 throw-nvcc-failed ] unless-zero
|
||||
path2 cu>ptx
|
||||
] with-directory ;
|
||||
|
|
|
@ -31,7 +31,7 @@ ERROR: unknown-filetype filetype ;
|
|||
|
||||
: check-filetype ( filetype -- filetype )
|
||||
dup { "BINARY" "MOTOROLA" "AIFF" "WAVE" "MP3" } member?
|
||||
[ unknown-filetype ] unless ;
|
||||
[ throw-unknown-filetype ] unless ;
|
||||
|
||||
ERROR: unknown-flag flag ;
|
||||
|
||||
|
|
|
@ -179,8 +179,8 @@ ERROR: unsupported-curses-terminal ;
|
|||
: >BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline
|
||||
|
||||
: curses-pointer-error ( ptr/f -- ptr )
|
||||
[ curses-failed ] unless* ; inline
|
||||
: curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ;
|
||||
[ throw-curses-failed ] unless* ; inline
|
||||
: curses-error ( n -- ) ffi:ERR = [ throw-curses-failed ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
@ -262,7 +262,7 @@ PRIVATE>
|
|||
[ current-window ] dip with-variable ; inline
|
||||
|
||||
: with-curses ( window quot -- )
|
||||
curses-ok? [ unsupported-curses-terminal ] unless
|
||||
curses-ok? [ throw-unsupported-curses-terminal ] unless
|
||||
[
|
||||
'[
|
||||
ffi:initscr curses-pointer-error
|
||||
|
|
|
@ -67,7 +67,9 @@ GENERIC: cursor-key-value-unsafe ( cursor -- key value )
|
|||
PRIVATE>
|
||||
M: input-cursor cursor-key-value-unsafe cursor-key-value ; inline
|
||||
M: input-cursor cursor-key-value
|
||||
dup cursor-valid? [ cursor-key-value-unsafe ] [ invalid-cursor ] if ; inline
|
||||
dup cursor-valid?
|
||||
[ cursor-key-value-unsafe ]
|
||||
[ throw-invalid-cursor ] if ; inline
|
||||
|
||||
: cursor-key ( cursor -- key ) cursor-key-value drop ;
|
||||
: cursor-value ( cursor -- key ) cursor-key-value nip ;
|
||||
|
@ -87,7 +89,9 @@ GENERIC: set-cursor-value-unsafe ( value cursor -- )
|
|||
PRIVATE>
|
||||
M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline
|
||||
M: output-cursor set-cursor-value
|
||||
dup cursor-valid? [ set-cursor-value-unsafe ] [ invalid-cursor ] if ; inline
|
||||
dup cursor-valid?
|
||||
[ set-cursor-value-unsafe ]
|
||||
[ throw-invalid-cursor ] if ; inline
|
||||
|
||||
!
|
||||
! stream cursors
|
||||
|
|
|
@ -21,7 +21,7 @@ ERROR: decimal-test-failure D1 D2 quot ;
|
|||
D1 D2
|
||||
quot1 [ decimal>ratio >float ] compose
|
||||
[ [ decimal>ratio ] bi@ quot2 call( obj obj -- obj ) >float ] 2bi -.1 ~
|
||||
[ t ] [ D1 D2 quot1 decimal-test-failure ] if ; inline
|
||||
[ t ] [ D1 D2 quot1 throw-decimal-test-failure ] if ; inline
|
||||
|
||||
: test-decimal-op ( quot1 quot2 -- ? )
|
||||
[ random-test-decimal random-test-decimal ] 2dip (test-decimal-op) ; inline
|
||||
|
|
|
@ -43,7 +43,7 @@ ERROR: decimal-types-expected d1 d2 ;
|
|||
|
||||
: guard-decimals ( obj1 obj2 -- D1 D2 )
|
||||
2dup [ decimal? ] both?
|
||||
[ decimal-types-expected ] unless ;
|
||||
[ throw-decimal-types-expected ] unless ;
|
||||
|
||||
M: decimal equal?
|
||||
{
|
||||
|
|
|
@ -19,7 +19,7 @@ M: descriptive-error error.
|
|||
|
||||
: rethrower ( word inputs -- quot )
|
||||
[ length ] keep [ [ narray ] dip swap 2array flip ] 2curry
|
||||
[ 2 ndip descriptive-error ] 2curry ;
|
||||
[ 2 ndip throw-descriptive-error ] 2curry ;
|
||||
|
||||
: [descriptive] ( word def effect -- newdef )
|
||||
swapd in>> rethrower [ recover ] 2curry ;
|
||||
|
|
|
@ -242,7 +242,7 @@ ERROR: unsupported-domain-name string ;
|
|||
|
||||
: >n/label ( string -- byte-array )
|
||||
dup [ ascii? ] all?
|
||||
[ unsupported-domain-name ] unless
|
||||
[ throw-unsupported-domain-name ] unless
|
||||
[ length 1array ] [ ] bi B{ } append-as ;
|
||||
|
||||
: >name ( domain -- byte-array )
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: forestdb.lib
|
|||
ERROR: fdb-error error ;
|
||||
|
||||
: fdb-check-error ( ret -- )
|
||||
dup FDB_RESULT_SUCCESS = [ drop ] [ fdb-error ] if ;
|
||||
dup FDB_RESULT_SUCCESS = [ drop ] [ throw-fdb-error ] if ;
|
||||
|
||||
|
||||
TUPLE: fdb-kvs-handle < disposable handle ;
|
||||
|
@ -93,7 +93,7 @@ SYMBOL: current-fdb-kvs-handle
|
|||
rot {
|
||||
{ FDB_RESULT_SUCCESS [ ret>string ] }
|
||||
{ FDB_RESULT_KEY_NOT_FOUND [ 2drop f ] }
|
||||
[ fdb-error ]
|
||||
[ throw-fdb-error ]
|
||||
} case ;
|
||||
|
||||
: fdb-del-kv ( key -- )
|
||||
|
|
|
@ -18,12 +18,12 @@ CONSTANT: fdb-filename-base "fq"
|
|||
ERROR: not-an-fdb-filename string ;
|
||||
|
||||
: ensure-fdb-filename ( string -- string )
|
||||
dup fdb-filename? [ not-an-fdb-filename ] unless ;
|
||||
dup fdb-filename? [ throw-not-an-fdb-filename ] unless ;
|
||||
|
||||
ERROR: not-a-string-number string ;
|
||||
|
||||
: ?string>number ( string -- n )
|
||||
dup string>number dup [ nip ] [ not-a-string-number ] if ;
|
||||
dup string>number dup [ nip ] [ throw-not-a-string-number ] if ;
|
||||
|
||||
: change-string-number ( string quot -- string' )
|
||||
[ [ string>number ] dip call number>string ] 2keep drop
|
||||
|
|
|
@ -55,12 +55,12 @@ ERROR: display-change-error n ;
|
|||
: fullscreen-mode ( monitor-info devmode -- )
|
||||
[ szDevice>> ] dip f CDS_FULLSCREEN f
|
||||
ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
|
||||
[ drop ] [ display-change-error ] if ;
|
||||
[ drop ] [ throw-display-change-error ] if ;
|
||||
|
||||
: non-fullscreen-mode ( monitor-info devmode -- )
|
||||
[ szDevice>> ] dip f 0 f
|
||||
ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
|
||||
[ drop ] [ display-change-error ] if ;
|
||||
[ drop ] [ throw-display-change-error ] if ;
|
||||
|
||||
: get-style ( hwnd n -- style )
|
||||
GetWindowLongPtr [ win32-error=0/f ] keep ;
|
||||
|
@ -86,7 +86,7 @@ ERROR: unsupported-resolution triple ;
|
|||
[
|
||||
slots{ dmPelsWidth dmPelsHeight dmBitsPerPel }
|
||||
triple =
|
||||
] find nip [ triple unsupported-resolution ] unless* ;
|
||||
] find nip [ triple throw-unsupported-resolution ] unless* ;
|
||||
|
||||
:: set-fullscreen-window-position ( hwnd triple -- )
|
||||
hwnd f
|
||||
|
|
|
@ -24,12 +24,12 @@ SYMBOLS: up-axis unit-ratio ;
|
|||
|
||||
: x/ ( tag child-name -- child-tag )
|
||||
[ tag-named ]
|
||||
[ rot dup [ drop missing-child ] unless 2nip ]
|
||||
[ rot dup [ drop throw-missing-child ] unless 2nip ]
|
||||
2bi ; inline
|
||||
|
||||
: x@ ( tag attr-name -- attr-value )
|
||||
[ attr ]
|
||||
[ rot dup [ drop missing-attr ] unless 2nip ]
|
||||
[ rot dup [ drop throw-missing-attr ] unless 2nip ]
|
||||
2bi ; inline
|
||||
|
||||
: xt ( tag -- content ) children>string ;
|
||||
|
|
|
@ -15,11 +15,11 @@ types [ H{ } clone ] initialize
|
|||
|
||||
: models-class ( path -- class )
|
||||
file-extension >lower types get ?at
|
||||
[ unknown-models-extension ] unless second ;
|
||||
[ throw-unknown-models-extension ] unless second ;
|
||||
|
||||
: models-encoding ( path -- encoding )
|
||||
file-extension >lower types get ?at
|
||||
[ unknown-models-extension ] unless first ;
|
||||
[ throw-unknown-models-extension ] unless first ;
|
||||
|
||||
: open-models-file ( path encoding -- stream )
|
||||
<file-reader> ;
|
||||
|
|
|
@ -53,7 +53,7 @@ ERROR: not-a-gopher-url url ;
|
|||
|
||||
: gopher ( url -- item-type byte-array )
|
||||
dup url? [ >url ] unless
|
||||
dup protocol>> "gopher" = [ not-a-gopher-url ] unless {
|
||||
dup protocol>> "gopher" = [ throw-not-a-gopher-url ] unless {
|
||||
[ host>> ]
|
||||
[ port>> 70 or <inet> binary ]
|
||||
[ path>> rest [ "1/" ] when-empty ]
|
||||
|
|
|
@ -399,7 +399,7 @@ DEFER: [bind-uniform-tuple]
|
|||
{ mat4-uniform { [ dim 0 ] dip 4 4 >uniform-matrix-array glUniformMatrix4fv } }
|
||||
|
||||
{ texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
|
||||
} at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
|
||||
} at [ uniform throw-invalid-uniform-type ] unless* >quotation :> value-quot
|
||||
|
||||
type uniform-type-texture-units dim * texture-unit +
|
||||
pre-quot value-quot append ;
|
||||
|
@ -442,7 +442,7 @@ DEFER: [bind-uniform-tuple]
|
|||
{ mat4-uniform [ [ 1 0 ] dip 4 4 >uniform-matrix glUniformMatrix4fv ] }
|
||||
|
||||
{ texture-uniform { drop texture-unit glUniform1i } }
|
||||
} at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
|
||||
} at [ uniform throw-invalid-uniform-type ] unless* >quotation :> value-quot
|
||||
|
||||
type uniform-type-texture-units texture-unit +
|
||||
pre-quot value-quot append ;
|
||||
|
|
|
@ -139,7 +139,7 @@ TR: hyphens>underscores "-" "_" ;
|
|||
[ vertex-attribute name>> name = ]
|
||||
[ size 1 = ]
|
||||
[ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
|
||||
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
|
||||
} 0&& [ vertex-attribute throw-inaccurate-feedback-attribute-error ] unless ;
|
||||
|
||||
:: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
|
||||
program-instance name attribute-index :> idx
|
||||
|
@ -182,7 +182,7 @@ TR: hyphens>underscores "-" "_" ;
|
|||
|
||||
:: [link-feedback-format] ( vertex-attributes -- quot )
|
||||
vertex-attributes [ name>> not ] any?
|
||||
[ [ nip invalid-link-feedback-format-error ] ] [
|
||||
[ [ nip throw-invalid-link-feedback-format-error ] ] [
|
||||
vertex-attributes
|
||||
[ name>> ascii malloc-string ]
|
||||
void*-array{ } map-as :> varying-names
|
||||
|
@ -529,7 +529,7 @@ TUPLE: feedback-format
|
|||
: validate-feedback-format ( sequence -- vertex-format/f )
|
||||
dup length 1 <=
|
||||
[ [ f ] [ first vertex-format>> ] if-empty ]
|
||||
[ too-many-feedback-formats-error ] if ;
|
||||
[ throw-too-many-feedback-formats-error ] if ;
|
||||
|
||||
: ?shader ( object -- shader/f )
|
||||
dup word? [ def>> first dup shader? [ drop f ] unless ] [ drop f ] if ;
|
||||
|
|
|
@ -112,7 +112,7 @@ PRIVATE>
|
|||
{ "png" [ ".png" ] }
|
||||
{ "tif" [ ".tif" ] }
|
||||
{ "tiff" [ ".tif" ] }
|
||||
[ unsupported-preview-format ]
|
||||
[ throw-unsupported-preview-format ]
|
||||
} case ;
|
||||
|
||||
:: with-preview ( graph quot: ( path -- ) -- )
|
||||
|
|
|
@ -36,7 +36,7 @@ IN: html.parser.analyzer
|
|||
ERROR: undefined-find-nth m n seq quot ;
|
||||
|
||||
: check-trivial-find ( m n seq quot -- m n seq quot )
|
||||
pick 0 = [ undefined-find-nth ] when ; inline
|
||||
pick 0 = [ throw-undefined-find-nth ] when ; inline
|
||||
|
||||
: find-nth-from ( m n seq quot -- i/f elt/f )
|
||||
check-trivial-find [ f ] 3dip '[
|
||||
|
|
|
@ -56,7 +56,7 @@ ERROR: atlas-image-formats-dont-match images ;
|
|||
[ [ upside-down?>> ] same? ] 2tri and and
|
||||
] all?
|
||||
[ first [ component-order>> ] [ component-type>> ] [ upside-down?>> ] tri ]
|
||||
[ atlas-image-formats-dont-match ] if ; inline
|
||||
[ throw-atlas-image-formats-dont-match ] if ; inline
|
||||
|
||||
: atlas-dim ( image-placements -- dim )
|
||||
[ [ loc>> ] [ image>> dim>> ] bi v+ atlas-padding v+n ] [ vmax ] map-reduce
|
||||
|
|
|
@ -182,7 +182,7 @@ UNION: os2-header os2v1-header os2v2-header ;
|
|||
{ 40 [ read-v3-header ] }
|
||||
{ 108 [ read-v4-header ] }
|
||||
{ 124 [ read-v5-header ] }
|
||||
[ unknown-bitmap-header ]
|
||||
[ throw-unknown-bitmap-header ]
|
||||
} case ;
|
||||
|
||||
: color-index-length ( header -- n )
|
||||
|
@ -228,7 +228,7 @@ GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
|
|||
{ 8 [ BGR ] }
|
||||
{ 4 [ BGR ] }
|
||||
{ 1 [ BGR ] }
|
||||
[ unknown-component-order ]
|
||||
[ throw-unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: advanced-bitmap>component-order ( loading-bitmap -- object )
|
||||
|
|
|
@ -126,7 +126,7 @@ CONSTANT: BLOCK-TERMINATOR 0x00
|
|||
|
||||
ERROR: unimplemented message ;
|
||||
: read-GIF87a ( loading-gif -- loading-gif )
|
||||
"GIF87a" unimplemented ;
|
||||
"GIF87a" throw-unimplemented ;
|
||||
|
||||
: read-logical-screen-descriptor ( loading-gif -- loading-gif )
|
||||
2 read le> >>width
|
||||
|
@ -182,8 +182,8 @@ ERROR: unimplemented message ;
|
|||
{ APPLICATION-EXTENSION [
|
||||
read-application-extension over application-extensions>> push
|
||||
] }
|
||||
{ f [ gif-unexpected-eof ] }
|
||||
[ unknown-extension ]
|
||||
{ f [ throw-gif-unexpected-eof ] }
|
||||
[ throw-unknown-extension ]
|
||||
} case ;
|
||||
|
||||
ERROR: unhandled-data byte ;
|
||||
|
@ -197,7 +197,7 @@ ERROR: unhandled-data byte ;
|
|||
] }
|
||||
{ IMAGE-DESCRIPTOR [ read-table-based-image ] }
|
||||
{ TRAILER [ f >>loading? ] }
|
||||
[ unhandled-data ]
|
||||
[ throw-unhandled-data ]
|
||||
} case ;
|
||||
|
||||
: read-GIF89a ( loading-gif -- loading-gif )
|
||||
|
@ -211,7 +211,7 @@ ERROR: unhandled-data byte ;
|
|||
read-gif-header dup magic>> {
|
||||
{ "GIF87a" [ read-GIF87a ] }
|
||||
{ "GIF89a" [ read-GIF89a ] }
|
||||
[ unsupported-gif-format ]
|
||||
[ throw-unsupported-gif-format ]
|
||||
} case
|
||||
] with-input-stream ;
|
||||
|
||||
|
@ -246,7 +246,7 @@ ERROR: unhandled-data byte ;
|
|||
ERROR: loading-gif-error gif-image ;
|
||||
|
||||
: ensure-loaded ( gif-image -- gif-image )
|
||||
dup loading?>> [ loading-gif-error ] when ;
|
||||
dup loading?>> [ throw-loading-gif-error ] when ;
|
||||
|
||||
M: gif-image stream>image* ( path gif-image -- image )
|
||||
drop load-gif ensure-loaded gif>image ;
|
||||
|
|
|
@ -56,7 +56,7 @@ ERROR: bad-png-header header ;
|
|||
|
||||
: read-png-header ( -- )
|
||||
8 read dup png-header sequence= [
|
||||
bad-png-header
|
||||
throw-bad-png-header
|
||||
] unless drop ;
|
||||
|
||||
ERROR: bad-checksum ;
|
||||
|
|
|
@ -20,11 +20,11 @@ ERROR: bad-tga-unsupported ;
|
|||
|
||||
: read-color-map-type ( -- byte )
|
||||
1 read le> dup
|
||||
{ 0 1 } member? [ bad-tga-header ] unless ;
|
||||
{ 0 1 } member? [ throw-bad-tga-header ] unless ;
|
||||
|
||||
: read-image-type ( -- byte )
|
||||
1 read le> dup
|
||||
{ 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
|
||||
{ 0 1 2 3 9 10 11 } member? [ throw-bad-tga-header ] unless ; inline
|
||||
|
||||
: read-color-map-first ( -- short )
|
||||
2 read le> ; inline
|
||||
|
@ -70,10 +70,10 @@ ERROR: bad-tga-unsupported ;
|
|||
4 read le> ; inline
|
||||
|
||||
: read-signature ( -- )
|
||||
18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
|
||||
18 read ascii decode "TRUEVISION-XFILE.\0" = [ throw-bad-tga-footer ] unless ; inline
|
||||
|
||||
: read-extension-size ( -- )
|
||||
2 read le> 495 = [ bad-tga-extension-size ] unless ; inline
|
||||
2 read le> 495 = [ throw-bad-tga-extension-size ] unless ; inline
|
||||
|
||||
: read-author-name ( -- string )
|
||||
41 read ascii decode [ 0 = ] trim ; inline
|
||||
|
@ -83,12 +83,12 @@ ERROR: bad-tga-unsupported ;
|
|||
|
||||
: read-date-timestamp ( -- timestamp )
|
||||
timestamp new
|
||||
2 read le> dup 12 [1,b] member? [ bad-tga-timestamp ] unless >>month
|
||||
2 read le> dup 31 [1,b] member? [ bad-tga-timestamp ] unless >>day
|
||||
2 read le> dup 12 [1,b] member? [ throw-bad-tga-timestamp ] unless >>month
|
||||
2 read le> dup 31 [1,b] member? [ throw-bad-tga-timestamp ] unless >>day
|
||||
2 read le> >>year
|
||||
2 read le> dup 23 [0,b] member? [ bad-tga-timestamp ] unless >>hour
|
||||
2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
|
||||
2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
|
||||
2 read le> dup 23 [0,b] member? [ throw-bad-tga-timestamp ] unless >>hour
|
||||
2 read le> dup 59 [0,b] member? [ throw-bad-tga-timestamp ] unless >>minute
|
||||
2 read le> dup 59 [0,b] member? [ throw-bad-tga-timestamp ] unless >>second ; inline
|
||||
|
||||
: read-job-name ( -- string )
|
||||
41 read ascii decode [ 0 = ] trim ; inline
|
||||
|
@ -96,8 +96,8 @@ ERROR: bad-tga-unsupported ;
|
|||
: read-job-time ( -- duration )
|
||||
duration new
|
||||
2 read le> >>hour
|
||||
2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
|
||||
2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
|
||||
2 read le> dup 59 [0,b] member? [ throw-bad-tga-timestamp ] unless >>minute
|
||||
2 read le> dup 59 [0,b] member? [ throw-bad-tga-timestamp ] unless >>second ; inline
|
||||
|
||||
: read-software-id ( -- string )
|
||||
41 read ascii decode [ 0 = ] trim ; inline
|
||||
|
@ -240,10 +240,10 @@ ERROR: bad-tga-unsupported ;
|
|||
|
||||
#! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
|
||||
#! Other formats would need to be converted to work within the image class.
|
||||
map-type 0 = [ bad-tga-unsupported ] unless
|
||||
image-type 2 = [ bad-tga-unsupported ] unless
|
||||
pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
|
||||
pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
|
||||
map-type 0 = [ throw-bad-tga-unsupported ] unless
|
||||
image-type 2 = [ throw-bad-tga-unsupported ] unless
|
||||
pixel-depth { 24 32 } member? [ throw-bad-tga-unsupported ] unless
|
||||
pixel-order { 0 2 } member? [ throw-bad-tga-unsupported ] unless
|
||||
|
||||
#! Create image instance
|
||||
image new
|
||||
|
@ -259,7 +259,7 @@ M: tga-image stream>image*
|
|||
M: tga-image image>stream
|
||||
2drop
|
||||
[
|
||||
component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
|
||||
component-order>> { BGRA BGRA } member? [ throw-bad-tga-unsupported ] unless
|
||||
] keep
|
||||
|
||||
B{ 0 } write #! id-length
|
||||
|
|
|
@ -65,7 +65,7 @@ ERROR: bad-photometric-interpretation n ;
|
|||
{ 10 [ photometric-interpretation-itulab ] }
|
||||
{ 32844 [ photometric-interpretation-logl ] }
|
||||
{ 32845 [ photometric-interpretation-logluv ] }
|
||||
[ bad-photometric-interpretation ]
|
||||
[ throw-bad-photometric-interpretation ]
|
||||
} case ;
|
||||
|
||||
SINGLETONS: compression
|
||||
|
@ -124,7 +124,7 @@ ERROR: bad-compression n ;
|
|||
{ 34676 [ compression-sgilog ] }
|
||||
{ 34677 [ compression-sgilog24 ] }
|
||||
{ 34712 [ compression-jp2000 ] }
|
||||
[ bad-compression ]
|
||||
[ throw-bad-compression ]
|
||||
} case ;
|
||||
|
||||
SINGLETONS: resolution-unit
|
||||
|
@ -137,7 +137,7 @@ ERROR: bad-resolution-unit n ;
|
|||
{ 1 [ resolution-unit-none ] }
|
||||
{ 2 [ resolution-unit-inch ] }
|
||||
{ 3 [ resolution-unit-centimeter ] }
|
||||
[ bad-resolution-unit ]
|
||||
[ throw-bad-resolution-unit ]
|
||||
} case ;
|
||||
|
||||
SINGLETONS: predictor
|
||||
|
@ -148,7 +148,7 @@ ERROR: bad-predictor n ;
|
|||
{
|
||||
{ 1 [ predictor-none ] }
|
||||
{ 2 [ predictor-horizontal-differencing ] }
|
||||
[ bad-predictor ]
|
||||
[ throw-bad-predictor ]
|
||||
} case ;
|
||||
|
||||
SINGLETONS: planar-configuration
|
||||
|
@ -159,7 +159,7 @@ ERROR: bad-planar-configuration n ;
|
|||
{
|
||||
{ 1 [ planar-configuration-chunky ] }
|
||||
{ 2 [ planar-configuration-planar ] }
|
||||
[ bad-planar-configuration ]
|
||||
[ throw-bad-planar-configuration ]
|
||||
} case ;
|
||||
|
||||
SINGLETONS: sample-format
|
||||
|
@ -177,7 +177,7 @@ ERROR: bad-sample-format n ;
|
|||
{ 2 [ sample-format-signed-integer ] }
|
||||
{ 3 [ sample-format-ieee-float ] }
|
||||
{ 4 [ sample-format-undefined-data ] }
|
||||
[ bad-sample-format ]
|
||||
[ throw-bad-sample-format ]
|
||||
} case
|
||||
] map ;
|
||||
|
||||
|
@ -191,7 +191,7 @@ ERROR: bad-extra-samples n ;
|
|||
{ 0 [ extra-samples-unspecified-alpha-data ] }
|
||||
{ 1 [ extra-samples-associated-alpha-data ] }
|
||||
{ 2 [ extra-samples-unassociated-alpha-data ] }
|
||||
[ bad-extra-samples ]
|
||||
[ throw-bad-extra-samples ]
|
||||
} case ;
|
||||
|
||||
SINGLETONS: image-length image-width x-resolution y-resolution
|
||||
|
@ -224,7 +224,7 @@ ERROR: bad-jpeg-proc n ;
|
|||
{
|
||||
{ 1 [ jpeg-proc-baseline ] }
|
||||
{ 14 [ jpeg-proc-lossless ] }
|
||||
[ bad-jpeg-proc ]
|
||||
[ throw-bad-jpeg-proc ]
|
||||
} case ;
|
||||
|
||||
ERROR: bad-tiff-magic bytes ;
|
||||
|
@ -232,7 +232,7 @@ ERROR: bad-tiff-magic bytes ;
|
|||
{
|
||||
{ B{ CHAR: M CHAR: M } [ big-endian ] }
|
||||
{ B{ CHAR: I CHAR: I } [ little-endian ] }
|
||||
[ bad-tiff-magic ]
|
||||
[ throw-bad-tiff-magic ]
|
||||
} case ;
|
||||
|
||||
: read-header ( tiff -- tiff )
|
||||
|
@ -277,7 +277,7 @@ ERROR: no-tag class ;
|
|||
swap processed-tags>> ?at ;
|
||||
|
||||
: find-tag ( ifd class -- tag )
|
||||
find-tag* [ no-tag ] unless ;
|
||||
find-tag* [ throw-no-tag ] unless ;
|
||||
|
||||
: tag? ( ifd class -- tag )
|
||||
swap processed-tags>> key? ;
|
||||
|
@ -314,7 +314,7 @@ ERROR: unknown-ifd-type n where ;
|
|||
{ 11 [ 4 * ] }
|
||||
{ 12 [ 8 * ] }
|
||||
{ 13 [ 4 * ] }
|
||||
[ "value-length" unknown-ifd-type ]
|
||||
[ "value-length" throw-unknown-ifd-type ]
|
||||
} case ;
|
||||
|
||||
ERROR: bad-small-ifd-type n ;
|
||||
|
@ -330,7 +330,7 @@ ERROR: bad-small-ifd-type n ;
|
|||
{ 9 [ endian> 32 >signed ] }
|
||||
{ 11 [ endian> bits>float ] }
|
||||
{ 13 [ endian> 32 >signed ] }
|
||||
[ bad-small-ifd-type ]
|
||||
[ throw-bad-small-ifd-type ]
|
||||
} case ;
|
||||
|
||||
: offset-bytes>obj ( bytes type -- obj )
|
||||
|
@ -347,7 +347,7 @@ ERROR: bad-small-ifd-type n ;
|
|||
{ 10 [ 8 group [ "ii" unpack first2 / ] map ] }
|
||||
{ 11 [ 4 group [ "f" unpack ] map ] }
|
||||
{ 12 [ 8 group [ "d" unpack ] map ] }
|
||||
[ "offset-bytes>obj" unknown-ifd-type ]
|
||||
[ "offset-bytes>obj" throw-unknown-ifd-type ]
|
||||
} case ;
|
||||
|
||||
: ifd-entry-value ( ifd-entry -- n )
|
||||
|
@ -455,7 +455,7 @@ ERROR: unhandled-compression compression ;
|
|||
{
|
||||
{ compression-none [ ] }
|
||||
{ compression-lzw [ [ tiff-lzw-uncompress ] map ] }
|
||||
[ unhandled-compression ]
|
||||
[ throw-unhandled-compression ]
|
||||
} case ;
|
||||
|
||||
: uncompress-strips ( ifd -- ifd )
|
||||
|
@ -483,7 +483,7 @@ ERROR: unhandled-compression compression ;
|
|||
{
|
||||
{ predictor-none [ ] }
|
||||
{ predictor-horizontal-differencing [ (strips-predictor) ] }
|
||||
[ bad-predictor ]
|
||||
[ throw-bad-predictor ]
|
||||
} case
|
||||
] when ;
|
||||
|
||||
|
@ -499,7 +499,7 @@ ERROR: unknown-component-order ifd ;
|
|||
{ { 8 8 8 8 } [ ] }
|
||||
{ { 8 8 8 } [ ] }
|
||||
{ 8 [ ] }
|
||||
[ unknown-component-order ]
|
||||
[ throw-unknown-component-order ]
|
||||
} case >>bitmap ;
|
||||
|
||||
: ifd-component-order ( ifd -- component-order component-type )
|
||||
|
@ -511,7 +511,7 @@ ERROR: unknown-component-order ifd ;
|
|||
{ { 8 8 8 8 } [ RGBA ubyte-components ] }
|
||||
{ { 8 8 8 } [ RGB ubyte-components ] }
|
||||
{ 8 [ LA ubyte-components ] }
|
||||
[ unknown-component-order ]
|
||||
[ throw-unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: handle-alpha-data ( ifd -- ifd )
|
||||
|
@ -519,7 +519,7 @@ ERROR: unknown-component-order ifd ;
|
|||
{ extra-samples-associated-alpha-data [ ] }
|
||||
{ extra-samples-unspecified-alpha-data [ ] }
|
||||
{ extra-samples-unassociated-alpha-data [ ] }
|
||||
[ bad-extra-samples ]
|
||||
[ throw-bad-extra-samples ]
|
||||
} case ;
|
||||
|
||||
: ifd>image ( ifd -- image )
|
||||
|
|
|
@ -29,7 +29,7 @@ IN: imap.tests
|
|||
ERROR: no-imap-test-host ;
|
||||
|
||||
: get-test-host ( -- host )
|
||||
\ imap-settings get-global host>> [ no-imap-test-host ] unless* ;
|
||||
\ imap-settings get-global host>> [ throw-no-imap-test-host ] unless* ;
|
||||
|
||||
: imap-test ( result quot -- )
|
||||
'[ \ imap-settings get-global _ with-imap-settings ] unit-test ; inline
|
||||
|
|
|
@ -41,7 +41,7 @@ CONSTANT: IMAP4_SSL_PORT 993
|
|||
[ number>string ] map "," join ;
|
||||
|
||||
: check-status ( ind data -- )
|
||||
over "OK" = not [ imap4-error ] [ 2drop ] if ;
|
||||
over "OK" = not [ throw-imap4-error ] [ 2drop ] if ;
|
||||
|
||||
: read-response-chunk ( stop-expr -- item ? )
|
||||
read-?crlf ascii decode swap dupd pcre:findall
|
||||
|
|
|
@ -16,7 +16,7 @@ M: local-not-defined summary
|
|||
|
||||
: >local-word ( string -- word )
|
||||
qualified-vocabs last words>> ?at
|
||||
[ local-not-defined ] unless ;
|
||||
[ throw-local-not-defined ] unless ;
|
||||
|
||||
ERROR: invalid-op string ;
|
||||
|
||||
|
@ -28,7 +28,7 @@ ERROR: invalid-op string ;
|
|||
{ "/" [ [ / ] ] }
|
||||
{ "%" [ [ mod ] ] }
|
||||
{ "**" [ [ ^ ] ] }
|
||||
[ invalid-op ]
|
||||
[ throw-invalid-op ]
|
||||
} case ;
|
||||
|
||||
GENERIC: infix-codegen ( ast -- quot/number )
|
||||
|
|
|
@ -14,7 +14,7 @@ IN: io.binary.fast
|
|||
ERROR: bad-length bytes n ;
|
||||
|
||||
: check-length ( bytes n -- bytes n )
|
||||
2dup [ length ] dip > [ bad-length ] when ; inline
|
||||
2dup [ length ] dip > [ throw-bad-length ] when ; inline
|
||||
|
||||
<<
|
||||
: be-range ( n -- range )
|
||||
|
|
|
@ -77,7 +77,7 @@ CONSTANT: ACL_EXTENDED_DENY 2
|
|||
ERROR: bad-acl-tag-t n ;
|
||||
|
||||
: acl_tag_t>string ( n -- string )
|
||||
dup 0 2 between? [ bad-acl-tag-t ] unless
|
||||
dup 0 2 between? [ throw-bad-acl-tag-t ] unless
|
||||
{ "undefined" "allow" "deny" } nth ;
|
||||
|
||||
! acl_flag_t
|
||||
|
|
|
@ -77,7 +77,7 @@ PRIVATE>
|
|||
ERROR: acl-init-failed n ;
|
||||
|
||||
:: n>new-acl ( n -- acl )
|
||||
n acl_init dup [ n acl-init-failed ] unless ;
|
||||
n acl_init dup [ n throw-acl-init-failed ] unless ;
|
||||
|
||||
: new-acl ( -- acl ) 1 n>new-acl ; inline
|
||||
|
||||
|
|
|
@ -33,7 +33,7 @@ ERROR: invalid-file-size n path ;
|
|||
|
||||
: zero-file ( n path -- )
|
||||
{
|
||||
{ [ over 0 < ] [ invalid-file-size ] }
|
||||
{ [ over 0 < ] [ throw-invalid-file-size ] }
|
||||
{ [ over 0 = ] [ nip touch-file ] }
|
||||
[ (zero-file) ]
|
||||
} cond ;
|
||||
|
|
|
@ -28,7 +28,7 @@ ERROR: invalid-ipv4 str ;
|
|||
{ 2 [ 1 cut { 0 0 } glue ] }
|
||||
{ 3 [ 2 cut { 0 } glue ] }
|
||||
{ 4 [ ] }
|
||||
[ drop invalid-ipv4 ]
|
||||
[ drop throw-invalid-ipv4 ]
|
||||
} case bubble nip ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
@ -7,7 +7,7 @@ IN: machine-learning.rebalancing
|
|||
ERROR: probability-sum-not-one seq ;
|
||||
|
||||
: check-probabilities ( seq -- seq )
|
||||
dup sum 1.0 .00000000001 ~ [ probability-sum-not-one ] unless ;
|
||||
dup sum 1.0 .00000000001 ~ [ throw-probability-sum-not-one ] unless ;
|
||||
|
||||
: equal-probabilities ( n -- array )
|
||||
dup recip <array> ; inline
|
||||
|
|
|
@ -833,7 +833,7 @@ ERROR: not-fat-binary ;
|
|||
fat_header memory>struct dup magic>> {
|
||||
{ FAT_MAGIC [ ] }
|
||||
{ FAT_CIGAM [ ] }
|
||||
[ 2drop not-fat-binary ]
|
||||
[ 2drop throw-not-fat-binary ]
|
||||
} case dup
|
||||
[ >c-ptr fat_header heap-size swap <displaced-alien> ]
|
||||
[ nfat_arch>> 4 >be le> ] bi
|
||||
|
|
|
@ -21,7 +21,7 @@ HOOK: handle-client-disconnect managed-server ( -- )
|
|||
|
||||
ERROR: already-logged-in username ;
|
||||
|
||||
M: managed-server handle-already-logged-in already-logged-in ;
|
||||
M: managed-server handle-already-logged-in throw-already-logged-in ;
|
||||
M: managed-server handle-client-join ;
|
||||
M: managed-server handle-client-disconnect ;
|
||||
|
||||
|
@ -44,7 +44,7 @@ ERROR: no-such-client username ;
|
|||
PRIVATE>
|
||||
|
||||
: send-client ( seq username -- )
|
||||
clients ?at [ no-such-client ] [ (send-client) ] if ;
|
||||
clients ?at [ throw-no-such-client ] [ (send-client) ] if ;
|
||||
|
||||
: send-everyone ( seq -- )
|
||||
[ client-streams ] dip '[ _ (send-client) ] each ;
|
||||
|
|
|
@ -13,7 +13,7 @@ IN: mason.common
|
|||
ERROR: no-host-name ;
|
||||
|
||||
: short-host-name ( -- string )
|
||||
host-name "." split1 drop [ no-host-name ] unless* ;
|
||||
host-name "." split1 drop [ throw-no-host-name ] unless* ;
|
||||
|
||||
SYMBOL: current-git-id
|
||||
|
||||
|
|
|
@ -23,7 +23,7 @@ DERIVATIVE: abs
|
|||
[ 0 <=>
|
||||
{
|
||||
{ +lt+ [ neg ] }
|
||||
{ +eq+ [ 0 \ abs undefined-derivative ] }
|
||||
{ +eq+ [ 0 \ abs throw-undefined-derivative ] }
|
||||
{ +gt+ [ ] }
|
||||
} case
|
||||
] ;
|
||||
|
|
|
@ -32,7 +32,7 @@ INSTANCE: missing immutable-sequence
|
|||
ERROR: not-a-square-matrix matrix ;
|
||||
|
||||
: check-square-matrix ( matrix -- matrix )
|
||||
dup square-matrix? [ not-a-square-matrix ] unless ; inline
|
||||
dup square-matrix? [ throw-not-a-square-matrix ] unless ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -39,10 +39,10 @@ PRIVATE>
|
|||
ERROR: not-enough-data ;
|
||||
|
||||
: fft ( seq -- seq' )
|
||||
[ not-enough-data ] [ f (fft) ] if-empty ;
|
||||
[ throw-not-enough-data ] [ f (fft) ] if-empty ;
|
||||
|
||||
: ifft ( seq -- seq' )
|
||||
[ not-enough-data ] [ t (fft) ] if-empty ;
|
||||
[ throw-not-enough-data ] [ t (fft) ] if-empty ;
|
||||
|
||||
: correlate ( x y -- z )
|
||||
[ fft ] [ reverse fft ] bi* v* ifft ;
|
||||
|
|
|
@ -112,14 +112,14 @@ TUPLE: request cmd key val extra opaque cas ;
|
|||
|
||||
: check-status ( header -- )
|
||||
[ 5 ] dip nth {
|
||||
{ NOT_FOUND [ key-not-found ] }
|
||||
{ EXISTS [ key-exists ] }
|
||||
{ TOO_LARGE [ value-too-large ] }
|
||||
{ INVALID_ARGS [ invalid-arguments ] }
|
||||
{ NOT_STORED [ item-not-stored ] }
|
||||
{ NOT_NUMERIC [ value-not-numeric ] }
|
||||
{ UNKNOWN_CMD [ unknown-command ] }
|
||||
{ MEMORY [ out-of-memory ] }
|
||||
{ NOT_FOUND [ throw-key-not-found ] }
|
||||
{ EXISTS [ throw-key-exists ] }
|
||||
{ TOO_LARGE [ throw-value-too-large ] }
|
||||
{ INVALID_ARGS [ throw-invalid-arguments ] }
|
||||
{ NOT_STORED [ throw-item-not-stored ] }
|
||||
{ NOT_NUMERIC [ throw-value-not-numeric ] }
|
||||
{ UNKNOWN_CMD [ throw-unknown-command ] }
|
||||
{ MEMORY [ throw-out-of-memory ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
|
|
|
@ -21,7 +21,7 @@ M: pile dispose
|
|||
: pile-alloc ( pile size -- alien )
|
||||
[
|
||||
[ [ ] [ size>> ] [ offset>> ] tri ] dip +
|
||||
< [ not-enough-pile-space ] [ drop ] if
|
||||
< [ throw-not-enough-pile-space ] [ drop ] if
|
||||
] [
|
||||
drop [ offset>> ] [ underlying>> ] bi <displaced-alien>
|
||||
] [
|
||||
|
|
|
@ -22,7 +22,7 @@ ERROR: bad-location str ;
|
|||
{ 3 [ first3 [ string>number ] tri@ 60.0 / + 60.0 / + ] }
|
||||
{ 2 [ first2 [ string>number ] bi@ 60.0 / + ] }
|
||||
{ 1 [ first string>number ] }
|
||||
[ drop bad-location ]
|
||||
[ drop throw-bad-location ]
|
||||
} case ;
|
||||
|
||||
: string>longitude ( str -- lon/f )
|
||||
|
|
|
@ -26,7 +26,7 @@ ERROR: not-an-integer x ;
|
|||
[ "-" ?head swap ] dip
|
||||
[ [ "0" ] when-empty ] bi@
|
||||
[
|
||||
[ dup string>number [ nip ] [ not-an-integer ] if* ] bi@
|
||||
[ dup string>number [ nip ] [ throw-not-an-integer ] if* ] bi@
|
||||
] keep length
|
||||
10^ / + swap [ neg ] when ;
|
||||
|
||||
|
|
|
@ -148,7 +148,10 @@ ERROR: mongod-connection-error address message ;
|
|||
clone [ verify-nodes ] [ <mdb-connection> ] [ ] tri
|
||||
master-node [
|
||||
open-connection [ authenticate-connection ] keep
|
||||
] [ drop nip address>> "Could not open connection to mongod" mongod-connection-error ] recover ;
|
||||
] [
|
||||
drop nip address>> "Could not open connection to mongod"
|
||||
throw-mongod-connection-error
|
||||
] recover ;
|
||||
|
||||
: mdb-close ( mdb-connection -- )
|
||||
[ [ dispose ] when* f ] change-handle drop ;
|
||||
|
|
|
@ -267,7 +267,7 @@ M: mdb-collection validate.
|
|||
<PRIVATE
|
||||
|
||||
: send-message-check-error ( message -- )
|
||||
send-message lasterror [ mdb-error ] when* ;
|
||||
send-message lasterror [ throw-mdb-error ] when* ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -160,7 +160,7 @@ CONSTANT: beep-freq 880
|
|||
{ dash-char [ dash ] }
|
||||
{ word-gap-char [ intra-char-gap ] }
|
||||
{ unknown-char [ intra-char-gap ] }
|
||||
[ no-morse-ch ]
|
||||
[ throw-no-morse-ch ]
|
||||
} case
|
||||
] interleave ;
|
||||
|
||||
|
|
|
@ -66,7 +66,7 @@ ERROR: unknown-format n ;
|
|||
{ [ dup 0xc7 = ] [ drop read1 read-ext ] }
|
||||
{ [ dup 0xc8 = ] [ drop 2 read be> read-ext ] }
|
||||
{ [ dup 0xc9 = ] [ drop 4 read be> read-ext ] }
|
||||
[ unknown-format ]
|
||||
[ throw-unknown-format ]
|
||||
} cond ;
|
||||
|
||||
ERROR: cannot-convert obj ;
|
||||
|
@ -89,7 +89,7 @@ M: integer write-msgpack
|
|||
{ [ dup 0xffff <= ] [ 0xcd write1 2 >be write ] }
|
||||
{ [ dup 0xffffffff <= ] [ 0xce write1 4 >be write ] }
|
||||
{ [ dup 0xffffffffffffffff <= ] [ 0xcf write1 8 >be write ] }
|
||||
[ cannot-convert ]
|
||||
[ throw-cannot-convert ]
|
||||
} cond
|
||||
] [
|
||||
{
|
||||
|
@ -98,7 +98,7 @@ M: integer write-msgpack
|
|||
{ [ dup -0x8000 >= ] [ 0xd1 write1 2 >be write ] }
|
||||
{ [ dup -0x80000000 >= ] [ 0xd2 write1 4 >be write ] }
|
||||
{ [ dup -0x8000000000000000 >= ] [ 0xd3 write1 8 >be write ] }
|
||||
[ cannot-convert ]
|
||||
[ throw-cannot-convert ]
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
|
@ -111,7 +111,7 @@ M: string write-msgpack
|
|||
{ [ dup 0xff <= ] [ 0xd9 write1 write1 ] }
|
||||
{ [ dup 0xffff <= ] [ 0xda write1 2 >be write ] }
|
||||
{ [ dup 0xffffffff <= ] [ 0xdb write1 4 >be write ] }
|
||||
[ cannot-convert ]
|
||||
[ throw-cannot-convert ]
|
||||
} cond output-stream get utf8 encode-string ;
|
||||
|
||||
M: byte-array write-msgpack
|
||||
|
@ -119,7 +119,7 @@ M: byte-array write-msgpack
|
|||
{ [ dup 0xff <= ] [ 0xc4 write1 write1 ] }
|
||||
{ [ dup 0xffff <= ] [ 0xc5 write1 2 >be write ] }
|
||||
{ [ dup 0xffffffff <= ] [ 0xc6 write1 4 >be write ] }
|
||||
[ cannot-convert ]
|
||||
[ throw-cannot-convert ]
|
||||
} cond write ;
|
||||
|
||||
: write-array-header ( n -- )
|
||||
|
@ -127,7 +127,7 @@ M: byte-array write-msgpack
|
|||
{ [ dup 0xf <= ] [ 0x90 bitor write1 ] }
|
||||
{ [ dup 0xffff <= ] [ 0xdc write1 2 >be write ] }
|
||||
{ [ dup 0xffffffff <= ] [ 0xdd write1 4 >be write ] }
|
||||
[ cannot-convert ]
|
||||
[ throw-cannot-convert ]
|
||||
} cond ;
|
||||
|
||||
M: sequence write-msgpack
|
||||
|
@ -138,7 +138,7 @@ M: sequence write-msgpack
|
|||
{ [ dup 0xf <= ] [ 0x80 bitor write1 ] }
|
||||
{ [ dup 0xffff <= ] [ 0xde write1 2 >be write ] }
|
||||
{ [ dup 0xffffffff <= ] [ 0xdf write1 4 >be write ] }
|
||||
[ cannot-convert ]
|
||||
[ throw-cannot-convert ]
|
||||
} cond ;
|
||||
|
||||
M: assoc write-msgpack
|
||||
|
|
|
@ -53,7 +53,7 @@ ERROR: invalid-perlin-noise-table table ;
|
|||
|
||||
: validate-table ( table -- table )
|
||||
dup { [ byte-array? ] [ length 512 >= ] } 1&&
|
||||
[ invalid-perlin-noise-table ] unless ;
|
||||
[ throw-invalid-perlin-noise-table ] unless ;
|
||||
|
||||
! XXX doesn't work when v is nan or |v| >= 2^31
|
||||
: floor-vector ( v -- v' )
|
||||
|
|
|
@ -21,7 +21,7 @@ __kernel void square(
|
|||
|
||||
ERROR: cl-error err ;
|
||||
: cl-success ( err -- )
|
||||
dup CL_SUCCESS = [ drop ] [ cl-error ] if ;
|
||||
dup CL_SUCCESS = [ drop ] [ throw-cl-error ] if ;
|
||||
|
||||
:: cl-string-array ( str -- alien )
|
||||
str ascii encode 0 suffix :> str-buffer
|
||||
|
|
|
@ -13,10 +13,10 @@ SPECIALIZED-ARRAYS: void* char size_t ;
|
|||
ERROR: cl-error err ;
|
||||
|
||||
: cl-success ( err -- )
|
||||
dup CL_SUCCESS = [ drop ] [ cl-error ] if ; inline
|
||||
dup CL_SUCCESS = [ drop ] [ throw-cl-error ] if ; inline
|
||||
|
||||
: cl-not-null ( err -- )
|
||||
dup f = [ cl-error ] [ drop ] if ; inline
|
||||
dup f = [ throw-cl-error ] [ drop ] if ; inline
|
||||
|
||||
: info-data-size ( handle name info-quot -- size_t )
|
||||
[ 0 f 0 size_t <ref> ] dip [ call cl-success ] 2keep drop size_t deref ; inline
|
||||
|
@ -354,7 +354,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
|
|||
{
|
||||
{ CL_BUILD_PROGRAM_FAILURE [
|
||||
program-handle device id>> program-build-log program-handle
|
||||
clReleaseProgram cl-success cl-error f ] }
|
||||
clReleaseProgram cl-success throw-cl-error f ] }
|
||||
{ CL_SUCCESS [ cl-program new-disposable program-handle >>handle ] }
|
||||
[ program-handle clReleaseProgram cl-success cl-success f ]
|
||||
} case ;
|
||||
|
|
|
@ -25,7 +25,7 @@ ERROR: no-pair-method a b generic ;
|
|||
|
||||
: pair-generic-definition ( word -- def )
|
||||
[ sorted-pair-methods [ first2 pair-method-cond ] map ]
|
||||
[ [ no-pair-method ] curry suffix ] bi 1quotation
|
||||
[ [ throw-no-pair-method ] curry suffix ] bi 1quotation
|
||||
[ 2dup [ class-of ] compare +gt+ eq? ?swap ] [ cond ] surround ;
|
||||
|
||||
: make-pair-generic ( word -- )
|
||||
|
|
|
@ -31,7 +31,7 @@ M: pair set-at
|
|||
ERROR: cannot-delete-key pair ;
|
||||
|
||||
M: pair delete-at
|
||||
[ cannot-delete-key ] [
|
||||
[ throw-cannot-delete-key ] [
|
||||
[ delete-at ] [ 2drop ] if-hash
|
||||
] if-key ; inline
|
||||
|
||||
|
|
|
@ -31,7 +31,7 @@ ERROR: pcre-error value ;
|
|||
] [ 2drop f ] if* ;
|
||||
|
||||
: check-bad-option ( err value what -- value )
|
||||
rot 0 = [ drop ] [ bad-option ] if ;
|
||||
rot 0 = [ drop ] [ throw-bad-option ] if ;
|
||||
|
||||
: pcre-config ( what -- value )
|
||||
[
|
||||
|
@ -81,7 +81,7 @@ CONSTANT: default-opts flags{ PCRE_UTF8 PCRE_UCP }
|
|||
default-opts { c-string int } [ f pcre_compile ] with-out-parameters ;
|
||||
|
||||
: <pcre> ( expr -- pcre )
|
||||
dup (pcre) 2array swap [ 2nip ] [ malformed-regexp ] if* ;
|
||||
dup (pcre) 2array swap [ 2nip ] [ throw-malformed-regexp ] if* ;
|
||||
|
||||
: <pcre-extra> ( pcre -- pcre-extra )
|
||||
0 { c-string } [ pcre_study ] with-out-parameters drop ;
|
||||
|
@ -104,7 +104,7 @@ CONSTANT: empty-match-opts flags{ PCRE_NOTEMPTY_ATSTART PCRE_ANCHORED }
|
|||
[ ofs>> ]
|
||||
[ exec-opts>> ]
|
||||
} cleave exec over dup -1 < [
|
||||
PCRE_ERRORS number>enum pcre-error
|
||||
PCRE_ERRORS number>enum throw-pcre-error
|
||||
] [
|
||||
-1 = [
|
||||
2drop dup exec-opts>> 0 =
|
||||
|
|
|
@ -198,7 +198,7 @@ ERROR: no-card card deck ;
|
|||
|
||||
: draw-specific-card ( card deck -- card )
|
||||
[ >ckf ] dip
|
||||
2dup index [ swap remove-nth! drop ] [ no-card ] if* ;
|
||||
2dup index [ swap remove-nth! drop ] [ throw-no-card ] if* ;
|
||||
|
||||
: start-hands ( seq -- seq' deck )
|
||||
<deck> [ '[ [ _ draw-specific-card ] map ] map ] keep ;
|
||||
|
@ -248,7 +248,7 @@ ERROR: bad-suit-symbol ch ;
|
|||
{ CHAR: D CHAR: D }
|
||||
{ CHAR: H CHAR: H }
|
||||
{ CHAR: C CHAR: C }
|
||||
} ?at [ bad-suit-symbol ] unless ;
|
||||
} ?at [ throw-bad-suit-symbol ] unless ;
|
||||
|
||||
: card> ( string -- card )
|
||||
1 over [ symbol>suit ] change-nth >ckf ;
|
||||
|
|
|
@ -7,12 +7,12 @@ IN: progress-bars
|
|||
ERROR: invalid-percent x ;
|
||||
|
||||
: check-percent ( x -- x )
|
||||
dup 0 1 between? [ invalid-percent ] unless ;
|
||||
dup 0 1 between? [ throw-invalid-percent ] unless ;
|
||||
|
||||
ERROR: invalid-length x ;
|
||||
|
||||
: check-length ( x -- x )
|
||||
dup { [ 0 > ] [ integer? ] } 1&& [ invalid-length ] unless ;
|
||||
dup { [ 0 > ] [ integer? ] } 1&& [ throw-invalid-length ] unless ;
|
||||
|
||||
: (make-progress-bar) ( percent len completed-ch pending-ch -- string )
|
||||
[ [ * >integer ] keep over - ] 2dip
|
||||
|
|
|
@ -24,7 +24,7 @@ ERROR: redis-error message ;
|
|||
<redis-response> ;
|
||||
|
||||
: handle-error ( string -- * )
|
||||
redis-error ;
|
||||
throw-redis-error ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -68,7 +68,7 @@ ERROR: unsupported-resolv.conf-option string ;
|
|||
{ [ "rotate" ?head ] [ drop t >>rotate? ] }
|
||||
{ [ "no-check-names" ?head ] [ drop t >>no-check-names? ] }
|
||||
{ [ "inet6" ?head ] [ drop t >>inet6? ] }
|
||||
[ unsupported-resolv.conf-option ]
|
||||
[ throw-unsupported-resolv.conf-option ]
|
||||
} cond drop ;
|
||||
|
||||
ERROR: unsupported-resolv.conf-line string ;
|
||||
|
@ -81,7 +81,7 @@ ERROR: unsupported-resolv.conf-line string ;
|
|||
{ [ "search" ?head ] [ parse-search ] }
|
||||
{ [ "sortlist" ?head ] [ parse-sortlist ] }
|
||||
{ [ "options" ?head ] [ parse-option ] }
|
||||
[ unsupported-resolv.conf-line ]
|
||||
[ throw-unsupported-resolv.conf-line ]
|
||||
} cond ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
@ -36,7 +36,7 @@ PREDICATE: role < mixin-class
|
|||
|
||||
: check-for-slot-overlap ( class roles-and-superclass slots -- )
|
||||
[ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append
|
||||
duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
|
||||
duplicates dup empty? [ 2drop ] [ throw-role-slot-overlap ] if ;
|
||||
|
||||
: roles>slots ( roles-and-superclass slots -- superclass slots' )
|
||||
[
|
||||
|
@ -44,7 +44,7 @@ PREDICATE: role < mixin-class
|
|||
dup length {
|
||||
{ 0 [ drop tuple ] }
|
||||
{ 1 [ first ] }
|
||||
[ drop multiple-inheritance-attempted ]
|
||||
[ drop throw-multiple-inheritance-attempted ]
|
||||
} case
|
||||
swap [ role-slots ] map concat
|
||||
] dip append ;
|
||||
|
|
|
@ -13,7 +13,7 @@ classes [ H{ } clone ] initialize
|
|||
ERROR: no-class name ;
|
||||
|
||||
: lookup-class ( class -- class )
|
||||
classes get ?at [ no-class ] unless ;
|
||||
classes get ?at [ throw-no-class ] unless ;
|
||||
|
||||
: define-class ( class superclass ivars -- class-word )
|
||||
[ create-class ] [ lookup-class ] [ ] tri*
|
||||
|
|
|
@ -47,7 +47,7 @@ M: bad-identifier summary drop "Unknown identifier" ;
|
|||
[ local-reader ]
|
||||
[ ivar-reader ]
|
||||
[ drop class-name ]
|
||||
[ drop bad-identifier ]
|
||||
[ drop throw-bad-identifier ]
|
||||
} 2|| ;
|
||||
|
||||
: local-writer ( name lexenv -- local )
|
||||
|
@ -63,5 +63,5 @@ M: bad-identifier summary drop "Unknown identifier" ;
|
|||
{
|
||||
[ local-writer ]
|
||||
[ ivar-writer ]
|
||||
[ drop bad-identifier ]
|
||||
[ drop throw-bad-identifier ]
|
||||
} 2|| ;
|
||||
|
|
|
@ -11,7 +11,7 @@ IN: smalltalk.parser
|
|||
ERROR: bad-number str ;
|
||||
|
||||
: check-number ( str -- n )
|
||||
>string dup string>number [ ] [ bad-number ] ?if ;
|
||||
>string dup string>number [ ] [ throw-bad-number ] ?if ;
|
||||
|
||||
EBNF: parse-smalltalk
|
||||
|
||||
|
|
|
@ -74,7 +74,7 @@ TYPED: checksum-header ( seq: byte-array -- n )
|
|||
[
|
||||
binary [ read-tar-header ] with-byte-reader
|
||||
dup checksum>>
|
||||
] dip = [ checksum-error ] unless
|
||||
] dip = [ throw-checksum-error ] unless
|
||||
] if ;
|
||||
|
||||
ERROR: unknown-typeflag ch ;
|
||||
|
|
|
@ -12,7 +12,7 @@ ERROR: fica-base-unknown ;
|
|||
{ 2009 106800 }
|
||||
{ 2008 102000 }
|
||||
{ 2007 97500 }
|
||||
} at [ fica-base-unknown ] unless* ;
|
||||
} at [ throw-fica-base-unknown ] unless* ;
|
||||
|
||||
: fica-tax ( salary w4 -- x )
|
||||
year>> fica-base-rate min fica-tax-rate * ;
|
||||
|
|
|
@ -18,7 +18,7 @@ CONSTANT: MAGIC 0o432
|
|||
ERROR: bad-magic ;
|
||||
|
||||
: check-magic ( n -- )
|
||||
MAGIC = [ bad-magic ] unless ;
|
||||
MAGIC = [ throw-bad-magic ] unless ;
|
||||
|
||||
TUPLE: terminfo-header names-bytes boolean-bytes #numbers
|
||||
#strings string-bytes ;
|
||||
|
|
|
@ -27,7 +27,7 @@ PACKED-STRUCT: ttinfo
|
|||
ERROR: bad-magic ;
|
||||
|
||||
: check-magic ( -- )
|
||||
4 read "TZif" sequence= [ bad-magic ] unless ;
|
||||
4 read "TZif" sequence= [ throw-bad-magic ] unless ;
|
||||
|
||||
TUPLE: tzfile header transition-times local-times types abbrevs
|
||||
leaps is-std is-gmt ;
|
||||
|
|
|
@ -34,7 +34,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
|
|||
|
||||
: check-dimensions ( d d -- )
|
||||
[ dimensions 2array ] same?
|
||||
[ dimensions-not-equal ] unless ;
|
||||
[ throw-dimensions-not-equal ] unless ;
|
||||
|
||||
: 2values ( dim dim -- val val ) [ value>> ] bi@ ;
|
||||
|
||||
|
|
|
@ -22,7 +22,7 @@ M: no-such-state summary drop "No such state" ;
|
|||
|
||||
MEMO: string>state ( string -- state )
|
||||
dup states [ name>> = ] with find nip
|
||||
[ ] [ no-such-state ] ?if ;
|
||||
[ ] [ throw-no-such-state ] ?if ;
|
||||
|
||||
TUPLE: city
|
||||
first-zip name state latitude longitude gmt-offset dst-offset ;
|
||||
|
|
|
@ -11,7 +11,7 @@ IN: uu
|
|||
ERROR: bad-length seq ;
|
||||
|
||||
: check-length ( seq -- seq )
|
||||
dup length 45 > [ bad-length ] when ; inline
|
||||
dup length 45 > [ throw-bad-length ] when ; inline
|
||||
|
||||
:: binary>ascii ( seq -- seq' )
|
||||
0 :> char!
|
||||
|
@ -41,7 +41,7 @@ ERROR: illegal-character ch ;
|
|||
|
||||
: check-illegal-character ( ch -- ch )
|
||||
dup { [ CHAR: \s < ] [ CHAR: \s 64 + > ] } 1||
|
||||
[ illegal-character ] when ;
|
||||
[ throw-illegal-character ] when ;
|
||||
|
||||
:: ascii>binary ( seq -- seq' )
|
||||
0 :> char!
|
||||
|
|
|
@ -23,6 +23,6 @@ ERROR: git-revision-not-found path ;
|
|||
: use-vocab-rev ( vocab-name rev -- )
|
||||
[ create-vocab vocab-source-path dup ] dip git-object-id
|
||||
[ [ input-stream get swap parse-stream call( -- ) ] with-git-object-stream ]
|
||||
[ git-revision-not-found ] if* ;
|
||||
[ throw-git-revision-not-found ] if* ;
|
||||
|
||||
SYNTAX: USE-REV: scan-token scan-token use-vocab-rev ;
|
||||
|
|
|
@ -22,7 +22,7 @@ ERROR: yaml-no-document ;
|
|||
<PRIVATE
|
||||
|
||||
: yaml-initialize-assert-ok ( ? -- )
|
||||
[ libyaml-initialize-error ] unless ;
|
||||
[ throw-libyaml-initialize-error ] unless ;
|
||||
|
||||
: (libyaml-parser-error) ( parser -- )
|
||||
{
|
||||
|
@ -33,10 +33,10 @@ ERROR: yaml-no-document ;
|
|||
[ problem_mark>> ]
|
||||
[ context>> ]
|
||||
[ context_mark>> ]
|
||||
} cleave [ clone ] 7 napply libyaml-parser-error ;
|
||||
} cleave [ clone ] 7 napply throw-libyaml-parser-error ;
|
||||
|
||||
: (libyaml-emitter-error) ( emitter -- )
|
||||
[ error>> ] [ problem>> ] bi [ clone ] bi@ libyaml-emitter-error ;
|
||||
[ error>> ] [ problem>> ] bi [ clone ] bi@ throw-libyaml-emitter-error ;
|
||||
|
||||
: yaml-parser-assert-ok ( ? parser -- )
|
||||
swap [ drop ] [ (libyaml-parser-error) ] if ;
|
||||
|
@ -60,7 +60,7 @@ SYMBOL: anchors
|
|||
|
||||
: assert-anchor-exists ( anchor -- )
|
||||
anchors get 2dup at* nip
|
||||
[ 2drop ] [ yaml-undefined-anchor ] if ;
|
||||
[ 2drop ] [ throw-yaml-undefined-anchor ] if ;
|
||||
|
||||
: deref-anchor ( event -- obj )
|
||||
data>> alias>> anchor>>
|
||||
|
@ -182,7 +182,7 @@ DEFER: parse-mapping
|
|||
: expect-event ( parser event type -- )
|
||||
[
|
||||
[ next-event type>> ] dip 2dup =
|
||||
[ 2drop ] [ 1array yaml-unexpected-event ] if
|
||||
[ 2drop ] [ 1array throw-yaml-unexpected-event ] if
|
||||
] with-destructors ;
|
||||
|
||||
! Same as 'with', but for combinators that
|
||||
|
@ -257,7 +257,7 @@ M: assoc apply-merge-keys
|
|||
parser event next-event type>> {
|
||||
{ YAML_DOCUMENT_START_EVENT [ t ] }
|
||||
{ YAML_STREAM_END_EVENT [ f ] }
|
||||
[ { YAML_DOCUMENT_START_EVENT YAML_STREAM_END_EVENT } yaml-unexpected-event ]
|
||||
[ { YAML_DOCUMENT_START_EVENT YAML_STREAM_END_EVENT } throw-yaml-unexpected-event ]
|
||||
} case
|
||||
] with-destructors [
|
||||
parser event parse-yaml-doc t
|
||||
|
@ -283,7 +283,7 @@ PRIVATE>
|
|||
[
|
||||
init-parser
|
||||
[ YAML_STREAM_START_EVENT expect-event ]
|
||||
[ ?parse-yaml-doc [ yaml-no-document ] unless ] 2bi
|
||||
[ ?parse-yaml-doc [ throw-yaml-no-document ] unless ] 2bi
|
||||
] with-destructors ;
|
||||
|
||||
: yaml-docs> ( str -- arr )
|
||||
|
|
|
@ -154,7 +154,7 @@ ERROR: zone-not-found name ;
|
|||
|
||||
: find-zone ( string -- rules )
|
||||
raw-zone-map
|
||||
[ last ] assoc-map ?at [ zone-not-found ] unless ;
|
||||
[ last ] assoc-map ?at [ throw-zone-not-found ] unless ;
|
||||
|
||||
: find-zone-rules ( string -- zone rules )
|
||||
find-zone dup rules/save>> find-rules ;
|
||||
|
|
Loading…
Reference in New Issue