change ERROR: words from throw-foo back to foo.
John Benediktsson
parent
a6926b19ce
commit
ceb75057da
|
|
@ -55,12 +55,12 @@ UNION: c-type-name
|
|||
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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ M: bad-byte-array-length summary
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ ERROR: invalid-signed-conversion n ;
|
|||
{ 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 )
|
||||
|
|
|
|||
|
|
@ -80,7 +80,7 @@ M: library dispose dll>> [ dispose ] when* ;
|
|||
|
||||
: address-of ( name library -- value )
|
||||
2dup load-library dlsym-raw
|
||||
[ 2nip ] [ throw-no-such-symbol ] if* ;
|
||||
[ 2nip ] [ no-such-symbol ] if* ;
|
||||
|
||||
SYMBOL: deploy-libraries
|
||||
|
||||
|
|
@ -89,7 +89,7 @@ deploy-libraries [ V{ } clone ] initialize
|
|||
: 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' )
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ ERROR: bad-array-type ;
|
|||
|
||||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ CONSTANT: alphabet
|
|||
|
||||
: 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 '[
|
||||
|
|
@ -84,7 +84,7 @@ PRIVATE>
|
|||
4 "\n\r" pick read-ignoring dup length {
|
||||
{ 0 [ 2drop ] }
|
||||
{ 4 [ decode4 (decode-base64) ] }
|
||||
[ throw-malformed-base64 ]
|
||||
[ malformed-base64 ]
|
||||
} case ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ M: no-biassoc-deletion summary
|
|||
drop "biassocs do not support deletion" ;
|
||||
|
||||
M: biassoc delete-at
|
||||
throw-no-biassoc-deletion ;
|
||||
no-biassoc-deletion ;
|
||||
|
||||
M: biassoc >alist from>> >alist ;
|
||||
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ PRIVATE>
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ M: bit-set delete
|
|||
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 ]
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ ERROR: invalid-widthed bits #bits ;
|
|||
dup 0 < [ neg ] when log2 <=
|
||||
] if-zero
|
||||
]
|
||||
} 2|| [ throw-invalid-widthed ] when ;
|
||||
} 2|| [ invalid-widthed ] when ;
|
||||
|
||||
: <widthed> ( bits #bits -- widthed )
|
||||
check-widthed
|
||||
|
|
@ -89,7 +89,7 @@ ERROR: not-enough-widthed-bits widthed n ;
|
|||
|
||||
: 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
|
||||
|
|
@ -161,7 +161,7 @@ ERROR: not-enough-bits n bit-reader ;
|
|||
] 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 ) ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IN: bootstrap.help
|
|||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -365,7 +365,7 @@ ERROR: not-in-image vocabulary word ;
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -437,7 +437,7 @@ M: byte-array '
|
|||
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 ]
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ ERROR: box-full box ;
|
|||
|
||||
: >box ( value box -- )
|
||||
dup occupied>>
|
||||
[ throw-box-full ] [ t >>occupied value<< ] if ; inline
|
||||
[ box-full ] [ t >>occupied value<< ] if ; inline
|
||||
|
||||
ERROR: box-empty box ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,6 @@ ERROR: odd-length-hex-string string ;
|
|||
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! ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ ERROR: cairo-error n message ;
|
|||
|
||||
: (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) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ M: not-a-month summary
|
|||
<PRIVATE
|
||||
|
||||
: check-month ( n -- n )
|
||||
[ throw-not-a-month ] when-zero ;
|
||||
[ not-a-month ] when-zero ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -93,7 +93,7 @@ CONSTANT: month-abbreviations-hash
|
|||
|
||||
: 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 }
|
||||
|
||||
|
|
|
|||
|
|
@ -202,7 +202,7 @@ M: timestamp year. ( timestamp -- )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ M: evp-md-context dispose*
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -285,7 +285,7 @@ M: struct binary-zero? binary-object uchar <c-direct-array> [ 0 = ] all? ; inlin
|
|||
|
||||
:: (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
|
||||
|
|
@ -376,7 +376,7 @@ PRIVATE>
|
|||
scan-token {
|
||||
{ ";" [ f ] }
|
||||
{ "{" [ parse-struct-slot suffix! t ] }
|
||||
[ throw-invalid-struct-slot ]
|
||||
[ invalid-struct-slot ]
|
||||
} case ;
|
||||
|
||||
: parse-struct-definition ( -- class slots )
|
||||
|
|
@ -413,7 +413,7 @@ SYNTAX: S@
|
|||
scan-token {
|
||||
{ ";" [ f ] }
|
||||
{ "{" [ parse-struct-slot` t ] }
|
||||
[ throw-invalid-struct-slot ]
|
||||
[ invalid-struct-slot ]
|
||||
} case ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ ERROR: no-objc-method name ;
|
|||
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 ;
|
||||
|
|
@ -196,7 +196,7 @@ ERROR: no-objc-type name ;
|
|||
|
||||
: 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 {
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ ERROR: invalid-plist-object object ;
|
|||
{ NSArray [ (plist-NSArray>) ] }
|
||||
{ NSDictionary [ (plist-NSDictionary>) ] }
|
||||
{ NSObject [ ] }
|
||||
[ throw-invalid-plist-object ]
|
||||
[ invalid-plist-object ]
|
||||
} objc-class-case ;
|
||||
|
||||
: read-plist ( path -- assoc )
|
||||
|
|
|
|||
|
|
@ -28,6 +28,6 @@ PRIVATE>
|
|||
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! ;
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ M: bad-probabilities summary
|
|||
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) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ ERROR: cannot-determine-arity ;
|
|||
|
||||
: arity ( quots -- n )
|
||||
first infer
|
||||
dup terminated?>> [ throw-cannot-determine-arity ] when
|
||||
dup terminated?>> [ cannot-determine-arity ] when
|
||||
effect-height neg 1 + ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ ERROR: vreg-not-new vreg ;
|
|||
|
||||
:: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ ERROR: bad-successors ;
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ ERROR: inline-intrinsics-not-supported word quot ;
|
|||
|
||||
: enable-intrinsics ( alist -- )
|
||||
[
|
||||
over inline? [ throw-inline-intrinsics-not-supported ] when
|
||||
over inline? [ inline-intrinsics-not-supported ] when
|
||||
"intrinsic" set-word-prop
|
||||
] assoc-each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@ MACRO: if-literals-match ( quots -- quot )
|
|||
! node literals quot
|
||||
[ _ firstn ] dip call
|
||||
drop
|
||||
] [ 2drop throw-bad-simd-intrinsic ] if
|
||||
] [ 2drop bad-simd-intrinsic ] if
|
||||
] ;
|
||||
|
||||
CONSTANT: [unary] [ ds-drop ds-pop ]
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ ERROR: bad-live-ranges interval ;
|
|||
: 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 -- )
|
||||
|
|
|
|||
|
|
@ -40,11 +40,11 @@ ERROR: splitting-atomic-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
|
||||
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ ERROR: register-already-used live-interval ;
|
|||
: 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? )
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ ERROR: not-spilled-error vreg ;
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -172,7 +172,7 @@ M: hairy-clobber-insn compute-live-intervals* ( insn -- )
|
|||
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 -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ ERROR: bad-numbering bb ;
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ SYMBOL: representations
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ M: scalar-rep int>rep ( dst src rep -- )
|
|||
! 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
|
||||
]
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ ERROR: vregs-shouldn't-interfere vreg1 vreg2 ;
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -68,6 +68,6 @@ ERROR: bad-kill-index vreg bb ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ ERROR: bad-peek dst loc ;
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ CONSTANT: initial-state { { 0 { } } { 0 { } } }
|
|||
[ 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 ;
|
||||
|
|
@ -68,7 +68,7 @@ ERROR: vacant-peek insn ;
|
|||
|
||||
: 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=
|
||||
|
|
|
|||
|
|
@ -319,7 +319,7 @@ ERROR: bug-in-fixnum* x y a b ;
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -11,11 +11,11 @@ IN: compiler.tree.checker
|
|||
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 ( -- )
|
||||
|
|
@ -62,7 +62,7 @@ ERROR: check-node-error node error ;
|
|||
[ node-defs-values check-values ]
|
||||
[ check-node* ]
|
||||
tri
|
||||
] [ throw-check-node-error ] recover ;
|
||||
] [ check-node-error ] recover ;
|
||||
|
||||
SYMBOL: datastack
|
||||
SYMBOL: retainstack
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ TUPLE: definition value node uses ;
|
|||
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) ;
|
||||
|
|
@ -27,7 +27,7 @@ ERROR: multiple-defs-error ;
|
|||
|
||||
: (def-value) ( node value def-use -- )
|
||||
2dup key? [
|
||||
throw-multiple-defs-error
|
||||
multiple-defs-error
|
||||
] [
|
||||
[ [ <definition> ] keep ] dip set-at
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ IN: compiler.tree.propagation.call-effect.tests
|
|||
2dip
|
||||
rot
|
||||
[ 2drop ]
|
||||
[ throw-wrong-values ]
|
||||
[ wrong-values ]
|
||||
if
|
||||
]
|
||||
( obj -- a b c )
|
||||
|
|
|
|||
|
|
@ -146,14 +146,14 @@ ERROR: uninferable ;
|
|||
: (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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ ERROR: invalid-outputs #call infos ;
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -164,7 +164,7 @@ ERROR: bad-partial-eval quot word ;
|
|||
|
||||
: 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 [
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ 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 <= [ 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
|
||||
|
|
@ -104,7 +104,7 @@ CONSTANT: dist-table
|
|||
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
|
||||
|
|
@ -113,7 +113,7 @@ CONSTANT: dist-table
|
|||
|
||||
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
|
||||
|
|
@ -157,7 +157,7 @@ CONSTANT: dist-table
|
|||
{ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ ERROR: code-size-zero ;
|
|||
|
||||
: <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
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ ERROR: snappy-error error ;
|
|||
<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 ;
|
||||
|
|
|
|||
|
|
@ -20,13 +20,13 @@ ERROR: zlib-failed n string ;
|
|||
"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 )
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ ERROR: timed-out-error timer ;
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ TUPLE: count-down-tuple n promise ;
|
|||
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 ;
|
||||
|
||||
|
|
@ -22,7 +22,7 @@ ERROR: count-down-already-done ;
|
|||
|
||||
: 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 -- )
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ M: cannot-send-synchronous-to-self summary
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ ERROR: promise-already-fulfilled promise ;
|
|||
|
||||
: fulfill ( value promise -- )
|
||||
dup promise-fulfilled? [
|
||||
throw-promise-already-fulfilled
|
||||
promise-already-fulfilled
|
||||
] [
|
||||
mailbox>> mailbox-put
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ M: negative-count-semaphore summary
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ CONSTANT: kLSUnknownCreator f
|
|||
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
|
||||
|
|
|
|||
|
|
@ -67,5 +67,5 @@ ERROR: unsupported-number-type type ;
|
|||
{ kCFNumberLongType [ long (CFNumber>number) ] }
|
||||
{ kCFNumberLongLongType [ longlong (CFNumber>number) ] }
|
||||
{ kCFNumberDoubleType [ double (CFNumber>number) ] }
|
||||
[ throw-unsupported-number-type ]
|
||||
[ unsupported-number-type ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ MEMO: make-attributes ( open-font color -- hashtable )
|
|||
[
|
||||
[
|
||||
dup selection? [ string>> ] when
|
||||
dup string? [ throw-not-a-string ] unless
|
||||
dup string? [ not-a-string ] unless
|
||||
] 2dip
|
||||
make-attributes <CFAttributedString> &CFRelease
|
||||
CTLineCreateWithAttributedString
|
||||
|
|
|
|||
|
|
@ -234,14 +234,14 @@ M: operand MOV 0x88 2-operand ;
|
|||
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 {
|
||||
|
|
@ -249,7 +249,7 @@ M: integer MOVABS
|
|||
{ 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 ;
|
||||
|
|
@ -481,7 +481,7 @@ ERROR: bad-x87-operands ;
|
|||
:: 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 -- )
|
||||
{
|
||||
|
|
@ -494,7 +494,7 @@ ERROR: bad-x87-operands ;
|
|||
{ [ src ST0 = dst register? and ] [
|
||||
dst opcode 4 + reg (x87-op)
|
||||
] }
|
||||
[ throw-bad-x87-operands ]
|
||||
[ bad-x87-operands ]
|
||||
} cond ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ M: indirect extended? base>> extended? ;
|
|||
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
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -278,7 +278,7 @@ M: postgresql-db-connection compound ( string object -- string' )
|
|||
{ "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
|
||||
|
|
|
|||
|
|
@ -158,7 +158,7 @@ M: db-connection <select-by-slots-statement> ( tuple class -- statement )
|
|||
[
|
||||
"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
|
||||
|
|
|
|||
|
|
@ -12,11 +12,11 @@ ERROR: sqlite-error < db-error n string ;
|
|||
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 -- )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@ ERROR: sqlite-last-id-fail ;
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@ ERROR: no-slots-named class seq ;
|
|||
[ 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
|
||||
|
|
@ -103,7 +103,7 @@ ERROR: no-defined-persistent object ;
|
|||
|
||||
: ensure-defined-persistent ( object -- object )
|
||||
dup { [ class? ] [ "db-table" word-prop ] } 1&& [
|
||||
throw-no-defined-persistent
|
||||
no-defined-persistent
|
||||
] unless ;
|
||||
|
||||
: create-table ( class -- )
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ SYMBOL: IGNORE
|
|||
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 ;
|
||||
|
|
@ -117,13 +117,13 @@ ERROR: unknown-modifier modifier ;
|
|||
: 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? [
|
||||
|
|
@ -152,5 +152,5 @@ ERROR: no-column column ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ M: tuple-class group-words
|
|||
|
||||
: 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
|
||||
|
||||
|
|
@ -160,7 +160,7 @@ ERROR: not-a-generic word ;
|
|||
|
||||
: check-generic ( generic -- )
|
||||
dup array? [ first ] when
|
||||
dup generic? [ drop ] [ throw-not-a-generic ] if ;
|
||||
dup generic? [ drop ] [ not-a-generic ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -18,13 +18,13 @@ GENERIC: deque-empty? ( deque -- ? )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ M: object editor-detached? t ;
|
|||
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* ;
|
||||
|
||||
|
|
@ -66,7 +66,7 @@ PRIVATE>
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ fmt-E = digits "E" => [[ first '[ _ format-scientific >upper ] ]]
|
|||
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 ]]
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ GENERIC: fry ( quot -- quot' )
|
|||
|
||||
: 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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ IN: ftp.client
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ ERROR: type-error type ;
|
|||
>upper {
|
||||
{ "IMAGE" [ "Binary" ] }
|
||||
{ "I" [ "Binary" ] }
|
||||
[ throw-type-error ]
|
||||
[ type-error ]
|
||||
} case ;
|
||||
|
||||
: handle-TYPE ( obj -- )
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ M: asides call-responder*
|
|||
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> ] }
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ ERROR: no-such-word name vocab ;
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -32,7 +32,7 @@ ERROR: no-such-responder responder ;
|
|||
: 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 [
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ ERROR: game-input-not-open ;
|
|||
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? [
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ ERROR: nonpositive-npick n ;
|
|||
|
||||
MACRO: npick ( n -- quot )
|
||||
{
|
||||
{ [ dup 0 <= ] [ throw-nonpositive-npick ] }
|
||||
{ [ dup 0 <= ] [ nonpositive-npick ] }
|
||||
{ [ dup 1 = ] [ drop [ dup ] ] }
|
||||
[ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ]
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ M: gir-not-found summary
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ ERROR: unknown-type-error type ;
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -105,8 +105,8 @@ ERROR: deferred-type-error ;
|
|||
|
||||
<<
|
||||
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
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ M: abstract-clumps group@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ TUPLE: heap { data vector } ;
|
|||
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 ;
|
||||
|
||||
|
|
@ -164,7 +164,7 @@ M: bad-heap-delete summary
|
|||
<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>
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ SYMBOL: vocab-articles
|
|||
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 -- )
|
||||
|
|
@ -88,7 +88,7 @@ SYMBOL: vocab-articles
|
|||
[ 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 ;
|
||||
|
||||
|
|
@ -96,17 +96,17 @@ SYMBOL: vocab-articles
|
|||
[ 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 ;
|
||||
|
|
@ -116,7 +116,7 @@ SYMBOL: vocab-articles
|
|||
second
|
||||
vocab-exists? [
|
||||
"$vocab-link to non-existent vocabulary"
|
||||
throw-simple-lint-error
|
||||
simple-lint-error
|
||||
] unless
|
||||
] each ;
|
||||
|
||||
|
|
@ -127,23 +127,23 @@ SYMBOL: vocab-articles
|
|||
[
|
||||
"\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 )
|
||||
|
|
@ -158,18 +158,18 @@ SYMBOL: vocab-articles
|
|||
] [ 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 -- )
|
||||
{
|
||||
|
|
@ -184,7 +184,7 @@ SYMBOL: vocab-articles
|
|||
swap '[
|
||||
_ elements [
|
||||
rest { { } { "" } } member?
|
||||
[ "Empty $description" throw-simple-lint-error ] when
|
||||
[ "Empty $description" simple-lint-error ] when
|
||||
] each
|
||||
] each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -210,11 +210,11 @@ M: word link-long-text
|
|||
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>
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ ERROR: article-expects-name-and-title got ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ M: no-article summary
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ M: object specializer-declaration class-of ;
|
|||
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:
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ SYMBOL: string-context?
|
|||
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
|
||||
|
|
|
|||
|
|
@ -39,10 +39,10 @@ M: no-boilerplate error.
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ SYMBOL: redirects
|
|||
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
|
||||
|
|
|
|||
|
|
@ -17,10 +17,10 @@ ERROR: content-length-missing < request-error ;
|
|||
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
|
||||
|
|
@ -36,7 +36,7 @@ upload-limit [ 200,000,000 ] initialize
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -49,10 +49,10 @@ upload-limit [ 200,000,000 ] initialize
|
|||
"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
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ os windows? [
|
|||
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
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ SYMBOL: types
|
|||
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) ;
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ ALIAS: value third-unsafe
|
|||
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>
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ TUPLE: interval-set { array uint-array read-only } ;
|
|||
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>
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: inverse
|
|||
ERROR: fail ;
|
||||
M: fail summary drop "Matching failed" ;
|
||||
|
||||
: assure ( ? -- ) [ throw-fail ] unless ; inline
|
||||
: assure ( ? -- ) [ fail ] unless ; inline
|
||||
|
||||
: =/fail ( obj1 obj2 -- ) = assure ; inline
|
||||
|
||||
|
|
@ -35,7 +35,7 @@ M: fail summary drop "Matching failed" ;
|
|||
ERROR: bad-math-inverse ;
|
||||
|
||||
: next ( revquot -- revquot* first )
|
||||
[ throw-bad-math-inverse ]
|
||||
[ bad-math-inverse ]
|
||||
[ unclip-slice ] if-empty ;
|
||||
|
||||
: constant-word? ( word -- ? )
|
||||
|
|
@ -44,7 +44,7 @@ ERROR: bad-math-inverse ;
|
|||
[ 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 @ ] ;
|
||||
|
|
@ -169,7 +169,7 @@ ERROR: missing-literal ;
|
|||
|
||||
\ ? 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
|
||||
|
||||
|
|
@ -255,7 +255,7 @@ DEFER: __
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ M: unix wait-for-fd ( handle event -- )
|
|||
{ +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 -- )
|
||||
|
|
@ -86,7 +86,7 @@ M: unix wait-for-fd ( handle 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*
|
||||
|
|
|
|||
|
|
@ -103,13 +103,13 @@ PRIVATE>
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ SYMBOL: 8-bit-encodings
|
|||
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 ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue