: 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 -- ? )
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 )
: 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 ;
{ 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 ;
{ 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 ;
{ f [ [ <complex-float> ] [ drop ] ] }
{ 8 [ [ <complex-float> ] [ drop ] ] }
{ 16 [ [ <complex-double> ] [ drop ] ] }
- [ invalid-fortran-type ]
+ [ throw-invalid-fortran-type ]
} case
] args?dims ;
{ 2 [ { [ c:short deref ] } ] }
{ 4 [ { [ c:int deref ] } ] }
{ 8 [ { [ c:longlong deref ] } ] }
- [ invalid-fortran-type ]
+ [ throw-invalid-fortran-type ]
} case
] result?dims ;
{ 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>)
{ 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>)
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 )
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 ;
elements get id>> 31 bitand
dup elements get tag<<
31 < [
- get-id unsupported-tag-encoding
+ get-id throw-unsupported-tag-encoding
] unless ;
: set-tagclass ( -- )
{ { 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 ;
: 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* ;
:: <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
: 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
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
#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 ;
: 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 )
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 ;
: 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
5 "\n\r" pick read-ignoring dup length {
{ 0 [ 2drop ] }
{ 5 [ decode5 (decode-base85) ] }
- [ malformed-base85 ]
+ [ throw-malformed-base85 ]
} case ;
PRIVATE>
{ { yellow blue } [ red ] }
{ { blue red } [ yellow ] }
{ { blue yellow } [ red ] }
- [ bad-color-pair ]
+ [ throw-bad-color-pair ]
} case
] if ;
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 ;
<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 ;
: check-status ( json -- json )
dup "status_code" of 200 = [
dup "status_txt" of
- bad-response
+ throw-bad-response
] unless ;
: json-data ( url -- json )
{ capacity fixnum read-only }
{ count fixnum } ;
-ERROR: invalid-size ;
+ERROR: invalid-size size ;
ERROR: invalid-error-rate error-rate ;
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
] 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>
{ 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 )
{ 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 -- )
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) ( -- )
{ "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 -- )
<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
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
dup instruction-cycles nth [
nip
] [
- undefined-8080-opcode
+ throw-undefined-8080-opcode
] if* ;
: process-interrupts ( cpu -- )
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
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 ;
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 ;
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 ;
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
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 ;
: check-filetype ( filetype -- filetype )
dup { "BINARY" "MOTOROLA" "AIFF" "WAVE" "MP3" } member?
- [ unknown-filetype ] unless ;
+ [ throw-unknown-filetype ] unless ;
ERROR: unknown-flag flag ;
: >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>
[ 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
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 ;
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
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
: guard-decimals ( obj1 obj2 -- D1 D2 )
2dup [ decimal? ] both?
- [ decimal-types-expected ] unless ;
+ [ throw-decimal-types-expected ] unless ;
M: decimal equal?
{
: 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 ;
: >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 )
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 ;
rot {
{ FDB_RESULT_SUCCESS [ ret>string ] }
{ FDB_RESULT_KEY_NOT_FOUND [ 2drop f ] }
- [ fdb-error ]
+ [ throw-fdb-error ]
} case ;
: fdb-del-kv ( key -- )
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
: 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 ;
[
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
: 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 ;
: 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> ;
: 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 ]
{ 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 ;
{ 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 ;
[ 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
:: [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
: 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 ;
{ "png" [ ".png" ] }
{ "tif" [ ".tif" ] }
{ "tiff" [ ".tif" ] }
- [ unsupported-preview-format ]
+ [ throw-unsupported-preview-format ]
} case ;
:: with-preview ( graph quot: ( path -- ) -- )
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 '[
[ [ 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
{ 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 )
{ 8 [ BGR ] }
{ 4 [ BGR ] }
{ 1 [ BGR ] }
- [ unknown-component-order ]
+ [ throw-unknown-component-order ]
} case ;
: advanced-bitmap>component-order ( loading-bitmap -- object )
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
{ 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 ;
] }
{ IMAGE-DESCRIPTOR [ read-table-based-image ] }
{ TRAILER [ f >>loading? ] }
- [ unhandled-data ]
+ [ throw-unhandled-data ]
} case ;
: read-GIF89a ( loading-gif -- loading-gif )
read-gif-header dup magic>> {
{ "GIF87a" [ read-GIF87a ] }
{ "GIF89a" [ read-GIF89a ] }
- [ unsupported-gif-format ]
+ [ throw-unsupported-gif-format ]
} case
] with-input-stream ;
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 ;
: read-png-header ( -- )
8 read dup png-header sequence= [
- bad-png-header
+ throw-bad-png-header
] unless drop ;
ERROR: bad-checksum ;
: 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
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
: 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
: 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
#! 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
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
{ 10 [ photometric-interpretation-itulab ] }
{ 32844 [ photometric-interpretation-logl ] }
{ 32845 [ photometric-interpretation-logluv ] }
- [ bad-photometric-interpretation ]
+ [ throw-bad-photometric-interpretation ]
} case ;
SINGLETONS: compression
{ 34676 [ compression-sgilog ] }
{ 34677 [ compression-sgilog24 ] }
{ 34712 [ compression-jp2000 ] }
- [ bad-compression ]
+ [ throw-bad-compression ]
} case ;
SINGLETONS: resolution-unit
{ 1 [ resolution-unit-none ] }
{ 2 [ resolution-unit-inch ] }
{ 3 [ resolution-unit-centimeter ] }
- [ bad-resolution-unit ]
+ [ throw-bad-resolution-unit ]
} case ;
SINGLETONS: predictor
{
{ 1 [ predictor-none ] }
{ 2 [ predictor-horizontal-differencing ] }
- [ bad-predictor ]
+ [ throw-bad-predictor ]
} case ;
SINGLETONS: planar-configuration
{
{ 1 [ planar-configuration-chunky ] }
{ 2 [ planar-configuration-planar ] }
- [ bad-planar-configuration ]
+ [ throw-bad-planar-configuration ]
} case ;
SINGLETONS: sample-format
{ 2 [ sample-format-signed-integer ] }
{ 3 [ sample-format-ieee-float ] }
{ 4 [ sample-format-undefined-data ] }
- [ bad-sample-format ]
+ [ throw-bad-sample-format ]
} case
] map ;
{ 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
{
{ 1 [ jpeg-proc-baseline ] }
{ 14 [ jpeg-proc-lossless ] }
- [ bad-jpeg-proc ]
+ [ throw-bad-jpeg-proc ]
} case ;
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 )
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? ;
{ 11 [ 4 * ] }
{ 12 [ 8 * ] }
{ 13 [ 4 * ] }
- [ "value-length" unknown-ifd-type ]
+ [ "value-length" throw-unknown-ifd-type ]
} case ;
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 )
{ 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 )
{
{ compression-none [ ] }
{ compression-lzw [ [ tiff-lzw-uncompress ] map ] }
- [ unhandled-compression ]
+ [ throw-unhandled-compression ]
} case ;
: uncompress-strips ( ifd -- ifd )
{
{ predictor-none [ ] }
{ predictor-horizontal-differencing [ (strips-predictor) ] }
- [ bad-predictor ]
+ [ throw-bad-predictor ]
} case
] when ;
{ { 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 )
{ { 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 )
{ 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 )
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
[ 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
: >local-word ( string -- word )
qualified-vocabs last words>> ?at
- [ local-not-defined ] unless ;
+ [ throw-local-not-defined ] unless ;
ERROR: invalid-op string ;
{ "/" [ [ / ] ] }
{ "%" [ [ mod ] ] }
{ "**" [ [ ^ ] ] }
- [ invalid-op ]
+ [ throw-invalid-op ]
} case ;
GENERIC: infix-codegen ( ast -- quot/number )
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 )
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
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
: zero-file ( n path -- )
{
- { [ over 0 < ] [ invalid-file-size ] }
+ { [ over 0 < ] [ throw-invalid-file-size ] }
{ [ over 0 = ] [ nip touch-file ] }
[ (zero-file) ]
} cond ;
{ 2 [ 1 cut { 0 0 } glue ] }
{ 3 [ 2 cut { 0 } glue ] }
{ 4 [ ] }
- [ drop invalid-ipv4 ]
+ [ drop throw-invalid-ipv4 ]
} case bubble nip ; inline
PRIVATE>
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
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
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 ;
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 ;
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
[ 0 <=>
{
{ +lt+ [ neg ] }
- { +eq+ [ 0 \ abs undefined-derivative ] }
+ { +eq+ [ 0 \ abs throw-undefined-derivative ] }
{ +gt+ [ ] }
} case
] ;
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>
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 ;
: 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 ;
: 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>
] [
{ 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 )
[ "-" ?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 ;
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 ;
<PRIVATE
: send-message-check-error ( message -- )
- send-message lasterror [ mdb-error ] when* ;
+ send-message lasterror [ throw-mdb-error ] when* ;
PRIVATE>
{ dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] }
{ unknown-char [ intra-char-gap ] }
- [ no-morse-ch ]
+ [ throw-no-morse-ch ]
} case
] interleave ;
{ [ 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 ;
{ [ 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
] [
{
{ [ 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 ;
{ [ 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
{ [ 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 -- )
{ [ 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
{ [ 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
: 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' )
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
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
{
{ 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 ;
: 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 -- )
ERROR: cannot-delete-key pair ;
M: pair delete-at
- [ cannot-delete-key ] [
+ [ throw-cannot-delete-key ] [
[ delete-at ] [ 2drop ] if-hash
] if-key ; inline
] [ 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 )
[
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 ;
[ 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 =
: 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 ;
{ 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 ;
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
<redis-response> ;
: handle-error ( string -- * )
- redis-error ;
+ throw-redis-error ;
PRIVATE>
{ [ "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 ;
{ [ "search" ?head ] [ parse-search ] }
{ [ "sortlist" ?head ] [ parse-sortlist ] }
{ [ "options" ?head ] [ parse-option ] }
- [ unsupported-resolv.conf-line ]
+ [ throw-unsupported-resolv.conf-line ]
} cond ;
PRIVATE>
: 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' )
[
dup length {
{ 0 [ drop tuple ] }
{ 1 [ first ] }
- [ drop multiple-inheritance-attempted ]
+ [ drop throw-multiple-inheritance-attempted ]
} case
swap [ role-slots ] map concat
] dip append ;
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*
[ local-reader ]
[ ivar-reader ]
[ drop class-name ]
- [ drop bad-identifier ]
+ [ drop throw-bad-identifier ]
} 2|| ;
: local-writer ( name lexenv -- local )
{
[ local-writer ]
[ ivar-writer ]
- [ drop bad-identifier ]
+ [ drop throw-bad-identifier ]
} 2|| ;
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
[
binary [ read-tar-header ] with-byte-reader
dup checksum>>
- ] dip = [ checksum-error ] unless
+ ] dip = [ throw-checksum-error ] unless
] if ;
ERROR: unknown-typeflag ch ;
{ 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 * ;
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 ;
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 ;
: check-dimensions ( d d -- )
[ dimensions 2array ] same?
- [ dimensions-not-equal ] unless ;
+ [ throw-dimensions-not-equal ] unless ;
: 2values ( dim dim -- val val ) [ value>> ] bi@ ;
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 ;
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!
: 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!
: 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 ;
<PRIVATE
: yaml-initialize-assert-ok ( ? -- )
- [ libyaml-initialize-error ] unless ;
+ [ throw-libyaml-initialize-error ] unless ;
: (libyaml-parser-error) ( parser -- )
{
[ 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 ;
: 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>>
: 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
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
[
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 )
: 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 ;
projects / factor.git / commitdiff