c-type-word pointer ;
: resolve-typedef ( name -- c-type )
- dup void? [ throw-no-c-type ] when
+ dup void? [ no-c-type ] when
dup c-type-name? [ lookup-c-type ] when ;
M: word lookup-c-type
dup "c-type" word-prop resolve-typedef
- [ ] [ throw-no-c-type ] ?if ;
+ [ ] [ no-c-type ] ?if ;
GENERIC: c-type-class ( name -- class )
: cast-array ( byte-array c-type -- array )
[ binary-object ] dip [ heap-size /mod 0 = ] keep swap
- [ <c-direct-array> ] [ throw-bad-byte-array-length ] if ; inline
+ [ <c-direct-array> ] [ bad-byte-array-length ] if ; inline
: malloc-array ( n c-type -- array )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
{ 2 [ [ c:short <ref> c:short deref ] ] }
{ 4 [ [ int <ref> int deref ] ] }
{ 8 [ [ longlong <ref> longlong deref ] ] }
- [ throw-invalid-signed-conversion ]
+ [ invalid-signed-conversion ]
} case ; inline
MACRO: byte-reverse ( n signed? -- quot )
: address-of ( name library -- value )
2dup load-library dlsym-raw
- [ 2nip ] [ throw-no-such-symbol ] if* ;
+ [ 2nip ] [ no-such-symbol ] if* ;
SYMBOL: deploy-libraries
: deploy-library ( name -- )
dup libraries get key?
[ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
- [ "deploy-library failure" throw-no-such-library ] if ;
+ [ "deploy-library failure" no-such-library ] if ;
HOOK: >deployed-library-path os ( path -- path' )
: parse-array-type ( name -- c-type )
"[" split unclip
- [ [ "]" ?tail [ throw-bad-array-type ] unless parse-datum ] map ]
+ [ [ "]" ?tail [ bad-array-type ] unless parse-datum ] map ]
[ (parse-c-type) ]
bi* prefix ;
: base64>ch ( ch -- ch )
$[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth
- [ throw-malformed-base64 ] unless* ; inline
+ [ malformed-base64 ] unless* ; inline
: (write-lines) ( column byte-array -- column' )
output-stream get dup '[
4 "\n\r" pick read-ignoring dup length {
{ 0 [ 2drop ] }
{ 4 [ decode4 (decode-base64) ] }
- [ throw-malformed-base64 ]
+ [ malformed-base64 ]
} case ;
PRIVATE>
drop "biassocs do not support deletion" ;
M: biassoc delete-at
- throw-no-biassoc-deletion ;
+ no-biassoc-deletion ;
M: biassoc >alist from>> >alist ;
ERROR: bad-array-length n ;
: <bit-array> ( n -- bit-array )
- dup 0 < [ throw-bad-array-length ] when
+ dup 0 < [ bad-array-length ] when
dup bits>bytes <byte-array>
bit-array boa ; inline
ERROR: check-bit-set-failed ;
: check-bit-set ( bit-set -- bit-set )
- dup bit-set? [ throw-check-bit-set-failed ] unless ; inline
+ dup bit-set? [ check-bit-set-failed ] unless ; inline
: bit-set-map ( seq1 seq2 quot -- seq )
[ drop [ length ] bi@ [ assert= ] keep ]
dup 0 < [ neg ] when log2 <=
] if-zero
]
- } 2|| [ throw-invalid-widthed ] when ;
+ } 2|| [ invalid-widthed ] when ;
: <widthed> ( bits #bits -- widthed )
check-widthed
: check-widthed-bits ( widthed n -- widthed n )
2dup { [ nip 0 < ] [ [ #bits>> ] dip < ] } 2||
- [ throw-not-enough-widthed-bits ] when ;
+ [ not-enough-widthed-bits ] when ;
: widthed-bits ( widthed n -- bits )
check-widthed-bits
] if ;
:: (peek) ( n bs endian> subseq-endian -- bits )
- n bs enough-bits? [ n bs throw-not-enough-bits ] unless
+ n bs enough-bits? [ n bs not-enough-bits ] unless
bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
bs bytes>> subseq endian> execute( seq -- x )
n bs subseq-endian execute( bignum n bs -- bits ) ;
t load-help? set-global
- [ dup lookup-vocab [ drop ] [ throw-no-vocab ] if ] require-hook [
+ [ dup lookup-vocab [ drop ] [ no-vocab ] if ] require-hook [
dictionary get values
[ docs-loaded?>> ] reject
[ load-docs ] each
: fixup-word ( word -- offset )
transfer-word dup lookup-object
- [ ] [ [ vocabulary>> ] [ name>> ] bi throw-not-in-image ] ?if ;
+ [ ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?if ;
: fixup-words ( -- )
bootstrapping-image get [ dup word? [ fixup-word ] when ] map! drop ;
ERROR: tuple-removed class ;
: require-tuple-layout ( word -- layout )
- dup tuple-layout [ ] [ throw-tuple-removed ] ?if ;
+ dup tuple-layout [ ] [ tuple-removed ] ?if ;
: (emit-tuple) ( tuple -- pointer )
[ tuple-slots ]
: >box ( value box -- )
dup occupied>>
- [ throw-box-full ] [ t >>occupied value<< ] if ; inline
+ [ box-full ] [ t >>occupied value<< ] if ; inline
ERROR: box-empty box ;
SYNTAX: HEX{
"}" parse-tokens concat
[ blank? ] reject
- dup length even? [ throw-odd-length-hex-string ] unless
+ dup length even? [ odd-length-hex-string ] unless
2 <groups> [ hex> ] B{ } map-as
suffix! ;
: (check-cairo) ( cairo_status_t -- )
dup CAIRO_STATUS_SUCCESS =
- [ drop ] [ [ ] [ cairo_status_to_string ] bi throw-cairo-error ] if ;
+ [ drop ] [ [ ] [ cairo_status_to_string ] bi cairo-error ] if ;
: check-cairo ( cairo -- ) cairo_status (check-cairo) ;
<PRIVATE
: check-month ( n -- n )
- [ throw-not-a-month ] when-zero ;
+ [ not-a-month ] when-zero ;
PRIVATE>
: month-abbreviation-index ( string -- n )
month-abbreviations-hash ?at
- [ throw-not-a-month-abbreviation ] unless ;
+ [ not-a-month-abbreviation ] unless ;
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
ERROR: invalid-timestamp-format ;
: check-timestamp ( obj/f -- obj )
- [ throw-invalid-timestamp-format ] unless* ;
+ [ invalid-timestamp-format ] unless* ;
: read-token ( seps -- token )
[ read-until ] keep member? check-timestamp drop ;
: digest-named ( name -- md )
dup EVP_get_digestbyname
- [ ] [ throw-unknown-digest ] ?if ;
+ [ ] [ unknown-digest ] ?if ;
: set-digest ( name ctx -- )
handle>> swap digest-named f EVP_DigestInit_ex ssl-error ;
:: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- )
slot-specs check-struct-slots
- slot-specs empty? [ throw-struct-must-have-slots ] when
+ slot-specs empty? [ struct-must-have-slots ] when
class redefine-struct-tuple-class
slot-specs offsets-quot call :> unaligned-size
slot-specs alignment-quot call :> alignment
scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot suffix! t ] }
- [ throw-invalid-struct-slot ]
+ [ invalid-struct-slot ]
} case ;
: parse-struct-definition ( -- class slots )
scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot` t ] }
- [ throw-invalid-struct-slot ]
+ [ invalid-struct-slot ]
} case ;
PRIVATE>
objc-methods get at ;
: lookup-method ( selector -- method )
- dup ?lookup-method [ ] [ throw-no-objc-method ] ?if ;
+ dup ?lookup-method [ ] [ no-objc-method ] ?if ;
: lookup-sender ( name -- method )
lookup-method message-senders get at ;
: decode-type ( ch -- ctype )
1string dup objc>alien-types get at
- [ ] [ throw-no-objc-type ] ?if ;
+ [ ] [ no-objc-type ] ?if ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1 + ] dip ] [ nth ] 2bi {
{ NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] }
- [ throw-invalid-plist-object ]
+ [ invalid-plist-object ]
} objc-class-case ;
: read-plist ( path -- assoc )
ERROR: no-such-color name ;
: named-color ( name -- color )
- dup colors at [ ] [ throw-no-such-color ] ?if ;
+ dup colors at [ ] [ no-such-color ] ?if ;
SYNTAX: COLOR: scan-token named-color suffix! ;
dup good-probabilities? [
[ dup pair? [ prepare-pair ] [ with-drop ] if ] map
cond>quot
- ] [ throw-bad-probabilities ] if ;
+ ] [ bad-probabilities ] if ;
MACRO: (casep) ( assoc -- quot ) (casep>quot) ;
: arity ( quots -- n )
first infer
- dup terminated?>> [ throw-cannot-determine-arity ] when
+ dup terminated?>> [ cannot-determine-arity ] when
effect-height neg 1 + ;
PRIVATE>
:: set-ac ( vreg ac -- )
#! Set alias class of newly-seen vreg.
- vreg vregs>acs get key? [ vreg throw-vreg-not-new ] when
+ vreg vregs>acs get key? [ vreg vreg-not-new ] when
ac vreg vregs>acs get set-at
vreg ac ac>vregs push ;
: check-successors ( bb -- )
dup successors>> [ predecessors>> member-eq? ] with all?
- [ throw-bad-successors ] unless ;
+ [ bad-successors ] unless ;
: check-cfg ( cfg -- )
[ check-successors ] each-basic-block ;
: enable-intrinsics ( alist -- )
[
- over inline? [ throw-inline-intrinsics-not-supported ] when
+ over inline? [ inline-intrinsics-not-supported ] when
"intrinsic" set-word-prop
] assoc-each ;
! node literals quot
[ _ firstn ] dip call
drop
- ] [ 2drop throw-bad-simd-intrinsic ] if
+ ] [ 2drop bad-simd-intrinsic ] if
] ;
CONSTANT: [unary] [ ds-drop ds-pop ]
: check-ranges ( live-interval -- )
check-allocation? get [
dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
- [ drop ] [ throw-bad-live-ranges ] if
+ [ drop ] [ bad-live-ranges ] if
] [ drop ] if ;
: trim-before-ranges ( live-interval -- )
: check-split ( live-interval n -- )
check-allocation? get [
- [ [ start>> ] dip > [ throw-splitting-too-early ] when ]
- [ [ end>> ] dip < [ throw-splitting-too-late ] when ]
+ [ [ start>> ] dip > [ splitting-too-early ] when ]
+ [ [ end>> ] dip < [ splitting-too-late ] when ]
[
drop [ end>> ] [ start>> ] bi =
- [ throw-splitting-atomic-interval ] when
+ [ splitting-atomic-interval ] when
] 2tri
] [ 2drop ] if ; inline
: check-activate ( live-interval -- )
check-allocation? get [
dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member?
- [ throw-register-already-used ] [ drop ] if
+ [ register-already-used ] [ drop ] if
] [ drop ] if ;
: activate ( n live-interval -- keep? )
: vreg>spill-slot ( vreg -- spill-slot )
dup vreg>reg dup spill-slot?
[ nip ]
- [ drop leader throw-not-spilled-error ] if ;
+ [ drop leader not-spilled-error ] if ;
: vregs>regs ( vregs -- assoc )
[ dup vreg>reg ] H{ } map>assoc ;
ERROR: bad-live-interval live-interval ;
: check-start ( live-interval -- )
- dup start>> -1 = [ throw-bad-live-interval ] [ drop ] if ;
+ dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
: finish-live-intervals ( live-intervals -- )
[
: check-block-numbering ( bb -- )
dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
- [ drop ] [ throw-bad-numbering ] if ;
+ [ drop ] [ bad-numbering ] if ;
: check-numbering ( cfg -- )
check-numbering? get
ERROR: bad-vreg vreg ;
: rep-of ( vreg -- rep )
- representations get ?at [ throw-bad-vreg ] unless ;
+ representations get ?at [ bad-vreg ] unless ;
: set-rep-of ( rep vreg -- )
representations get set-at ;
! it is allowed... otherwise bail out.
[
drop 2dup [ reg-class-of ] bi@ eq?
- [ drop ##copy, ] [ throw-bad-conversion ] if
+ [ drop ##copy, ] [ bad-conversion ] if
]
} case
]
: try-eliminate-copy ( follower leader must? -- )
-rot leaders 2dup = [ 3drop ] [
2dup vregs-interfere? [
- drop rot [ throw-vregs-shouldn't-interfere ] [ 2drop ] if
+ drop rot [ vregs-shouldn't-interfere ] [ 2drop ] if
] [ -rot coalesce-vregs drop ] if
] if ;
2dup live-out? [ 2drop 1/0. ] [
2dup kill-indices get at at* [ 2nip ] [
drop 2dup live-in?
- [ throw-bad-kill-index ] [ 2drop -1/0. ] if
+ [ bad-kill-index ] [ 2drop -1/0. ] if
] if
] if ;
: insert-peeks ( from to -- )
[ inserting-peeks ] keep
- [ dup n>> 0 < [ throw-bad-peek ] [ ##peek, ] if ] each-insertion ;
+ [ dup n>> 0 < [ bad-peek ] [ ##peek, ] if ] each-insertion ;
: insert-replaces ( from to -- )
[ inserting-replaces ] keep
[ register-write ] apply-stack-op ;
: ensure-no-vacant ( state -- )
- [ second ] map dup { { } { } } = [ drop ] [ throw-vacant-when-calling ] if ;
+ [ second ] map dup { { } { } } = [ drop ] [ vacant-when-calling ] if ;
: all-live ( state -- state' )
[ first { } 2array ] map ;
: underflowable-peek? ( state peek -- ? )
2dup loc>> >loc< swap [ 0 1 ? swap nth ] dip classify-read
- dup 2 = [ drop throw-vacant-peek ] [ 2nip 1 = ] if ;
+ dup 2 = [ drop vacant-peek ] [ 2nip 1 = ] if ;
M: ##peek visit-insn ( state insn -- state )
dup loc>> n>> 0 >= t assert=
32 random-bits >fixnum
32 random-bits >fixnum
2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
- [ 4drop ] [ throw-bug-in-fixnum* ] if
+ [ 4drop ] [ bug-in-fixnum* ] if
] times
] unit-test
ERROR: check-use-error value message ;
: check-use ( value uses -- )
- [ empty? [ "No use" throw-check-use-error ] [ drop ] if ]
+ [ empty? [ "No use" check-use-error ] [ drop ] if ]
[
all-unique?
[ drop ]
- [ "Uses not all unique" throw-check-use-error ] if
+ [ "Uses not all unique" check-use-error ] if
] 2bi ;
: check-def-use ( -- )
[ node-defs-values check-values ]
[ check-node* ]
tri
- ] [ throw-check-node-error ] recover ;
+ ] [ check-node-error ] recover ;
SYMBOL: datastack
SYMBOL: retainstack
ERROR: no-def-error value ;
: (def-of) ( value def-use -- definition )
- ?at [ throw-no-def-error ] unless ; inline
+ ?at [ no-def-error ] unless ; inline
: def-of ( value -- definition )
def-use get (def-of) ;
: (def-value) ( node value def-use -- )
2dup key? [
- throw-multiple-defs-error
+ multiple-defs-error
] [
[ [ <definition> ] keep ] dip set-at
] if ; inline
2dip
rot
[ 2drop ]
- [ throw-wrong-values ]
+ [ wrong-values ]
if
]
( obj -- a b c )
: (infer-value) ( value-info -- effect )
dup literal?>> [
literal>>
- [ callable? [ throw-uninferable ] unless ]
- [ already-inlined-quot? [ throw-uninferable ] when ]
- [ safe-infer dup +unknown+ = [ throw-uninferable ] when ] tri
+ [ callable? [ uninferable ] unless ]
+ [ already-inlined-quot? [ uninferable ] when ]
+ [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
] [
dup class>> {
{ \ curry [ slots>> third (infer-value) remove-effect-input ] }
{ \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
- [ throw-uninferable ]
+ [ uninferable ]
} case
] if ;
: check-outputs ( #call infos -- infos )
over out-d>> over [ length ] bi@ =
- [ nip ] [ throw-invalid-outputs ] if ;
+ [ nip ] [ invalid-outputs ] if ;
: call-outputs-quot ( #call word -- infos )
dupd
: check-effect ( quot word -- )
2dup [ infer ] [ stack-effect ] bi* effect<=
- [ 2drop ] [ throw-bad-partial-eval ] if ;
+ [ 2drop ] [ bad-partial-eval ] if ;
:: define-partial-eval ( word quot n -- )
word [
0 assert=
4 data bs:read 8 assert= ! compression method: deflate
4 data bs:read ! log2(max length)-8, 32K max
- 7 <= [ throw-bad-zlib-header ] unless
+ 7 <= [ bad-zlib-header ] unless
5 data bs:seek ! drop check bits
1 data bs:read 0 assert= ! dictionary - not allowed in png
2 data bs:seek ! compression level; ignore
dup 285 = [
dup 264 > [
dup 261 - 4 /i
- dup 5 > [ throw-bad-zlib-data ] when
+ dup 5 > [ bad-zlib-data ] when
bitstream bs:read 2array
] when
] unless
dup 3 > [
dup 2 - 2 /i dup 13 >
- [ throw-bad-zlib-data ] when
+ [ bad-zlib-data ] when
bitstream bs:read 2array
] when 2array
] when dup 256 = not
{ 0 [ inflate-raw ] }
{ 1 [ inflate-static ] }
{ 2 [ inflate-dynamic ] }
- { 3 [ throw-bad-zlib-data f ] }
+ { 3 [ bad-zlib-data f ] }
} case
] [ produce ] keep call suffix concat ;
: <lzw-uncompress> ( input code-size class -- obj )
new
- swap [ throw-code-size-zero ] when-zero >>code-size
+ swap [ code-size-zero ] when-zero >>code-size
dup code-size>> >>initial-code-size
dup code-size>> 1 - 2^ >>clear-code
dup clear-code>> 1 + >>end-of-information-code
<PRIVATE
: check-snappy ( ret -- )
- dup SNAPPY_OK = [ drop ] [ throw-snappy-error ] if ;
+ dup SNAPPY_OK = [ drop ] [ snappy-error ] if ;
: n>outs ( n -- byte-array size_t* )
[ <byte-array> ] [ size_t <ref> ] bi ;
"stream error" "data error"
"memory error" "buffer error" "zlib version error"
} ?nth
- ] if throw-zlib-failed ;
+ ] if zlib-failed ;
: zlib-error ( n -- )
dup {
{ compression.zlib.ffi:Z_OK [ drop ] }
{ compression.zlib.ffi:Z_STREAM_END [ drop ] }
- [ dup zlib-error-message throw-zlib-failed ]
+ [ dup zlib-error-message zlib-failed ]
} case ;
: compressed-size ( byte-array -- n )
: wait ( queue timeout status -- )
over [
[ queue-timeout ] dip suspend
- [ throw-timed-out-error ] [ stop-timer ] if
+ [ timed-out-error ] [ stop-timer ] if
] [
[ drop queue ] dip suspend drop
] if ; inline
ERROR: invalid-count-down-count count ;
: <count-down> ( n -- count-down )
- dup 0 < [ throw-invalid-count-down-count ] when
+ dup 0 < [ invalid-count-down-count ] when
<promise> \ count-down-tuple boa
dup count-down-check ;
: count-down ( count-down -- )
dup n>> dup zero?
- [ throw-count-down-already-done ]
+ [ count-down-already-done ]
[ 1 - >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )
: send-synchronous ( message thread -- reply )
dup self eq? [
- throw-cannot-send-synchronous-to-self
+ cannot-send-synchronous-to-self
] [
[ <synchronous> dup ] dip send
'[ _ synchronous-reply? ] receive-if
: fulfill ( value promise -- )
dup promise-fulfilled? [
- throw-promise-already-fulfilled
+ promise-already-fulfilled
] [
mailbox>> mailbox-put
] if ;
drop "Cannot have semaphore with negative count" ;
: <semaphore> ( n -- semaphore )
- dup 0 < [ throw-negative-count-semaphore ] when
+ dup 0 < [ negative-count-semaphore ] when
<dlist> semaphore boa ;
: wait-to-acquire ( semaphore timeout -- )
ERROR: core-foundation-error n ;
: cf-error ( n -- )
- dup 0 = [ drop ] [ throw-core-foundation-error ] if ;
+ dup 0 = [ drop ] [ core-foundation-error ] if ;
: fsref>string ( fsref -- string )
MAXPATHLEN [ <char-array> ] [ ] bi
{ kCFNumberLongType [ long (CFNumber>number) ] }
{ kCFNumberLongLongType [ longlong (CFNumber>number) ] }
{ kCFNumberDoubleType [ double (CFNumber>number) ] }
- [ throw-unsupported-number-type ]
+ [ unsupported-number-type ]
} case ;
[
[
dup selection? [ string>> ] when
- dup string? [ throw-not-a-string ] unless
+ dup string? [ not-a-string ] unless
] 2dip
make-attributes <CFAttributedString> &CFRelease
CTLineCreateWithAttributedString
ERROR: bad-movabs-operands dst src ;
GENERIC: MOVABS ( dst src -- )
-M: object MOVABS throw-bad-movabs-operands ;
+M: object MOVABS bad-movabs-operands ;
M: register MOVABS
{
{ AL [ 0xa2 , cell, ] }
{ AX [ 0x66 , 0xa3 , cell, ] }
{ EAX [ 0xa3 , cell, ] }
{ RAX [ 0x48 , 0xa3 , cell, ] }
- [ swap throw-bad-movabs-operands ]
+ [ swap bad-movabs-operands ]
} case ;
M: integer MOVABS
swap {
{ AX [ 0x66 , 0xa1 , cell, ] }
{ EAX [ 0xa1 , cell, ] }
{ RAX [ 0x48 , 0xa1 , cell, ] }
- [ swap throw-bad-movabs-operands ]
+ [ swap bad-movabs-operands ]
} case ;
: LEA ( dst src -- ) swap 0x8d 2-operand ;
:: x87-st0-op ( src opcode reg -- )
src register?
[ src opcode reg (x87-op) ]
- [ throw-bad-x87-operands ] if ;
+ [ bad-x87-operands ] if ;
:: x87-m-st0/n-op ( dst src opcode reg -- )
{
{ [ src ST0 = dst register? and ] [
dst opcode 4 + reg (x87-op)
] }
- [ throw-bad-x87-operands ]
+ [ bad-x87-operands ]
} cond ;
PRIVATE>
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
- dup index>> { ESP RSP } member-eq? [ throw-bad-index ] when ;
+ dup index>> { ESP RSP } member-eq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
drop "PQexec returned f." ;
: postgresql-result-ok? ( res -- ? )
- [ throw-postgresql-result-null ] unless*
+ [ postgresql-result-null ] unless*
PQresultStatus
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
{ "default" [ first number>string " " glue ] }
{ "varchar" [ first number>string "(" ")" surround append ] }
{ "references" [ >reference-string ] }
- [ drop throw-no-compound-found ]
+ [ drop no-compound-found ]
} case ;
M: postgresql-db-connection parse-db-error
[
"select " 0%
[ dupd filter-ignores ] dip
- over empty? [ throw-all-slots-ignored ] when
+ over empty? [ all-slots-ignored ] when
over
[ ", " 0% ]
[ dup column-name>> 0% 2, ] interleave
ERROR: sqlite-sql-error < sql-error n string ;
: sqlite-other-error ( n -- * )
- dup sqlite-error-messages nth throw-sqlite-error ;
+ dup sqlite-error-messages nth sqlite-error ;
: sqlite-statement-error ( -- * )
SQLITE_ERROR
- db-connection get handle>> sqlite3_errmsg throw-sqlite-sql-error ;
+ db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
: sqlite-check-result ( n -- )
{
: last-insert-id ( -- id )
db-connection get handle>> sqlite3_last_insert_rowid
- dup zero? [ throw-sqlite-last-id-fail ] when ;
+ dup zero? [ sqlite-last-id-fail ] when ;
M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
[ keys ]
[ all-slots [ name>> ] map ] bi* diff
] 2bi
- [ drop ] [ throw-no-slots-named ] if-empty ;
+ [ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )
pick dupd
: ensure-defined-persistent ( object -- object )
dup { [ class? ] [ "db-table" word-prop ] } 1&& [
- throw-no-defined-persistent
+ no-defined-persistent
] unless ;
: create-table ( class -- )
ERROR: not-persistent class ;
: db-table-name ( class -- object )
- dup "db-table" word-prop [ ] [ throw-not-persistent ] ?if ;
+ dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object )
superclasses-of [ "db-columns" word-prop ] map concat ;
: lookup-modifier ( obj -- string )
{
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
- [ persistent-table ?at [ throw-unknown-modifier ] unless third ]
+ [ persistent-table ?at [ unknown-modifier ] unless third ]
} cond ;
ERROR: no-sql-type type ;
: (lookup-type) ( obj -- string )
- persistent-table ?at [ throw-no-sql-type ] unless ;
+ persistent-table ?at [ no-sql-type ] unless ;
: lookup-type ( obj -- string )
dup array? [
first2
[ [ db-table-name " " glue ] [ db-columns ] bi ] dip
swap [ column-name>> = ] with find nip
- [ throw-no-column ] unless*
+ [ no-column ] unless*
column-name>> "(" ")" surround append ;
: check-broadcast-group ( group -- group )
dup group-words [ first stack-effect out>> empty? ] all?
- [ throw-broadcast-words-must-have-no-outputs ] unless ;
+ [ broadcast-words-must-have-no-outputs ] unless ;
! Consultation
: check-generic ( generic -- )
dup array? [ first ] when
- dup generic? [ drop ] [ throw-not-a-generic ] if ;
+ dup generic? [ drop ] [ not-a-generic ] if ;
PRIVATE>
ERROR: empty-deque ;
: peek-front ( deque -- obj )
- peek-front* [ drop throw-empty-deque ] unless ;
+ peek-front* [ drop empty-deque ] unless ;
: ?peek-front ( deque -- obj/f )
peek-front* [ drop f ] unless ;
: peek-back ( deque -- obj )
- peek-back* [ drop throw-empty-deque ] unless ;
+ peek-back* [ drop empty-deque ] unless ;
: ?peek-back ( deque -- obj/f )
peek-back* [ drop f ] unless ;
ERROR: invalid-location file line ;
: edit-location ( file line -- )
- over [ throw-invalid-location ] unless
+ over [ invalid-location ] unless
[ absolute-path ] dip
editor-command [ run-and-wait-for-editor ] when* ;
GENERIC: edit ( object -- )
M: object edit
- dup where [ first2 edit-location ] [ throw-cannot-find-source ] ?if ;
+ dup where [ first2 edit-location ] [ cannot-find-source ] ?if ;
M: string edit edit-vocab ;
fmt-f = digits "f" => [[ first '[ _ format-decimal ] ]]
fmt-x = "x" => [[ [ >hex ] ]]
fmt-X = "X" => [[ [ >hex >upper ] ]]
-unknown = (.)* => [[ throw-unknown-printf-directive ]]
+unknown = (.)* => [[ unknown-printf-directive ]]
strings_ = fmt-c|fmt-C|fmt-s|fmt-S|fmt-u
strings = pad width strings_ => [[ <reversed> compose-all ]]
: check-fry ( quot -- quot )
dup { load-local load-locals get-local drop-locals } intersect
- [ throw->r/r>-in-fry-error ] unless-empty ;
+ [ >r/r>-in-fry-error ] unless-empty ;
PREDICATE: fry-specifier < word { _ @ } member-eq? ;
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
- 2dup [ n>> ] dip = [ 2drop ] [ throw-ftp-error ] if ;
+ 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
>upper {
{ "IMAGE" [ "Binary" ] }
{ "I" [ "Binary" ] }
- [ throw-type-error ]
+ [ type-error ]
} case ;
: handle-TYPE ( obj -- )
ERROR: end-aside-in-get-error ;
: move-on ( id -- response )
- post-request? [ throw-end-aside-in-get-error ] unless
+ post-request? [ end-aside-in-get-error ] unless
dup method>> {
{ "GET" [ url>> <redirect> ] }
{ "HEAD" [ url>> <redirect> ] }
: string>word ( string -- word )
":" split1 swap 2dup lookup-word dup
- [ 2nip ] [ drop throw-no-such-word ] if ;
+ [ 2nip ] [ drop no-such-word ] if ;
: strings>words ( seq -- seq' )
[ string>word ] map ;
: base-path ( string -- seq )
dup responder-nesting get
[ second class-of superclasses-of [ name>> = ] with any? ] with find nip
- [ first ] [ throw-no-such-responder ] ?if ;
+ [ first ] [ no-such-responder ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
reset-mouse ;
: close-game-input ( -- )
game-input-opened [
- dup zero? [ throw-game-input-not-open ] when
+ dup zero? [ game-input-not-open ] when
1 -
] change-global
game-input-opened? [
MACRO: npick ( n -- quot )
{
- { [ dup 0 <= ] [ throw-nonpositive-npick ] }
+ { [ dup 0 <= ] [ nonpositive-npick ] }
{ [ dup 1 = ] [ drop [ dup ] ] }
[ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ]
} cond ;
current-vocab-dirs custom-gir-dirs system-gir-dirs
3append sift :> paths
paths [ path append-path exists? ] find nip
- [ path append-path ] [ path paths throw-gir-not-found ] if*
+ [ path append-path ] [ path paths gir-not-found ] if*
] if ;
: define-gir-vocab ( path -- )
: get-type-info ( data-type -- info )
qualified-type-name dup type-infos get-global at
- [ ] [ throw-unknown-type-error ] ?if ;
+ [ ] [ unknown-type-error ] ?if ;
: find-type-info ( data-type -- info/f )
qualified-type-name type-infos get-global at ;
<<
void* lookup-c-type clone
- [ drop throw-deferred-type-error ] >>unboxer-quot
- [ drop throw-deferred-type-error ] >>boxer-quot
+ [ drop deferred-type-error ] >>unboxer-quot
+ [ drop deferred-type-error ] >>boxer-quot
object >>boxed-class
"deferred-type" create-word-in typedef
>>
TUPLE: chunking-seq { seq read-only } { n read-only } ;
: check-groups ( seq n -- seq n )
- dup 0 <= [ throw-groups-error ] when ; inline
+ dup 0 <= [ groups-error ] when ; inline
: new-groups ( seq n class -- groups )
[ check-groups ] dip boa ; inline
ERROR: not-a-heap object ;
: check-heap ( heap -- heap )
- dup heap? [ throw-not-a-heap ] unless ; inline
+ dup heap? [ not-a-heap ] unless ; inline
TUPLE: entry value key heap index ;
<PRIVATE
: entry>index ( entry heap -- n )
- over heap>> eq? [ throw-bad-heap-delete ] unless
+ over heap>> eq? [ bad-heap-delete ] unless
index>> { fixnum } declare ; inline
PRIVATE>
last assert=
] vocabs-quot get call( quot -- )
] leaks members length [
- "%d disposable(s) leaked in example" sprintf throw-simple-lint-error
+ "%d disposable(s) leaked in example" sprintf simple-lint-error
] unless-zero ;
: check-examples ( element -- )
[ effect-values ] [ extract-values ] bi* 2dup
sequence= [ 2drop ] [
"$values don't match stack effect; expected %u, got %u" sprintf
- throw-simple-lint-error
+ simple-lint-error
] if
] if ;
[ effect-effects ] [ extract-value-effects ] bi*
[ 2dup and [ = ] [ 2drop t ] if ] 2all? [
"$quotation stack effects in $values don't match"
- throw-simple-lint-error
+ simple-lint-error
] unless ;
: check-nulls ( element -- )
\ $values swap elements
null swap deep-member?
- [ "$values should not contain null" throw-simple-lint-error ] when ;
+ [ "$values should not contain null" simple-lint-error ] when ;
: check-see-also ( element -- )
\ $see-also swap elements [ rest all-unique? ] all?
- [ "$see-also are not unique" throw-simple-lint-error ] unless ;
+ [ "$see-also are not unique" simple-lint-error ] unless ;
: vocab-exists? ( name -- ? )
[ lookup-vocab ] [ all-vocabs-list get member? ] bi or ;
second
vocab-exists? [
"$vocab-link to non-existent vocabulary"
- throw-simple-lint-error
+ simple-lint-error
] unless
] each ;
[
"\n\t" intersects? [
"Paragraph text should not contain \\n or \\t"
- throw-simple-lint-error
+ simple-lint-error
] when
] [
" " swap subseq? [
"Paragraph text should not contain double spaces"
- throw-simple-lint-error
+ simple-lint-error
] when
] bi ;
: check-whitespace ( str1 str2 -- )
[ " " tail? ] [ " " head? ] bi* or
- [ "Missing whitespace between strings" throw-simple-lint-error ] unless ;
+ [ "Missing whitespace between strings" simple-lint-error ] unless ;
: check-bogus-nl ( element -- )
{ { $nl } { { $nl } } } [ head? ] with any? [
"Simple element should not begin with a paragraph break"
- throw-simple-lint-error
+ simple-lint-error
] when ;
: extract-slots ( elements -- seq )
] [ extract-slots ] bi*
[ swap member? ] with reject [
", " join "Described $slot does not exist: " prepend
- throw-simple-lint-error
+ simple-lint-error
] unless-empty
] [
nip empty? not [
"A word that is not a class has a $class-description"
- throw-simple-lint-error
+ simple-lint-error
] when
] if ;
: check-article-title ( article -- )
article-title first LETTER?
- [ "Article title must begin with a capital letter" throw-simple-lint-error ] unless ;
+ [ "Article title must begin with a capital letter" simple-lint-error ] unless ;
: check-elements ( element -- )
{
swap '[
_ elements [
rest { { } { "" } } member?
- [ "Empty $description" throw-simple-lint-error ] when
+ [ "Empty $description" simple-lint-error ] when
] each
] each ;
ERROR: number-of-arguments found required ;
: check-first ( seq -- first )
- dup length 1 = [ length 1 throw-number-of-arguments ] unless
+ dup length 1 = [ length 1 number-of-arguments ] unless
first-unsafe ;
: check-first2 ( seq -- first second )
- dup length 2 = [ length 2 throw-number-of-arguments ] unless
+ dup length 2 = [ length 2 number-of-arguments ] unless
first2-unsafe ;
PRIVATE>
SYNTAX: ARTICLE:
location [
\ ; parse-until >array
- dup length 2 < [ throw-article-expects-name-and-title ] when
+ dup length 2 < [ article-expects-name-and-title ] when
[ first2 ] [ 2 tail ] bi <article>
over add-article >link
] dip remember-definition ;
drop "Help article does not exist" ;
: lookup-article ( name -- article )
- articles get ?at [ throw-no-article ] unless ;
+ articles get ?at [ no-article ] unless ;
M: object valid-article? articles get key? ;
M: object article-title lookup-article article-title ;
ERROR: cannot-specialize word specializer ;
: set-specializer ( word specializer -- )
- over inline-recursive? [ throw-cannot-specialize ] when
+ over inline-recursive? [ cannot-specialize ] when
"specializer" set-word-prop ;
SYNTAX: HINTS:
ERROR: tag-not-allowed-here ;
: check-tag ( -- )
- string-context? get [ throw-tag-not-allowed-here ] when ;
+ string-context? get [ tag-not-allowed-here ] when ;
: compile-tag ( tag -- )
check-tag
SYMBOL: title
: set-title ( string -- )
- title get [ >box ] [ throw-no-boilerplate ] if* ;
+ title get [ >box ] [ no-boilerplate ] if* ;
: get-title ( -- string )
- title get [ value>> ] [ throw-no-boilerplate ] if* ;
+ title get [ value>> ] [ no-boilerplate ] if* ;
: write-title ( -- )
get-title write ;
response "location" header redirect-url
response code>> 307 = [ "GET" >>method ] unless
quot (with-http-request)
- ] [ throw-too-many-redirects ] if ; inline recursive
+ ] [ too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )
read-crlf ";" split1 drop [ blank? ] trim-tail
ERROR: bad-request-line < request-error parse-error ;
: check-absolute ( url -- )
- path>> dup "/" head? [ drop ] [ throw-invalid-path ] if ; inline
+ path>> dup "/" head? [ drop ] [ invalid-path ] if ; inline
: parse-request-line-safe ( string -- triple )
- [ parse-request-line ] [ nip throw-bad-request-line ] recover ;
+ [ parse-request-line ] [ nip bad-request-line ] recover ;
: read-request-line ( request -- request )
read-?crlf [ dup "" = ] [ drop read-?crlf ] while
: parse-multipart-form-data ( string -- separator )
";" split1 nip
- "=" split1 nip [ throw-no-boundary ] unless* ;
+ "=" split1 nip [ no-boundary ] unless* ;
: maybe-limit-input ( content-length -- )
unlimited-input upload-limit get [ min ] when* limited-input ;
"content-length" header [
dup string>number [
nip dup 0 upload-limit get between? [
- throw-invalid-content-length
+ invalid-content-length
] unless
- ] [ throw-invalid-content-length ] if*
- ] [ throw-content-length-missing ] if* ;
+ ] [ invalid-content-length ] if*
+ ] [ content-length-missing ] if* ;
: parse-content ( request content-type -- post-data )
dup <post-data> -rot over parse-content-length-safe swap
ERROR: unsupported-pixel-format component-order ;
: check-pixel-format ( image -- )
- component-order>> dup BGRA = [ drop ] [ throw-unsupported-pixel-format ] if ;
+ component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ;
: image>gdi+-bitmap ( image -- bitmap )
dup check-pixel-format
types [ H{ } clone ] initialize
: (image-class) ( type -- class )
- >lower types get ?at [ throw-unknown-image-extension ] unless ;
+ >lower types get ?at [ unknown-image-extension ] unless ;
: image-class ( path -- class )
file-extension (image-class) ;
ERROR: not-an-interval-map obj ;
: check-interval-map ( map -- map )
- dup interval-map? [ throw-not-an-interval-map ] unless ; inline
+ dup interval-map? [ not-an-interval-map ] unless ; inline
PRIVATE>
ERROR: not-an-interval-set obj ;
: check-interval-set ( map -- map )
- dup interval-set? [ throw-not-an-interval-set ] unless ; inline
+ dup interval-set? [ not-an-interval-set ] unless ; inline
PRIVATE>
ERROR: fail ;
M: fail summary drop "Matching failed" ;
-: assure ( ? -- ) [ throw-fail ] unless ; inline
+: assure ( ? -- ) [ fail ] unless ; inline
: =/fail ( obj1 obj2 -- ) = assure ; inline
ERROR: bad-math-inverse ;
: next ( revquot -- revquot* first )
- [ throw-bad-math-inverse ]
+ [ bad-math-inverse ]
[ unclip-slice ] if-empty ;
: constant-word? ( word -- ? )
[ in>> empty? ] bi and ;
: assure-constant ( constant -- quot )
- dup word? [ throw-bad-math-inverse ] when 1quotation ;
+ dup word? [ bad-math-inverse ] when 1quotation ;
: swap-inverse ( math-inverse revquot -- revquot* quot )
next assure-constant rot second '[ @ swap @ ] ;
\ ? 2 [
[ assert-literal ] bi@
- [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ throw-fail ] if ] if ]
+ [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
2curry
] define-pop-inverse
: empty-inverse ( class -- quot )
deconstruct-pred
- [ tuple-slots [ ] any? [ throw-fail ] when ]
+ [ tuple-slots [ ] any? [ fail ] when ]
compose ;
\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
- "I/O" suspend [ throw-io-timeout ] when
+ "I/O" suspend [ io-timeout ] when
] if ;
: wait-for-port ( port event -- )
ERROR: not-a-buffered-port port ;
: check-buffered-port ( port -- port )
- dup buffered-port? [ throw-not-a-buffered-port ] unless ; inline
+ dup buffered-port? [ not-a-buffered-port ] unless ; inline
M: fd refill
[ check-buffered-port buffer>> ] [ fd>> ] bi*
ERROR: file-not-found path bfs? quot ;
: find-file-throws ( path bfs? quot -- path )
- 3dup find-file [ 2nip nip ] [ throw-file-not-found ] if* ; inline
+ 3dup find-file [ 2nip nip ] [ file-not-found ] if* ; inline
ERROR: sequence-expected obj ;
: ensure-sequence-of-directories ( obj -- seq )
dup string? [ 1array ] when
- dup sequence? [ throw-sequence-expected ] unless ;
+ dup sequence? [ sequence-expected ] unless ;
! Can't make this generic# on string/sequence because of combinators
: find-in-directories ( directories bfs? quot -- path'/f )
TUPLE: 8-bit { biassoc biassoc read-only } ;
: 8-bit-encode ( char 8-bit -- byte )
- biassoc>> value-at [ throw-encode-error ] unless* ; inline
+ biassoc>> value-at [ encode-error ] unless* ; inline
M: 8-bit encode-char
swap [ 8-bit-encode ] dip stream-write1 ;
h>b/b swap 2byte-array
swap stream-write
] if
- ] [ throw-encode-error ] if* ;
+ ] [ encode-error ] if* ;
: euc-multibyte? ( ch -- ? )
0x81 0xfe between? ;
: lookup-range ( char -- byte-array )
dup u>gb get-global interval-at [
[ ufirst>> - ] [ bfirst>> ] bi + unlinear
- ] [ throw-encode-error ] if* ;
+ ] [ encode-error ] if* ;
M: gb18030 encode-char ( char stream encoding -- )
drop [
{ [ dup jis201 get-global value? ] [ drop switch-jis201 jis201 get-global ] }
{ [ dup jis208 get-global value? ] [ drop switch-jis208 jis208 get-global ] }
{ [ dup jis212 get-global value? ] [ drop switch-jis212 jis212 get-global ] }
- [ throw-encode-error ]
+ [ encode-error ]
} cond ;
: stream-write-num ( num stream -- )
TUPLE: jis assoc ;
-: ch>jis ( ch tuple -- jis ) assoc>> value-at [ throw-encode-error ] unless* ;
+: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
: jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ;
: make-jis ( filename -- jis )
C: strict strict-state
M: strict-state decode-char
- code>> decode-char dup replacement-char = [ throw-decode-error ] when ;
+ code>> decode-char dup replacement-char = [ decode-error ] when ;
[ length 2 >= ]
[ second CHAR: : = ]
[ first Letter? ]
- } 1&& [ 2 head "\\" append ] [ throw-not-absolute-path ] if ;
+ } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
<PRIVATE
<PRIVATE
: (follow-links) ( n path -- path' )
- over 0 = [ symlink-depth get throw-too-many-symlinks ] when
+ over 0 = [ symlink-depth get too-many-symlinks ] when
dup link-info symbolic-link?
[ [ 1 - ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
ERROR: seek-before-start n ;
: set-seek-ptr ( n handle -- )
- [ dup 0 < [ throw-seek-before-start ] when ] dip ptr<< ;
+ [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
M: windows tell-handle ( handle -- n ) ptr>> ;
process>> . ;
M: process >process
- dup process-started? [ throw-process-already-started ] when
+ dup process-started? [ process-already-started ] when
clone ;
M: object >process <process> swap >>command ;
: (wait-for-process) ( process -- status )
dup handle>>
[ self over processes get at push "process" suspend drop ] when
- dup killed>> [ throw-process-was-killed ] [ status>> ] if ;
+ dup killed>> [ process-was-killed ] [ status>> ] if ;
: wait-for-process ( process -- status )
[ (wait-for-process) ] with-timeout ;
] [ process>> . ] bi ;
: check-success ( process status -- )
- 0 = [ drop ] [ throw-process-failed ] if ;
+ 0 = [ drop ] [ process-failed ] if ;
: wait-for-success ( process -- )
dup wait-for-process check-success ;
[ +closed+ or ] change-stdin
utf8 (process-reader)
[ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
- 0 = [ 2drop ] [ throw-output-process-error ] if ;
+ 0 = [ 2drop ] [ output-process-error ] if ;
<PRIVATE
dup call-CreateProcess
lpProcessInformation>>
] with-destructors
- ] [ throw-launch-error ] recover ;
+ ] [ launch-error ] recover ;
: prepare-mapped-file ( path quot -- mapped-file path' length )
[
[ normalize-path ] [ file-info size>> ] bi
- [ dup 0 <= [ throw-bad-mmap-size ] [ 2drop ] if ]
+ [ dup 0 <= [ bad-mmap-size ] [ 2drop ] if ]
[ nip mapped-file new-disposable swap >>length ]
] dip 2tri [ >>address ] [ >>handle ] bi* ; inline
ERROR: not-a-c-ptr object ;
: check-c-ptr ( c-ptr -- c-ptr )
- dup c-ptr? [ throw-not-a-c-ptr ] unless ; inline
+ dup c-ptr? [ not-a-c-ptr ] unless ; inline
<PRIVATE
<PRIVATE
: must-be-running ( threaded-server -- threaded-server )
- dup running-servers get in? [ throw-server-not-running ] unless ;
+ dup running-servers get in? [ server-not-running ] unless ;
: must-not-be-running ( threaded-server -- threaded-server )
- dup running-servers get in? [ throw-server-already-running ] when ;
+ dup running-servers get in? [ server-already-running ] when ;
: add-running-server ( threaded-server -- )
must-not-be-running
ERROR: file-expected path ;
: ensure-exists ( path -- path )
- dup exists? [ throw-file-expected ] unless ; inline
+ dup exists? [ file-expected ] unless ; inline
: ssl-file-path ( path -- path' )
absolute-path ensure-exists ;
ERR_get_error [
{
{ -1 [
- errno ECONNRESET = [ throw-premature-close ]
+ errno ECONNRESET = [ premature-close ]
[ throw-errno ] if
] }
! OpenSSL docs say this it is an error condition for
: check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK =
- [ drop ] [ verify-message throw-certificate-verify-error ] if ;
+ [ drop ] [ verify-message certificate-verify-error ] if ;
: x509name>string ( x509name -- string )
NID_commonName 256 <byte-array>
SSL_get_peer_certificate [
[ alternative-dns-names ] [ subject-name ] bi suffix
2dup [ subject-names-match? ] with any?
- [ 2drop ] [ throw-subject-name-verify-error ] if
- ] [ throw-certificate-missing-error ] if* ;
+ [ 2drop ] [ subject-name-verify-error ] if
+ ] [ certificate-missing-error ] if* ;
M: openssl check-certificate ( host ssl -- )
current-secure-context config>> verify>> [
] [ 2drop ] if ;
: check-buffer ( port -- port )
- dup buffer>> buffer-empty? [ throw-upgrade-buffers-full ] unless ;
+ dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ;
: input/output-ports ( -- input output )
input-stream output-stream
[ get underlying-port check-buffer ] bi@
- 2dup [ handle>> ] bi@ eq? [ throw-upgrade-on-non-socket ] unless ;
+ 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ;
: make-input/output-secure ( input output -- )
- dup handle>> non-ssl-socket? [ throw-upgrade-on-non-socket ] unless
+ dup handle>> non-ssl-socket? [ upgrade-on-non-socket ] unless
[ <ssl-socket> ] change-handle
handle>> >>handle drop ;
: (send-secure-handshake) ( output -- )
- remote-address get [ throw-upgrade-on-non-socket ] unless*
+ remote-address get [ upgrade-on-non-socket ] unless*
secure-connection ;
M: openssl send-secure-handshake
: parse-ipv4 ( string -- seq )
[ f ] [
- "." split dup length 4 = [ throw-malformed-ipv4 ] unless
- [ dup string>number [ ] [ throw-bad-ipv4-component ] ?if ] B{ } map-as
+ "." split dup length 4 = [ malformed-ipv4 ] unless
+ [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as
] if-empty ;
: check-ipv4 ( string -- )
- [ parse-ipv4 drop ] [ throw-invalid-ipv4 ] recover ;
+ [ parse-ipv4 drop ] [ invalid-ipv4 ] recover ;
PRIVATE>
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
M: ipv4 inet-pton ( str addrspec -- data )
- drop [ parse-ipv4 ] [ throw-invalid-ipv4 ] recover ;
+ drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ;
M: ipv4 address-size drop 4 ;
ERROR: more-than-8-components ;
: parse-ipv6-component ( seq -- seq' )
- [ dup hex> [ nip ] [ throw-bad-ipv6-component ] if* ] { } map-as ;
+ [ dup hex> [ nip ] [ bad-ipv6-component ] if* ] { } map-as ;
: parse-ipv6 ( string -- seq )
[ f ] [
] if-empty ;
: check-ipv6 ( string -- )
- [ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ throw-invalid-ipv6 ] recover ;
+ [ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ invalid-ipv6 ] recover ;
PRIVATE>
: pad-ipv6 ( string1 string2 -- seq )
2dup [ length ] bi@ + 8 swap -
- dup 0 < [ throw-more-than-8-components ] when
+ dup 0 < [ more-than-8-components ] when
<byte-array> glue ;
: ipv6-bytes ( seq -- bytes )
M: ipv6 inet-pton ( str addrspec -- data )
drop
[ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ]
- [ throw-invalid-ipv6 ]
+ [ invalid-ipv6 ]
recover ;
M: ipv6 address-size drop 16 ;
pick class-of byte-array assert= ;
: check-connectionless-port ( port -- port )
- dup { [ datagram-port? ] [ raw-port? ] } 1|| [ throw-invalid-port ] unless ;
+ dup { [ datagram-port? ] [ raw-port? ] } 1|| [ invalid-port ] unless ;
: check-send ( packet addrspec port -- packet addrspec port )
check-connectionless-port check-disposed check-port ;
M: string resolve-host
f prepare-addrinfo f void* <ref> [
getaddrinfo [
- dup addrinfo-error-string throw-addrinfo-error
+ dup addrinfo-error-string addrinfo-error
] unless-zero
] keep void* deref addrinfo memory>struct
[ parse-addrinfo-list ] keep freeaddrinfo ;
drop "Cannot use <server> with <inet>; use <inet4> or <inet6> instead" ;
M: inet (server)
- throw-invalid-inet-server ;
+ invalid-inet-server ;
ERROR: invalid-local-address addrspec ;
[
[ ] [ inet4? ] [ inet6? ] tri or
[ bind-local-address ]
- [ throw-invalid-local-address ] if
+ [ invalid-local-address ] if
] dip with-variable ; inline
: protocol-port ( protocol -- port )
M: duplex-stream underlying-handle
>duplex-stream<
[ underlying-handle ] bi@
- [ = [ throw-invalid-duplex-stream ] when ] keep ;
+ [ = [ invalid-duplex-stream ] when ] keep ;
: check-count-bounds ( n stream -- n stream )
dup [ count>> ] [ limit>> ] bi >
- [ throw-limit-exceeded ] when ;
+ [ limit-exceeded ] when ;
: check-current-bounds ( n stream -- n stream )
dup [ current>> ] [ start>> ] bi <
- [ throw-limit-exceeded ] when ;
+ [ limit-exceeded ] when ;
: adjust-limited-read ( n stream -- n stream )
dup start>> [
M:: throws-on-eof-stream stream-read1 ( stream -- obj )
stream stream>> stream-read1
- [ 1 stream \ read1 throw-stream-exhausted ] unless* ;
+ [ 1 stream \ read1 stream-exhausted ] unless* ;
M:: throws-on-eof-stream stream-read-unsafe ( n buf stream -- count )
n buf stream stream>> stream-read-unsafe
- dup n = [ n stream \ stream-read-unsafe throw-stream-exhausted ] unless ;
+ dup n = [ n stream \ stream-read-unsafe stream-exhausted ] unless ;
M:: throws-on-eof-stream stream-read-partial-unsafe ( n buf stream -- count )
n buf stream stream>> stream-read-partial-unsafe
- [ n stream \ stream-read-partial-unsafe throw-stream-exhausted ] when-zero ;
+ [ n stream \ stream-read-partial-unsafe stream-exhausted ] when-zero ;
M: throws-on-eof-stream stream-tell
stream>> stream-tell ;
M: throws-on-eof-stream stream-read-until
[ stream>> stream-read-until ]
- [ '[ length _ \ read-until throw-stream-exhausted ] unless* ] bi ;
+ [ '[ length _ \ read-until stream-exhausted ] unless* ] bi ;
: stream-throw-on-eof ( ..a stream quot: ( ..a stream' -- ..b ) -- ..b )
[ <throws-on-eof-stream> ] dip with-input-stream* ; inline
] dip ;
: json-expect ( token stream -- )
- [ dup length ] [ stream-read ] bi* = [ throw-json-error ] unless ; inline
+ [ dup length ] [ stream-read ] bi* = [ json-error ] unless ; inline
DEFER: (read-json-string)
{ CHAR: t [ CHAR: \t ] }
{ CHAR: u [ over read-json-escape-unicode ] }
[ ]
- } case [ suffix! (read-json-string) ] [ throw-json-error ] if* ;
+ } case [ suffix! (read-json-string) ] [ json-error ] if* ;
: (read-json-string) ( stream accum -- accum )
{ sbuf } declare
[ length 1 - ] keep [ nth-unsafe ] [ shorten ] 2bi ; inline
: check-length ( seq n -- seq )
- [ dup length ] [ >= ] bi* [ throw-json-error ] unless ; inline
+ [ dup length ] [ >= ] bi* [ json-error ] unless ; inline
: v-over-push ( accum -- accum )
{ vector } declare 2 check-length
ERROR: libc-error errno message ;
-: (throw-errno) ( errno -- * ) dup strerror throw-libc-error ;
+: (throw-errno) ( errno -- * ) dup strerror libc-error ;
: throw-errno ( -- * ) errno (throw-errno) ;
drop "Memory allocation failed" ;
: check-ptr ( c-ptr -- c-ptr )
- [ throw-bad-ptr ] unless* ;
+ [ bad-ptr ] unless* ;
ERROR: realloc-error ptr size ;
: realloc ( alien size -- newalien )
[ >c-ptr ] dip
- over malloc-exists? [ throw-realloc-error ] unless
+ over malloc-exists? [ realloc-error ] unless
[ drop ] [ (realloc) check-ptr ] 2bi
[ delete-malloc ] [ add-malloc ] bi* ;
IN: locals
SYNTAX: :>
- in-lambda? get [ throw-:>-outside-lambda-error ] unless
+ in-lambda? get [ :>-outside-lambda-error ] unless
scan-token parse-def suffix! ;
SYNTAX: [| parse-lambda append! ;
ERROR: invalid-local-name name ;
: check-local-name ( name -- name )
- dup { "]" "]!" } member? [ throw-invalid-local-name ] when ;
+ dup { "]" "]!" } member? [ invalid-local-name ] when ;
: make-local ( name -- word )
check-local-name "!" ?tail [
: (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect )
with-lambda-scope <lambda>
[ nip "lambda" set-word-prop ]
- [ nip rewrite-closures dup length 1 = [ first ] [ throw-bad-rewrite ] if ]
+ [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
[ drop nip ] 3tri ; inline
: parse-locals-definition ( word reader-quot -- word quot effect )
: local-index ( args obj -- n )
2dup '[ unquote _ eq? ] find drop
- [ 2nip ] [ throw-bad-local ] if* ;
+ [ 2nip ] [ bad-local ] if* ;
: read-local-quot ( args obj -- quot )
local-index neg [ get-local ] curry ;
M: lambda rewrite-element rewrite-sugar* ;
-M: let rewrite-element throw-let-form-in-literal-error ;
+M: let rewrite-element let-form-in-literal-error ;
M: local rewrite-element , ;
M: local-reader rewrite-element , ;
M: local-writer rewrite-element
- throw-local-writer-in-literal-error ;
+ local-writer-in-literal-error ;
M: word rewrite-element <wrapper> , ;
ERROR: undefined-log-level ;
: log-level<=> ( log-level log-level -- <=> )
- [ log-levels at* [ throw-undefined-log-level ] unless ] compare ;
+ [ log-levels at* [ undefined-log-level ] unless ] compare ;
: log? ( log-level -- ? )
log-level get log-level<=> +lt+ = not ;
: check-log-message ( msg word level -- msg word level )
3dup [ string? ] [ word? ] [ word? ] tri* and and
- [ throw-bad-log-message-parameters ] unless ; inline
+ [ bad-log-message-parameters ] unless ; inline
: log-message ( msg word level -- )
check-log-message
PREDICATE: macro < word "macro" word-prop >boolean ;
-M: macro make-inline throw-cannot-be-inline ;
+M: macro make-inline cannot-be-inline ;
M: macro definer drop \ MACRO: \ ; ;
MACRO: match-cond ( assoc -- quot )
<reversed>
- dup ?first callable? [ unclip ] [ [ throw-no-match-cond ] ] if
+ dup ?first callable? [ unclip ] [ [ no-match-cond ] ] if
[
first2
[ [ dupd match ] curry ] dip
ERROR: bit-range-error x high low ;
: bit-range ( x high low -- y )
- 2dup { [ nip 0 < ] [ < ] } 2|| [ throw-bit-range-error ] when
+ 2dup { [ nip 0 < ] [ < ] } 2|| [ bit-range-error ] when
[ nip neg shift ] [ - 1 + ] 2bi bits ; inline
: bitroll ( x s w -- y )
ERROR: malformed-complex obj ;
: parse-complex ( seq -- complex )
- dup length 2 = [ first2-unsafe rect> ] [ throw-malformed-complex ] if ;
+ dup length 2 = [ first2-unsafe rect> ] [ malformed-complex ] if ;
SYNTAX: C{ \ } [ parse-complex ] parse-literal ;
: mod-inv ( x n -- y )
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
- [ throw-non-trivial-divisor ] if ; foldable
+ [ non-trivial-divisor ] if ; foldable
: ^mod ( x y n -- z )
over 0 <
[ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
: m^n ( m n -- n )
- dup 0 >= [ (m^n) ] [ throw-negative-power-matrix ] if ;
+ dup 0 >= [ (m^n) ] [ negative-power-matrix ] if ;
: stitch ( m -- m' )
[ ] [ [ append ] 2map ] map-reduce ;
M: word integer-op-input-classes
dup "input-classes" word-prop
- [ ] [ throw-bad-integer-op ] ?if ;
+ [ ] [ bad-integer-op ] ?if ;
: generic-variant ( op -- generic-op/f )
dup "derived-from" word-prop [ first ] [ ] ?if ;
make-bits { 1 } [ [ over p* ] when [ p-sq ] dip ] reduce nip ;
: p^ ( p n -- p^n )
- dup 0 >= [ (p^) ] [ throw-negative-power-polynomial ] if ;
+ dup 0 >= [ (p^) ] [ negative-power-polynomial ] if ;
<PRIVATE
: lucas-lehmer-guard ( obj -- obj )
dup { [ integer? ] [ 0 > ] } 1&&
- [ throw-invalid-lucas-lehmer-candidate ] unless ;
+ [ invalid-lucas-lehmer-candidate ] unless ;
PRIVATE>
ERROR: no-relative-prime n ;
: find-relative-prime* ( n guess -- p )
- [ dup 1 <= [ throw-no-relative-prime ] when ]
+ [ dup 1 <= [ no-relative-prime ] when ]
[ >odd dup 1 <= [ drop 3 ] when ] bi*
[ 2dup coprime? ] [ 2 + ] until nip ;
ERROR: too-few-primes n numbits ;
: unique-primes ( n numbits -- seq )
- 2dup 2^ estimated-primes > [ throw-too-few-primes ] when
+ 2dup 2^ estimated-primes > [ too-few-primes ] when
2dup [ random-prime ] curry replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
inputs narray
[ quot with-datastack ]
[ [ [ declaration declare quot call ] compile-call ] with-datastack ] bi
- 2dup = [ throw-optimized-vconvert-inconsistent ] unless
+ 2dup = [ optimized-vconvert-inconsistent ] unless
drop outputs firstn
] ;
{ uchar ushort uint ulonglong } member-eq? ;
: check-vconvert-type ( value expected-type -- value )
- 2dup instance? [ drop ] [ throw-bad-vconvert-input ] if ; inline
+ 2dup instance? [ drop ] [ bad-vconvert-input ] if ; inline
:: [vconvert] ( from-element to-element from-size to-size from-type to-type -- quot )
{
[ steps 1 = not ]
[ from-element to-element [ float-type? ] bi@ xor ]
[ from-element unsigned-type? to-element unsigned-type? not and ]
- } 0|| [ from-type to-type throw-bad-vconvert ] when ;
+ } 0|| [ from-type to-type bad-vconvert ] when ;
:: ([vpack-unsigned]) ( from-type to-type -- quot )
from-type new simd-rep
[ steps 1 = not ]
[ from-element to-element [ float-type? ] bi@ xor ]
[ from-element unsigned-type? not to-element unsigned-type? and ]
- } 0|| [ from-type to-type throw-bad-vconvert ] when ;
+ } 0|| [ from-type to-type bad-vconvert ] when ;
:: ([vunpack]) ( from-type to-type -- quot )
from-type new simd-rep
from-element heap-size :> from-size
to-element heap-size :> to-size
- from-length to-length = [ from-type to-type throw-bad-vconvert ] unless
+ from-length to-length = [ from-type to-type bad-vconvert ] unless
from-element to-element from-size to-size from-type to-type {
{ [ from-size to-size < ] [ [vunpack] ] }
M: simd-128 new-sequence
2dup length =
[ nip [ 16 (byte-array) ] make-underlying ]
- [ length throw-bad-simd-length ] if ; inline
+ [ length bad-simd-length ] if ; inline
M: simd-128 equal?
dup simd-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
A >>boxed-class
{ A-rep alien-vector A boa } >quotation >>getter
{
- [ dup simd-128? [ throw-bad-simd-vector ] unless underlying>> ] 2dip
+ [ dup simd-128? [ bad-simd-vector ] unless underlying>> ] 2dip
A-rep set-alien-vector
} >quotation >>setter
16 >>size
[ dup mime-separator>> dump-string >>name-content ] dip
>>name dup save-mime-part
] [
- throw-unknown-content-disposition
+ unknown-content-disposition
] if*
] if* ;
parse-content-disposition-form-data >>content-disposition
parse-form-data
] }
- [ throw-no-content-disposition ]
+ [ no-content-disposition ]
} case ;
: read-assert-sequence= ( sequence -- )
: check-set-slot ( val slot -- val offset )
{
- { [ dup not ] [ throw-no-such-slot ] }
- { [ dup read-only>> ] [ throw-read-only-slot ] }
+ { [ dup not ] [ no-such-slot ] }
+ { [ dup read-only>> ] [ read-only-slot ] }
{ [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
[ offset>> ]
} cond ; inline
: parse-here ( -- str )
[
lexer get
- dup rest-of-line [ throw-text-found-before-eol ] unless-empty
+ dup rest-of-line [ text-found-before-eol ] unless-empty
(parse-here)
] "" make but-last ;
begin-text lexer (parse-til-line-begins)
] if
] [
- begin-text throw-bad-heredoc
+ begin-text bad-heredoc
] if ;
: parse-til-line-begins ( begin-text lexer -- seq )
ERROR: bad-array-length n ;
: <nibble-array> ( n -- nibble-array )
- dup 0 < [ throw-bad-array-length ] when
+ dup 0 < [ bad-array-length ] when
dup nibbles>bytes <byte-array> nibble-array boa ; inline
M: nibble-array length length>> ;
{ $description "Annotate every OpenGL function to log using " { $link log-gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
HELP: reset-gl-functions
-{ $description "Removes any annotations from all OpenGL functions, such as those applied by " { $link throw-gl-errors } " or " { $link log-gl-errors } "." } ;
+{ $description "Removes any annotations from all OpenGL functions, such as those applied by " { $link gl-errors } " or " { $link log-gl-errors } "." } ;
-{ throw-gl-errors gl-error log-gl-errors log-gl-error clear-gl-error-log reset-gl-functions } related-words
+{ gl-errors gl-error log-gl-errors log-gl-error clear-gl-error-log reset-gl-functions } related-words
ARTICLE: "opengl.annotations" "OpenGL error reporting"
"The " { $vocab-link "opengl.annotations" } " vocabulary provides some tools for tracking down GL errors:"
{ $subsections
- throw-gl-errors
+ gl-errors
log-gl-errors
clear-gl-error-log
reset-gl-functions
{ [ os windows? ] [ "opengl.gl.windows" ] }
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
{ [ os unix? ] [ "opengl.gl.gtk" ] }
- [ throw-unknown-gl-platform ]
+ [ unknown-gl-platform ]
} cond use-vocab >>
SYMBOL: +gl-function-counter+
: image-internal-format ( component-order component-type -- internal-format )
2dup
[ fix-internal-component-order ] dip 2array image-internal-formats at
- [ 2nip ] [ throw-unsupported-component-order ] if* ;
+ [ 2nip ] [ unsupported-component-order ] if* ;
: reversed-type? ( component-type -- ? )
{ u-9-9-9-e5-components float-11-11-10-components } member? ;
{ RGBA [ drop GL_RGBA_INTEGER ] }
{ BGRX [ drop GL_BGRA_INTEGER ] }
{ RGBX [ drop GL_RGBA_INTEGER ] }
- [ swap throw-unsupported-component-order ]
+ [ swap unsupported-component-order ]
} case
] [
swap {
{ INTENSITY [ drop GL_INTENSITY ] }
{ DEPTH [ drop GL_DEPTH_COMPONENT ] }
{ DEPTH-STENCIL [ drop GL_DEPTH_STENCIL ] }
- [ swap throw-unsupported-component-order ]
+ [ swap unsupported-component-order ]
} case
] if ;
GENERIC: (component-type>type) ( component-order component-type -- gl-type )
-M: object (component-type>type) throw-unsupported-component-order ;
+M: object (component-type>type) unsupported-component-order ;
: four-channel-alpha-first? ( component-order component-type -- ? )
over component-count 4 =
[ drop alpha-channel-precedes-colors? ]
- [ throw-unsupported-component-order ] if ;
+ [ unsupported-component-order ] if ;
: not-alpha-first ( component-order component-type -- )
over alpha-channel-precedes-colors?
- [ throw-unsupported-component-order ]
+ [ unsupported-component-order ]
[ 2drop ] if ;
M: ubyte-components (component-type>type)
M: u-24-components (component-type>type)
over DEPTH =
[ 2drop GL_UNSIGNED_INT ]
- [ throw-unsupported-component-order ] if ;
+ [ unsupported-component-order ] if ;
M: u-24-8-components (component-type>type)
over DEPTH-STENCIL =
[ 2drop GL_UNSIGNED_INT_24_8 ]
- [ throw-unsupported-component-order ] if ;
+ [ unsupported-component-order ] if ;
M: u-9-9-9-e5-components (component-type>type)
over BGR =
[ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ]
- [ throw-unsupported-component-order ] if ;
+ [ unsupported-component-order ] if ;
M: float-11-11-10-components (component-type>type)
over BGR =
[ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ]
- [ throw-unsupported-component-order ] if ;
+ [ unsupported-component-order ] if ;
: image-data-format ( component-order component-type -- gl-format gl-type )
[ (component-order>format) ] [ (component-type>type) ] 2bi ;
: read-packed-bytes ( str -- bytes )
dup packed-length [ read dup length ] keep =
- [ nip ] [ throw-packed-read-fail ] if ; inline
+ [ nip ] [ packed-read-fail ] if ; inline
PRIVATE>
<PRIVATE
: lookup-rule ( rule parser -- rule' )
- 2dup rule [ 2nip ] [ throw-no-rule ] if* ;
+ 2dup rule [ 2nip ] [ no-rule ] if* ;
TUPLE: tokenizer-tuple any one many ;
drop "Tokenizer not found" ;
SYNTAX: TOKENIZER:
- scan-word-name dup search [ nip ] [ throw-no-tokenizer ] if*
+ scan-word-name dup search [ nip ] [ no-tokenizer ] if*
execute( -- tokenizer ) \ tokenizer set-global ;
TUPLE: ebnf-non-terminal symbol ;
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
(transform) [
- swap symbol>> dup get parser? [ throw-redefined-rule ] [ set ] if
+ swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
def call compile :> compiled-def
[
dup compiled-def compiled-parse
- [ ast>> ] [ word throw-parse-failed ] ?if
+ [ ast>> ] [ word parse-failed ] ?if
]
word swap effect define-declared
] with-compilation-unit
M: persistent-vector ppop ( pvec -- pvec' )
dup count>> {
- { 0 [ throw-empty-error ] }
+ { 0 [ empty-error ] }
{ 1 [ drop T{ persistent-vector } ] }
[
[
M: no-random-number-generator summary
drop "Random number generator is not defined." ;
-M: f random-bytes* ( n obj -- * ) throw-no-random-number-generator ;
+M: f random-bytes* ( n obj -- * ) no-random-number-generator ;
-M: f random-32* ( obj -- * ) throw-no-random-number-generator ;
+M: f random-32* ( obj -- * ) no-random-number-generator ;
: random-32 ( -- n )
random-generator get random-32* ;
ERROR: too-many-samples seq n ;
: sample ( seq n -- seq' )
- 2dup [ length ] dip < [ throw-too-many-samples ] when
+ 2dup [ length ] dip < [ too-many-samples ] when
[ [ length iota >array ] dip [ randomize-n-last ] keep tail-slice* ]
[ drop ] 2bi nths-unsafe ;
[ acquire-crypto-context ]
[
drop [ create-crypto-context ]
- [ throw-acquire-crypto-context-failed ] recover
+ [ acquire-crypto-context-failed ] recover
] recover ;
: initialize-crypto-context ( crypto-context -- crypto-context )
ERROR: bad-number ;
: ensure-number ( n -- n )
- [ throw-bad-number ] unless* ;
+ [ bad-number ] unless* ;
:: at-error ( key assoc quot: ( key -- replacement ) -- value )
key assoc at* [ drop key quot call ] unless ; inline
{ [ "script=" ?head ] [
dup simple-script-table at
[ <script-class> ]
- [ "script=" prepend throw-bad-class ] ?if
+ [ "script=" prepend bad-class ] ?if
] }
- [ throw-bad-class ]
+ [ bad-class ]
} cond ;
: unicode-class ( name -- class )
- dup parse-unicode-class [ ] [ throw-bad-class ] ?if ;
+ dup parse-unicode-class [ ] [ bad-class ] ?if ;
: name>class ( name -- class )
>string simple {
ERROR: nonexistent-option name ;
: ch>option ( ch -- singleton )
- dup options-assoc at [ ] [ throw-nonexistent-option ] ?if ;
+ dup options-assoc at [ ] [ nonexistent-option ] ?if ;
: option>ch ( option -- string )
options-assoc value-at ;
Times = "," Number:n "}" => [[ 0 n <from-to> ]]
| Number:n ",}" => [[ n <at-least> ]]
| Number:n "}" => [[ n n <from-to> ]]
- | "}" => [[ throw-bad-number ]]
+ | "}" => [[ bad-number ]]
| Number:n "," Number:m "}" => [[ n m <from-to> ]]
Repeated = Element:e "{" Times:t => [[ e t <times> ]]
ERROR: roman-range-error n ;
: roman-range-check ( n -- n )
- dup 1 10000 between? [ throw-roman-range-error ] unless ;
+ dup 1 10000 between? [ roman-range-error ] unless ;
: roman-digit-index ( ch -- n )
1string roman-digits index ; inline
<PRIVATE
: unrolled-bounds-check ( seq len quot -- seq len quot )
- 2over swap length > [ 2over throw-unrolled-bounds-error ] when ; inline
+ 2over swap length > [ 2over unrolled-bounds-error ] when ; inline
:: unrolled-2bounds-check ( xseq yseq len quot -- xseq yseq len quot )
{ [ len xseq length > ] [ len yseq length > ] } 0||
- [ xseq yseq len throw-unrolled-2bounds-error ]
+ [ xseq yseq len unrolled-2bounds-error ]
[ xseq yseq len quot ] if ; inline
: (unrolled-each) ( seq len quot -- len quot )
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
dup "\r\n>" intersects?
- [ throw-bad-email-address ] when ;
+ [ bad-email-address ] when ;
: mail-from ( fromaddr -- )
validate-address
: check-response ( response -- )
dup code>> {
{ [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
- { [ dup 400 499 between? ] [ drop throw-smtp-server-busy ] }
- { [ dup 500 = ] [ drop throw-smtp-syntax-error ] }
- { [ dup 501 = ] [ drop throw-smtp-command-not-implemented ] }
- { [ dup 500 509 between? ] [ drop throw-smtp-syntax-error ] }
- { [ dup 530 539 between? ] [ drop throw-smtp-bad-authentication ] }
- { [ dup 550 = ] [ drop throw-smtp-mailbox-unavailable ] }
- { [ dup 551 = ] [ drop throw-smtp-user-not-local ] }
- { [ dup 552 = ] [ drop throw-smtp-exceeded-storage-allocation ] }
- { [ dup 553 = ] [ drop throw-smtp-bad-mailbox-name ] }
- { [ dup 554 = ] [ drop throw-smtp-transaction-failed ] }
- [ drop throw-smtp-error ]
+ { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
+ { [ dup 500 = ] [ drop smtp-syntax-error ] }
+ { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
+ { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
+ { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
+ { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
+ { [ dup 551 = ] [ drop smtp-user-not-local ] }
+ { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
+ { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
+ { [ dup 554 = ] [ drop smtp-transaction-failed ] }
+ [ drop smtp-error ]
} cond ;
: get-ok ( -- ) receive-response check-response ;
: validate-header ( string -- string' )
dup "\r\n" intersects?
- [ throw-invalid-header-string ] when ;
+ [ invalid-header-string ] when ;
: write-header ( key value -- )
[ validate-header write ]
M: c-type-word c-array-constructor
underlying-type
dup [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-array-constructor drop void* c-array-constructor ;
M: c-type-word c-(array)-constructor
underlying-type
dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-(array)-constructor drop void* c-(array)-constructor ;
M: c-type-word c-direct-array-constructor
underlying-type
dup [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ;
M: c-type-word c-array-type
underlying-type
dup [ name>> "-array" append ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-array-type drop void* c-array-type ;
M: c-type-word c-array-type?
underlying-type
dup [ name>> "-array?" append ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-array-type? drop void* c-array-type? ;
ERROR: custom-error ;
{ T{ effect f { } { } t } } [
- [ throw-custom-error ] infer
+ [ custom-error ] infer
] unit-test
: funny-throw ( a -- * ) throw ; inline
] unit-test
{ T{ effect f { } { } t } } [
- [ throw-custom-error inference-error ] infer
+ [ custom-error inference-error ] infer
] unit-test
{ T{ effect f { "x" } { "x" "x" } t } } [
<PRIVATE
: check-annotate-twice ( word -- word )
- dup annotated? [ throw-cannot-annotate-twice ] when ;
+ dup annotated? [ cannot-annotate-twice ] when ;
: annotate-generic ( word quot -- )
[ "methods" word-prop values ] dip each ; inline
:: check-stream-read-unsafe-before ( n buf stream word -- n buf stream )
buf alien? [ n buf port ] [
n buf byte-length >
- [ n buf stream word throw-invalid-stream-read-unsafe ]
+ [ n buf stream word invalid-stream-read-unsafe ]
[ n buf stream ] if
] if ; inline
:: check-stream-read-unsafe-after ( count n buf stream word -- count )
count n >
- [ count n buf stream word throw-invalid-stream-read-unsafe-return ]
+ [ count n buf stream word invalid-stream-read-unsafe-return ]
[ count ] if ;
: (assert-stream-read-unsafe) ( word -- )
: copy-library ( dir library -- )
dup find-library-file
[ swap over file-name append-path copy-file ]
- [ throw-can't-deploy-library-file ] ?if ;
+ [ can't-deploy-library-file ] ?if ;
: copy-libraries ( manifest name dir -- )
append-path swap libraries>> [ copy-library ] with each ;
ERROR: no-vocab-main vocab ;
: check-vocab-main ( vocab -- vocab )
- [ require ] keep dup vocab-main [ throw-no-vocab-main ] unless ;
+ [ require ] keep dup vocab-main [ no-vocab-main ] unless ;
: deploy ( vocab -- )
- dup find-vocab-root [ check-vocab-main deploy* ] [ throw-no-vocab ] if ;
+ dup find-vocab-root [ check-vocab-main deploy* ] [ no-vocab ] if ;
: deploy-image-only ( vocab image -- )
[ vm-path ] 2dip
ERROR: cannot-define-array-in-deployed-app type ;
-: define-array-vocab ( type -- ) throw-cannot-define-array-in-deployed-app ;
+: define-array-vocab ( type -- ) cannot-define-array-in-deployed-app ;
cpu ppc? [ 100000 + ] when
os windows? [ 160000 + ] when
] bi*
- 2dup <= [ 2drop ] [ throw-image-too-big ] if ;
+ 2dup <= [ 2drop ] [ image-too-big ] if ;
: deploy-test-command ( -- args )
os macosx?
: check-ico-type ( bytes -- bytes )
dup "PNG" head? [
- "PNG" throw-unsupported-ico-format
+ "PNG" unsupported-ico-format
] when
dup B{ 0 0 } head? [
- "UNKNOWN" throw-unsupported-ico-format
+ "UNKNOWN" unsupported-ico-format
] unless ;
PRIVATE>
{ +file-date+ [ file-info>> modified>> listing-date ] }
{ +file-time+ [ file-info>> modified>> listing-time ] }
{ +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] }
- [ throw-unknown-file-spec ]
+ [ unknown-file-spec ]
} case ;
: list-files-fast ( listing-tool -- array )
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
: ensure-vocab-exists ( string -- string )
- dup loaded-vocab-names member? [ throw-no-vocab ] unless ;
+ dup loaded-vocab-names member? [ no-vocab ] unless ;
: check-root ( string -- string )
- dup vocab-root? [ throw-not-a-vocab-root ] unless ;
+ dup vocab-root? [ not-a-vocab-root ] unless ;
: check-vocab-root/vocab ( vocab-root string -- vocab-root string )
[ check-root ] [ check-vocab-name ] bi* ;
: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
: check-tr ( from to -- )
- [ [ ascii? ] all? ] both? [ throw-bad-tr ] unless ;
+ [ [ ascii? ] all? ] both? [ bad-tr ] unless ;
: compute-tr ( quot from to -- mapping )
[ 128 iota ] 3dip zip
: check-final ( class -- )
{
- { [ dup tuple-class? not ] [ throw-not-a-tuple ] }
- { [ dup final-class? not ] [ throw-not-final ] }
+ { [ dup tuple-class? not ] [ not-a-tuple ] }
+ { [ dup final-class? not ] [ not-final ] }
[ drop ]
} cond ;
:: (typed-get) ( name type getter: ( name -- value ) -- value )
name getter call :> value
- value type instance? [ name value type throw-variable-type-error ] unless
+ value type instance? [ name value type variable-type-error ] unless
value type declare1 ; inline
: typed-get ( name type -- value )
[ get-global ] (typed-get) ; inline
:: (typed-set) ( value name type setter: ( value name -- ) -- )
- value type instance? [ name value type throw-variable-type-error ] unless
+ value type instance? [ name value type variable-type-error ] unless
value name setter call ; inline
: typed-set ( value name type -- )
:: typed-inputs ( quot word types -- quot' )
types unboxed-types :> unboxed-types
- [ throw-input-mismatch-error ] word types make-unboxer
+ [ input-mismatch-error ] word types make-unboxer
unboxed-types quot '[ _ declare @ ]
compose ;
! typed outputs
:: typed-outputs ( quot word types -- quot' )
- [ throw-output-mismatch-error ] word types make-unboxer
+ [ output-mismatch-error ] word types make-unboxer
quot prepose ;
DEFER: make-boxer
dup {
[ effect-in-types typed-stack-effect? ]
[ effect-out-types typed-stack-effect? ]
- } 1|| [ (typed-def) ] [ nip throw-no-types-specified ] if ;
+ } 1|| [ (typed-def) ] [ nip no-types-specified ] if ;
M: typed-word subwords
[ call-next-method ]
{
{ [ dup string-array? ] [ ] }
{ [ dup string? ] [ ?string-lines ] }
- [ throw-not-a-string ]
+ [ not-a-string ]
} cond
] dip [ text<< ] [ relayout ] bi ; inline
: find-gl-context ( gadget -- )
find-world dup
- [ set-gl-context ] [ throw-no-world-found ] if ;
+ [ set-gl-context ] [ no-world-found ] if ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
: <pixel-format> ( world attributes -- pixel-format )
2dup (make-pixel-format)
[ pixel-format new-disposable swap >>handle swap >>world ]
- [ throw-invalid-pixel-format-attributes ]
+ [ invalid-pixel-format-attributes ]
?if ;
M: pixel-format dispose*
ERROR: no-group string ;
: ?group-id ( string -- id )
- dup group-struct [ nip gr_gid>> ] [ throw-no-group ] if* ;
+ dup group-struct [ nip gr_gid>> ] [ no-group ] if* ;
<PRIVATE
{ "vendor_id" [ >>vendor-id ] }
{ "wp" [ "yes" = >>wp? ] }
{ "TLB size" [ >>tlb-size ] }
- [ throw-unknown-cpuinfo-line ]
+ [ unknown-cpuinfo-line ]
} case ;
failed [
n narray
errno dup strerror
- word throw-unix-system-call-error
+ word unix-system-call-error
] [
n ndrop
ret
errno EINTR = [
n narray
errno dup strerror
- word throw-unix-system-call-error
+ word unix-system-call-error
] unless
] [
n ndrop
ERROR: no-user string ;
: ?user-id ( string -- id/f )
- dup user-passwd [ nip uid>> ] [ throw-no-user ] if* ;
+ dup user-passwd [ nip uid>> ] [ no-user ] if* ;
: real-user-id ( -- id )
unix.ffi:getuid ; inline
ERROR: no-such-user obj ;
: user-home ( name/uid -- path )
- dup user-passwd [ nip dir>> ] [ throw-no-such-user ] if* ;
+ dup user-passwd [ nip dir>> ] [ no-such-user ] if* ;
os macosx? [ "unix.users.macosx" require ] when
drop ; inline
M: unrolled-list pop-front*
- dup front>> [ throw-empty-unrolled-list ] unless*
+ dup front>> [ empty-unrolled-list ] unless*
over front-pos>> unroll-factor 1 - eq?
[ pop-front/new ] [ pop-front/existing ] if ;
drop ; inline
M: unrolled-list pop-back*
- dup back>> [ throw-empty-unrolled-list ] unless*
+ dup back>> [ empty-unrolled-list ] unless*
over back-pos>> 1 eq?
[ pop-back/new ] [ pop-back/existing ] if ;
: parse-host ( string -- host/f port/f )
[
":" split1-last [ url-decode ]
- [ dup [ string>number [ throw-malformed-port ] unless* ] when ] bi*
+ [ dup [ string>number [ malformed-port ] unless* ] when ] bi*
] [ f f ] if* ;
GENERIC: >url ( obj -- url )
ERROR: empty-vlist-error ;
M: vlist ppop
- [ throw-empty-vlist-error ]
+ [ empty-vlist-error ]
[ [ length>> 1 - ] [ vector>> ] bi vlist boa ] if-empty ;
M: vlist clone
ERROR: vocab-root-required root ;
: ensure-vocab-root ( root -- root )
- dup vocab-roots get member? [ throw-vocab-root-required ] unless ;
+ dup vocab-roots get member? [ vocab-root-required ] unless ;
: ensure-vocab-root/prefix ( root prefix -- root prefix )
[ ensure-vocab-root ] [ check-vocab-name ] bi* ;
IN: vocabs.metadata
: check-vocab ( vocab -- vocab )
- dup find-vocab-root [ throw-no-vocab ] unless ;
+ dup find-vocab-root [ no-vocab ] unless ;
MEMO: vocab-file-contents ( vocab name -- seq )
vocab-append-path dup
dupd vocab-append-path [
swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty
\ vocab-file-contents reset-memoized
- ] [ vocab-name throw-no-vocab ] ?if ;
+ ] [ vocab-name no-vocab ] ?if ;
: vocab-windows-icon-path ( vocab -- string )
vocab-dir "icon.ico" append-path ;
: vocab-platforms ( vocab -- platforms )
dup vocab-platforms-path vocab-file-contents
- [ dup "system" lookup-word [ ] [ throw-bad-platform ] ?if ] map ;
+ [ dup "system" lookup-word [ ] [ bad-platform ] ?if ] map ;
: set-vocab-platforms ( platforms vocab -- )
[ [ name>> ] map ] dip
TUPLE: unsupported-platform vocab requires ;
: throw-unsupported-platform ( vocab requires -- )
- \ unsupported-platform boa throw-continue ;
+ unsupported-platform boa throw-continue ;
M: unsupported-platform summary
drop "Current operating system not supported by this vocabulary" ;
[
dup vocab-platforms dup supported-platform?
- [ 2drop ] [ [ vocab-name ] dip throw-unsupported-platform ] if
+ [ 2drop ] [ [ vocab-name ] dip unsupported-platform ] if
] check-vocab-hook set-global
ERROR: null-com-release ;
: com-release ( interface -- )
- [ IUnknown::Release drop ] [ throw-null-com-release ] if* ; inline
+ [ IUnknown::Release drop ] [ null-com-release ] if* ; inline
: with-com-interface ( interface quot -- )
over [ com-release ] curry [ ] cleanup ; inline
: find-com-interface-definition ( name -- definition )
[
dup +com-interface-definitions+ get-global at*
- [ nip ] [ drop throw-no-com-interface ] if
+ [ nip ] [ drop no-com-interface ] if
] [ f ] if* ;
: save-com-interface-definition ( definition -- )
ERROR: gdi+-error status ;
: check-gdi+-status ( GpStatus -- )
- dup Ok = [ drop ] [ throw-gdi+-error ] if ;
+ dup Ok = [ drop ] [ gdi+-error ] if ;
CONSTANT: standard-gdi+-startup-input
S{ GdiplusStartupInput
dup iSockaddrLength>> {
{ 16 [ lpSockaddr>> sockaddr-in memory>struct ] }
{ 28 [ lpSockaddr>> sockaddr-in6 memory>struct ] }
- [ throw-unknown-sockaddr-length ]
+ [ unknown-sockaddr-length ]
} case ;
TYPEDEF: SOCKET_ADDRESS* PSOCKET_ADDRESS
drop
] [
[ key subkey mode ] dip n>win32-error-string
- throw-open-key-failed
+ open-key-failed
] if
] keep HKEY deref ;
hKey lpSubKey 0 lpClass dwOptions samDesired
lpSecurityAttributes
] dip n>win32-error-string
- throw-create-key-failed
+ create-key-failed
] unless ;
: create-key ( hkey lsubkey -- hkey )
ERROR: mci-error n ;
: check-mci-error ( n -- )
- [ throw-mci-error ] unless-zero ;
+ [ mci-error ] unless-zero ;
: open-command ( path -- )
"open \"%s\" type mpegvideo alias MediaFile" sprintf f 0 f
: winsock-error ( -- )
maybe-winsock-exception [ throw ] when* ;
-: (throw-winsock-error) ( n -- * )
- [ ] [ n>win32-error-string ] bi throw-winsock-exception ;
+: (winsock-error) ( n -- * )
+ [ ] [ n>win32-error-string ] bi winsock-exception ;
: throw-winsock-error ( -- * )
- WSAGetLastError (throw-winsock-error) ;
+ WSAGetLastError (winsock-error) ;
: winsock-error=0/f ( n/f -- )
- { 0 f } member? [ throw-winsock-error ] when ;
+ { 0 f } member? [ winsock-error ] when ;
: winsock-error!=0/f ( n/f -- )
- { 0 f } member? [ throw-winsock-error ] unless ;
+ { 0 f } member? [ winsock-error ] unless ;
! WSAStartup and WSACleanup return the error code directly
: winsock-return-check ( n/f -- )
children>string {
{ "1" [ t ] }
{ "0" [ f ] }
- [ "Bad boolean" throw-server-error ]
+ [ "Bad boolean" server-error ]
} case ;
: unstruct-member ( tag -- )
dup first-child-tag main>> "fault" =
[ parse-fault <rpc-fault> ]
[ parse-rpc-response <rpc-response> ] if
- ] [ "Bad main tag name" throw-server-error ] if
+ ] [ "Bad main tag name" server-error ] if
] if ;
<PRIVATE
drop "The tag-dispatching word has no method for the given tag name" ;
: compile-tags ( word xtable -- quot )
- >alist swap '[ _ throw-no-tag ] suffix '[ dup main>> _ case ] ;
+ >alist swap '[ _ no-tag ] suffix '[ dup main>> _ case ] ;
: define-tags ( word effect -- )
[ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
- throw-alien-callback-error ;
+ alien-callback-error ;
ERROR: alien-indirect-error ;
: alien-indirect ( args... funcptr return parameters abi -- return... )
- throw-alien-indirect-error ;
+ alien-indirect-error ;
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( args... return library function parameters -- return... )
- 2over throw-alien-invoke-error ;
+ 2over alien-invoke-error ;
ERROR: alien-assembly-error code ;
: alien-assembly ( args... return parameters abi quot -- return... )
- dup throw-alien-assembly-error ;
+ dup alien-assembly-error ;
<PRIVATE
ERROR: invalid-c-string string ;
: check-string ( string -- )
- 0 over member-eq? [ throw-invalid-c-string ] [ drop ] if ;
+ 0 over member-eq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
: check-classoids ( members -- members )
dup [ classoid? ] all?
- [ [ classoid? ] reject throw-not-classoids ] unless ;
+ [ [ classoid? ] reject not-classoids ] unless ;
ERROR: not-a-classoid object ;
: check-classoid ( object -- object )
- dup classoid? [ throw-not-a-classoid ] unless ;
+ dup classoid? [ not-a-classoid ] unless ;
: <anonymous-union> ( members -- classoid )
check-classoids
INSTANCE: anonymous-complement classoid
: <anonymous-complement> ( object -- classoid )
- dup classoid? [ 1array throw-not-classoids ] unless
+ dup classoid? [ 1array not-classoids ] unless
anonymous-complement boa ;
M: anonymous-complement rank-class drop 3 ;
: largest-class ( seq -- n elt )
dup [ [ class< ] with any? not ] curry find-last
- [ throw-topological-sort-failed ] unless* ;
+ [ topological-sort-failed ] unless* ;
: sort-classes ( seq -- newseq )
[ class-name ] sort-with >vector
ERROR: not-a-builtin object ;
: check-builtin ( class -- )
- dup builtin-class? [ drop ] [ throw-not-a-builtin ] if ;
+ dup builtin-class? [ drop ] [ not-a-builtin ] if ;
: class>type ( class -- n ) "type" word-prop ; foldable
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
: check-inheritance ( subclass superclass -- )
- 2dup superclass-of? [ throw-bad-inheritance ] [ 2drop ] if ;
+ 2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ;
: define-class ( word superclass members participants metaclass -- )
[ 2dup check-inheritance ] 3dip
! Test error classes
ERROR: error-class-test a b c ;
-{ "( a b c -- * )" } [ \ throw-error-class-test stack-effect effect>string ] unit-test
-{ f } [ \ throw-error-class-test "inline" word-prop ] unit-test
+{ "( a b c -- * )" } [ \ error-class-test stack-effect effect>string ] unit-test
+{ f } [ \ error-class-test "inline" word-prop ] unit-test
[ "IN: classes.error.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ]
[ error>> error>> redefine-error? ] must-fail-with
ERROR: base-error x y ;
ERROR: derived-error < base-error z ;
-{ ( x y z -- * ) } [ \ throw-derived-error stack-effect ] unit-test
+{ ( x y z -- * ) } [ \ derived-error stack-effect ] unit-test
[ all-slots thrower-effect ]
tri define-declared
]
- [
- 2drop
- [ name>> "throw-" prepend create-word-in [ reset-generic ] keep ]
- [ [ boa throw ] curry ]
- [ all-slots thrower-effect ]
- tri define-declared
- ]
} 3cleave ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
- throw-check-mixin-class-error
+ check-mixin-class-error
] unless ;
<PRIVATE
: check-duplicate-slots ( slots -- )
slot-names duplicates
- [ throw-duplicate-slot-names ] unless-empty ;
+ [ duplicate-slot-names ] unless-empty ;
ERROR: invalid-slot-name name ;
!
! : ...
{
- { [ dup { ":" "(" "<" "\"" "!" } member? ] [ throw-invalid-slot-name ] }
+ { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond nip ;
ERROR: bad-slot-name class slot ;
: check-slot-name ( class slots name -- name )
- 2dup swap slot-named [ 2nip ] [ nip throw-bad-slot-name ] if ;
+ 2dup swap slot-named [ 2nip ] [ nip bad-slot-name ] if ;
: parse-slot-value ( class slots -- )
scan-token check-slot-name scan-object 2array , scan-token {
{ "}" [ ] }
- [ throw-bad-literal-tuple ]
+ [ bad-literal-tuple ]
} case ;
: (parse-slot-values) ( class slots -- )
scan-token {
{ "{" [ (parse-slot-values) ] }
{ "}" [ 2drop ] }
- [ 2nip throw-bad-literal-tuple ]
+ [ 2nip bad-literal-tuple ]
} case ;
: parse-slot-values ( class slots -- values )
swap slots>tuple ;
: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
- over [ drop ] [ nip nip nip throw-bad-slot-name ] if ;
+ over [ drop ] [ nip nip nip bad-slot-name ] if ;
: slot-named-checked ( class initials name slots -- class initials slot-spec )
over [ slot-named* ] dip check-slot-exists drop ;
{ "f" [ drop \ } parse-until boa>object ] }
{ "{" [ 2dup parse-slot-values assoc>object ] }
{ "}" [ drop new ] }
- [ throw-bad-literal-tuple ]
+ [ bad-literal-tuple ]
} case ;
: parse-tuple-literal ( -- tuple )
: offset-of-slot ( name tuple -- n )
2dup class-of all-slots slot-named
- [ 2nip offset>> ] [ throw-no-slot ] if* ;
+ [ 2nip offset>> ] [ no-slot ] if* ;
: get-slot-named ( name tuple -- value )
[ nip ] [ offset-of-slot ] 2bi slot ;
[ [ layout-of ] [ class-of tuple-layout ] bi eq? ] [ drop t ] if ;
: check-tuple ( object -- tuple )
- dup tuple? [ throw-not-a-tuple ] unless ; inline
+ dup tuple? [ not-a-tuple ] unless ; inline
: prepare-tuple-slots ( tuple -- n tuple )
check-tuple [ tuple-size iota ] keep ;
ERROR: not-a-tuple-class object ;
: check-tuple-class ( class -- class )
- dup tuple-class? [ throw-not-a-tuple-class ] unless ; inline
+ dup tuple-class? [ not-a-tuple-class ] unless ; inline
: define-boa-word ( word class -- )
check-tuple-class [ [ boa ] curry ] [ boa-effect ] bi
dup dup [ classes-contained-by ] map concat sift append
2dup set= [ 2drop f ] [ nip ] if
] follow concat
- member-eq? [ throw-cannot-reference-self ] when ;
+ member-eq? [ cannot-reference-self ] when ;
PRIVATE>
check-datastack
] if
] 2dip rot
- [ 2drop ] [ throw-wrong-values ] if ;
+ [ 2drop ] [ wrong-values ] if ;
: execute-effect ( word effect -- )
[ [ execute ] curry ] dip call-effect ;
ERROR: not-a-continuation object ;
: >continuation< ( continuation -- data call retain name catch )
- dup continuation? [ throw-not-a-continuation ] unless
+ dup continuation? [ not-a-continuation ] unless
{ [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ] } cleave ; inline
PRIVATE>
ERROR: no-compilation-unit definition ;
: add-to-unit ( key set -- )
- [ adjoin ] [ throw-no-compilation-unit ] if* ;
+ [ adjoin ] [ no-compilation-unit ] if* ;
SYMBOL: changed-definitions
disposables get adjoin ;
: unregister-disposable ( obj -- )
- disposables get 2dup in? [ delete ] [ drop throw-already-unregistered ] if ;
+ disposables get 2dup in? [ delete ] [ drop already-unregistered ] if ;
PRIVATE>
: check-stack-effect ( word effect -- )
over stack-effect 2dup effect=
- [ 3drop ] [ throw-bad-stack-effect ] if ;
+ [ 3drop ] [ bad-stack-effect ] if ;
: parse-effect-var ( first? var name -- var )
nip
- [ ":" ?tail [ throw-row-variable-can't-have-type ] when ] curry
- [ throw-invalid-row-variable ] if ;
+ [ ":" ?tail [ row-variable-can't-have-type ] when ] curry
+ [ invalid-row-variable ] if ;
: parse-effect-value ( token -- value )
":" ?tail [ scan-object 2array ] when ;
: parse-effect-token ( first? var end -- var more? )
scan-token {
{ [ end-token? ] [ drop nip f ] }
- { [ effect-opener? ] [ throw-bad-effect ] }
- { [ effect-closer? ] [ throw-stack-effect-omits-dashes ] }
+ { [ effect-opener? ] [ bad-effect ] }
+ { [ effect-closer? ] [ stack-effect-omits-dashes ] }
{ [ row-variable? ] [ parse-effect-var t ] }
[ [ drop ] 2dip parse-effect-value , t ]
} cond ;
"methods" word-prop at ;
: lookup-method ( class generic -- method )
- 2dup ?lookup-method [ 2nip ] [ throw-method-lookup-failed ] if* ;
+ 2dup ?lookup-method [ 2nip ] [ method-lookup-failed ] if* ;
<PRIVATE
ERROR: no-math-method left right generic ;
: default-math-method ( generic -- quot )
- [ throw-no-math-method ] curry [ ] like ;
+ [ no-math-method ] curry [ ] like ;
<PRIVATE
ERROR: bad-method-effect ;
: check-method-effect ( effect -- )
- last-word generic-effect method-effect= [ throw-bad-method-effect ] unless ;
+ last-word generic-effect method-effect= [ bad-method-effect ] unless ;
: ?execute-parsing ( word/number -- seq )
dup parsing-word?
PREDICATE: single-generic < generic
"combination" word-prop single-combination? ;
-M: single-generic make-inline throw-cannot-be-inline ;
+M: single-generic make-inline cannot-be-inline ;
GENERIC: dispatch# ( word -- n )
[
pick predicate-def %
1quotation ,
- [ throw-inconsistent-next-method ] 2curry ,
+ [ inconsistent-next-method ] 2curry ,
\ if ,
] [ ] make picker prepend
] [ 3drop f ] if
bi or ;
M: single-combination make-default-method
- [ [ picker ] dip [ throw-no-method ] curry append ] with-combination ;
+ [ [ picker ] dip [ no-method ] curry append ] with-combination ;
! ! ! Build an engine ! ! !
: prune-redundant-predicates ( assoc -- default assoc' )
{
- { [ dup empty? ] [ drop [ throw-unreachable ] { } ] }
+ { [ dup empty? ] [ drop [ unreachable ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
[ [ first second ] [ rest-slice ] bi ]
ERROR: malformed-hashtable-pair seq pair ;
: check-hashtable ( seq -- seq )
- dup [ dup length 2 = [ drop ] [ throw-malformed-hashtable-pair ] if ] each ;
+ dup [ dup length 2 = [ drop ] [ malformed-hashtable-pair ] if ] each ;
: parse-hashtable ( seq -- hashtable )
check-hashtable H{ } assoc-clone-like ;
M: ascii encode-char
drop
- over 127 <= [ stream-write1 ] [ throw-encode-error ] if ; inline
+ over 127 <= [ stream-write1 ] [ encode-error ] if ; inline
<PRIVATE
M: string ascii>
dup aux>>
- [ [ dup 127 <= [ throw-encode-error ] unless ] B{ } map-as ]
+ [ [ dup 127 <= [ encode-error ] unless ] B{ } map-as ]
[ string>byte-array-fast ] if ; inline
PRIVATE>
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf16le ] [
- bom-be sequence= [ utf16be ] [ throw-missing-bom ] if
+ bom-be sequence= [ utf16be ] [ missing-bom ] if
] if ;
M: utf16 <decoder> ( stream utf16 -- decoder )
drop "." swap
] if
{ "" "." ".." } member? [
- throw-no-parent-directory
+ no-parent-directory
] when
] unless ;
{ [ dup head.? ] [
rest trim-head-separators append-path-empty
] }
- { [ dup head..? ] [ drop throw-no-parent-directory ] }
+ { [ dup head..? ] [ drop no-parent-directory ] }
[ nip ]
} cond ;
ERROR: assert got expect ;
-: assert= ( a b -- ) 2dup = [ 2drop ] [ throw-assert ] if ;
+: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
<PRIVATE
ERROR: not-a-lexer object ;
: check-lexer ( lexer -- lexer )
- dup lexer? [ throw-not-a-lexer ] unless ; inline
+ dup lexer? [ not-a-lexer ] unless ; inline
: next-line ( lexer -- )
check-lexer
ERROR: log2-expects-positive x ;
: log2 ( x -- n )
- dup 0 <= [ throw-log2-expects-positive ] [ (log2) ] if ; inline
+ dup 0 <= [ log2-expects-positive ] [ (log2) ] if ; inline
: zero? ( x -- ? ) 0 number= ; inline
: 2/ ( x -- y ) -1 shift ; inline
1 over (count-digits) <sbuf> (fixnum>dec) "" like reverse! nip ; inline
: (positive>base) ( num radix -- str )
- dup 1 <= [ throw-invalid-radix ] when
+ dup 1 <= [ invalid-radix ] when
[ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
reverse! ; inline
{ 16 [ [ float>hex-value ] swap (bin-float>base) ] }
{ 8 [ [ float>oct-value ] swap (bin-float>base) ] }
{ 2 [ [ float>bin-value ] swap (bin-float>base) ] }
- [ throw-invalid-radix ]
+ [ invalid-radix ]
} case ;
: format-string ( format -- format )
M: integer /
[
- throw-division-by-zero
+ division-by-zero
] [
dup 0 < [ [ neg ] bi@ ] when
2dup fast-gcd [ /i ] curry bi@ fraction>
M: integer recip
1 swap [
- throw-division-by-zero
+ division-by-zero
] [
dup 0 < [ [ neg ] bi@ ] when fraction>
] if-zero ;
ERROR: number-expected ;
: parse-number ( string -- number )
- string>number [ throw-number-expected ] unless* ;
+ string>number [ number-expected ] unless* ;
: parse-datum ( string -- word/number )
dup search [ ] [
: scan-word-name ( -- string )
scan-token
dup "\"" = [ t ] [ dup string>number ] if
- [ throw-invalid-word-name ] when ;
+ [ invalid-word-name ] when ;
: scan-new ( -- word )
scan-word-name create-word-in ;
pop-parsing-word ; inline
: execute-parsing ( accum word -- accum )
- dup changed-definitions get in? [ throw-staging-violation ] when
+ dup changed-definitions get in? [ staging-violation ] when
(execute-parsing) ;
: scan-object ( -- object )
dupd length < [ 0 >= ] [ drop f ] if ; inline
: bounds-check ( n seq -- n seq )
- 2dup bounds-check? [ throw-bounds-error ] unless ; inline
+ 2dup bounds-check? [ bounds-error ] unless ; inline
MIXIN: immutable-sequence
ERROR: immutable element index sequence ;
-M: immutable-sequence set-nth throw-immutable ;
+M: immutable-sequence set-nth immutable ;
INSTANCE: immutable-sequence sequence
3dup nip new-sequence 0 swap <copy> ; inline
: bounds-check-head ( n seq -- n seq )
- over 0 < [ throw-bounds-error ] when ; inline
+ over 0 < [ bounds-error ] when ; inline
: check-copy ( src n dst -- src n dst )
3dup bounds-check-head
: last ( seq -- elt )
[ length 1 - ] keep
- over 0 < [ throw-bounds-error ] [ nth-unsafe ] if ; inline
+ over 0 < [ bounds-error ] [ nth-unsafe ] if ; inline
<PRIVATE
: set-last ( elt seq -- )
[ length 1 - ] keep
- over 0 < [ throw-bounds-error ] [ set-nth-unsafe ] if ; inline
+ over 0 < [ bounds-error ] [ set-nth-unsafe ] if ; inline
: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
: pop ( seq -- elt )
[ length 1 - ] keep over 0 >=
[ [ nth-unsafe ] [ shorten ] 2bi ]
- [ throw-bounds-error ] if ;
+ [ bounds-error ] if ;
: exchange ( m n seq -- )
[ nip bounds-check 2drop ]
[
\ dup ,
[ predicate-def % ]
- [ [ throw-bad-slot-value ] curry , ] bi
+ [ [ bad-slot-value ] curry , ] bi
\ unless ,
] [ ] make ;
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
- [ throw-bad-slot-attribute ]
+ [ bad-slot-attribute ]
} case
] unless ;
ERROR: invalid-source-file-path path ;
: path>source-file ( path -- source-file )
- dup string? [ throw-invalid-source-file-path ] unless
+ dup string? [ invalid-source-file-path ] unless
source-files get [ <source-file> ] cache ;
: reset-checksums ( -- )
{ CHAR: 0 CHAR: \0 }
{ CHAR: \\ CHAR: \\ }
{ CHAR: \" CHAR: \" }
- } ?at [ throw-bad-escape ] unless ;
+ } ?at [ bad-escape ] unless ;
SYMBOL: name>char-hook
dup still-parsing-line? [
[ current-char ] [ advance-char ] bi
] [
- throw-escaped-char-expected
+ escaped-char-expected
] if ;
: lexer-head? ( lexer string -- ? )
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
-{ $description "Defines a new tuple class and a word " { $snippet "throw-classname" } " that throws a new instance of the error." }
+{ $description "Defines a new tuple class and a word " { $snippet "classname" } " that throws a new instance of the error." }
{ $notes
"The following two snippets are equivalent:"
{ $code
: define-core-syntax ( name quot -- )
[
- dup "syntax" lookup-word [ ] [ throw-no-word-error ] ?if
+ dup "syntax" lookup-word [ ] [ no-word-error ] ?if
mark-top-level-syntax
] dip
define-syntax ;
literalize suffix!
\ (call-next-method) suffix!
] [
- throw-not-in-a-method-error
+ not-in-a-method-error
] if*
] define-core-syntax
HELP: no-vocab
{ $values { "name" "a vocabulary name" } }
-{ $description "A " { $link no-vocab } " error tuple. Call " { $link throw-no-vocab } " to throw it." }
+{ $description "A " { $link no-vocab } " error tuple. Call " { $link no-vocab } " to throw it." }
{ $error-description "Thrown when a " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " form refers to a non-existent vocabulary." } ;
HELP: load-help?
vocab-roots get [ prepend-path exists? ] with find nip ;
M: string vocab-path ( string -- path/f )
- dup find-root-for [ prepend-path ] [ throw-not-found-in-roots ] if* ;
+ dup find-root-for [ prepend-path ] [ not-found-in-roots ] if* ;
PRIVATE>
[
drop dup find-vocab-root
[ (require) ]
- [ dup lookup-vocab [ drop ] [ throw-no-vocab ] if ]
+ [ dup lookup-vocab [ drop ] [ no-vocab ] if ]
if
] if
] require-hook set-global
: extract-words ( seq vocab -- assoc )
[ words>> extract-keys dup ] [ name>> ] bi
- [ swap [ 2drop ] [ throw-no-word-in-vocab ] if ] curry assoc-each ;
+ [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
: excluding-words ( seq vocab -- assoc )
[ nip words>> ] [ extract-words ] 2bi assoc-diff ;
: begin-private ( -- )
current-vocab name>> ".private" ?tail
- [ throw-unbalanced-private-declaration ]
+ [ unbalanced-private-declaration ]
[ ".private" append set-current-vocab ] if ;
: end-private ( -- )
current-vocab name>> ".private" ?tail
[ set-current-vocab ]
- [ throw-unbalanced-private-declaration ] if ;
+ [ unbalanced-private-declaration ] if ;
: using-vocab? ( vocab -- ? )
vocab-name manifest get search-vocab-names>> in? ;
: <rename> ( word vocab new-name -- rename )
[
2dup load-vocab words>> dupd at
- [ ] [ swap throw-no-word-in-vocab ] ?if
+ [ ] [ swap no-word-in-vocab ] ?if
] dip associate rename boa ;
: add-renamed-word ( word vocab new-name -- )
ERROR: bad-vocab-name name ;
: check-vocab-name ( name -- name )
- dup string? [ throw-bad-vocab-name ] unless
- dup [ ":/\\ " member? ] any? [ throw-bad-vocab-name ] when ;
+ dup string? [ bad-vocab-name ] unless
+ dup [ ":/\\ " member? ] any? [ bad-vocab-name ] when ;
TUPLE: vocab-link name ;
[ drop vocabulary>> = ]
[ drop nip primitive? ]
[ [ nip "declared-effect" word-prop ] dip = ] 3tri and and
- [ 3drop ] [ throw-invalid-primitive ] if ;
+ [ 3drop ] [ invalid-primitive ] if ;
: lookup-word ( name vocab -- word ) vocab-words-assoc at ;
: reveal ( word -- )
dup [ name>> ] [ vocabulary>> ] bi dup vocab-words-assoc
- [ ] [ throw-no-vocab ] ?if set-at ;
+ [ ] [ no-vocab ] ?if set-at ;
ERROR: bad-create name vocab ;
: check-create ( name vocab -- name vocab )
2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and
- [ throw-bad-create ] unless ;
+ [ bad-create ] unless ;
: create-word ( name vocab -- word )
check-create 2dup lookup-word
: demangle-error ( name status -- )
{
{ 0 [ drop ] }
- { -1 [ drop throw-demangle-memory-allocation-failure ] }
- { -2 [ throw-invalid-mangled-name ] }
- { -3 [ throw-invalid-demangle-args ] }
+ { -1 [ drop demangle-memory-allocation-failure ] }
+ { -2 [ invalid-mangled-name ] }
+ { -3 [ invalid-demangle-args ] }
} case ;
: mangled-name? ( name -- ? )
dims>> [ product 2array ] when* ;
MACRO: size-case-type ( cases -- quot )
- [ throw-invalid-fortran-type ] suffix
+ [ invalid-fortran-type ] suffix
'[ [ size>> _ case ] [ append-dimensions ] bi ] ;
: simple-type ( type base-c-type -- c-type )
swap
- [ dup size>> [ throw-invalid-fortran-type ] [ drop ] if ]
+ [ dup size>> [ 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>> [ throw-invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
+ [ dup dims>> [ 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 ] ] }
- [ throw-invalid-fortran-type ]
+ [ invalid-fortran-type ]
} case
] args?dims ;
{ f [ [ c:float <ref> ] [ drop ] ] }
{ 4 [ [ c:float <ref> ] [ drop ] ] }
{ 8 [ [ c:double <ref> ] [ drop ] ] }
- [ throw-invalid-fortran-type ]
+ [ invalid-fortran-type ]
} case
] args?dims ;
{ f [ [ <complex-float> ] [ drop ] ] }
{ 8 [ [ <complex-float> ] [ drop ] ] }
{ 16 [ [ <complex-double> ] [ drop ] ] }
- [ throw-invalid-fortran-type ]
+ [ invalid-fortran-type ]
} case
] args?dims ;
{ 2 [ { [ c:short deref ] } ] }
{ 4 [ { [ c:int deref ] } ] }
{ 8 [ { [ c:longlong deref ] } ] }
- [ throw-invalid-fortran-type ]
+ [ invalid-fortran-type ]
} case
] result?dims ;
{ f [ { [ c:float deref ] } ] }
{ 4 [ { [ c:float deref ] } ] }
{ 8 [ { [ c:double deref ] } ] }
- [ throw-invalid-fortran-type ]
+ [ invalid-fortran-type ]
} case ] result?dims ;
M: real-complex-type (fortran-result>)
{ f [ { [ *complex-float ] } ] }
{ 8 [ { [ *complex-float ] } ] }
{ 16 [ { [ *complex-double ] } ] }
- [ throw-invalid-fortran-type ]
+ [ 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? [ throw-no-negative-shape-components ] when ;
+ dup [ 0 < ] any? [ no-negative-shape-components ] when ;
GENERIC: shape-capacity ( shape -- n )
GENERIC: check-underlying-shape ( underlying shape -- underlying shape )
M: abnormal-shape check-underlying-shape
- throw-no-abnormally-shaped-arrays ;
+ no-abnormally-shaped-arrays ;
M: uniform-shape check-underlying-shape
shape>> check-underlying-shape ;
M: sequence check-underlying-shape
2dup [ length ] [ shape-capacity ] bi*
- = [ throw-underlying-shape-mismatch ] unless ; inline
+ = [ underlying-shape-mismatch ] unless ; inline
ERROR: shape-mismatch shaped0 shaped1 ;
: check-shape ( shaped-array shaped-array -- shaped-array shaped-array )
2dup [ shape>> ] bi@
- sequence= [ throw-shape-mismatch ] unless ;
+ sequence= [ 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 throw-unsupported-tag-encoding
+ get-id 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 throw-format-unsupported-by-openal ]
+ [ drop format-unsupported-by-openal ]
} case ;
: ensured-read ( count -- output/f )
[ read ] keep over length = [ drop f ] unless ;
: ensured-read* ( count -- output )
- ensured-read [ throw-invalid-audio-file ] unless* ;
+ ensured-read [ 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 throw-audio-device-not-found ] unless
+ al-device [ device-name audio-device-not-found ] unless
al-device |alcCloseDevice* drop
al-device f alcCreateContext :> al-context
- al-context [ device-name throw-audio-context-not-available ] unless
+ al-context [ device-name 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 ) ]
- [ throw-unknown-audio-extension ] if ;
+ [ unknown-audio-extension ] if ;
"audio.wav" require
"audio.aiff" require
stream>> read-bytes-into ; inline
: ?ogg-error ( n -- )
- dup 0 < [ throw-ogg-error ] [ drop ] if ; inline
+ dup 0 < [ 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 -- )
- [ throw-vorbis-error ] unless-zero ; inline
+ [ vorbis-error ] unless-zero ; inline
: get-remaining-vorbis-header-packet ( player -- ? )
[ stream-state>> ] [ packet>> ] bi ogg_stream_packetout {
- { [ dup 0 < ] [ throw-vorbis-error ] }
+ { [ dup 0 < ] [ vorbis-error ] }
{ [ dup zero? ] [ drop f ] }
[ drop t ]
} cond ;
: initialize-decoder ( vorbis-stream -- )
dup #vorbis-headers>> zero?
- [ throw-no-vorbis-in-ogg ]
+ [ 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 ] [ throw-amb-failure ] if* ;
+ failure get [ continue ] [ amb-failure ] if* ;
: must-be-true ( ? -- )
[ fail ] unless ;
: base85>ch ( ch -- ch )
$[ alphabet alphabet-inverse ] nth
- [ throw-malformed-base85 ] unless* ; inline
+ [ 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) ] }
- [ throw-malformed-base85 ]
+ [ malformed-base85 ]
} case ;
PRIVATE>
{ { yellow blue } [ red ] }
{ { blue red } [ yellow ] }
{ { blue yellow } [ red ] }
- [ throw-bad-color-pair ]
+ [ bad-color-pair ]
} case
] if ;
ERROR: incorrect-#bytes ;
: check-bytes ( bytes n -- bytes )
- over length = [ throw-incorrect-#bytes ] unless ;
+ over length = [ 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? [ throw-incorrect-#bytes ] unless
+ contents empty? [ incorrect-#bytes ] unless
] with-client
] with-threaded-server ;
: check-status ( json -- json )
dup "status_code" of 200 = [
dup "status_txt" of
- throw-bad-response
+ bad-response
] unless ;
: json-data ( url -- json )
! 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 <= [ throw-invalid-size ] when ;
+ dup first 0 <= [ 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 <= [ throw-invalid-capacity ] when ;
+ dup 0 <= [ invalid-capacity ] when ;
: check-error-rate ( error-rate -- error-rate )
dup [ 0 after? ] [ 1 before? ] bi and
- [ throw-invalid-error-rate ] unless ;
+ [ 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" throw-unknown-bson-type ]
+ [ "unknown binary sub-type" 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" throw-unknown-bson-type ]
+ [ "type unknown" 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 ] }
- [ throw-bad-include-line ]
+ [ bad-include-line ]
} case ;
: (readlns) ( -- )
{ "else" [ handle-else ] }
{ "pragma" [ handle-pragma ] }
{ "include_next" [ handle-include-next ] }
- [ throw-unknown-c-preprocessor ]
+ [ unknown-c-preprocessor ]
} case ;
: parse-directive-line ( preprocessor-state sequence-parser -- )
<PRIVATE
: draw-hello-world ( gadget -- )
- cairo-t>> [ throw-no-cairo-t ] unless*
+ cairo-t>> [ 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? [ throw-repeated-constructor-parameters ] unless
+ dup in>> all-unique? [ repeated-constructor-parameters ] unless
2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
- [ throw-unknown-constructor-parameters ] unless-empty ;
+ [ unknown-constructor-parameters ] unless-empty ;
: constructor-boa-quot ( constructor-word class effect -- word quot )
in>> swap '[ _ _ slots>boa ] ; inline
dup instruction-cycles nth [
nip
] [
- throw-undefined-8080-opcode
+ undefined-8080-opcode
] if* ;
: process-interrupts ( cpu -- )
ERROR: aes-192-256-not-implemented ;
M: aes-256-key key-expand-round ( temp i -- temp' )
- throw-aes-192-256-not-implemented ;
+ aes-192-256-not-implemented ;
: (key-sched-round) ( output temp i -- output' )
key-expand-round
ERROR: empty-xor-key ;
: xor-crypt ( seq key -- seq' )
- [ throw-empty-xor-key ] when-empty
+ [ 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 ] [ throw-cuda-error-state ] if ;
+ dup CUDA_SUCCESS = [ drop ] [ 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 [ throw-no-cuda-library ] unless ;
+ cuda-libraries get ?at [ no-cuda-library ] unless ;
: remove-cuda-library ( name -- library )
- cuda-libraries get ?delete-at [ throw-no-cuda-library ] unless ;
+ cuda-libraries get ?delete-at [ 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? [ throw-bad-cuda-abi ] unless ; inline
+ dup cuda-abi? [ 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 throw-nvcc-failed ] unless-zero
+ run-process wait-for-process [ path2 nvcc-failed ] unless-zero
path2 cu>ptx
] with-directory ;
: check-filetype ( filetype -- filetype )
dup { "BINARY" "MOTOROLA" "AIFF" "WAVE" "MP3" } member?
- [ throw-unknown-filetype ] unless ;
+ [ unknown-filetype ] unless ;
ERROR: unknown-flag flag ;
: >BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline
: curses-pointer-error ( ptr/f -- ptr )
- [ throw-curses-failed ] unless* ; inline
-: curses-error ( n -- ) ffi:ERR = [ throw-curses-failed ] when ;
+ [ curses-failed ] unless* ; inline
+: curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ;
PRIVATE>
[ current-window ] dip with-variable ; inline
: with-curses ( window quot -- )
- curses-ok? [ throw-unsupported-curses-terminal ] unless
+ curses-ok? [ unsupported-curses-terminal ] unless
[
'[
ffi:initscr curses-pointer-error
M: input-cursor cursor-key-value
dup cursor-valid?
[ cursor-key-value-unsafe ]
- [ throw-invalid-cursor ] if ; inline
+ [ invalid-cursor ] if ; inline
: cursor-key ( cursor -- key ) cursor-key-value drop ;
: cursor-value ( cursor -- key ) cursor-key-value nip ;
M: output-cursor set-cursor-value
dup cursor-valid?
[ set-cursor-value-unsafe ]
- [ throw-invalid-cursor ] if ; inline
+ [ 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 throw-decimal-test-failure ] if ; inline
+ [ t ] [ D1 D2 quot1 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?
- [ throw-decimal-types-expected ] unless ;
+ [ decimal-types-expected ] unless ;
M: decimal equal?
{
: rethrower ( word inputs -- quot )
[ length ] keep [ [ narray ] dip swap 2array flip ] 2curry
- [ 2 ndip throw-descriptive-error ] 2curry ;
+ [ 2 ndip descriptive-error ] 2curry ;
: [descriptive] ( word def effect -- newdef )
swapd in>> rethrower [ recover ] 2curry ;
: >n/label ( string -- byte-array )
dup [ ascii? ] all?
- [ throw-unsupported-domain-name ] unless
+ [ 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 ] [ throw-fdb-error ] if ;
+ dup FDB_RESULT_SUCCESS = [ drop ] [ fdb-error ] if ;
TUPLE: fdb-kvs-handle < disposable handle ;
rot {
{ FDB_RESULT_SUCCESS [ ret>string ] }
{ FDB_RESULT_KEY_NOT_FOUND [ 2drop f ] }
- [ throw-fdb-error ]
+ [ fdb-error ]
} case ;
: fdb-del-kv ( key -- )
ERROR: not-an-fdb-filename string ;
: ensure-fdb-filename ( string -- string )
- dup fdb-filename? [ throw-not-an-fdb-filename ] unless ;
+ dup fdb-filename? [ not-an-fdb-filename ] unless ;
ERROR: not-a-string-number string ;
: ?string>number ( string -- n )
- dup string>number dup [ nip ] [ throw-not-a-string-number ] if ;
+ dup string>number dup [ nip ] [ 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 ] [ throw-display-change-error ] if ;
+ [ drop ] [ display-change-error ] if ;
: non-fullscreen-mode ( monitor-info devmode -- )
[ szDevice>> ] dip f 0 f
ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
- [ drop ] [ throw-display-change-error ] if ;
+ [ drop ] [ display-change-error ] if ;
: get-style ( hwnd n -- style )
GetWindowLongPtr [ win32-error=0/f ] keep ;
[
slots{ dmPelsWidth dmPelsHeight dmBitsPerPel }
triple =
- ] find nip [ triple throw-unsupported-resolution ] unless* ;
+ ] find nip [ triple unsupported-resolution ] unless* ;
:: set-fullscreen-window-position ( hwnd triple -- )
hwnd f
: x/ ( tag child-name -- child-tag )
[ tag-named ]
- [ rot dup [ drop throw-missing-child ] unless 2nip ]
+ [ rot dup [ drop missing-child ] unless 2nip ]
2bi ; inline
: x@ ( tag attr-name -- attr-value )
[ attr ]
- [ rot dup [ drop throw-missing-attr ] unless 2nip ]
+ [ rot dup [ drop missing-attr ] unless 2nip ]
2bi ; inline
: xt ( tag -- content ) children>string ;
: models-class ( path -- class )
file-extension >lower types get ?at
- [ throw-unknown-models-extension ] unless second ;
+ [ unknown-models-extension ] unless second ;
: models-encoding ( path -- encoding )
file-extension >lower types get ?at
- [ throw-unknown-models-extension ] unless first ;
+ [ unknown-models-extension ] unless first ;
: open-models-file ( path encoding -- stream )
<file-reader> ;
: check-response ( response -- response )
"responseStatus" over at {
{ 200 [ ] }
- { 400 [ throw-response-error ] }
- [ drop throw-response-error ]
+ { 400 [ response-error ] }
+ [ drop response-error ]
} case ;
: query-response>text ( response -- text )
: gopher ( url -- item-type byte-array )
dup url? [ >url ] unless
- dup protocol>> "gopher" = [ throw-not-a-gopher-url ] unless {
+ dup protocol>> "gopher" = [ 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 throw-invalid-uniform-type ] unless* >quotation :> value-quot
+ } at [ uniform 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 throw-invalid-uniform-type ] unless* >quotation :> value-quot
+ } at [ uniform 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 throw-inaccurate-feedback-attribute-error ] unless ;
+ } 0&& [ vertex-attribute 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 throw-invalid-link-feedback-format-error ] ] [
+ [ [ nip invalid-link-feedback-format-error ] ] [
vertex-attributes
[ name>> ascii malloc-string ]
void*-array{ } map-as :> varying-names
[ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
dup gl-shader-ok?
[ swap world get \ shader-instance boa window-resource ]
- [ throw-compile-shader-error ] if ;
+ [ compile-shader-error ] if ;
: (link-program) ( program shader-instances -- program-instance )
'[ _ [ handle>> ] map ]
dup gl-program-ok? [
[ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
with-destructors window-resource
- ] [ throw-link-program-error ] if ;
+ ] [ link-program-error ] if ;
: link-program ( program -- program-instance )
dup shaders>> [ <shader-instance> ] map (link-program) ;
: validate-feedback-format ( sequence -- vertex-format/f )
dup length 1 <=
[ [ f ] [ first vertex-format>> ] if-empty ]
- [ throw-too-many-feedback-formats-error ] if ;
+ [ 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" ] }
- [ throw-unsupported-preview-format ]
+ [ 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 = [ throw-undefined-find-nth ] when ; inline
+ pick 0 = [ 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 ]
- [ throw-atlas-image-formats-dont-match ] if ; inline
+ [ 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 ] }
- [ throw-unknown-bitmap-header ]
+ [ unknown-bitmap-header ]
} case ;
: color-index-length ( header -- n )
{ 8 [ BGR ] }
{ 4 [ BGR ] }
{ 1 [ BGR ] }
- [ throw-unknown-component-order ]
+ [ unknown-component-order ]
} case ;
: advanced-bitmap>component-order ( loading-bitmap -- object )
ERROR: unimplemented message ;
: read-GIF87a ( loading-gif -- loading-gif )
- "GIF87a" throw-unimplemented ;
+ "GIF87a" unimplemented ;
: read-logical-screen-descriptor ( loading-gif -- loading-gif )
2 read le> >>width
{ APPLICATION-EXTENSION [
read-application-extension over application-extensions>> push
] }
- { f [ throw-gif-unexpected-eof ] }
- [ throw-unknown-extension ]
+ { f [ gif-unexpected-eof ] }
+ [ unknown-extension ]
} case ;
ERROR: unhandled-data byte ;
] }
{ IMAGE-DESCRIPTOR [ read-table-based-image ] }
{ TRAILER [ f >>loading? ] }
- [ throw-unhandled-data ]
+ [ unhandled-data ]
} case ;
: read-GIF89a ( loading-gif -- loading-gif )
read-gif-header dup magic>> {
{ "GIF87a" [ read-GIF87a ] }
{ "GIF89a" [ read-GIF89a ] }
- [ throw-unsupported-gif-format ]
+ [ unsupported-gif-format ]
} case
] with-input-stream ;
ERROR: loading-gif-error gif-image ;
: ensure-loaded ( gif-image -- gif-image )
- dup loading?>> [ throw-loading-gif-error ] when ;
+ dup loading?>> [ 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= [
- throw-bad-png-header
+ bad-png-header
] unless drop ;
ERROR: bad-checksum ;
: read-color-map-type ( -- byte )
1 read le> dup
- { 0 1 } member? [ throw-bad-tga-header ] unless ;
+ { 0 1 } member? [ bad-tga-header ] unless ;
: read-image-type ( -- byte )
1 read le> dup
- { 0 1 2 3 9 10 11 } member? [ throw-bad-tga-header ] unless ; inline
+ { 0 1 2 3 9 10 11 } member? [ 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" = [ throw-bad-tga-footer ] unless ; inline
+ 18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
: read-extension-size ( -- )
- 2 read le> 495 = [ throw-bad-tga-extension-size ] unless ; inline
+ 2 read le> 495 = [ 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? [ throw-bad-tga-timestamp ] unless >>month
- 2 read le> dup 31 [1,b] member? [ throw-bad-tga-timestamp ] unless >>day
+ 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> >>year
- 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
+ 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
: 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? [ throw-bad-tga-timestamp ] unless >>minute
- 2 read le> dup 59 [0,b] member? [ throw-bad-tga-timestamp ] unless >>second ; inline
+ 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
: 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 = [ 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
+ 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
#! Create image instance
image new
M: tga-image image>stream
2drop
[
- component-order>> { BGRA BGRA } member? [ throw-bad-tga-unsupported ] unless
+ component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
] keep
B{ 0 } write #! id-length
{ 10 [ photometric-interpretation-itulab ] }
{ 32844 [ photometric-interpretation-logl ] }
{ 32845 [ photometric-interpretation-logluv ] }
- [ throw-bad-photometric-interpretation ]
+ [ bad-photometric-interpretation ]
} case ;
SINGLETONS: compression
{ 34676 [ compression-sgilog ] }
{ 34677 [ compression-sgilog24 ] }
{ 34712 [ compression-jp2000 ] }
- [ throw-bad-compression ]
+ [ bad-compression ]
} case ;
SINGLETONS: resolution-unit
{ 1 [ resolution-unit-none ] }
{ 2 [ resolution-unit-inch ] }
{ 3 [ resolution-unit-centimeter ] }
- [ throw-bad-resolution-unit ]
+ [ bad-resolution-unit ]
} case ;
SINGLETONS: predictor
{
{ 1 [ predictor-none ] }
{ 2 [ predictor-horizontal-differencing ] }
- [ throw-bad-predictor ]
+ [ bad-predictor ]
} case ;
SINGLETONS: planar-configuration
{
{ 1 [ planar-configuration-chunky ] }
{ 2 [ planar-configuration-planar ] }
- [ throw-bad-planar-configuration ]
+ [ bad-planar-configuration ]
} case ;
SINGLETONS: sample-format
{ 2 [ sample-format-signed-integer ] }
{ 3 [ sample-format-ieee-float ] }
{ 4 [ sample-format-undefined-data ] }
- [ throw-bad-sample-format ]
+ [ bad-sample-format ]
} case
] map ;
{ 0 [ extra-samples-unspecified-alpha-data ] }
{ 1 [ extra-samples-associated-alpha-data ] }
{ 2 [ extra-samples-unassociated-alpha-data ] }
- [ throw-bad-extra-samples ]
+ [ bad-extra-samples ]
} case ;
SINGLETONS: image-length image-width x-resolution y-resolution
{
{ 1 [ jpeg-proc-baseline ] }
{ 14 [ jpeg-proc-lossless ] }
- [ throw-bad-jpeg-proc ]
+ [ bad-jpeg-proc ]
} case ;
ERROR: bad-tiff-magic bytes ;
{
{ B{ CHAR: M CHAR: M } [ big-endian ] }
{ B{ CHAR: I CHAR: I } [ little-endian ] }
- [ throw-bad-tiff-magic ]
+ [ bad-tiff-magic ]
} case ;
: read-header ( tiff -- tiff )
swap processed-tags>> ?at ;
: find-tag ( ifd class -- tag )
- find-tag* [ throw-no-tag ] unless ;
+ find-tag* [ no-tag ] unless ;
: tag? ( ifd class -- tag )
swap processed-tags>> key? ;
{ 11 [ 4 * ] }
{ 12 [ 8 * ] }
{ 13 [ 4 * ] }
- [ "value-length" throw-unknown-ifd-type ]
+ [ "value-length" unknown-ifd-type ]
} case ;
ERROR: bad-small-ifd-type n ;
{ 9 [ endian> 32 >signed ] }
{ 11 [ endian> bits>float ] }
{ 13 [ endian> 32 >signed ] }
- [ throw-bad-small-ifd-type ]
+ [ 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" throw-unknown-ifd-type ]
+ [ "offset-bytes>obj" unknown-ifd-type ]
} case ;
: ifd-entry-value ( ifd-entry -- n )
{
{ compression-none [ ] }
{ compression-lzw [ [ tiff-lzw-uncompress ] map ] }
- [ throw-unhandled-compression ]
+ [ unhandled-compression ]
} case ;
: uncompress-strips ( ifd -- ifd )
{
{ predictor-none [ ] }
{ predictor-horizontal-differencing [ (strips-predictor) ] }
- [ throw-bad-predictor ]
+ [ bad-predictor ]
} case
] when ;
{ { 8 8 8 8 } [ ] }
{ { 8 8 8 } [ ] }
{ 8 [ ] }
- [ throw-unknown-component-order ]
+ [ 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 ] }
- [ throw-unknown-component-order ]
+ [ unknown-component-order ]
} case ;
: handle-alpha-data ( ifd -- ifd )
{ extra-samples-associated-alpha-data [ ] }
{ extra-samples-unspecified-alpha-data [ ] }
{ extra-samples-unassociated-alpha-data [ ] }
- [ throw-bad-extra-samples ]
+ [ bad-extra-samples ]
} case ;
: ifd>image ( ifd -- image )
ERROR: no-imap-test-host ;
: get-test-host ( -- host )
- \ imap-settings get-global host>> [ throw-no-imap-test-host ] unless* ;
+ \ imap-settings get-global host>> [ 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 [ throw-imap4-error ] [ 2drop ] if ;
+ over "OK" = not [ 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
- [ throw-local-not-defined ] unless ;
+ [ local-not-defined ] unless ;
ERROR: invalid-op string ;
{ "/" [ [ / ] ] }
{ "%" [ [ mod ] ] }
{ "**" [ [ ^ ] ] }
- [ throw-invalid-op ]
+ [ invalid-op ]
} case ;
GENERIC: infix-codegen ( ast -- quot/number )
ERROR: bad-length bytes n ;
: check-length ( bytes n -- bytes n )
- 2dup [ length ] dip > [ throw-bad-length ] when ; inline
+ 2dup [ length ] dip > [ bad-length ] when ; inline
<<
: be-range ( n -- range )
ERROR: bad-acl-tag-t n ;
: acl_tag_t>string ( n -- string )
- dup 0 2 between? [ throw-bad-acl-tag-t ] unless
+ dup 0 2 between? [ 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 throw-acl-init-failed ] unless ;
+ n acl_init dup [ n acl-init-failed ] unless ;
: new-acl ( -- acl ) 1 n>new-acl ; inline
: zero-file ( n path -- )
{
- { [ over 0 < ] [ throw-invalid-file-size ] }
+ { [ over 0 < ] [ invalid-file-size ] }
{ [ over 0 = ] [ nip touch-file ] }
[ (zero-file) ]
} cond ;
{ 2 [ 1 cut { 0 0 } glue ] }
{ 3 [ 2 cut { 0 } glue ] }
{ 4 [ ] }
- [ drop throw-invalid-ipv4 ]
+ [ drop invalid-ipv4 ]
} case bubble nip ; inline
PRIVATE>
ERROR: probability-sum-not-one seq ;
: check-probabilities ( seq -- seq )
- dup sum 1.0 .00000000001 ~ [ throw-probability-sum-not-one ] unless ;
+ dup sum 1.0 .00000000001 ~ [ probability-sum-not-one ] unless ;
: equal-probabilities ( n -- array )
dup recip <array> ; inline
fat_header memory>struct dup magic>> {
{ FAT_MAGIC [ ] }
{ FAT_CIGAM [ ] }
- [ 2drop throw-not-fat-binary ]
+ [ 2drop 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 throw-already-logged-in ;
+M: managed-server handle-already-logged-in already-logged-in ;
M: managed-server handle-client-join ;
M: managed-server handle-client-disconnect ;
PRIVATE>
: send-client ( seq username -- )
- clients ?at [ throw-no-such-client ] [ (send-client) ] if ;
+ clients ?at [ 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 [ throw-no-host-name ] unless* ;
+ host-name "." split1 drop [ no-host-name ] unless* ;
SYMBOL: current-git-id
[ 0 <=>
{
{ +lt+ [ neg ] }
- { +eq+ [ 0 \ abs throw-undefined-derivative ] }
+ { +eq+ [ 0 \ abs undefined-derivative ] }
{ +gt+ [ ] }
} case
] ;
ERROR: not-a-square-matrix matrix ;
: check-square-matrix ( matrix -- matrix )
- dup square-matrix? [ throw-not-a-square-matrix ] unless ; inline
+ dup square-matrix? [ not-a-square-matrix ] unless ; inline
PRIVATE>
ERROR: not-enough-data ;
: fft ( seq -- seq' )
- [ throw-not-enough-data ] [ f (fft) ] if-empty ;
+ [ not-enough-data ] [ f (fft) ] if-empty ;
: ifft ( seq -- seq' )
- [ throw-not-enough-data ] [ t (fft) ] if-empty ;
+ [ 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 [ 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 ] }
+ { 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 ] }
[ drop ]
} case ;
: pile-alloc ( pile size -- alien )
[
[ [ ] [ size>> ] [ offset>> ] tri ] dip +
- < [ throw-not-enough-pile-space ] [ drop ] if
+ < [ 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 throw-bad-location ]
+ [ drop bad-location ]
} case ;
: string>longitude ( str -- lon/f )
[ "-" ?head swap ] dip
[ [ "0" ] when-empty ] bi@
[
- [ dup string>number [ nip ] [ throw-not-an-integer ] if* ] bi@
+ [ dup string>number [ nip ] [ not-an-integer ] if* ] bi@
] keep length
10^ / + swap [ neg ] when ;
open-connection [ authenticate-connection ] keep
] [
drop nip address>> "Could not open connection to mongod"
- throw-mongod-connection-error
+ mongod-connection-error
] recover ;
: mdb-close ( mdb-connection -- )
<PRIVATE
: send-message-check-error ( message -- )
- send-message lasterror [ throw-mdb-error ] when* ;
+ send-message lasterror [ mdb-error ] when* ;
PRIVATE>
{ dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] }
{ unknown-char [ intra-char-gap ] }
- [ throw-no-morse-ch ]
+ [ 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 ] }
- [ throw-unknown-format ]
+ [ 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 ] }
- [ throw-cannot-convert ]
+ [ cannot-convert ]
} cond
] [
{
{ [ dup -0x8000 >= ] [ 0xd1 write1 2 >be write ] }
{ [ dup -0x80000000 >= ] [ 0xd2 write1 4 >be write ] }
{ [ dup -0x8000000000000000 >= ] [ 0xd3 write1 8 >be write ] }
- [ throw-cannot-convert ]
+ [ cannot-convert ]
} cond
] if ;
{ [ dup 0xff <= ] [ 0xd9 write1 write1 ] }
{ [ dup 0xffff <= ] [ 0xda write1 2 >be write ] }
{ [ dup 0xffffffff <= ] [ 0xdb write1 4 >be write ] }
- [ throw-cannot-convert ]
+ [ 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 ] }
- [ throw-cannot-convert ]
+ [ 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 ] }
- [ throw-cannot-convert ]
+ [ 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 ] }
- [ throw-cannot-convert ]
+ [ cannot-convert ]
} cond ;
M: assoc write-msgpack
: validate-table ( table -- table )
dup { [ byte-array? ] [ length 512 >= ] } 1&&
- [ throw-invalid-perlin-noise-table ] unless ;
+ [ 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 ] [ throw-cl-error ] if ;
+ dup CL_SUCCESS = [ drop ] [ 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 ] [ throw-cl-error ] if ; inline
+ dup CL_SUCCESS = [ drop ] [ cl-error ] if ; inline
: cl-not-null ( err -- )
- dup f = [ throw-cl-error ] [ drop ] if ; inline
+ dup f = [ 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 throw-cl-error f ] }
+ clReleaseProgram cl-success 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 ]
- [ [ throw-no-pair-method ] curry suffix ] bi 1quotation
+ [ [ 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
- [ throw-cannot-delete-key ] [
+ [ cannot-delete-key ] [
[ delete-at ] [ 2drop ] if-hash
] if-key ; inline
] [ 2drop f ] if* ;
: check-bad-option ( err value what -- value )
- rot 0 = [ drop ] [ throw-bad-option ] if ;
+ rot 0 = [ drop ] [ 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 ] [ throw-malformed-regexp ] if* ;
+ dup (pcre) 2array swap [ 2nip ] [ 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 throw-pcre-error
+ PCRE_ERRORS number>enum pcre-error
] [
-1 = [
2drop dup exec-opts>> 0 =
: draw-specific-card ( card deck -- card )
[ >ckf ] dip
- 2dup index [ swap remove-nth! drop ] [ throw-no-card ] if* ;
+ 2dup index [ swap remove-nth! drop ] [ 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 [ throw-bad-suit-symbol ] unless ;
+ } ?at [ 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? [ throw-invalid-percent ] unless ;
+ dup 0 1 between? [ invalid-percent ] unless ;
ERROR: invalid-length x ;
: check-length ( x -- x )
- dup { [ 0 > ] [ integer? ] } 1&& [ throw-invalid-length ] unless ;
+ dup { [ 0 > ] [ integer? ] } 1&& [ invalid-length ] unless ;
: (make-progress-bar) ( percent len completed-ch pending-ch -- string )
[ [ * >integer ] keep over - ] 2dip
<redis-response> ;
: handle-error ( string -- * )
- throw-redis-error ;
+ redis-error ;
PRIVATE>
{ [ "rotate" ?head ] [ drop t >>rotate? ] }
{ [ "no-check-names" ?head ] [ drop t >>no-check-names? ] }
{ [ "inet6" ?head ] [ drop t >>inet6? ] }
- [ throw-unsupported-resolv.conf-option ]
+ [ unsupported-resolv.conf-option ]
} cond drop ;
ERROR: unsupported-resolv.conf-line string ;
{ [ "search" ?head ] [ parse-search ] }
{ [ "sortlist" ?head ] [ parse-sortlist ] }
{ [ "options" ?head ] [ parse-option ] }
- [ throw-unsupported-resolv.conf-line ]
+ [ 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 ] [ throw-role-slot-overlap ] if ;
+ duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
: roles>slots ( roles-and-superclass slots -- superclass slots' )
[
dup length {
{ 0 [ drop tuple ] }
{ 1 [ first ] }
- [ drop throw-multiple-inheritance-attempted ]
+ [ drop multiple-inheritance-attempted ]
} case
swap [ role-slots ] map concat
] dip append ;
ERROR: no-class name ;
: lookup-class ( class -- class )
- classes get ?at [ throw-no-class ] unless ;
+ classes get ?at [ no-class ] unless ;
: define-class ( class superclass ivars -- class-word )
[ create-class ] [ lookup-class ] [ ] tri*
[ local-reader ]
[ ivar-reader ]
[ drop class-name ]
- [ drop throw-bad-identifier ]
+ [ drop bad-identifier ]
} 2|| ;
: local-writer ( name lexenv -- local )
{
[ local-writer ]
[ ivar-writer ]
- [ drop throw-bad-identifier ]
+ [ drop bad-identifier ]
} 2|| ;
ERROR: bad-number str ;
: check-number ( str -- n )
- >string dup string>number [ ] [ throw-bad-number ] ?if ;
+ >string dup string>number [ ] [ bad-number ] ?if ;
EBNF: parse-smalltalk
[
binary [ read-tar-header ] with-byte-reader
dup checksum>>
- ] dip = [ throw-checksum-error ] unless
+ ] dip = [ checksum-error ] unless
] if ;
ERROR: unknown-typeflag ch ;
{ 2009 106800 }
{ 2008 102000 }
{ 2007 97500 }
- } at [ throw-fica-base-unknown ] unless* ;
+ } at [ fica-base-unknown ] unless* ;
: fica-tax ( salary w4 -- x )
year>> fica-base-rate min fica-tax-rate * ;
ERROR: bad-magic ;
: check-magic ( n -- )
- MAGIC = [ throw-bad-magic ] unless ;
+ MAGIC = [ bad-magic ] unless ;
TUPLE: terminfo-header names-bytes boolean-bytes #numbers
#strings string-bytes ;
ERROR: bad-magic ;
: check-magic ( -- )
- 4 read "TZif" sequence= [ throw-bad-magic ] unless ;
+ 4 read "TZif" sequence= [ bad-magic ] unless ;
TUPLE: tzfile header transition-times local-times types abbrevs
leaps is-std is-gmt ;
: check-dimensions ( d d -- )
[ dimensions 2array ] same?
- [ throw-dimensions-not-equal ] unless ;
+ [ dimensions-not-equal ] unless ;
: 2values ( dim dim -- val val ) [ value>> ] bi@ ;
MEMO: string>state ( string -- state )
dup states [ name>> = ] with find nip
- [ ] [ throw-no-such-state ] ?if ;
+ [ ] [ 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 > [ throw-bad-length ] when ; inline
+ dup length 45 > [ bad-length ] when ; inline
:: binary>ascii ( seq -- seq' )
0 :> char!
: check-illegal-character ( ch -- ch )
dup { [ CHAR: \s < ] [ CHAR: \s 64 + > ] } 1||
- [ throw-illegal-character ] when ;
+ [ 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 ]
- [ throw-git-revision-not-found ] if* ;
+ [ git-revision-not-found ] if* ;
SYNTAX: USE-REV: scan-token scan-token use-vocab-rev ;
<PRIVATE
: yaml-initialize-assert-ok ( ? -- )
- [ throw-libyaml-initialize-error ] unless ;
+ [ libyaml-initialize-error ] unless ;
: (libyaml-parser-error) ( parser -- )
{
[ problem_mark>> ]
[ context>> ]
[ context_mark>> ]
- } cleave [ clone ] 7 napply throw-libyaml-parser-error ;
+ } cleave [ clone ] 7 napply libyaml-parser-error ;
: (libyaml-emitter-error) ( emitter -- )
- [ error>> ] [ problem>> ] bi [ clone ] bi@ throw-libyaml-emitter-error ;
+ [ error>> ] [ problem>> ] bi [ clone ] bi@ libyaml-emitter-error ;
: yaml-parser-assert-ok ( ? parser -- )
swap [ drop ] [ (libyaml-parser-error) ] if ;
: assert-anchor-exists ( anchor -- )
anchors get 2dup at* nip
- [ 2drop ] [ throw-yaml-undefined-anchor ] if ;
+ [ 2drop ] [ yaml-undefined-anchor ] if ;
: deref-anchor ( event -- obj )
data>> alias>> anchor>>
: expect-event ( parser event type -- )
[
[ next-event type>> ] dip 2dup =
- [ 2drop ] [ 1array throw-yaml-unexpected-event ] if
+ [ 2drop ] [ 1array 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 } throw-yaml-unexpected-event ]
+ [ { YAML_DOCUMENT_START_EVENT YAML_STREAM_END_EVENT } yaml-unexpected-event ]
} case
] with-destructors [
parser event parse-yaml-doc t
[
init-parser
[ YAML_STREAM_START_EVENT expect-event ]
- [ ?parse-yaml-doc [ throw-yaml-no-document ] unless ] 2bi
+ [ ?parse-yaml-doc [ yaml-no-document ] unless ] 2bi
] with-destructors ;
: yaml-docs> ( str -- arr )
zmq_errno dup zmq_strerror zmq-error boa throw ; inline
: check-zmq-error ( retval -- )
- [ throw-zmq-error ] unless-zero ; inline
+ [ zmq-error ] unless-zero ; inline
: zmq-version ( -- version )
{ int int int } [ zmq_version ] with-out-parameters 3array ;
: <zmq-socket> ( context type -- socket )
[ underlying>> ] dip zmq_socket
- dup [ throw-zmq-error ] unless
+ dup [ zmq-error ] unless
zmq-socket boa ;
M: zmq-socket dispose
: zmq-sendmsg ( socket msg flags -- )
[ [ underlying>> ] bi@ ] dip zmq_sendmsg
- 0 < [ throw-zmq-error ] when ;
+ 0 < [ zmq-error ] when ;
: zmq-recvmsg ( socket msg flags -- )
[ [ underlying>> ] bi@ ] dip zmq_recvmsg
- 0 < [ throw-zmq-error ] when ;
+ 0 < [ zmq-error ] when ;
: zmq-send ( socket byte-array flags -- )
[ byte-array>zmq-message ] dip
: find-zone ( string -- rules )
raw-zone-map
- [ last ] assoc-map ?at [ throw-zone-not-found ] unless ;
+ [ last ] assoc-map ?at [ zone-not-found ] unless ;
: find-zone-rules ( string -- zone rules )
find-zone dup rules/save>> find-rules ;
projects / factor.git / commitdiff