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