From 02008979d9078e078773d875c994d427de07b685 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 12 Aug 2015 15:26:18 -0500 Subject: [PATCH] factor: Change ERROR: foo ; to define ``throw-foo`` instead of having ``foo`` throw implicitly. The old ``foo`` still throws implicitly because this is a big change to get right in one patch, but it should be removed soon. --- basis/bootstrap/help/help.factor | 2 +- basis/help/help.factor | 4 +- basis/io/encodings/8-bit/8-bit.factor | 2 +- basis/io/encodings/euc/euc.factor | 2 +- basis/io/encodings/gb18030/gb18030.factor | 2 +- basis/io/encodings/iso2022/iso2022.factor | 2 +- basis/io/encodings/shift-jis/shift-jis.factor | 2 +- basis/io/encodings/strict/strict.factor | 2 +- basis/macros/macros.factor | 2 +- basis/tools/deploy/deploy.factor | 4 +- basis/tools/scaffold/scaffold.factor | 4 +- basis/vocabs/metadata/metadata.factor | 6 +- core/alien/alien.factor | 8 +- core/alien/strings/strings.factor | 2 +- core/classes/algebra/algebra.factor | 8 +- core/classes/builtin/builtin.factor | 2 +- core/classes/classes.factor | 2 +- core/classes/mixin/mixin.factor | 2 +- core/classes/tuple/parser/parser.factor | 14 +-- core/classes/tuple/tuple-tests.factor | 86 ++++++------------- core/classes/tuple/tuple.factor | 29 ++----- core/classes/union/union.factor | 2 +- core/combinators/combinators.factor | 2 +- core/continuations/continuations.factor | 2 +- core/definitions/definitions.factor | 2 +- core/destructors/destructors.factor | 2 +- core/effects/effects.factor | 2 +- core/effects/parser/parser.factor | 8 +- core/generic/generic.factor | 2 +- core/generic/math/math.factor | 2 +- core/generic/parser/parser.factor | 2 +- core/generic/single/single.factor | 8 +- core/hashtables/hashtables.factor | 2 +- core/io/encodings/ascii/ascii.factor | 4 +- core/io/encodings/utf16/utf16.factor | 2 +- core/io/pathnames/pathnames.factor | 4 +- core/kernel/kernel.factor | 2 +- core/lexer/lexer.factor | 2 +- core/math/math.factor | 2 +- core/math/parser/parser.factor | 4 +- core/math/ratios/ratios.factor | 4 +- core/parser/parser.factor | 6 +- core/sequences/sequences.factor | 12 +-- core/slots/slots.factor | 4 +- core/source-files/source-files.factor | 2 +- core/strings/parser/parser.factor | 6 +- core/syntax/syntax-docs.factor | 6 +- core/syntax/syntax.factor | 10 +-- core/vocabs/loader/loader-docs.factor | 2 +- core/vocabs/loader/loader.factor | 4 +- core/vocabs/parser/parser.factor | 8 +- core/vocabs/vocabs.factor | 4 +- core/words/words.factor | 6 +- 53 files changed, 133 insertions(+), 184 deletions(-) diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor index 85e94d5a1e..4d10a0beb0 100644 --- a/basis/bootstrap/help/help.factor +++ b/basis/bootstrap/help/help.factor @@ -13,7 +13,7 @@ IN: bootstrap.help t load-help? set-global - [ dup lookup-vocab [ drop ] [ no-vocab ] if ] require-hook [ + [ dup lookup-vocab [ drop ] [ throw-no-vocab ] if ] require-hook [ dictionary get values [ docs-loaded?>> ] reject [ load-docs ] each diff --git a/basis/help/help.factor b/basis/help/help.factor index d02ce72f7b..5c88e85a5d 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.tuple -combinators combinators.short-circuit continuations debugger -effects generic help.crossref help.markup help.stylesheet +classes.error combinators combinators.short-circuit continuations +debugger effects generic help.crossref help.markup help.stylesheet help.topics io io.styles kernel make namespaces prettyprint sequences sorting vocabs words words.symbol ; IN: help diff --git a/basis/io/encodings/8-bit/8-bit.factor b/basis/io/encodings/8-bit/8-bit.factor index 8aec5cb496..17b3a274f9 100644 --- a/basis/io/encodings/8-bit/8-bit.factor +++ b/basis/io/encodings/8-bit/8-bit.factor @@ -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 [ encode-error ] unless* ; inline + biassoc>> value-at [ throw-encode-error ] unless* ; inline M: 8-bit encode-char swap [ 8-bit-encode ] dip stream-write1 ; diff --git a/basis/io/encodings/euc/euc.factor b/basis/io/encodings/euc/euc.factor index 63a2c69cff..3938431c9c 100644 --- a/basis/io/encodings/euc/euc.factor +++ b/basis/io/encodings/euc/euc.factor @@ -19,7 +19,7 @@ M: euc encode-char ( char stream encoding -- ) h>b/b swap 2byte-array swap stream-write ] if - ] [ encode-error ] if* ; + ] [ throw-encode-error ] if* ; : euc-multibyte? ( ch -- ? ) 0x81 0xfe between? ; diff --git a/basis/io/encodings/gb18030/gb18030.factor b/basis/io/encodings/gb18030/gb18030.factor index 7e9d167857..57708b73cd 100644 --- a/basis/io/encodings/gb18030/gb18030.factor +++ b/basis/io/encodings/gb18030/gb18030.factor @@ -90,7 +90,7 @@ ascii xml>gb-data : lookup-range ( char -- byte-array ) dup u>gb get-global interval-at [ [ ufirst>> - ] [ bfirst>> ] bi + unlinear - ] [ encode-error ] if* ; + ] [ throw-encode-error ] if* ; M: gb18030 encode-char ( char stream encoding -- ) drop [ diff --git a/basis/io/encodings/iso2022/iso2022.factor b/basis/io/encodings/iso2022/iso2022.factor index 9b2f3f44c5..d9b9a7f6cd 100644 --- a/basis/io/encodings/iso2022/iso2022.factor +++ b/basis/io/encodings/iso2022/iso2022.factor @@ -44,7 +44,7 @@ CONSTANT: switch-jis212 B{ $ ESC CHAR: $ CHAR: ( CHAR: D } { [ dup jis201 get-global value? ] [ drop switch-jis201 jis201 get-global ] } { [ dup jis208 get-global value? ] [ drop switch-jis208 jis208 get-global ] } { [ dup jis212 get-global value? ] [ drop switch-jis212 jis212 get-global ] } - [ encode-error ] + [ throw-encode-error ] } cond ; : stream-write-num ( num stream -- ) diff --git a/basis/io/encodings/shift-jis/shift-jis.factor b/basis/io/encodings/shift-jis/shift-jis.factor index cd848cd6f8..7b2001255e 100644 --- a/basis/io/encodings/shift-jis/shift-jis.factor +++ b/basis/io/encodings/shift-jis/shift-jis.factor @@ -29,7 +29,7 @@ M: windows-31j drop windows-31j-table get-global ; TUPLE: jis assoc ; -: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ; +: ch>jis ( ch tuple -- jis ) assoc>> value-at [ throw-encode-error ] unless* ; : jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ; : make-jis ( filename -- jis ) diff --git a/basis/io/encodings/strict/strict.factor b/basis/io/encodings/strict/strict.factor index bf1d5376eb..a82fdbedde 100644 --- a/basis/io/encodings/strict/strict.factor +++ b/basis/io/encodings/strict/strict.factor @@ -8,4 +8,4 @@ TUPLE: strict-state code ; C: strict strict-state M: strict-state decode-char - code>> decode-char dup replacement-char = [ decode-error ] when ; + code>> decode-char dup replacement-char = [ throw-decode-error ] when ; diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 362e02c6e7..8c5425c410 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -31,7 +31,7 @@ SYNTAX: MACRO: (:) define-macro ; PREDICATE: macro < word "macro" word-prop >boolean ; -M: macro make-inline cannot-be-inline ; +M: macro make-inline throw-cannot-be-inline ; M: macro definer drop \ MACRO: \ ; ; diff --git a/basis/tools/deploy/deploy.factor b/basis/tools/deploy/deploy.factor index b647c5b5c7..403a9bfbd8 100644 --- a/basis/tools/deploy/deploy.factor +++ b/basis/tools/deploy/deploy.factor @@ -7,10 +7,10 @@ IN: tools.deploy ERROR: no-vocab-main vocab ; : check-vocab-main ( vocab -- vocab ) - [ require ] keep dup vocab-main [ no-vocab-main ] unless ; + [ require ] keep dup vocab-main [ throw-no-vocab-main ] unless ; : deploy ( vocab -- ) - dup find-vocab-root [ check-vocab-main deploy* ] [ no-vocab ] if ; + dup find-vocab-root [ check-vocab-main deploy* ] [ throw-no-vocab ] if ; : deploy-image-only ( vocab image -- ) [ vm-path ] 2dip diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 1eb40445fe..754a33c0ff 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -25,10 +25,10 @@ ERROR: not-a-vocab-root string ; : contains-separator? ( string -- ? ) [ path-separator? ] any? ; : ensure-vocab-exists ( string -- string ) - dup loaded-vocab-names member? [ no-vocab ] unless ; + dup loaded-vocab-names member? [ throw-no-vocab ] unless ; : check-root ( string -- string ) - dup vocab-root? [ not-a-vocab-root ] unless ; + dup vocab-root? [ throw-not-a-vocab-root ] unless ; : check-vocab-root/vocab ( vocab-root string -- vocab-root string ) [ check-root ] [ check-vocab-name ] bi* ; diff --git a/basis/vocabs/metadata/metadata.factor b/basis/vocabs/metadata/metadata.factor index a89c581ea4..7246afa06a 100644 --- a/basis/vocabs/metadata/metadata.factor +++ b/basis/vocabs/metadata/metadata.factor @@ -8,7 +8,7 @@ vocabs.loader words ; IN: vocabs.metadata : check-vocab ( vocab -- vocab ) - dup find-vocab-root [ no-vocab ] unless ; + dup find-vocab-root [ throw-no-vocab ] unless ; MEMO: vocab-file-contents ( vocab name -- seq ) vocab-append-path dup @@ -18,7 +18,7 @@ MEMO: vocab-file-contents ( vocab name -- seq ) dupd vocab-append-path [ swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty \ vocab-file-contents reset-memoized - ] [ vocab-name no-vocab ] ?if ; + ] [ vocab-name throw-no-vocab ] ?if ; : vocab-windows-icon-path ( vocab -- string ) vocab-dir "icon.ico" append-path ; @@ -92,7 +92,7 @@ ERROR: bad-platform name ; : vocab-platforms ( vocab -- platforms ) dup vocab-platforms-path vocab-file-contents - [ dup "system" lookup-word [ ] [ bad-platform ] ?if ] map ; + [ dup "system" lookup-word [ ] [ throw-bad-platform ] ?if ] map ; : set-vocab-platforms ( platforms vocab -- ) [ [ name>> ] map ] dip diff --git a/core/alien/alien.factor b/core/alien/alien.factor index b60331d8cb..e02bc08a43 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -86,22 +86,22 @@ UNION: abi stdcall thiscall fastcall cdecl mingw ; ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) - alien-callback-error ; + throw-alien-callback-error ; ERROR: alien-indirect-error ; : alien-indirect ( args... funcptr return parameters abi -- return... ) - alien-indirect-error ; + throw-alien-indirect-error ; ERROR: alien-invoke-error library symbol ; : alien-invoke ( args... return library function parameters -- return... ) - 2over alien-invoke-error ; + 2over throw-alien-invoke-error ; ERROR: alien-assembly-error code ; : alien-assembly ( args... return parameters abi quot -- return... ) - dup alien-assembly-error ; + dup throw-alien-assembly-error ; string ERROR: invalid-c-string string ; : check-string ( string -- ) - 0 over member-eq? [ invalid-c-string ] [ drop ] if ; + 0 over member-eq? [ throw-invalid-c-string ] [ drop ] if ; GENERIC# string>alien 1 ( string encoding -- byte-array ) diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index ad386c176e..c4b9cfc7fe 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -17,12 +17,12 @@ ERROR: not-classoids sequence ; : check-classoids ( members -- members ) dup [ classoid? ] all? - [ [ classoid? ] reject not-classoids ] unless ; + [ [ classoid? ] reject throw-not-classoids ] unless ; ERROR: not-a-classoid object ; : check-classoid ( object -- object ) - dup classoid? [ not-a-classoid ] unless ; + dup classoid? [ throw-not-a-classoid ] unless ; : ( members -- classoid ) check-classoids @@ -47,7 +47,7 @@ TUPLE: anonymous-complement { class read-only } ; INSTANCE: anonymous-complement classoid : ( object -- classoid ) - dup classoid? [ 1array not-classoids ] unless + dup classoid? [ 1array throw-not-classoids ] unless anonymous-complement boa ; M: anonymous-complement rank-class drop 3 ; @@ -283,7 +283,7 @@ ERROR: topological-sort-failed ; : largest-class ( seq -- n elt ) dup [ [ class< ] with any? not ] curry find-last - [ topological-sort-failed ] unless* ; + [ throw-topological-sort-failed ] unless* ; : sort-classes ( seq -- newseq ) [ class-name ] sort-with >vector diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 72178f62f2..9a2469f70b 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -12,7 +12,7 @@ PREDICATE: builtin-class < class ERROR: not-a-builtin object ; : check-builtin ( class -- ) - dup builtin-class? [ drop ] [ not-a-builtin ] if ; + dup builtin-class? [ drop ] [ throw-not-a-builtin ] if ; : class>type ( class -- n ) "type" word-prop ; foldable diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 8c65a5d10b..9e39b40923 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -225,7 +225,7 @@ GENERIC: update-methods ( class seq -- ) [ nip [ update-class ] each ] [ update-methods ] 2bi ; : check-inheritance ( subclass superclass -- ) - 2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ; + 2dup superclass-of? [ throw-bad-inheritance ] [ 2drop ] if ; : define-class ( word superclass members participants metaclass -- ) [ 2dup check-inheritance ] 3dip diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index bacb34a385..f73c1059a8 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -22,7 +22,7 @@ ERROR: check-mixin-class-error class ; : check-mixin-class ( mixin -- mixin ) dup mixin-class? [ - check-mixin-class-error + throw-check-mixin-class-error ] unless ; object swap slots>tuple ; : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index ) - over [ drop ] [ nip nip nip bad-slot-name ] if ; + over [ drop ] [ nip nip nip throw-bad-slot-name ] if ; : slot-named-checked ( class initials name slots -- class initials slot-spec ) over [ slot-named* ] dip check-slot-exists drop ; @@ -112,7 +112,7 @@ M: tuple-class boa>object { "f" [ drop \ } parse-until boa>object ] } { "{" [ 2dup parse-slot-values assoc>object ] } { "}" [ drop new ] } - [ bad-literal-tuple ] + [ throw-bad-literal-tuple ] } case ; : parse-tuple-literal ( -- tuple ) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 082a15d930..6d5b8750a9 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -602,61 +602,6 @@ must-fail-with { V{ } } [ blah ] unit-test -! Test reshaping with type declarations and slot attributes -TUPLE: reshape-test x ; - -T{ reshape-test f "hi" } "tuple" set - -{ } [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test - -{ f } [ \ reshape-test \ x<< ?lookup-method ] unit-test - -[ "tuple" get 5 >>x ] must-fail - -{ "hi" } [ "tuple" get x>> ] unit-test - -{ } [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test - -{ 0 } [ "tuple" get x>> ] unit-test - -{ } [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test - -{ 0 } [ "tuple" get x>> ] unit-test - -TUPLE: boa-coercer-test { x array-capacity } ; - -{ fixnum } [ 0 >bignum boa-coercer-test boa x>> class-of ] unit-test - -{ T{ boa-coercer-test f 0 } } [ T{ boa-coercer-test } ] unit-test - -! Test error classes -ERROR: error-class-test a b c ; - -{ "( a b c -- * )" } [ \ error-class-test stack-effect effect>string ] unit-test -{ f } [ \ error-class-test "inline" word-prop ] unit-test - -[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ] -[ error>> error>> redefine-error? ] must-fail-with - -DEFER: error-y - -{ } [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test - -{ } [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test - -{ f } [ \ error-y tuple-class? ] unit-test - -{ f } [ \ error-y error-class? ] unit-test - -{ t } [ \ error-y generic? ] unit-test - -{ } [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test - -{ t } [ \ error-y tuple-class? ] unit-test - -{ t } [ \ error-y error-class? ] unit-test - -{ f } [ \ error-y generic? ] unit-test { } [ "IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;" @@ -672,10 +617,12 @@ DEFER: error-y drop ] unit-test + { } [ "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- ) ] unit-test + TUPLE: bogus-hashcode-1 x ; TUPLE: bogus-hashcode-2 x ; @@ -726,10 +673,33 @@ DEFER: redefine-tuple-twice { t } [ \ redefine-tuple-twice symbol? ] unit-test -ERROR: base-error x y ; -ERROR: derived-error < base-error z ; -{ ( x y z -- * ) } [ \ derived-error stack-effect ] unit-test +! Test reshaping with type declarations and slot attributes +TUPLE: reshape-test x ; + +T{ reshape-test f "hi" } "tuple" set + +{ } [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test + +{ f } [ \ reshape-test \ x<< ?lookup-method ] unit-test + +[ "tuple" get 5 >>x ] must-fail + +{ "hi" } [ "tuple" get x>> ] unit-test + +{ } [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test + +{ 0 } [ "tuple" get x>> ] unit-test + +{ } [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test + +{ 0 } [ "tuple" get x>> ] unit-test + +TUPLE: boa-coercer-test { x array-capacity } ; + +{ fixnum } [ 0 >bignum boa-coercer-test boa x>> class-of ] unit-test + +{ T{ boa-coercer-test f 0 } } [ T{ boa-coercer-test } ] unit-test ! Make sure that tuple reshaping updates code heap roots TUPLE: code-heap-ref ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 5addf3a98d..6c1bcf7527 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -3,8 +3,8 @@ USING: accessors arrays assocs classes classes.algebra classes.algebra.private classes.builtin classes.private combinators definitions effects generic kernel kernel.private -make math math.private memory namespaces quotations sequences -sequences.private slots slots.private strings words ; +make math math.private memory namespaces quotations +sequences sequences.private slots slots.private strings words ; IN: classes.tuple > ] [ no-slot ] if* ; + [ 2nip offset>> ] [ throw-no-slot ] if* ; : get-slot-named ( name tuple -- value ) [ nip ] [ offset-of-slot ] 2bi slot ; @@ -59,7 +59,7 @@ M: tuple class-of layout-of 2 slot { word } declare ; inline [ [ layout-of ] [ class-of tuple-layout ] bi eq? ] [ drop t ] if ; : check-tuple ( object -- tuple ) - dup tuple? [ not-a-tuple ] unless ; inline + dup tuple? [ throw-not-a-tuple ] unless ; inline : prepare-tuple-slots ( tuple -- n tuple ) check-tuple [ tuple-size iota ] keep ; @@ -318,32 +318,13 @@ M: tuple-class (define-tuple-class) 3dup tuple-class-unchanged? [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ; -PREDICATE: error-class < tuple-class - "error-class" word-prop ; - -M: error-class reset-class - [ call-next-method ] [ "error-class" remove-word-prop ] bi ; - -: define-error-class ( class superclass slots -- ) - error-slots { - [ define-tuple-class ] - [ 2drop reset-generic ] - [ 2drop t "error-class" set-word-prop ] - [ - 2drop - [ dup [ boa throw ] curry ] - [ all-slots thrower-effect ] - bi define-declared - ] - } 3cleave ; - : boa-effect ( class -- effect ) [ all-slots [ name>> ] map ] [ name>> 1array ] bi ; ERROR: not-a-tuple-class object ; : check-tuple-class ( class -- class ) - dup tuple-class? [ not-a-tuple-class ] unless ; inline + dup tuple-class? [ throw-not-a-tuple-class ] unless ; inline : define-boa-word ( word class -- ) check-tuple-class [ [ boa ] curry ] [ boa-effect ] bi diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 0e4cf5742a..b375b20b4c 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -68,7 +68,7 @@ M: object classes-contained-by dup dup [ classes-contained-by ] map concat sift append 2dup set= [ 2drop f ] [ nip ] if ] follow concat - member-eq? [ cannot-reference-self ] when ; + member-eq? [ throw-cannot-reference-self ] when ; PRIVATE> diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index c64c57b14a..ef855bfd37 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -38,7 +38,7 @@ SLOT: terminated? check-datastack ] if ] 2dip rot - [ 2drop ] [ wrong-values ] if ; + [ 2drop ] [ throw-wrong-values ] if ; : execute-effect ( word effect -- ) [ [ execute ] curry ] dip call-effect ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 292a0b5bc8..8e43e48669 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -52,7 +52,7 @@ C: continuation ERROR: not-a-continuation object ; : >continuation< ( continuation -- data call retain name catch ) - dup continuation? [ not-a-continuation ] unless + dup continuation? [ throw-not-a-continuation ] unless { [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ] } cleave ; inline PRIVATE> diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 350268630c..4fdae1da75 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -8,7 +8,7 @@ MIXIN: definition-mixin ERROR: no-compilation-unit definition ; : add-to-unit ( key set -- ) - [ adjoin ] [ no-compilation-unit ] if* ; + [ adjoin ] [ throw-no-compilation-unit ] if* ; SYMBOL: changed-definitions diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 3e4eaeeec9..fc79a193df 100755 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -19,7 +19,7 @@ SLOT: continuation disposables get adjoin ; : unregister-disposable ( obj -- ) - disposables get 2dup in? [ delete ] [ drop already-unregistered ] if ; + disposables get 2dup in? [ delete ] [ drop throw-already-unregistered ] if ; PRIVATE> diff --git a/core/effects/effects.factor b/core/effects/effects.factor index c1288052b1..2e9d668321 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -132,4 +132,4 @@ ERROR: bad-stack-effect word expected got ; : check-stack-effect ( word effect -- ) over stack-effect 2dup effect= - [ 3drop ] [ bad-stack-effect ] if ; + [ 3drop ] [ throw-bad-stack-effect ] if ; diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 2a9246c1b2..aed4e2f3ea 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -21,8 +21,8 @@ SYMBOL: effect-var : parse-effect-var ( first? var name -- var ) nip - [ ":" ?tail [ row-variable-can't-have-type ] when ] curry - [ invalid-row-variable ] if ; + [ ":" ?tail [ throw-row-variable-can't-have-type ] when ] curry + [ throw-invalid-row-variable ] if ; : parse-effect-value ( token -- value ) ":" ?tail [ scan-object 2array ] when ; @@ -31,8 +31,8 @@ PRIVATE> : parse-effect-token ( first? var end -- var more? ) scan-token { { [ end-token? ] [ drop nip f ] } - { [ effect-opener? ] [ bad-effect ] } - { [ effect-closer? ] [ stack-effect-omits-dashes ] } + { [ effect-opener? ] [ throw-bad-effect ] } + { [ effect-closer? ] [ throw-stack-effect-omits-dashes ] } { [ row-variable? ] [ parse-effect-var t ] } [ [ drop ] 2dip parse-effect-value , t ] } cond ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c861f7c54b..cd773a89f1 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -30,7 +30,7 @@ ERROR: method-lookup-failed class generic ; "methods" word-prop at ; : lookup-method ( class generic -- method ) - 2dup ?lookup-method [ 2nip ] [ method-lookup-failed ] if* ; + 2dup ?lookup-method [ 2nip ] [ throw-method-lookup-failed ] if* ; ERROR: no-math-method left right generic ; : default-math-method ( generic -- quot ) - [ no-math-method ] curry [ ] like ; + [ throw-no-math-method ] curry [ ] like ; ( string -- byte-array ) M: string ascii> dup aux>> - [ [ dup 127 <= [ encode-error ] unless ] B{ } map-as ] + [ [ dup 127 <= [ throw-encode-error ] unless ] B{ } map-as ] [ string>byte-array-fast ] if ; inline PRIVATE> diff --git a/core/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor index 0660ddfd77..13406a23f1 100644 --- a/core/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -139,7 +139,7 @@ CONSTANT: bom-be B{ 0xfe 0xff } : bom>le/be ( bom -- le/be ) dup bom-le sequence= [ drop utf16le ] [ - bom-be sequence= [ utf16be ] [ missing-bom ] if + bom-be sequence= [ utf16be ] [ throw-missing-bom ] if ] if ; M: utf16 ( stream utf16 -- decoder ) diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 2d382e49d1..d96bcf6d20 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -35,7 +35,7 @@ ERROR: no-parent-directory path ; drop "." swap ] if { "" "." ".." } member? [ - no-parent-directory + throw-no-parent-directory ] when ] unless ; @@ -57,7 +57,7 @@ ERROR: no-parent-directory path ; { [ dup head.? ] [ rest trim-head-separators append-path-empty ] } - { [ dup head..? ] [ drop no-parent-directory ] } + { [ dup head..? ] [ drop throw-no-parent-directory ] } [ nip ] } cond ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d73d480d80..50a0bededf 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -304,7 +304,7 @@ GENERIC: throw ( error -- * ) ERROR: assert got expect ; -: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ; +: assert= ( a b -- ) 2dup = [ 2drop ] [ throw-assert ] if ; ERROR: log2-expects-positive x ; : log2 ( x -- n ) - dup 0 <= [ log2-expects-positive ] [ (log2) ] if ; inline + dup 0 <= [ throw-log2-expects-positive ] [ (log2) ] if ; inline : zero? ( x -- ? ) 0 number= ; inline : 2/ ( x -- y ) -1 shift ; inline diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index de8f60ce1d..4cc773e0ee 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -454,7 +454,7 @@ M: fixnum (positive>dec) 1 over (count-digits) (fixnum>dec) "" like reverse! nip ; inline : (positive>base) ( num radix -- str ) - dup 1 <= [ invalid-radix ] when + dup 1 <= [ throw-invalid-radix ] when [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip reverse! ; inline @@ -534,7 +534,7 @@ M: ratio >base { 16 [ [ float>hex-value ] swap (bin-float>base) ] } { 8 [ [ float>oct-value ] swap (bin-float>base) ] } { 2 [ [ float>bin-value ] swap (bin-float>base) ] } - [ invalid-radix ] + [ throw-invalid-radix ] } case ; : format-string ( format -- format ) diff --git a/core/math/ratios/ratios.factor b/core/math/ratios/ratios.factor index 167d335b9b..71d0aebcc9 100644 --- a/core/math/ratios/ratios.factor +++ b/core/math/ratios/ratios.factor @@ -26,7 +26,7 @@ ERROR: division-by-zero x ; M: integer / [ - division-by-zero + throw-division-by-zero ] [ dup 0 < [ [ neg ] bi@ ] when 2dup fast-gcd [ /i ] curry bi@ fraction> @@ -34,7 +34,7 @@ M: integer / M: integer recip 1 swap [ - division-by-zero + throw-division-by-zero ] [ dup 0 < [ [ neg ] bi@ ] when fraction> ] if-zero ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 91dea25487..990d00d9f2 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -53,7 +53,7 @@ SYMBOL: auto-use? ERROR: number-expected ; : parse-number ( string -- number ) - string>number [ number-expected ] unless* ; + string>number [ throw-number-expected ] unless* ; : parse-datum ( string -- word/number ) dup search [ ] [ @@ -77,7 +77,7 @@ ERROR: invalid-word-name string ; : scan-word-name ( -- string ) scan-token dup "\"" = [ t ] [ dup string>number ] if - [ invalid-word-name ] when ; + [ throw-invalid-word-name ] when ; : scan-new ( -- word ) scan-word-name create-word-in ; @@ -93,7 +93,7 @@ ERROR: staging-violation word ; pop-parsing-word ; inline : execute-parsing ( accum word -- accum ) - dup changed-definitions get in? [ staging-violation ] when + dup changed-definitions get in? [ throw-staging-violation ] when (execute-parsing) ; : scan-object ( -- object ) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index a2ab3ee8e2..d5d6ddc3d0 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -57,13 +57,13 @@ M: integer bounds-check? ( n seq -- ? ) dupd length < [ 0 >= ] [ drop f ] if ; inline : bounds-check ( n seq -- n seq ) - 2dup bounds-check? [ bounds-error ] unless ; inline + 2dup bounds-check? [ throw-bounds-error ] unless ; inline MIXIN: immutable-sequence ERROR: immutable element index sequence ; -M: immutable-sequence set-nth immutable ; +M: immutable-sequence set-nth throw-immutable ; INSTANCE: immutable-sequence sequence @@ -304,7 +304,7 @@ C: copy-state 3dup nip new-sequence 0 swap ; inline : bounds-check-head ( n seq -- n seq ) - over 0 < [ bounds-error ] when ; inline + over 0 < [ throw-bounds-error ] when ; inline : check-copy ( src n dst -- src n dst ) 3dup bounds-check-head @@ -742,7 +742,7 @@ PRIVATE> : last ( seq -- elt ) [ length 1 - ] keep - over 0 < [ bounds-error ] [ nth-unsafe ] if ; inline + over 0 < [ throw-bounds-error ] [ nth-unsafe ] if ; inline : set-last ( elt seq -- ) [ length 1 - ] keep - over 0 < [ bounds-error ] [ set-nth-unsafe ] if ; inline + over 0 < [ throw-bounds-error ] [ set-nth-unsafe ] if ; inline : pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ; @@ -814,7 +814,7 @@ PRIVATE> : pop ( seq -- elt ) [ length 1 - ] keep over 0 >= [ [ nth-unsafe ] [ shorten ] 2bi ] - [ bounds-error ] if ; + [ throw-bounds-error ] if ; : exchange ( m n seq -- ) [ nip bounds-check 2drop ] diff --git a/core/slots/slots.factor b/core/slots/slots.factor index e3f6ea995b..22d3e1068e 100644 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -83,7 +83,7 @@ M: object instance-check-quot [ \ dup , [ predicate-def % ] - [ [ bad-slot-value ] curry , ] bi + [ [ throw-bad-slot-value ] curry , ] bi \ unless , ] [ ] make ; @@ -241,7 +241,7 @@ ERROR: bad-slot-attribute key ; unclip { { initial: [ [ first >>initial ] [ rest ] bi ] } { read-only [ [ t >>read-only ] dip ] } - [ bad-slot-attribute ] + [ throw-bad-slot-attribute ] } case ] unless ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 2575ea686f..dbdd042778 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -33,7 +33,7 @@ main ; ERROR: invalid-source-file-path path ; : path>source-file ( path -- source-file ) - dup string? [ invalid-source-file-path ] unless + dup string? [ throw-invalid-source-file-path ] unless source-files get [ ] cache ; : reset-checksums ( -- ) diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 771b31ac54..86f6030b05 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -22,7 +22,7 @@ ERROR: bad-escape char ; { CHAR: 0 CHAR: \0 } { CHAR: \\ CHAR: \\ } { CHAR: \" CHAR: \" } - } ?at [ bad-escape ] unless ; + } ?at [ throw-bad-escape ] unless ; SYMBOL: name>char-hook @@ -116,7 +116,7 @@ ERROR: escaped-char-expected ; dup still-parsing-line? [ [ current-char ] [ advance-char ] bi ] [ - escaped-char-expected + throw-escaped-char-expected ] if ; : lexer-head? ( lexer string -- ? ) @@ -175,8 +175,6 @@ DEFER: (parse-multiline-string-until) ] if ] if ; -ERROR: trailing-characters string ; - : (parse-multiline-string-until) ( accum lexer string -- ) { sbuf lexer fixnum } declare over still-parsing? [ diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index d381685cec..9b9b47f542 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -823,15 +823,15 @@ HELP: SLOT: HELP: ERROR: { $syntax "ERROR: class slots... ;" } { $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } -{ $description "Defines a new tuple class whose class word throws a new instance of the error." } +{ $description "Defines a new tuple class and a word " { $snippet "throw-classname" } " that throws a new instance of the error." } { $notes "The following two snippets are equivalent:" { $code "ERROR: invalid-values x y ;" "" "TUPLE: invalid-values x y ;" - ": invalid-values ( x y -- * )" - " \\ invalid-values boa throw ;" + ": throw-invalid-values ( x y -- * )" + " invalid-values boa throw ;" } } ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 4ffd70b384..8a99364675 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays byte-vectors -classes.algebra.private classes.builtin classes.intersection -classes.maybe classes.mixin classes.parser classes.predicate -classes.singleton classes.tuple classes.tuple.parser +classes.algebra.private classes.builtin classes.error +classes.intersection classes.maybe classes.mixin classes.parser +classes.predicate classes.singleton classes.tuple classes.tuple.parser classes.union combinators compiler.units definitions effects effects.parser generic generic.hook generic.math generic.parser generic.standard hash-sets hashtables io.pathnames kernel lexer @@ -31,7 +31,7 @@ IN: bootstrap.syntax : define-core-syntax ( name quot -- ) [ - dup "syntax" lookup-word [ ] [ no-word-error ] ?if + dup "syntax" lookup-word [ ] [ throw-no-word-error ] ?if mark-top-level-syntax ] dip define-syntax ; @@ -261,7 +261,7 @@ IN: bootstrap.syntax literalize suffix! \ (call-next-method) suffix! ] [ - not-in-a-method-error + throw-not-in-a-method-error ] if* ] define-core-syntax diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 520ee41945..e17f85461b 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -93,7 +93,7 @@ HELP: find-vocab-root HELP: no-vocab { $values { "name" "a vocabulary name" } } -{ $description "Throws a " { $link no-vocab } "." } +{ $description "A " { $link no-vocab } " error tuple. Call " { $link throw-no-vocab } " to throw it." } { $error-description "Thrown when a " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " form refers to a non-existent vocabulary." } ; HELP: load-help? diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 1de8ecabd5..17de3f26d4 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -36,7 +36,7 @@ ERROR: not-found-in-roots path ; vocab-roots get [ prepend-path exists? ] with find nip ; M: string vocab-path ( string -- path/f ) - dup find-root-for [ prepend-path ] [ not-found-in-roots ] if* ; + dup find-root-for [ prepend-path ] [ throw-not-found-in-roots ] if* ; PRIVATE> @@ -165,7 +165,7 @@ PRIVATE> [ drop dup find-vocab-root [ (require) ] - [ dup lookup-vocab [ drop ] [ no-vocab ] if ] + [ dup lookup-vocab [ drop ] [ throw-no-vocab ] if ] if ] if ] require-hook set-global diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index 5cf59fdaf5..f7a18a2c53 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -58,7 +58,7 @@ ERROR: no-word-in-vocab word vocab ; : extract-words ( seq vocab -- assoc ) [ words>> extract-keys dup ] [ name>> ] bi - [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ; + [ swap [ 2drop ] [ throw-no-word-in-vocab ] if ] curry assoc-each ; : excluding-words ( seq vocab -- assoc ) [ nip words>> ] [ extract-words ] 2bi assoc-diff ; @@ -98,13 +98,13 @@ ERROR: unbalanced-private-declaration vocab ; : begin-private ( -- ) current-vocab name>> ".private" ?tail - [ unbalanced-private-declaration ] + [ throw-unbalanced-private-declaration ] [ ".private" append set-current-vocab ] if ; : end-private ( -- ) current-vocab name>> ".private" ?tail [ set-current-vocab ] - [ unbalanced-private-declaration ] if ; + [ throw-unbalanced-private-declaration ] if ; : using-vocab? ( vocab -- ? ) vocab-name manifest get search-vocab-names>> in? ; @@ -161,7 +161,7 @@ TUPLE: rename word vocab words ; : ( word vocab new-name -- rename ) [ 2dup load-vocab words>> dupd at - [ ] [ swap no-word-in-vocab ] ?if + [ ] [ swap throw-no-word-in-vocab ] ?if ] dip associate rename boa ; : add-renamed-word ( word vocab new-name -- ) diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 66f706eac7..a3389cd2ea 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -24,8 +24,8 @@ SYMBOL: +done+ ERROR: bad-vocab-name name ; : check-vocab-name ( name -- name ) - dup string? [ bad-vocab-name ] unless - dup [ ":/\\ " member? ] any? [ bad-vocab-name ] when ; + dup string? [ throw-bad-vocab-name ] unless + dup [ ":/\\ " member? ] any? [ throw-bad-vocab-name ] when ; TUPLE: vocab-link name ; diff --git a/core/words/words.factor b/core/words/words.factor index 91a3a517ef..c9123b6f82 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -80,7 +80,7 @@ ERROR: invalid-primitive vocabulary word effect ; [ drop vocabulary>> = ] [ drop nip primitive? ] [ [ nip "declared-effect" word-prop ] dip = ] 3tri and and - [ 3drop ] [ invalid-primitive ] if ; + [ 3drop ] [ throw-invalid-primitive ] if ; : lookup-word ( name vocab -- word ) vocab-words-assoc at ; @@ -216,13 +216,13 @@ M: word reset-word : reveal ( word -- ) dup [ name>> ] [ vocabulary>> ] bi dup vocab-words-assoc - [ ] [ no-vocab ] ?if set-at ; + [ ] [ throw-no-vocab ] ?if set-at ; ERROR: bad-create name vocab ; : check-create ( name vocab -- name vocab ) 2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and - [ bad-create ] unless ; + [ throw-bad-create ] unless ; : create-word ( name vocab -- word ) check-create 2dup lookup-word -- 2.34.1