diff --git a/core/alien/alien.factor b/core/alien/alien.factor index fc89586b68..0afff0c497 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -65,21 +65,21 @@ TUPLE: library path abi dll ; TUPLE: alien-callback return parameters abi quot xt ; -TUPLE: alien-callback-error ; +ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) - \ alien-callback-error construct-empty throw ; + alien-callback-error ; TUPLE: alien-indirect return parameters abi ; -TUPLE: alien-indirect-error ; +ERROR: alien-indirect-error ; : alien-indirect ( ... funcptr return parameters abi -- ) - \ alien-indirect-error construct-empty throw ; + alien-indirect-error ; TUPLE: alien-invoke library function return parameters ; -TUPLE: alien-invoke-error library symbol ; +ERROR: alien-invoke-error library symbol ; : alien-invoke ( ... return library function parameters -- ... ) - 2over \ alien-invoke-error construct-boa throw ; + 2over alien-invoke-error ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f1d8abdc1e..d874243d71 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -26,9 +26,7 @@ global [ c-types [ H{ } assoc-like ] change ] bind -TUPLE: no-c-type name ; - -: no-c-type ( type -- * ) \ no-c-type construct-boa throw ; +ERROR: no-c-type name ; : (c-type) ( name -- type/f ) c-types get-global at dup [ diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 53d18b53ca..807b372e1d 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting ; -TUPLE: no-cond ; - -: no-cond ( -- * ) \ no-cond construct-empty throw ; +ERROR: no-cond ; : cond ( assoc -- ) [ first call ] find nip dup [ second call ] [ no-cond ] if ; -TUPLE: no-case ; - -: no-case ( -- * ) \ no-case construct-empty throw ; +ERROR: no-case ; : case ( obj assoc -- ) [ dup array? [ dupd first = ] [ quotation? ] if ] find nip diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index ad2fa14954..40bc6615fa 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -75,9 +75,7 @@ SYMBOL: error-hook : try ( quot -- ) [ error-hook get call ] recover ; -TUPLE: assert got expect ; - -: assert ( got expect -- * ) \ assert construct-boa throw ; +ERROR: assert got expect ; : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ; @@ -86,28 +84,22 @@ TUPLE: assert got expect ; : trim-datastacks ( seq1 seq2 -- seq1' seq2' ) 2dup [ length ] 2apply min tuck tail >r tail r> ; -TUPLE: relative-underflow stack ; - -: relative-underflow ( before after -- * ) - trim-datastacks nip \ relative-underflow construct-boa throw ; +ERROR: relative-underflow stack ; M: relative-underflow summary drop "Too many items removed from data stack" ; -TUPLE: relative-overflow stack ; +ERROR: relative-overflow stack ; M: relative-overflow summary drop "Superfluous items pushed to data stack" ; -: relative-overflow ( before after -- * ) - trim-datastacks drop \ relative-overflow construct-boa throw ; - : assert-depth ( quot -- ) >r datastack r> swap slip >r datastack r> 2dup [ length ] compare sgn { - { -1 [ relative-underflow ] } + { -1 [ trim-datastacks nip relative-underflow ] } { 0 [ 2drop ] } - { 1 [ relative-overflow ] } + { 1 [ trim-datastacks drop relative-overflow ] } } case ; inline : expired-error. ( obj -- ) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 01f9643cdd..cec5109909 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -3,10 +3,7 @@ IN: definitions USING: kernel sequences namespaces assocs graphs ; -TUPLE: no-compilation-unit definition ; - -: no-compilation-unit ( definition -- * ) - \ no-compilation-unit construct-boa throw ; +ERROR: no-compilation-unit definition ; GENERIC: where ( defspec -- loc ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index b01fb87f72..46f57a1629 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? ) dup empty? [ [ dip ] curry [ ] like ] unless r> append ; -TUPLE: no-math-method left right generic ; - -: no-math-method ( left right generic -- * ) - \ no-math-method construct-boa throw ; +ERROR: no-math-method left right generic ; : default-math-method ( generic -- quot ) [ no-math-method ] curry [ ] like ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 35161319ef..37f72e7d95 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -26,10 +26,7 @@ SYMBOL: (dispatch#) : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ; -TUPLE: no-method object generic ; - -: no-method ( object generic -- * ) - \ no-method construct-boa throw ; +ERROR: no-method object generic ; : error-method ( word -- quot ) picker swap [ no-method ] curry append ; diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3c12e388c4..4f5d199264 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -514,10 +514,10 @@ DEFER: an-inline-word { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as -TUPLE: custom-error ; +ERROR: custom-error ; [ T{ effect f 0 0 t } ] [ - [ custom-error construct-boa throw ] infer + [ custom-error ] infer ] unit-test : funny-throw throw ; inline diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 240f39218b..a829bad47e 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot ) \ get-slots [ [get-slots] ] 1 define-transform -TUPLE: duplicated-slots-error names ; +ERROR: duplicated-slots-error names ; M: duplicated-slots-error summary drop "Calling set-slots with duplicate slot setters" ; -: duplicated-slots-error ( names -- * ) - \ duplicated-slots-error construct-boa throw ; - \ set-slots [ dup all-unique? [ [get-slots] ] [ duplicated-slots-error ] if diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 03ea2262a8..610d294bb6 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -18,17 +18,13 @@ GENERIC: ( stream decoding -- newstream ) TUPLE: decoder stream code cr ; -TUPLE: decode-error ; - -: decode-error ( -- * ) \ decode-error construct-empty throw ; +ERROR: decode-error ; GENERIC: ( stream encoding -- newstream ) TUPLE: encoder stream code ; -TUPLE: encode-error ; - -: encode-error ( -- * ) \ encode-error construct-empty throw ; +ERROR: encode-error ; ! Decoding diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3de7559303..f9116895e4 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -48,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ; : special-directory? ( name -- ? ) { "." ".." } member? ; -TUPLE: no-parent-directory path ; - -: no-parent-directory ( path -- * ) - \ no-parent-directory construct-boa throw ; +ERROR: no-parent-directory path ; : parent-directory ( path -- parent ) right-trim-separators { diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor index 97e60b4a60..83e991b713 100755 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ; : ( in out -- stream ) f duplex-stream construct-boa ; -TUPLE: check-closed ; +ERROR: stream-closed-twice ; : check-closed ( stream -- ) - duplex-stream-closed? - [ \ check-closed construct-boa throw ] when ; + duplex-stream-closed? [ stream-closed-twice ] when ; : duplex-stream-in+ ( duplex -- stream ) dup check-closed duplex-stream-in ; diff --git a/core/libc/libc.factor b/core/libc/libc.factor index e82b244d6d..756d29e551 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -23,20 +23,14 @@ SYMBOL: mallocs PRIVATE> -TUPLE: check-ptr ; +ERROR: bad-ptr ; : check-ptr ( c-ptr -- c-ptr ) - [ \ check-ptr construct-boa throw ] unless* ; + [ bad-ptr ] unless* ; -TUPLE: double-free ; +ERROR: double-free ; -: double-free ( -- * ) - \ double-free construct-empty throw ; - -TUPLE: realloc-error ptr size ; - -: realloc-error ( alien size -- * ) - \ realloc-error construct-boa throw ; +ERROR: realloc-error ptr size ; [ bad-number ] unless* parsed ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 3c69bfa41c..14674ba2f2 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; : bounds-check? ( n seq -- ? ) length 1- 0 swap between? ; inline -TUPLE: bounds-error index seq ; - -: bounds-error ( n seq -- * ) - \ bounds-error construct-boa throw ; +ERROR: bounds-error index seq ; : bounds-check ( n seq -- n seq ) 2dup bounds-check? [ bounds-error ] unless ; inline MIXIN: immutable-sequence -TUPLE: immutable seq ; - -: immutable ( seq -- * ) \ immutable construct-boa throw ; +ERROR: immutable seq ; M: immutable-sequence set-nth immutable ; @@ -190,8 +185,7 @@ TUPLE: slice from to seq ; : collapse-slice ( m n slice -- m' n' seq ) dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline -TUPLE: slice-error reason ; -: slice-error ( str -- * ) \ slice-error construct-boa throw ; +ERROR: slice-error reason ; : check-slice ( from to seq -- from to seq ) pick 0 < [ "start < 0" slice-error ] when diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 8cc9211599..843f372542 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -165,6 +165,7 @@ IN: bootstrap.syntax "ERROR:" [ CREATE-CLASS dup ";" parse-tokens define-tuple-class + dup save-location dup [ construct-boa throw ] curry define ] define-syntax diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index e48a803659..6f94d034fa 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -87,11 +87,11 @@ PRIVATE> 2dup delegate-slot-spec add* "slots" set-word-prop define-slots ; -TUPLE: check-tuple class ; +ERROR: no-tuple-class class ; : check-tuple ( class -- ) dup tuple-class? - [ drop ] [ \ check-tuple construct-boa throw ] if ; + [ drop ] [ no-tuple-class ] if ; : define-tuple-class ( class slots -- ) 2dup check-shape diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 807e08f73b..9cf5a39772 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -60,16 +60,13 @@ M: f vocab-help ; : create-vocab ( name -- vocab ) dictionary get [ ] cache ; -TUPLE: no-vocab name ; - -: no-vocab ( name -- * ) - vocab-name \ no-vocab construct-boa throw ; +ERROR: no-vocab name ; SYMBOL: load-vocab-hook ! ( name -- ) : load-vocab ( name -- vocab ) dup load-vocab-hook get call - dup vocab [ ] [ no-vocab ] ?if ; + dup vocab [ ] [ vocab-name no-vocab ] ?if ; : vocabs ( -- seq ) dictionary get keys natural-sort ; diff --git a/core/words/words.factor b/core/words/words.factor index a36cca00ac..de253e6fee 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ; M: word definition word-def ; -TUPLE: undefined ; - -: undefined ( -- * ) \ undefined construct-empty throw ; +ERROR: undefined ; PREDICATE: word deferred ( obj -- ? ) word-def [ undefined ] = ; @@ -189,12 +187,11 @@ M: word subwords drop f ; [ ] [ no-vocab ] ?if set-at ; -TUPLE: check-create name vocab ; +ERROR: bad-create name vocab ; : check-create ( name vocab -- name vocab ) - 2dup [ string? ] both? [ - \ check-create construct-boa throw - ] unless ; + 2dup [ string? ] both? + [ bad-create ] unless ; : create ( name vocab -- word ) check-create 2dup lookup