c-type-word pointer ;
: resolve-typedef ( name -- c-type )
- dup void? [ no-c-type ] when
+ dup void? [ throw-no-c-type ] when
dup c-type-name? [ lookup-c-type ] when ;
M: word lookup-c-type
dup "c-type" word-prop resolve-typedef
- [ ] [ no-c-type ] ?if ;
+ [ ] [ throw-no-c-type ] ?if ;
GENERIC: c-type-class ( name -- class )
: cast-array ( byte-array c-type -- array )
[ binary-object ] dip [ heap-size /mod 0 = ] keep swap
- [ <c-direct-array> ] [ bad-byte-array-length ] if ; inline
+ [ <c-direct-array> ] [ throw-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 ] ] }
- [ invalid-signed-conversion ]
+ [ throw-invalid-signed-conversion ]
} case ; inline
MACRO: byte-reverse ( n signed? -- quot )
: parse-array-type ( name -- c-type )
"[" split unclip
- [ [ "]" ?tail [ bad-array-type ] unless parse-datum ] map ]
+ [ [ "]" ?tail [ throw-bad-array-type ] unless parse-datum ] map ]
[ (parse-c-type) ]
bi* prefix ;
: base64>ch ( ch -- ch )
$[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth
- [ malformed-base64 ] unless* ; inline
+ [ throw-malformed-base64 ] unless* ; inline
: (write-lines) ( column byte-array -- column' )
output-stream get dup '[
4 "\n\r" pick read-ignoring dup length {
{ 0 [ 2drop ] }
{ 4 [ decode4 (decode-base64) ] }
- [ malformed-base64 ]
+ [ throw-malformed-base64 ]
} case ;
PRIVATE>
drop "biassocs do not support deletion" ;
M: biassoc delete-at
- no-biassoc-deletion ;
+ throw-no-biassoc-deletion ;
M: biassoc >alist from>> >alist ;
ERROR: bad-array-length n ;
: <bit-array> ( n -- bit-array )
- dup 0 < [ bad-array-length ] when
+ dup 0 < [ throw-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? [ check-bit-set-failed ] unless ; inline
+ dup bit-set? [ throw-check-bit-set-failed ] unless ; inline
: bit-set-map ( seq1 seq2 quot -- seq )
[ drop [ length ] bi@ [ assert= ] keep ]
dup 0 < [ neg ] when log2 <=
] if-zero
]
- } 2|| [ invalid-widthed ] when ;
+ } 2|| [ throw-invalid-widthed ] when ;
: <widthed> ( bits #bits -- widthed )
check-widthed
<PRIVATE
-ERROR: not-enough-bits widthed n ;
+ERROR: not-enough-widthed-bits widthed n ;
: check-widthed-bits ( widthed n -- widthed n )
2dup { [ nip 0 < ] [ [ #bits>> ] dip < ] } 2||
- [ not-enough-bits ] when ;
+ [ throw-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 not-enough-bits ] unless
+ n bs enough-bits? [ n bs throw-not-enough-bits ] unless
bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
bs bytes>> subseq endian> execute( seq -- x )
n bs subseq-endian execute( bignum n bs -- bits ) ;
: fixup-word ( word -- offset )
transfer-word dup lookup-object
- [ ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?if ;
+ [ ] [ [ vocabulary>> ] [ name>> ] bi throw-not-in-image ] ?if ;
: fixup-words ( -- )
bootstrapping-image get [ dup word? [ fixup-word ] when ] map! drop ;
ERROR: tuple-removed class ;
: require-tuple-layout ( word -- layout )
- dup tuple-layout [ ] [ tuple-removed ] ?if ;
+ dup tuple-layout [ ] [ throw-tuple-removed ] ?if ;
: (emit-tuple) ( tuple -- pointer )
[ tuple-slots ]
: >box ( value box -- )
dup occupied>>
- [ box-full ] [ t >>occupied value<< ] if ; inline
+ [ throw-box-full ] [ t >>occupied value<< ] if ; inline
ERROR: box-empty box ;
SYNTAX: HEX{
"}" parse-tokens concat
[ blank? ] reject
- dup length even? [ odd-length-hex-string ] unless
+ dup length even? [ throw-odd-length-hex-string ] unless
2 <groups> [ hex> ] B{ } map-as
suffix! ;
: (check-cairo) ( cairo_status_t -- )
dup CAIRO_STATUS_SUCCESS =
- [ drop ] [ [ ] [ cairo_status_to_string ] bi cairo-error ] if ;
+ [ drop ] [ [ ] [ cairo_status_to_string ] bi throw-cairo-error ] if ;
: check-cairo ( cairo -- ) cairo_status (check-cairo) ;
<PRIVATE
: check-month ( n -- n )
- [ not-a-month ] when-zero ;
+ [ throw-not-a-month ] when-zero ;
PRIVATE>
: month-abbreviation-index ( string -- n )
month-abbreviations-hash ?at
- [ not-a-month-abbreviation ] unless ;
+ [ throw-not-a-month-abbreviation ] unless ;
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
ERROR: invalid-timestamp-format ;
: check-timestamp ( obj/f -- obj )
- [ invalid-timestamp-format ] unless* ;
+ [ throw-invalid-timestamp-format ] unless* ;
: read-token ( seps -- token )
[ read-until ] keep member? check-timestamp drop ;
: digest-named ( name -- md )
dup EVP_get_digestbyname
- [ ] [ unknown-digest ] ?if ;
+ [ ] [ throw-unknown-digest ] ?if ;
: set-digest ( name ctx -- )
handle>> swap digest-named f EVP_DigestInit_ex ssl-error ;
:: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- )
slot-specs check-struct-slots
- slot-specs empty? [ struct-must-have-slots ] when
+ slot-specs empty? [ throw-struct-must-have-slots ] when
class redefine-struct-tuple-class
slot-specs offsets-quot call :> unaligned-size
slot-specs alignment-quot call :> alignment
scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot suffix! t ] }
- [ invalid-struct-slot ]
+ [ throw-invalid-struct-slot ]
} case ;
: parse-struct-definition ( -- class slots )
scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot` t ] }
- [ invalid-struct-slot ]
+ [ throw-invalid-struct-slot ]
} case ;
PRIVATE>
objc-methods get at ;
: lookup-method ( selector -- method )
- dup ?lookup-method [ ] [ no-objc-method ] ?if ;
+ dup ?lookup-method [ ] [ throw-no-objc-method ] ?if ;
: lookup-sender ( name -- method )
lookup-method message-senders get at ;
: decode-type ( ch -- ctype )
1string dup objc>alien-types get at
- [ ] [ no-objc-type ] ?if ;
+ [ ] [ throw-no-objc-type ] ?if ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1 + ] dip ] [ nth ] 2bi {
{ NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] }
- [ invalid-plist-object ]
+ [ throw-invalid-plist-object ]
} objc-class-case ;
: read-plist ( path -- assoc )
ERROR: no-such-color name ;
: named-color ( name -- color )
- dup colors at [ ] [ no-such-color ] ?if ;
+ dup colors at [ ] [ throw-no-such-color ] ?if ;
SYNTAX: COLOR: scan-token named-color suffix! ;
dup good-probabilities? [
[ dup pair? [ prepare-pair ] [ with-drop ] if ] map
cond>quot
- ] [ bad-probabilities ] if ;
+ ] [ throw-bad-probabilities ] if ;
MACRO: (casep) ( assoc -- quot ) (casep>quot) ;
: arity ( quots -- n )
first infer
- dup terminated?>> [ cannot-determine-arity ] when
+ dup terminated?>> [ throw-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 vreg-not-new ] when
+ vreg vregs>acs get key? [ vreg throw-vreg-not-new ] when
ac vreg vregs>acs get set-at
vreg ac ac>vregs push ;
: check-successors ( bb -- )
dup successors>> [ predecessors>> member-eq? ] with all?
- [ bad-successors ] unless ;
+ [ throw-bad-successors ] unless ;
: check-cfg ( cfg -- )
[ check-successors ] each-basic-block ;
: enable-intrinsics ( alist -- )
[
- over inline? [ inline-intrinsics-not-supported ] when
+ over inline? [ throw-inline-intrinsics-not-supported ] when
"intrinsic" set-word-prop
] assoc-each ;
! node literals quot
[ _ firstn ] dip call
drop
- ] [ 2drop bad-simd-intrinsic ] if
+ ] [ 2drop throw-bad-simd-intrinsic ] if
] ;
CONSTANT: [unary] [ ds-drop ds-pop ]
: check-ranges ( live-interval -- )
check-allocation? get [
dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
- [ drop ] [ bad-live-ranges ] if
+ [ drop ] [ throw-bad-live-ranges ] if
] [ drop ] if ;
: trim-before-ranges ( live-interval -- )
: check-split ( live-interval n -- )
check-allocation? get [
- [ [ start>> ] dip > [ splitting-too-early ] when ]
- [ [ end>> ] dip < [ splitting-too-late ] when ]
- [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
- 2tri
+ [ [ start>> ] dip > [ throw-splitting-too-early ] when ]
+ [ [ end>> ] dip < [ throw-splitting-too-late ] when ]
+ [
+ drop [ end>> ] [ start>> ] bi =
+ [ throw-splitting-atomic-interval ] when
+ ] 2tri
] [ 2drop ] if ; inline
: split-before ( before -- before' )
: check-activate ( live-interval -- )
check-allocation? get [
dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member?
- [ register-already-used ] [ drop ] if
+ [ throw-register-already-used ] [ drop ] if
] [ drop ] if ;
: activate ( n live-interval -- keep? )
ERROR: not-spilled-error vreg ;
: vreg>spill-slot ( vreg -- spill-slot )
- dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ;
+ dup vreg>reg dup spill-slot?
+ [ nip ]
+ [ drop leader throw-not-spilled-error ] if ;
: vregs>regs ( vregs -- assoc )
[ dup vreg>reg ] H{ } map>assoc ;
ERROR: bad-live-interval live-interval ;
: check-start ( live-interval -- )
- dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
+ dup start>> -1 = [ throw-bad-live-interval ] [ drop ] if ;
: finish-live-intervals ( live-intervals -- )
[
: check-block-numbering ( bb -- )
dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
- [ drop ] [ bad-numbering ] if ;
+ [ drop ] [ throw-bad-numbering ] if ;
: check-numbering ( cfg -- )
check-numbering? get
ERROR: bad-vreg vreg ;
: rep-of ( vreg -- rep )
- representations get ?at [ bad-vreg ] unless ;
+ representations get ?at [ throw-bad-vreg ] unless ;
: set-rep-of ( rep vreg -- )
representations get set-at ;
! it is allowed... otherwise bail out.
[
drop 2dup [ reg-class-of ] bi@ eq?
- [ drop ##copy, ] [ bad-conversion ] if
+ [ drop ##copy, ] [ throw-bad-conversion ] if
]
} case
]
: try-eliminate-copy ( follower leader must? -- )
-rot leaders 2dup = [ 3drop ] [
2dup vregs-interfere? [
- drop rot [ vregs-shouldn't-interfere ] [ 2drop ] if
+ drop rot [ throw-vregs-shouldn't-interfere ] [ 2drop ] if
] [ -rot coalesce-vregs drop ] if
] if ;
2dup live-out? [ 2drop 1/0. ] [
2dup kill-indices get at at* [ 2nip ] [
drop 2dup live-in?
- [ bad-kill-index ] [ 2drop -1/0. ] if
+ [ throw-bad-kill-index ] [ 2drop -1/0. ] if
] if
] if ;
: insert-peeks ( from to -- )
[ inserting-peeks ] keep
- [ dup n>> 0 < [ bad-peek ] [ ##peek, ] if ] each-insertion ;
+ [ dup n>> 0 < [ throw-bad-peek ] [ ##peek, ] if ] each-insertion ;
: insert-replaces ( from to -- )
[ inserting-replaces ] keep
[ register-write ] apply-stack-op ;
: ensure-no-vacant ( state -- )
- [ second ] map dup { { } { } } = [ drop ] [ vacant-when-calling ] if ;
+ [ second ] map dup { { } { } } = [ drop ] [ throw-vacant-when-calling ] if ;
: all-live ( state -- state' )
[ first { } 2array ] map ;
: underflowable-peek? ( state peek -- ? )
2dup loc>> >loc< swap [ 0 1 ? swap nth ] dip classify-read
- dup 2 = [ drop vacant-peek ] [ 2nip 1 = ] if ;
+ dup 2 = [ drop throw-vacant-peek ] [ 2nip 1 = ] if ;
M: ##peek visit-insn ( state insn -- state )
dup loc>> n>> 0 >= t assert=
M: no-such-library summary drop "Library not found" ;
-: no-such-library-error ( name message word -- ) \ no-such-library set-linkage-error ;
+: no-such-library-error ( name message word -- )
+ \ no-such-library set-linkage-error ;
ERROR: no-such-symbol name message ;
M: no-such-symbol summary drop "Symbol not found" ;
-: no-such-symbol-error ( name message word -- ) \ no-such-symbol set-linkage-error ;
+: no-such-symbol-error ( name message word -- )
+ \ no-such-symbol set-linkage-error ;
ERROR: not-compiled word error ;
32 random-bits >fixnum
32 random-bits >fixnum
2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
- [ 4drop ] [ bug-in-fixnum* ] if
+ [ 4drop ] [ throw-bug-in-fixnum* ] if
] times
] unit-test
ERROR: check-use-error value message ;
: check-use ( value uses -- )
- [ empty? [ "No use" check-use-error ] [ drop ] if ]
- [ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
+ [ empty? [ "No use" throw-check-use-error ] [ drop ] if ]
+ [
+ all-unique?
+ [ drop ]
+ [ "Uses not all unique" throw-check-use-error ] if
+ ] 2bi ;
: check-def-use ( -- )
def-use get [ uses>> check-use ] assoc-each ;
[ node-defs-values check-values ]
[ check-node* ]
tri
- ] [ check-node-error ] recover ;
+ ] [ throw-check-node-error ] recover ;
SYMBOL: datastack
SYMBOL: retainstack
ERROR: no-def-error value ;
: (def-of) ( value def-use -- definition )
- ?at [ no-def-error ] unless ; inline
+ ?at [ throw-no-def-error ] unless ; inline
: def-of ( value -- definition )
def-use get (def-of) ;
: (def-value) ( node value def-use -- )
2dup key? [
- multiple-defs-error
+ throw-multiple-defs-error
] [
[ [ <definition> ] keep ] dip set-at
] if ; inline
<PRIVATE
-ERROR: zlib-unimplemented ;
ERROR: bad-zlib-data ;
ERROR: bad-zlib-header ;
0 assert=
4 data bs:read 8 assert= ! compression method: deflate
4 data bs:read ! log2(max length)-8, 32K max
- 7 <= [ bad-zlib-header ] unless
+ 7 <= [ throw-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 > [ bad-zlib-data ] when
+ dup 5 > [ throw-bad-zlib-data ] when
bitstream bs:read 2array
] when
] unless
dup 3 > [
dup 2 - 2 /i dup 13 >
- [ bad-zlib-data ] when
+ [ throw-bad-zlib-data ] when
bitstream bs:read 2array
] when 2array
] when dup 256 = not
{ 0 [ inflate-raw ] }
{ 1 [ inflate-static ] }
{ 2 [ inflate-dynamic ] }
- { 3 [ bad-zlib-data f ] }
+ { 3 [ throw-bad-zlib-data f ] }
} case
] [ produce ] keep call suffix concat ;
: <lzw-uncompress> ( input code-size class -- obj )
new
- swap [ code-size-zero ] when-zero >>code-size
+ swap [ throw-code-size-zero ] when-zero >>code-size
dup code-size>> >>initial-code-size
dup code-size>> 1 - 2^ >>clear-code
dup clear-code>> 1 + >>end-of-information-code
BV{ } clone >>output
reset-lzw-uncompress ;
-ERROR: not-in-table value ;
-
: lookup-old-code ( lzw -- vector )
[ old-code>> ] [ table>> ] bi nth ;
<PRIVATE
: check-snappy ( ret -- )
- dup SNAPPY_OK = [ drop ] [ snappy-error ] if ;
+ dup SNAPPY_OK = [ drop ] [ throw-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 zlib-failed ;
+ ] if throw-zlib-failed ;
: zlib-error ( n -- )
dup {
{ compression.zlib.ffi:Z_OK [ drop ] }
{ compression.zlib.ffi:Z_STREAM_END [ drop ] }
- [ dup zlib-error-message zlib-failed ]
+ [ dup zlib-error-message throw-zlib-failed ]
} case ;
: compressed-size ( byte-array -- n )
: wait ( queue timeout status -- )
over [
[ queue-timeout ] dip suspend
- [ timed-out-error ] [ stop-timer ] if
+ [ throw-timed-out-error ] [ stop-timer ] if
] [
[ drop queue ] dip suspend drop
] if ; inline
ERROR: invalid-count-down-count count ;
: <count-down> ( n -- count-down )
- dup 0 < [ invalid-count-down-count ] when
+ dup 0 < [ throw-invalid-count-down-count ] when
<promise> \ count-down-tuple boa
dup count-down-check ;
: count-down ( count-down -- )
dup n>> dup zero?
- [ count-down-already-done ]
+ [ throw-count-down-already-done ]
[ 1 - >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )
: send-synchronous ( message thread -- reply )
dup self eq? [
- cannot-send-synchronous-to-self
+ throw-cannot-send-synchronous-to-self
] [
[ <synchronous> dup ] dip send
'[ _ synchronous-reply? ] receive-if
: fulfill ( value promise -- )
dup promise-fulfilled? [
- promise-already-fulfilled
+ throw-promise-already-fulfilled
] [
mailbox>> mailbox-put
] if ;
drop "Cannot have semaphore with negative count" ;
: <semaphore> ( n -- semaphore )
- dup 0 < [ negative-count-semaphore ] when
+ dup 0 < [ throw-negative-count-semaphore ] when
<dlist> semaphore boa ;
: wait-to-acquire ( semaphore timeout -- )
ERROR: core-foundation-error n ;
: cf-error ( n -- )
- dup 0 = [ drop ] [ core-foundation-error ] if ;
+ dup 0 = [ drop ] [ throw-core-foundation-error ] if ;
: fsref>string ( fsref -- string )
MAXPATHLEN [ <char-array> ] [ ] bi
{ kCFNumberLongType [ long (CFNumber>number) ] }
{ kCFNumberLongLongType [ longlong (CFNumber>number) ] }
{ kCFNumberDoubleType [ double (CFNumber>number) ] }
- [ unsupported-number-type ]
+ [ throw-unsupported-number-type ]
} case ;
[
[
dup selection? [ string>> ] when
- dup string? [ not-a-string ] unless
+ dup string? [ throw-not-a-string ] unless
] 2dip
make-attributes <CFAttributedString> &CFRelease
CTLineCreateWithAttributedString
ERROR: bad-movabs-operands dst src ;
GENERIC: MOVABS ( dst src -- )
-M: object MOVABS bad-movabs-operands ;
+M: object MOVABS throw-bad-movabs-operands ;
M: register MOVABS
{
{ AL [ 0xa2 , cell, ] }
{ AX [ 0x66 , 0xa3 , cell, ] }
{ EAX [ 0xa3 , cell, ] }
{ RAX [ 0x48 , 0xa3 , cell, ] }
- [ swap bad-movabs-operands ]
+ [ swap throw-bad-movabs-operands ]
} case ;
M: integer MOVABS
swap {
{ AX [ 0x66 , 0xa1 , cell, ] }
{ EAX [ 0xa1 , cell, ] }
{ RAX [ 0x48 , 0xa1 , cell, ] }
- [ swap bad-movabs-operands ]
+ [ swap throw-bad-movabs-operands ]
} case ;
: LEA ( dst src -- ) swap 0x8d 2-operand ;
:: x87-st0-op ( src opcode reg -- )
src register?
[ src opcode reg (x87-op) ]
- [ bad-x87-operands ] if ;
+ [ throw-bad-x87-operands ] if ;
:: x87-m-st0/n-op ( dst src opcode reg -- )
{
{ [ src ST0 = dst register? and ] [
dst opcode 4 + reg (x87-op)
] }
- [ bad-x87-operands ]
+ [ throw-bad-x87-operands ]
} cond ;
PRIVATE>
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
- dup index>> { ESP RSP } member-eq? [ bad-index ] when ;
+ dup index>> { ESP RSP } member-eq? [ throw-bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
drop "PQexec returned f." ;
: postgresql-result-ok? ( res -- ? )
- [ postgresql-result-null ] unless*
+ [ throw-postgresql-result-null ] unless*
PQresultStatus
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
{ "default" [ first number>string " " glue ] }
{ "varchar" [ first number>string "(" ")" surround append ] }
{ "references" [ >reference-string ] }
- [ drop no-compound-found ]
+ [ drop throw-no-compound-found ]
} case ;
M: postgresql-db-connection parse-db-error
[
"select " 0%
[ dupd filter-ignores ] dip
- over empty? [ all-slots-ignored ] when
+ over empty? [ throw-all-slots-ignored ] when
over
[ ", " 0% ]
[ dup column-name>> 0% 2, ] interleave
: last-insert-id ( -- id )
db-connection get handle>> sqlite3_last_insert_rowid
- dup zero? [ sqlite-last-id-fail ] when ;
+ dup zero? [ throw-sqlite-last-id-fail ] when ;
M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
[ keys ]
[ all-slots [ name>> ] map ] bi* diff
] 2bi
- [ drop ] [ no-slots-named ] if-empty ;
+ [ drop ] [ throw-no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )
pick dupd
: ensure-defined-persistent ( object -- object )
dup { [ class? ] [ "db-table" word-prop ] } 1&& [
- no-defined-persistent
+ throw-no-defined-persistent
] unless ;
: create-table ( class -- )
ERROR: not-persistent class ;
: db-table-name ( class -- object )
- dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
+ dup "db-table" word-prop [ ] [ throw-not-persistent ] ?if ;
: db-columns ( class -- object )
superclasses-of [ "db-columns" word-prop ] map concat ;
: lookup-modifier ( obj -- string )
{
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
- [ persistent-table ?at [ unknown-modifier ] unless third ]
+ [ persistent-table ?at [ throw-unknown-modifier ] unless third ]
} cond ;
ERROR: no-sql-type type ;
: (lookup-type) ( obj -- string )
- persistent-table ?at [ no-sql-type ] unless ;
+ persistent-table ?at [ throw-no-sql-type ] unless ;
: lookup-type ( obj -- string )
dup array? [
first2
[ [ db-table-name " " glue ] [ db-columns ] bi ] dip
swap [ column-name>> = ] with find nip
- [ no-column ] unless*
+ [ throw-no-column ] unless*
column-name>> "(" ")" surround append ;
: check-broadcast-group ( group -- group )
dup group-words [ first stack-effect out>> empty? ] all?
- [ broadcast-words-must-have-no-outputs ] unless ;
+ [ throw-broadcast-words-must-have-no-outputs ] unless ;
! Consultation
: check-generic ( generic -- )
dup array? [ first ] when
- dup generic? [ drop ] [ not-a-generic ] if ;
+ dup generic? [ drop ] [ throw-not-a-generic ] if ;
PRIVATE>
ERROR: empty-deque ;
: peek-front ( deque -- obj )
- peek-front* [ drop empty-deque ] unless ;
+ peek-front* [ drop throw-empty-deque ] unless ;
: ?peek-front ( deque -- obj/f )
peek-front* [ drop f ] unless ;
: peek-back ( deque -- obj )
- peek-back* [ drop empty-deque ] unless ;
+ peek-back* [ drop throw-empty-deque ] unless ;
: ?peek-back ( deque -- obj/f )
peek-back* [ drop f ] unless ;
ERROR: invalid-location file line ;
: edit-location ( file line -- )
- over [ invalid-location ] unless
+ over [ throw-invalid-location ] unless
[ absolute-path ] dip
editor-command [ run-and-wait-for-editor ] when* ;
GENERIC: edit ( object -- )
M: object edit
- dup where [ first2 edit-location ] [ cannot-find-source ] ?if ;
+ dup where [ first2 edit-location ] [ throw-cannot-find-source ] ?if ;
M: string edit edit-vocab ;
SINGLETON: jedit
jedit editor-class set-global
-ERROR: jedit-not-found ;
-
HOOK: find-jedit-path os ( -- path )
M: object find-jedit-path f ;
fmt-f = digits "f" => [[ first '[ _ format-decimal ] ]]
fmt-x = "x" => [[ [ >hex ] ]]
fmt-X = "X" => [[ [ >hex >upper ] ]]
-unknown = (.)* => [[ unknown-printf-directive ]]
+unknown = (.)* => [[ throw-unknown-printf-directive ]]
strings_ = fmt-c|fmt-C|fmt-s|fmt-S|fmt-u
strings = pad width strings_ => [[ <reversed> compose-all ]]
: check-fry ( quot -- quot )
dup { load-local load-locals get-local drop-locals } intersect
- [ >r/r>-in-fry-error ] unless-empty ;
+ [ throw->r/r>-in-fry-error ] unless-empty ;
PREDICATE: fry-specifier < word { _ @ } member-eq? ;
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
- 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
+ 2dup [ n>> ] dip = [ 2drop ] [ throw-ftp-error ] if ;
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
>upper {
{ "IMAGE" [ "Binary" ] }
{ "I" [ "Binary" ] }
- [ type-error ]
+ [ throw-type-error ]
} case ;
: handle-TYPE ( obj -- )
"" not-a-plain-file
] if* ;
-ERROR: not-a-directory ;
-ERROR: no-directory-permissions ;
-
: directory-change-success ( -- )
"Directory successully changed." 250 server-response ;
ERROR: end-aside-in-get-error ;
: move-on ( id -- response )
- post-request? [ end-aside-in-get-error ] unless
+ post-request? [ throw-end-aside-in-get-error ] unless
dup method>> {
{ "GET" [ url>> <redirect> ] }
{ "HEAD" [ url>> <redirect> ] }
: string>word ( string -- word )
":" split1 swap 2dup lookup-word dup
- [ 2nip ] [ drop no-such-word ] if ;
+ [ 2nip ] [ drop throw-no-such-word ] if ;
: strings>words ( seq -- seq' )
[ string>word ] map ;
: base-path ( string -- seq )
dup responder-nesting get
[ second class-of superclasses-of [ name>> = ] with any? ] with find nip
- [ first ] [ no-such-responder ] ?if ;
+ [ first ] [ throw-no-such-responder ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
reset-mouse ;
: close-game-input ( -- )
game-input-opened [
- dup zero? [ game-input-not-open ] when
+ dup zero? [ throw-game-input-not-open ] when
1 -
] change-global
game-input-opened? [
MACRO: npick ( n -- quot )
{
- { [ dup 0 <= ] [ nonpositive-npick ] }
+ { [ dup 0 <= ] [ throw-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 gir-not-found ] if*
+ [ path append-path ] [ path paths throw-gir-not-found ] if*
] if ;
: define-gir-vocab ( path -- )
: get-type-info ( data-type -- info )
qualified-type-name dup type-infos get-global at
- [ ] [ unknown-type-error ] ?if ;
+ [ ] [ throw-unknown-type-error ] ?if ;
: find-type-info ( data-type -- info/f )
qualified-type-name type-infos get-global at ;
<<
void* lookup-c-type clone
- [ drop deferred-type-error ] >>unboxer-quot
- [ drop deferred-type-error ] >>boxer-quot
+ [ drop throw-deferred-type-error ] >>unboxer-quot
+ [ drop throw-deferred-type-error ] >>boxer-quot
object >>boxed-class
"deferred-type" create-word-in typedef
>>
TUPLE: chunking-seq { seq read-only } { n read-only } ;
: check-groups ( seq n -- seq n )
- dup 0 <= [ groups-error ] when ; inline
+ dup 0 <= [ throw-groups-error ] when ; inline
: new-groups ( seq n class -- groups )
[ check-groups ] dip boa ; inline
ERROR: not-a-heap object ;
: check-heap ( heap -- heap )
- dup heap? [ not-a-heap ] unless ; inline
+ dup heap? [ throw-not-a-heap ] unless ; inline
TUPLE: entry value key heap index ;
<PRIVATE
: entry>index ( entry heap -- n )
- over heap>> eq? [ bad-heap-delete ] unless
+ over heap>> eq? [ throw-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 simple-lint-error
+ "%d disposable(s) leaked in example" sprintf throw-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
- simple-lint-error
+ throw-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"
- simple-lint-error
+ throw-simple-lint-error
] unless ;
: check-nulls ( element -- )
\ $values swap elements
null swap deep-member?
- [ "$values should not contain null" simple-lint-error ] when ;
+ [ "$values should not contain null" throw-simple-lint-error ] when ;
: check-see-also ( element -- )
\ $see-also swap elements [ rest all-unique? ] all?
- [ "$see-also are not unique" simple-lint-error ] unless ;
+ [ "$see-also are not unique" throw-simple-lint-error ] unless ;
: vocab-exists? ( name -- ? )
[ lookup-vocab ] [ all-vocabs-list get member? ] bi or ;
second
vocab-exists? [
"$vocab-link to non-existent vocabulary"
- simple-lint-error
+ throw-simple-lint-error
] unless
] each ;
[
"\n\t" intersects? [
"Paragraph text should not contain \\n or \\t"
- simple-lint-error
+ throw-simple-lint-error
] when
] [
" " swap subseq? [
"Paragraph text should not contain double spaces"
- simple-lint-error
+ throw-simple-lint-error
] when
] bi ;
: check-whitespace ( str1 str2 -- )
[ " " tail? ] [ " " head? ] bi* or
- [ "Missing whitespace between strings" simple-lint-error ] unless ;
+ [ "Missing whitespace between strings" throw-simple-lint-error ] unless ;
: check-bogus-nl ( element -- )
{ { $nl } { { $nl } } } [ head? ] with any? [
"Simple element should not begin with a paragraph break"
- simple-lint-error
+ throw-simple-lint-error
] when ;
: extract-slots ( elements -- seq )
] [ extract-slots ] bi*
[ swap member? ] with reject [
", " join "Described $slot does not exist: " prepend
- simple-lint-error
+ throw-simple-lint-error
] unless-empty
] [
nip empty? not [
"A word that is not a class has a $class-description"
- simple-lint-error
+ throw-simple-lint-error
] when
] if ;
: check-article-title ( article -- )
article-title first LETTER?
- [ "Article title must begin with a capital letter" simple-lint-error ] unless ;
+ [ "Article title must begin with a capital letter" throw-simple-lint-error ] unless ;
: check-elements ( element -- )
{
swap '[
_ elements [
rest { { } { "" } } member?
- [ "Empty $description" simple-lint-error ] when
+ [ "Empty $description" throw-simple-lint-error ] when
] each
] each ;
ERROR: number-of-arguments found required ;
: check-first ( seq -- first )
- dup length 1 = [ length 1 number-of-arguments ] unless
+ dup length 1 = [ length 1 throw-number-of-arguments ] unless
first-unsafe ;
: check-first2 ( seq -- first second )
- dup length 2 = [ length 2 number-of-arguments ] unless
+ dup length 2 = [ length 2 throw-number-of-arguments ] unless
first2-unsafe ;
PRIVATE>
SYNTAX: ARTICLE:
location [
\ ; parse-until >array
- dup length 2 < [ article-expects-name-and-title ] when
+ dup length 2 < [ throw-article-expects-name-and-title ] when
[ first2 ] [ 2 tail ] bi <article>
over add-article >link
] dip remember-definition ;
drop "Help article does not exist" ;
: lookup-article ( name -- article )
- articles get ?at [ no-article ] unless ;
+ articles get ?at [ throw-no-article ] unless ;
M: object valid-article? articles get key? ;
M: object article-title lookup-article article-title ;
ERROR: cannot-specialize word specializer ;
: set-specializer ( word specializer -- )
- over inline-recursive? [ cannot-specialize ] when
+ over inline-recursive? [ throw-cannot-specialize ] when
"specializer" set-word-prop ;
SYNTAX: HINTS:
ERROR: tag-not-allowed-here ;
: check-tag ( -- )
- string-context? get [ tag-not-allowed-here ] when ;
+ string-context? get [ throw-tag-not-allowed-here ] when ;
: compile-tag ( tag -- )
check-tag
SYMBOL: title
: set-title ( string -- )
- title get [ >box ] [ no-boilerplate ] if* ;
+ title get [ >box ] [ throw-no-boilerplate ] if* ;
: get-title ( -- string )
- title get [ value>> ] [ no-boilerplate ] if* ;
+ title get [ value>> ] [ throw-no-boilerplate ] if* ;
: write-title ( -- )
get-title write ;
response "location" header redirect-url
response code>> 307 = [ "GET" >>method ] unless
quot (with-http-request)
- ] [ too-many-redirects ] if ; inline recursive
+ ] [ throw-too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )
read-crlf ";" split1 drop [ blank? ] trim-tail
ERROR: bad-request-line < request-error parse-error ;
: check-absolute ( url -- )
- path>> dup "/" head? [ drop ] [ invalid-path ] if ; inline
+ path>> dup "/" head? [ drop ] [ throw-invalid-path ] if ; inline
: parse-request-line-safe ( string -- triple )
- [ parse-request-line ] [ nip bad-request-line ] recover ;
+ [ parse-request-line ] [ nip throw-bad-request-line ] recover ;
: read-request-line ( request -- request )
read-?crlf [ dup "" = ] [ drop read-?crlf ] while
: parse-multipart-form-data ( string -- separator )
";" split1 nip
- "=" split1 nip [ no-boundary ] unless* ;
+ "=" split1 nip [ throw-no-boundary ] unless* ;
: maybe-limit-input ( content-length -- )
unlimited-input upload-limit get [ min ] when* limited-input ;
"content-length" header [
dup string>number [
nip dup 0 upload-limit get between? [
- invalid-content-length
+ throw-invalid-content-length
] unless
- ] [ invalid-content-length ] if*
- ] [ content-length-missing ] if* ;
+ ] [ throw-invalid-content-length ] if*
+ ] [ throw-content-length-missing ] if* ;
: parse-content ( request content-type -- post-data )
dup <post-data> -rot over parse-content-length-safe swap
ERROR: unsupported-pixel-format component-order ;
: check-pixel-format ( image -- )
- component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ;
+ component-order>> dup BGRA = [ drop ] [ throw-unsupported-pixel-format ] if ;
: image>gdi+-bitmap ( image -- bitmap )
dup check-pixel-format
types [ H{ } clone ] initialize
: (image-class) ( type -- class )
- >lower types get ?at [ unknown-image-extension ] unless ;
+ >lower types get ?at [ throw-unknown-image-extension ] unless ;
: image-class ( path -- class )
file-extension (image-class) ;
ERROR: not-an-interval-map obj ;
: check-interval-map ( map -- map )
- dup interval-map? [ not-an-interval-map ] unless ; inline
+ dup interval-map? [ throw-not-an-interval-map ] unless ; inline
PRIVATE>
ERROR: not-an-interval-set obj ;
: check-interval-set ( map -- map )
- dup interval-set? [ not-an-interval-set ] unless ; inline
+ dup interval-set? [ throw-not-an-interval-set ] unless ; inline
PRIVATE>
ERROR: fail ;
M: fail summary drop "Matching failed" ;
-: assure ( ? -- ) [ fail ] unless ; inline
+: assure ( ? -- ) [ throw-fail ] unless ; inline
: =/fail ( obj1 obj2 -- ) = assure ; inline
[ dupd "pop-length" set-word-prop ] dip
"pop-inverse" set-word-prop ;
-ERROR: no-inverse word ;
-M: no-inverse summary
- drop "The word cannot be used in pattern matching" ;
-
ERROR: bad-math-inverse ;
: next ( revquot -- revquot* first )
- [ bad-math-inverse ]
+ [ throw-bad-math-inverse ]
[ unclip-slice ] if-empty ;
: constant-word? ( word -- ? )
[ in>> empty? ] bi and ;
: assure-constant ( constant -- quot )
- dup word? [ bad-math-inverse ] when 1quotation ;
+ dup word? [ throw-bad-math-inverse ] when 1quotation ;
: swap-inverse ( math-inverse revquot -- revquot* quot )
next assure-constant rot second '[ @ swap @ ] ;
\ ? 2 [
[ assert-literal ] bi@
- [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
+ [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ throw-fail ] if ] if ]
2curry
] define-pop-inverse
: empty-inverse ( class -- quot )
deconstruct-pred
- [ tuple-slots [ ] any? [ fail ] when ]
+ [ tuple-slots [ ] any? [ throw-fail ] when ]
compose ;
\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
- "I/O" suspend [ io-timeout ] when
+ "I/O" suspend [ throw-io-timeout ] when
] if ;
: wait-for-port ( port event -- )
ERROR: not-a-buffered-port port ;
: check-buffered-port ( port -- port )
- dup buffered-port? [ not-a-buffered-port ] unless ; inline
+ dup buffered-port? [ throw-not-a-buffered-port ] unless ; inline
M: fd refill
[ check-buffered-port buffer>> ] [ fd>> ] bi*
ERROR: file-not-found path bfs? quot ;
: find-file-throws ( path bfs? quot -- path )
- 3dup find-file [ 2nip nip ] [ file-not-found ] if* ; inline
+ 3dup find-file [ 2nip nip ] [ throw-file-not-found ] if* ; inline
ERROR: sequence-expected obj ;
: ensure-sequence-of-directories ( obj -- seq )
dup string? [ 1array ] when
- dup sequence? [ sequence-expected ] unless ;
+ dup sequence? [ throw-sequence-expected ] unless ;
! Can't make this generic# on string/sequence because of combinators
: find-in-directories ( directories bfs? quot -- path'/f )
resolve-symlinks
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
-ERROR: file-system-not-found ;
-
M: linux file-system-info ( path -- file-system-info )
normalize-path
[
[ length 2 >= ]
[ second CHAR: : = ]
[ first Letter? ]
- } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
+ } 1&& [ 2 head "\\" append ] [ throw-not-absolute-path ] if ;
<PRIVATE
<PRIVATE
: (follow-links) ( n path -- path' )
- over 0 = [ symlink-depth get too-many-symlinks ] when
+ over 0 = [ symlink-depth get throw-too-many-symlinks ] when
dup link-info symbolic-link?
[ [ 1 - ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
<master-completion-port> master-completion-port set-global
H{ } clone pending-overlapped set-global ;
-ERROR: invalid-file-size n ;
-
: (handle>file-size) ( handle -- n/f )
0 ulonglong <ref> [ GetFileSizeEx ] keep swap
[ drop f ] [ drop ulonglong deref ] if-zero ;
ERROR: seek-before-start n ;
: set-seek-ptr ( n handle -- )
- [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
+ [ dup 0 < [ throw-seek-before-start ] when ] dip ptr<< ;
M: windows tell-handle ( handle -- n ) ptr>> ;
process>> . ;
M: process >process
- dup process-started? [ process-already-started ] when
+ dup process-started? [ throw-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>> [ process-was-killed ] [ status>> ] if ;
+ dup killed>> [ throw process-was-killed ] [ status>> ] if ;
: wait-for-process ( process -- status )
[ (wait-for-process) ] with-timeout ;
] [ process>> . ] bi ;
: check-success ( process status -- )
- 0 = [ drop ] [ process-failed ] if ;
+ 0 = [ drop ] [ throw-process-failed ] if ;
: wait-for-success ( process -- )
dup wait-for-process check-success ;
[ +closed+ or ] change-stdin
utf8 (process-reader)
[ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
- 0 = [ 2drop ] [ output-process-error ] if ;
+ 0 = [ 2drop ] [ throw-output-process-error ] if ;
<PRIVATE
dup call-CreateProcess
lpProcessInformation>>
] with-destructors
- ] [ launch-error ] recover ;
+ ] [ throw-launch-error ] recover ;
: prepare-mapped-file ( path quot -- mapped-file path' length )
[
[ normalize-path ] [ file-info size>> ] bi
- [ dup 0 <= [ bad-mmap-size ] [ 2drop ] if ]
+ [ dup 0 <= [ throw-bad-mmap-size ] [ 2drop ] if ]
[ nip mapped-file new-disposable swap >>length ]
] dip 2tri [ >>address ] [ >>handle ] bi* ; inline
ERROR: not-a-c-ptr object ;
: check-c-ptr ( c-ptr -- c-ptr )
- dup c-ptr? [ not-a-c-ptr ] unless ; inline
+ dup c-ptr? [ throw-not-a-c-ptr ] unless ; inline
<PRIVATE
SYMBOL: running-servers
running-servers [ HS{ } clone ] initialize
-ERROR: server-already-running threaded-server ;
-
ERROR: server-not-running threaded-server ;
+ERROR: server-already-running threaded-server ;
+
<PRIVATE
: must-be-running ( threaded-server -- threaded-server )
- dup running-servers get in? [ server-not-running ] unless ;
+ dup running-servers get in? [ throw-server-not-running ] unless ;
: must-not-be-running ( threaded-server -- threaded-server )
- dup running-servers get in? [ server-already-running ] when ;
+ dup running-servers get in? [ throw-server-already-running ] when ;
: add-running-server ( threaded-server -- )
must-not-be-running
ERROR: file-expected path ;
: ensure-exists ( path -- path )
- dup exists? [ file-expected ] unless ; inline
+ dup exists? [ throw-file-expected ] unless ; inline
: ssl-file-path ( path -- path' )
absolute-path ensure-exists ;
: syscall-error ( r -- event )
ERR_get_error [
{
- { -1 [ errno ECONNRESET = [ premature-close ] [ throw-errno ] if ] }
+ { -1 [
+ errno ECONNRESET = [ throw-premature-close ]
+ [ throw-errno ] if
+ ] }
! OpenSSL docs say this it is an error condition for
! a server to not send a close notify, but web
! servers in the wild don't seem to do this, for
: check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK =
- [ drop ] [ verify-message certificate-verify-error ] if ;
+ [ drop ] [ verify-message throw-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 ] [ subject-name-verify-error ] if
- ] [ certificate-missing-error ] if* ;
+ [ 2drop ] [ throw-subject-name-verify-error ] if
+ ] [ throw-certificate-missing-error ] if* ;
M: openssl check-certificate ( host ssl -- )
current-secure-context config>> verify>> [
] [ 2drop ] if ;
: check-buffer ( port -- port )
- dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ;
+ dup buffer>> buffer-empty? [ throw-upgrade-buffers-full ] unless ;
: input/output-ports ( -- input output )
input-stream output-stream
[ get underlying-port check-buffer ] bi@
- 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ;
+ 2dup [ handle>> ] bi@ eq? [ throw-upgrade-on-non-socket ] unless ;
: make-input/output-secure ( input output -- )
- dup handle>> non-ssl-socket? [ upgrade-on-non-socket ] unless
+ dup handle>> non-ssl-socket? [ throw-upgrade-on-non-socket ] unless
[ <ssl-socket> ] change-handle
handle>> >>handle drop ;
: (send-secure-handshake) ( output -- )
- remote-address get [ upgrade-on-non-socket ] unless*
+ remote-address get [ throw-upgrade-on-non-socket ] unless*
secure-connection ;
M: openssl send-secure-handshake
: parse-ipv4 ( string -- seq )
[ f ] [
- "." split dup length 4 = [ malformed-ipv4 ] unless
- [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as
+ "." split dup length 4 = [ throw-malformed-ipv4 ] unless
+ [ dup string>number [ ] [ throw-bad-ipv4-component ] ?if ] B{ } map-as
] if-empty ;
: check-ipv4 ( string -- )
- [ parse-ipv4 drop ] [ invalid-ipv4 ] recover ;
+ [ parse-ipv4 drop ] [ throw-invalid-ipv4 ] recover ;
PRIVATE>
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
M: ipv4 inet-pton ( str addrspec -- data )
- drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ;
+ drop [ parse-ipv4 ] [ throw-invalid-ipv4 ] recover ;
M: ipv4 address-size drop 4 ;
ERROR: more-than-8-components ;
: parse-ipv6-component ( seq -- seq' )
- [ dup hex> [ nip ] [ bad-ipv6-component ] if* ] { } map-as ;
+ [ dup hex> [ nip ] [ throw-bad-ipv6-component ] if* ] { } map-as ;
: parse-ipv6 ( string -- seq )
[ f ] [
] if-empty ;
: check-ipv6 ( string -- )
- [ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ invalid-ipv6 ] recover ;
+ [ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ throw-invalid-ipv6 ] recover ;
PRIVATE>
: pad-ipv6 ( string1 string2 -- seq )
2dup [ length ] bi@ + 8 swap -
- dup 0 < [ more-than-8-components ] when
+ dup 0 < [ throw-more-than-8-components ] when
<byte-array> glue ;
: ipv6-bytes ( seq -- bytes )
M: ipv6 inet-pton ( str addrspec -- data )
drop
[ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ]
- [ invalid-ipv6 ]
+ [ throw-invalid-ipv6 ]
recover ;
M: ipv6 address-size drop 16 ;
pick class-of byte-array assert= ;
: check-connectionless-port ( port -- port )
- dup { [ datagram-port? ] [ raw-port? ] } 1|| [ invalid-port ] unless ;
+ dup { [ datagram-port? ] [ raw-port? ] } 1|| [ throw-invalid-port ] unless ;
: check-send ( packet addrspec port -- packet addrspec port )
check-connectionless-port check-disposed check-port ;
M: string resolve-host
f prepare-addrinfo f void* <ref> [
getaddrinfo [
- dup addrinfo-error-string addrinfo-error
+ dup addrinfo-error-string throw-addrinfo-error
] unless-zero
] keep void* deref addrinfo memory>struct
[ parse-addrinfo-list ] keep freeaddrinfo ;
drop "Cannot use <server> with <inet>; use <inet4> or <inet6> instead" ;
M: inet (server)
- invalid-inet-server ;
+ throw-invalid-inet-server ;
ERROR: invalid-local-address addrspec ;
[
[ ] [ inet4? ] [ inet6? ] tri or
[ bind-local-address ]
- [ invalid-local-address ] if
+ [ throw-invalid-local-address ] if
] dip with-variable ; inline
: protocol-port ( protocol -- port )
M: duplex-stream underlying-handle
>duplex-stream<
[ underlying-handle ] bi@
- [ = [ invalid-duplex-stream ] when ] keep ;
+ [ = [ throw-invalid-duplex-stream ] when ] keep ;
: check-count-bounds ( n stream -- n stream )
dup [ count>> ] [ limit>> ] bi >
- [ limit-exceeded ] when ;
+ [ throw-limit-exceeded ] when ;
: check-current-bounds ( n stream -- n stream )
dup [ current>> ] [ start>> ] bi <
- [ limit-exceeded ] when ;
+ [ throw-limit-exceeded ] when ;
: adjust-limited-read ( n stream -- n stream )
dup start>> [
M:: throws-on-eof-stream stream-read1 ( stream -- obj )
stream stream>> stream-read1
- [ 1 stream \ read1 stream-exhausted ] unless* ;
+ [ 1 stream \ read1 throw-stream-exhausted ] unless* ;
M:: throws-on-eof-stream stream-read-unsafe ( n buf stream -- count )
n buf stream stream>> stream-read-unsafe
- dup n = [ n stream \ stream-read-unsafe stream-exhausted ] unless ;
+ dup n = [ n stream \ stream-read-unsafe throw-stream-exhausted ] unless ;
M:: throws-on-eof-stream stream-read-partial-unsafe ( n buf stream -- count )
n buf stream stream>> stream-read-partial-unsafe
- [ n stream \ stream-read-partial-unsafe stream-exhausted ] when-zero ;
+ [ n stream \ stream-read-partial-unsafe throw-stream-exhausted ] when-zero ;
M: throws-on-eof-stream stream-tell
stream>> stream-tell ;
M: throws-on-eof-stream stream-read-until
[ stream>> stream-read-until ]
- [ '[ length _ \ read-until stream-exhausted ] unless* ] bi ;
+ [ '[ length _ \ read-until throw-stream-exhausted ] unless* ] bi ;
: stream-throw-on-eof ( ..a stream quot: ( ..a stream' -- ..b ) -- ..b )
[ <throws-on-eof-stream> ] dip with-input-stream* ; inline
] dip ;
: json-expect ( token stream -- )
- [ dup length ] [ stream-read ] bi* = [ json-error ] unless ; inline
+ [ dup length ] [ stream-read ] bi* = [ throw-json-error ] unless ; inline
DEFER: (read-json-string)
{ CHAR: t [ CHAR: \t ] }
{ CHAR: u [ over read-json-escape-unicode ] }
[ ]
- } case [ suffix! (read-json-string) ] [ json-error ] if* ;
+ } case [ suffix! (read-json-string) ] [ throw-json-error ] if* ;
: (read-json-string) ( stream accum -- accum )
{ sbuf } declare
[ length 1 - ] keep [ nth-unsafe ] [ shorten ] 2bi ; inline
: check-length ( seq n -- seq )
- [ dup length ] [ >= ] bi* [ json-error ] unless ; inline
+ [ dup length ] [ >= ] bi* [ throw-json-error ] unless ; inline
: v-over-push ( accum -- accum )
{ vector } declare 2 check-length
ERROR: libc-error errno message ;
-: (throw-errno) ( errno -- * ) dup strerror libc-error ;
+: (throw-errno) ( errno -- * ) dup strerror throw-libc-error ;
: throw-errno ( -- * ) errno (throw-errno) ;
drop "Memory allocation failed" ;
: check-ptr ( c-ptr -- c-ptr )
- [ bad-ptr ] unless* ;
+ [ throw-bad-ptr ] unless* ;
ERROR: realloc-error ptr size ;
: realloc ( alien size -- newalien )
[ >c-ptr ] dip
- over malloc-exists? [ realloc-error ] unless
+ over malloc-exists? [ throw-realloc-error ] unless
[ drop ] [ (realloc) check-ptr ] 2bi
[ delete-malloc ] [ add-malloc ] bi* ;
IN: locals
SYNTAX: :>
- in-lambda? get [ :>-outside-lambda-error ] unless
+ in-lambda? get [ throw-:>-outside-lambda-error ] unless
scan-token parse-def suffix! ;
SYNTAX: [| parse-lambda append! ;
ERROR: invalid-local-name name ;
: check-local-name ( name -- name )
- dup { "]" "]!" } member? [ invalid-local-name ] when ;
+ dup { "]" "]!" } member? [ throw-invalid-local-name ] when ;
: make-local ( name -- word )
check-local-name "!" ?tail [
: (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 ] [ bad-rewrite ] if ]
+ [ nip rewrite-closures dup length 1 = [ first ] [ throw-bad-rewrite ] if ]
[ drop nip ] 3tri ; inline
: parse-locals-definition ( word reader-quot -- word quot effect )
: local-index ( args obj -- n )
2dup '[ unquote _ eq? ] find drop
- [ 2nip ] [ bad-local ] if* ;
+ [ 2nip ] [ throw-bad-local ] if* ;
: read-local-quot ( args obj -- quot )
local-index neg [ get-local ] curry ;
M: lambda rewrite-element rewrite-sugar* ;
-M: let rewrite-element let-form-in-literal-error ;
+M: let rewrite-element throw-let-form-in-literal-error ;
M: local rewrite-element , ;
M: local-reader rewrite-element , ;
M: local-writer rewrite-element
- local-writer-in-literal-error ;
+ throw-local-writer-in-literal-error ;
M: word rewrite-element <wrapper> , ;
ERROR: undefined-log-level ;
: log-level<=> ( log-level log-level -- <=> )
- [ log-levels at* [ undefined-log-level ] unless ] compare ;
+ [ log-levels at* [ throw-undefined-log-level ] unless ] compare ;
: log? ( log-level -- ? )
log-level get log-level<=> +lt+ = not ;
: check-log-message ( msg word level -- msg word level )
3dup [ string? ] [ word? ] [ word? ] tri* and and
- [ bad-log-message-parameters ] unless ; inline
+ [ throw-bad-log-message-parameters ] unless ; inline
: log-message ( msg word level -- )
check-log-message
MACRO: match-cond ( assoc -- quot )
<reversed>
- dup ?first callable? [ unclip ] [ [ no-match-cond ] ] if
+ dup ?first callable? [ unclip ] [ [ throw-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|| [ bit-range-error ] when
+ 2dup { [ nip 0 < ] [ < ] } 2|| [ throw-bit-range-error ] when
[ nip neg shift ] [ - 1 + ] 2bi bits ; inline
: bitroll ( x s w -- y )
ERROR: malformed-complex obj ;
: parse-complex ( seq -- complex )
- dup length 2 = [ first2-unsafe rect> ] [ malformed-complex ] if ;
+ dup length 2 = [ first2-unsafe rect> ] [ throw-malformed-complex ] if ;
SYNTAX: C{ \ } [ parse-complex ] parse-literal ;
: mod-inv ( x n -- y )
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
- [ non-trivial-divisor ] if ; foldable
+ [ throw-non-trivial-divisor ] if ; foldable
: ^mod ( x y n -- z )
over 0 <
[ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
: m^n ( m n -- n )
- dup 0 >= [ (m^n) ] [ negative-power-matrix ] if ;
+ dup 0 >= [ (m^n) ] [ throw-negative-power-matrix ] if ;
: stitch ( m -- m' )
[ ] [ [ append ] 2map ] map-reduce ;
M: word integer-op-input-classes
dup "input-classes" word-prop
- [ ] [ bad-integer-op ] ?if ;
+ [ ] [ throw-bad-integer-op ] ?if ;
: generic-variant ( op -- generic-op/f )
dup "derived-from" word-prop [ first ] [ ] ?if ;
make-bits { 1 } [ [ over p* ] when [ p-sq ] dip ] reduce nip ;
: p^ ( p n -- p^n )
- dup 0 >= [ (p^) ] [ negative-power-polynomial ] if ;
+ dup 0 >= [ (p^) ] [ throw-negative-power-polynomial ] if ;
<PRIVATE
: lucas-lehmer-guard ( obj -- obj )
dup { [ integer? ] [ 0 > ] } 1&&
- [ invalid-lucas-lehmer-candidate ] unless ;
+ [ throw-invalid-lucas-lehmer-candidate ] unless ;
PRIVATE>
ERROR: no-relative-prime n ;
: find-relative-prime* ( n guess -- p )
- [ dup 1 <= [ no-relative-prime ] when ]
+ [ dup 1 <= [ throw-no-relative-prime ] when ]
[ >odd dup 1 <= [ drop 3 ] when ] bi*
[ 2dup coprime? ] [ 2 + ] until nip ;
ERROR: too-few-primes n numbits ;
: unique-primes ( n numbits -- seq )
- 2dup 2^ estimated-primes > [ too-few-primes ] when
+ 2dup 2^ estimated-primes > [ throw-too-few-primes ] when
2dup [ random-prime ] curry replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
inputs narray
[ quot with-datastack ]
[ [ [ declaration declare quot call ] compile-call ] with-datastack ] bi
- 2dup = [ optimized-vconvert-inconsistent ] unless
+ 2dup = [ throw-optimized-vconvert-inconsistent ] unless
drop outputs firstn
] ;
{ uchar ushort uint ulonglong } member-eq? ;
: check-vconvert-type ( value expected-type -- value )
- 2dup instance? [ drop ] [ bad-vconvert-input ] if ; inline
+ 2dup instance? [ drop ] [ throw-bad-vconvert-input ] if ; inline
:: [vconvert] ( from-element to-element from-size to-size from-type to-type -- quot )
{
[ steps 1 = not ]
[ from-element to-element [ float-type? ] bi@ xor ]
[ from-element unsigned-type? to-element unsigned-type? not and ]
- } 0|| [ from-type to-type bad-vconvert ] when ;
+ } 0|| [ from-type to-type throw-bad-vconvert ] when ;
:: ([vpack-unsigned]) ( from-type to-type -- quot )
from-type new simd-rep
[ steps 1 = not ]
[ from-element to-element [ float-type? ] bi@ xor ]
[ from-element unsigned-type? not to-element unsigned-type? and ]
- } 0|| [ from-type to-type bad-vconvert ] when ;
+ } 0|| [ from-type to-type throw-bad-vconvert ] when ;
:: ([vunpack]) ( from-type to-type -- quot )
from-type new simd-rep
from-element heap-size :> from-size
to-element heap-size :> to-size
- from-length to-length = [ from-type to-type bad-vconvert ] unless
+ from-length to-length = [ from-type to-type throw-bad-vconvert ] unless
from-element to-element from-size to-size from-type to-type {
{ [ from-size to-size < ] [ [vunpack] ] }
IN: math.vectors.simd
ERROR: bad-simd-length got expected ;
-
ERROR: bad-simd-vector obj ;
<<
M: simd-128 new-sequence
2dup length =
[ nip [ 16 (byte-array) ] make-underlying ]
- [ length bad-simd-length ] if ; inline
+ [ length throw-bad-simd-length ] if ; inline
M: simd-128 equal?
dup simd-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
A >>boxed-class
{ A-rep alien-vector A boa } >quotation >>getter
{
- [ dup simd-128? [ bad-simd-vector ] unless underlying>> ] 2dip
+ [ dup simd-128? [ throw-bad-simd-vector ] unless underlying>> ] 2dip
A-rep set-alien-vector
} >quotation >>setter
16 >>size
swap >>mime-separator
H{ } clone >>mime-parts ;
-ERROR: bad-header bytes ;
-
: mime-write ( sequence -- )
>byte-array write ;
: parse-headers ( string -- hashtable )
string-lines harvest [ parse-header-line ] map >hashtable ;
-ERROR: end-of-stream multipart ;
-
: fill-bytes ( multipart -- multipart )
buffer-size read
[ '[ _ B{ } append-as ] change-bytes ]
[ dup mime-separator>> dump-string >>name-content ] dip
>>name dup save-mime-part
] [
- unknown-content-disposition
+ throw-unknown-content-disposition
] if*
] if* ;
parse-content-disposition-form-data >>content-disposition
parse-form-data
] }
- [ no-content-disposition ]
+ [ throw-no-content-disposition ]
} case ;
: read-assert-sequence= ( sequence -- )
: check-set-slot ( val slot -- val offset )
{
- { [ dup not ] [ no-such-slot ] }
- { [ dup read-only>> ] [ read-only-slot ] }
+ { [ dup not ] [ throw-no-such-slot ] }
+ { [ dup read-only>> ] [ throw-read-only-slot ] }
{ [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
[ offset>> ]
} cond ; inline
: parse-here ( -- str )
[
lexer get
- dup rest-of-line [ text-found-before-eol ] unless-empty
+ dup rest-of-line [ throw-text-found-before-eol ] unless-empty
(parse-here)
] "" make but-last ;
begin-text lexer (parse-til-line-begins)
] if
] [
- begin-text bad-heredoc
+ begin-text throw-bad-heredoc
] if ;
: parse-til-line-begins ( begin-text lexer -- seq )
ERROR: bad-array-length n ;
: <nibble-array> ( n -- nibble-array )
- dup 0 < [ bad-array-length ] when
+ dup 0 < [ throw-bad-array-length ] when
dup nibbles>bytes <byte-array> nibble-array boa ; inline
M: nibble-array length length>> ;
{ [ os windows? ] [ "opengl.gl.windows" ] }
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
{ [ os unix? ] [ "opengl.gl.gtk" ] }
- [ unknown-gl-platform ]
+ [ throw-unknown-gl-platform ]
} cond use-vocab >>
SYMBOL: +gl-function-counter+
: image-internal-format ( component-order component-type -- internal-format )
2dup
[ fix-internal-component-order ] dip 2array image-internal-formats at
- [ 2nip ] [ unsupported-component-order ] if* ;
+ [ 2nip ] [ throw-unsupported-component-order ] if* ;
: reversed-type? ( component-type -- ? )
{ u-9-9-9-e5-components float-11-11-10-components } member? ;
{ RGBA [ drop GL_RGBA_INTEGER ] }
{ BGRX [ drop GL_BGRA_INTEGER ] }
{ RGBX [ drop GL_RGBA_INTEGER ] }
- [ swap unsupported-component-order ]
+ [ swap throw-unsupported-component-order ]
} case
] [
swap {
{ INTENSITY [ drop GL_INTENSITY ] }
{ DEPTH [ drop GL_DEPTH_COMPONENT ] }
{ DEPTH-STENCIL [ drop GL_DEPTH_STENCIL ] }
- [ swap unsupported-component-order ]
+ [ swap throw-unsupported-component-order ]
} case
] if ;
GENERIC: (component-type>type) ( component-order component-type -- gl-type )
-M: object (component-type>type) unsupported-component-order ;
+M: object (component-type>type) throw-unsupported-component-order ;
: four-channel-alpha-first? ( component-order component-type -- ? )
over component-count 4 =
[ drop alpha-channel-precedes-colors? ]
- [ unsupported-component-order ] if ;
+ [ throw-unsupported-component-order ] if ;
: not-alpha-first ( component-order component-type -- )
over alpha-channel-precedes-colors?
- [ unsupported-component-order ]
+ [ throw-unsupported-component-order ]
[ 2drop ] if ;
M: ubyte-components (component-type>type)
M: u-24-components (component-type>type)
over DEPTH =
- [ 2drop GL_UNSIGNED_INT ] [ unsupported-component-order ] if ;
+ [ 2drop GL_UNSIGNED_INT ]
+ [ throw-unsupported-component-order ] if ;
M: u-24-8-components (component-type>type)
over DEPTH-STENCIL =
- [ 2drop GL_UNSIGNED_INT_24_8 ] [ unsupported-component-order ] if ;
+ [ 2drop GL_UNSIGNED_INT_24_8 ]
+ [ throw-unsupported-component-order ] if ;
M: u-9-9-9-e5-components (component-type>type)
over BGR =
- [ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ] [ unsupported-component-order ] if ;
+ [ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ]
+ [ throw-unsupported-component-order ] if ;
M: float-11-11-10-components (component-type>type)
over BGR =
- [ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ] [ unsupported-component-order ] if ;
+ [ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ]
+ [ throw-unsupported-component-order ] if ;
: image-data-format ( component-order component-type -- gl-format gl-type )
[ (component-order>format) ] [ (component-type>type) ] 2bi ;
: read-packed-bytes ( str -- bytes )
dup packed-length [ read dup length ] keep =
- [ nip ] [ packed-read-fail ] if ; inline
+ [ nip ] [ throw-packed-read-fail ] if ; inline
PRIVATE>
<PRIVATE
: lookup-rule ( rule parser -- rule' )
- 2dup rule [ 2nip ] [ no-rule ] if* ;
+ 2dup rule [ 2nip ] [ throw-no-rule ] if* ;
TUPLE: tokenizer-tuple any one many ;
drop "Tokenizer not found" ;
SYNTAX: TOKENIZER:
- scan-word-name dup search [ nip ] [ no-tokenizer ] if*
+ scan-word-name dup search [ nip ] [ throw-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? [ redefined-rule ] [ set ] if
+ swap symbol>> dup get parser? [ throw-redefined-rule ] [ set ] if
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
def call compile :> compiled-def
[
dup compiled-def compiled-parse
- [ ast>> ] [ word parse-failed ] ?if
+ [ ast>> ] [ word throw-parse-failed ] ?if
]
word swap effect define-declared
] with-compilation-unit
M: persistent-vector ppop ( pvec -- pvec' )
dup count>> {
- { 0 [ empty-error ] }
+ { 0 [ throw-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 -- * ) no-random-number-generator ;
+M: f random-bytes* ( n obj -- * ) throw-no-random-number-generator ;
-M: f random-32* ( obj -- * ) no-random-number-generator ;
+M: f random-32* ( obj -- * ) throw-no-random-number-generator ;
: random-32 ( -- n )
random-generator get random-32* ;
ERROR: too-many-samples seq n ;
: sample ( seq n -- seq' )
- 2dup [ length ] dip < [ too-many-samples ] when
+ 2dup [ length ] dip < [ throw-too-many-samples ] when
[ [ length iota >array ] dip [ randomize-n-last ] keep tail-slice* ]
[ drop ] 2bi nths-unsafe ;
: attempt-crypto-context ( provider type -- handle )
[ acquire-crypto-context ]
- [ drop [ create-crypto-context ] [ acquire-crypto-context-failed ] recover ] recover ;
+ [
+ drop [ create-crypto-context ]
+ [ throw-acquire-crypto-context-failed ] recover
+ ] recover ;
: initialize-crypto-context ( crypto-context -- crypto-context )
dup [ provider>> ] [ type>> ] bi attempt-crypto-context >>handle ;
ERROR: bad-number ;
: ensure-number ( n -- n )
- [ bad-number ] unless* ;
+ [ throw-bad-number ] unless* ;
:: at-error ( key assoc quot: ( key -- replacement ) -- value )
key assoc at* [ drop key quot call ] unless ; inline
{ [ "script=" ?head ] [
dup simple-script-table at
[ <script-class> ]
- [ "script=" prepend bad-class ] ?if
+ [ "script=" prepend throw-bad-class ] ?if
] }
- [ bad-class ]
+ [ throw-bad-class ]
} cond ;
: unicode-class ( name -- class )
- dup parse-unicode-class [ ] [ bad-class ] ?if ;
+ dup parse-unicode-class [ ] [ throw-bad-class ] ?if ;
: name>class ( name -- class )
>string simple {
ERROR: nonexistent-option name ;
: ch>option ( ch -- singleton )
- dup options-assoc at [ ] [ nonexistent-option ] ?if ;
+ dup options-assoc at [ ] [ throw-nonexistent-option ] ?if ;
: option>ch ( option -- string )
options-assoc value-at ;
Times = "," Number:n "}" => [[ 0 n <from-to> ]]
| Number:n ",}" => [[ n <at-least> ]]
| Number:n "}" => [[ n n <from-to> ]]
- | "}" => [[ bad-number ]]
+ | "}" => [[ throw-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? [ roman-range-error ] unless ;
+ dup 1 10000 between? [ throw-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 unrolled-bounds-error ] when ; inline
+ 2over swap length > [ 2over throw-unrolled-bounds-error ] when ; inline
:: unrolled-2bounds-check ( xseq yseq len quot -- xseq yseq len quot )
{ [ len xseq length > ] [ len yseq length > ] } 0||
- [ xseq yseq len unrolled-2bounds-error ]
+ [ xseq yseq len throw-unrolled-2bounds-error ]
[ xseq yseq len quot ] if ; inline
: (unrolled-each) ( seq len quot -- len quot )
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
dup "\r\n>" intersects?
- [ bad-email-address ] when ;
+ [ throw-bad-email-address ] when ;
: mail-from ( fromaddr -- )
validate-address
: check-response ( response -- )
dup code>> {
{ [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
- { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
- { [ dup 500 = ] [ drop smtp-syntax-error ] }
- { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
- { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
- { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
- { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
- { [ dup 551 = ] [ drop smtp-user-not-local ] }
- { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
- { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
- { [ dup 554 = ] [ drop smtp-transaction-failed ] }
- [ drop smtp-error ]
+ { [ dup 400 499 between? ] [ drop throw-smtp-server-busy ] }
+ { [ dup 500 = ] [ drop throw-smtp-syntax-error ] }
+ { [ dup 501 = ] [ drop throw-smtp-command-not-implemented ] }
+ { [ dup 500 509 between? ] [ drop throw-smtp-syntax-error ] }
+ { [ dup 530 539 between? ] [ drop throw-smtp-bad-authentication ] }
+ { [ dup 550 = ] [ drop throw-smtp-mailbox-unavailable ] }
+ { [ dup 551 = ] [ drop throw-smtp-user-not-local ] }
+ { [ dup 552 = ] [ drop throw-smtp-exceeded-storage-allocation ] }
+ { [ dup 553 = ] [ drop throw-smtp-bad-mailbox-name ] }
+ { [ dup 554 = ] [ drop throw-smtp-transaction-failed ] }
+ [ drop throw-smtp-error ]
} cond ;
: get-ok ( -- ) receive-response check-response ;
: validate-header ( string -- string' )
dup "\r\n" intersects?
- [ invalid-header-string ] when ;
+ [ throw-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
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-array-constructor drop void* c-array-constructor ;
M: c-type-word c-(array)-constructor
underlying-type
dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-(array)-constructor drop void* c-(array)-constructor ;
M: c-type-word c-direct-array-constructor
underlying-type
dup [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ;
M: c-type-word c-array-type
underlying-type
dup [ name>> "-array" append ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-array-type drop void* c-array-type ;
M: c-type-word c-array-type?
underlying-type
dup [ name>> "-array?" append ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ throw-specialized-array-vocab-not-loaded ] ?if ; foldable
M: pointer c-array-type? drop void* c-array-type? ;
ERROR: custom-error ;
{ T{ effect f { } { } t } } [
- [ custom-error ] infer
+ [ throw-custom-error ] infer
] unit-test
: funny-throw ( a -- * ) throw ; inline
] unit-test
{ T{ effect f { } { } t } } [
- [ custom-error inference-error ] infer
+ [ throw-custom-error inference-error ] infer
] unit-test
{ T{ effect f { "x" } { "x" "x" } t } } [
<PRIVATE
: check-annotate-twice ( word -- word )
- dup annotated? [ cannot-annotate-twice ] when ;
+ dup annotated? [ throw-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 invalid-stream-read-unsafe ]
+ [ n buf stream word throw-invalid-stream-read-unsafe ]
[ n buf stream ] if
] if ; inline
:: check-stream-read-unsafe-after ( count n buf stream word -- count )
count n >
- [ count n buf stream word invalid-stream-read-unsafe-return ]
+ [ count n buf stream word throw-invalid-stream-read-unsafe-return ]
[ count ] if ;
: (assert-stream-read-unsafe) ( word -- )
: copy-library ( dir library -- )
dup find-library-file
[ swap over file-name append-path copy-file ]
- [ can't-deploy-library-file ] ?if ;
+ [ throw-can't-deploy-library-file ] ?if ;
: copy-libraries ( manifest name dir -- )
append-path swap libraries>> [ copy-library ] with each ;
ERROR: cannot-define-array-in-deployed-app type ;
-: define-array-vocab ( type -- ) cannot-define-array-in-deployed-app ;
+: define-array-vocab ( type -- ) throw-cannot-define-array-in-deployed-app ;
cpu ppc? [ 100000 + ] when
os windows? [ 160000 + ] when
] bi*
- 2dup <= [ 2drop ] [ image-too-big ] if ;
+ 2dup <= [ 2drop ] [ throw-image-too-big ] if ;
: deploy-test-command ( -- args )
os macosx?
: check-ico-type ( bytes -- bytes )
dup "PNG" head? [
- "PNG" unsupported-ico-format
+ "PNG" throw-unsupported-ico-format
] when
dup B{ 0 0 } head? [
- "UNKNOWN" unsupported-ico-format
+ "UNKNOWN" throw-unsupported-ico-format
] unless ;
PRIVATE>
{ +file-date+ [ file-info>> modified>> listing-date ] }
{ +file-time+ [ file-info>> modified>> listing-time ] }
{ +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] }
- [ unknown-file-spec ]
+ [ throw-unknown-file-spec ]
} case ;
: list-files-fast ( listing-tool -- array )
: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
: check-tr ( from to -- )
- [ [ ascii? ] all? ] both? [ bad-tr ] unless ;
+ [ [ ascii? ] all? ] both? [ throw-bad-tr ] unless ;
: compute-tr ( quot from to -- mapping )
[ 128 iota ] 3dip zip
: check-final ( class -- )
{
- { [ dup tuple-class? not ] [ not-a-tuple ] }
- { [ dup final-class? not ] [ not-final ] }
+ { [ dup tuple-class? not ] [ throw-not-a-tuple ] }
+ { [ dup final-class? not ] [ throw-not-final ] }
[ drop ]
} cond ;
:: (typed-get) ( name type getter: ( name -- value ) -- value )
name getter call :> value
- value type instance? [ name value type variable-type-error ] unless
+ value type instance? [ name value type throw-variable-type-error ] unless
value type declare1 ; inline
: typed-get ( name type -- value )
[ get-global ] (typed-get) ; inline
:: (typed-set) ( value name type setter: ( value name -- ) -- )
- value type instance? [ name value type variable-type-error ] unless
+ value type instance? [ name value type throw-variable-type-error ] unless
value name setter call ; inline
: typed-set ( value name type -- )
:: typed-inputs ( quot word types -- quot' )
types unboxed-types :> unboxed-types
- [ input-mismatch-error ] word types make-unboxer
+ [ throw-input-mismatch-error ] word types make-unboxer
unboxed-types quot '[ _ declare @ ]
compose ;
! typed outputs
:: typed-outputs ( quot word types -- quot' )
- [ output-mismatch-error ] word types make-unboxer
+ [ throw-output-mismatch-error ] word types make-unboxer
quot prepose ;
DEFER: make-boxer
dup {
[ effect-in-types typed-stack-effect? ]
[ effect-out-types typed-stack-effect? ]
- } 1|| [ (typed-def) ] [ nip no-types-specified ] if ;
+ } 1|| [ (typed-def) ] [ nip throw-no-types-specified ] if ;
M: typed-word subwords
[ call-next-method ]
{
{ [ dup string-array? ] [ ] }
{ [ dup string? ] [ ?string-lines ] }
- [ not-a-string ]
+ [ throw-not-a-string ]
} cond
] dip [ text<< ] [ relayout ] bi ; inline
: find-gl-context ( gadget -- )
find-world dup
- [ set-gl-context ] [ no-world-found ] if ;
+ [ set-gl-context ] [ throw-no-world-found ] if ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
: <pixel-format> ( world attributes -- pixel-format )
2dup (make-pixel-format)
[ pixel-format new-disposable swap >>handle swap >>world ]
- [ invalid-pixel-format-attributes ]
+ [ throw-invalid-pixel-format-attributes ]
?if ;
M: pixel-format dispose*
ERROR: no-group string ;
: ?group-id ( string -- id )
- dup group-struct [ nip gr_gid>> ] [ no-group ] if* ;
+ dup group-struct [ nip gr_gid>> ] [ throw-no-group ] if* ;
<PRIVATE
{ "vendor_id" [ >>vendor-id ] }
{ "wp" [ "yes" = >>wp? ] }
{ "TLB size" [ >>tlb-size ] }
- [ unknown-cpuinfo-line ]
+ [ throw-unknown-cpuinfo-line ]
} case ;
failed [
n narray
errno dup strerror
- word unix-system-call-error
+ word throw-unix-system-call-error
] [
n ndrop
ret
errno EINTR = [
n narray
errno dup strerror
- word unix-system-call-error
+ word throw-unix-system-call-error
] unless
] [
n ndrop
ERROR: no-user string ;
: ?user-id ( string -- id/f )
- dup user-passwd [ nip uid>> ] [ no-user ] if* ;
+ dup user-passwd [ nip uid>> ] [ throw-no-user ] if* ;
: real-user-id ( -- id )
unix.ffi:getuid ; inline
ERROR: no-such-user obj ;
: user-home ( name/uid -- path )
- dup user-passwd [ nip dir>> ] [ no-such-user ] if* ;
+ dup user-passwd [ nip dir>> ] [ throw-no-such-user ] if* ;
os macosx? [ "unix.users.macosx" require ] when
drop ; inline
M: unrolled-list pop-front*
- dup front>> [ empty-unrolled-list ] unless*
+ dup front>> [ throw-empty-unrolled-list ] unless*
over front-pos>> unroll-factor 1 - eq?
[ pop-front/new ] [ pop-front/existing ] if ;
drop ; inline
M: unrolled-list pop-back*
- dup back>> [ empty-unrolled-list ] unless*
+ dup back>> [ throw-empty-unrolled-list ] unless*
over back-pos>> 1 eq?
[ pop-back/new ] [ pop-back/existing ] if ;
: parse-host ( string -- host/f port/f )
[
":" split1-last [ url-decode ]
- [ dup [ string>number [ malformed-port ] unless* ] when ] bi*
+ [ dup [ string>number [ throw-malformed-port ] unless* ] when ] bi*
] [ f f ] if* ;
GENERIC: >url ( obj -- url )
ERROR: empty-vlist-error ;
M: vlist ppop
- [ empty-vlist-error ]
+ [ throw-empty-vlist-error ]
[ [ length>> 1 - ] [ vector>> ] bi vlist boa ] if-empty ;
M: vlist clone
ERROR: vocab-root-required root ;
: ensure-vocab-root ( root -- root )
- dup vocab-roots get member? [ vocab-root-required ] unless ;
+ dup vocab-roots get member? [ throw-vocab-root-required ] unless ;
: ensure-vocab-root/prefix ( root prefix -- root prefix )
[ ensure-vocab-root ] [ check-vocab-name ] bi* ;
ERROR: null-com-release ;
: com-release ( interface -- )
- [ IUnknown::Release drop ] [ null-com-release ] if* ; inline
+ [ IUnknown::Release drop ] [ throw-null-com-release ] if* ; inline
: with-com-interface ( interface quot -- )
over [ com-release ] curry [ ] cleanup ; inline
: find-com-interface-definition ( name -- definition )
[
dup +com-interface-definitions+ get-global at*
- [ nip ] [ drop no-com-interface ] if
+ [ nip ] [ drop throw-no-com-interface ] if
] [ f ] if* ;
: save-com-interface-definition ( definition -- )
ERROR: windows-error n string ;
: (win32-error) ( n -- )
- [ dup win32-error-string windows-error ] unless-zero ;
+ [ dup win32-error-string throw-windows-error ] unless-zero ;
: win32-error ( -- )
GetLastError (win32-error) ;
dup ERROR_SUCCESS = [
drop
] [
- dup n>win32-error-string windows-error
+ dup n>win32-error-string throw-windows-error
] if ;
: throw-win32-error ( -- * )
ERROR: gdi+-error status ;
: check-gdi+-status ( GpStatus -- )
- dup Ok = [ drop ] [ gdi+-error ] if ;
+ dup Ok = [ drop ] [ throw-gdi+-error ] if ;
CONSTANT: standard-gdi+-startup-input
S{ GdiplusStartupInput
dup iSockaddrLength>> {
{ 16 [ lpSockaddr>> sockaddr-in memory>struct ] }
{ 28 [ lpSockaddr>> sockaddr-in6 memory>struct ] }
- [ unknown-sockaddr-length ]
+ [ throw-unknown-sockaddr-length ]
} case ;
TYPEDEF: SOCKET_ADDRESS* PSOCKET_ADDRESS
drop
] [
[ key subkey mode ] dip n>win32-error-string
- open-key-failed
+ throw-open-key-failed
] if
] keep HKEY deref ;
hKey lpSubKey 0 lpClass dwOptions samDesired
lpSecurityAttributes
] dip n>win32-error-string
- create-key-failed
+ throw-create-key-failed
] unless ;
: create-key ( hkey lsubkey -- hkey )
ERROR: mci-error n ;
: check-mci-error ( n -- )
- [ mci-error ] unless-zero ;
+ [ throw-mci-error ] unless-zero ;
: open-command ( path -- )
"open \"%s\" type mpegvideo alias MediaFile" sprintf f 0 f
maybe-winsock-exception [ throw ] when* ;
: (throw-winsock-error) ( n -- * )
- [ ] [ n>win32-error-string ] bi winsock-exception ;
+ [ ] [ n>win32-error-string ] bi throw-winsock-exception ;
: throw-winsock-error ( -- * )
WSAGetLastError (throw-winsock-error) ;
children>string {
{ "1" [ t ] }
{ "0" [ f ] }
- [ "Bad boolean" server-error ]
+ [ "Bad boolean" throw-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" server-error ] if
+ ] [ "Bad main tag name" throw-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 '[ _ no-tag ] suffix '[ dup main>> _ case ] ;
+ >alist swap '[ _ throw-no-tag ] suffix '[ dup main>> _ case ] ;
: define-tags ( word effect -- )
[ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
] with-variable
] with each ;
-ERROR: mutually-recursive-rulesets ruleset ;
-
: finalize-rule-set ( ruleset -- )
dup finalized?>> [ drop ] [
t >>finalized?
projects / factor.git / commitdiff