steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.

db4
Doug Coleman 2015-08-12 15:26:18 -05:00
parent e3ddd337e0
commit 02008979d9
53 changed files with 133 additions and 184 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bootstrap/help/help.factor
View File

@ -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

4
basis/help/help.factor
View File

@ -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

2
basis/io/encodings/8-bit/8-bit.factor
View File

@ -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 ;

2
basis/io/encodings/euc/euc.factor
View File

@ -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? ;

2
basis/io/encodings/gb18030/gb18030.factor
View File

@ -90,7 +90,7 @@ ascii <file-reader> 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 [

2
basis/io/encodings/iso2022/iso2022.factor
View File

@ -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 -- )

2
basis/io/encodings/shift-jis/shift-jis.factor
View File

@ -29,7 +29,7 @@ M: windows-31j <decoder> drop windows-31j-table get-global <decoder> ;
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 )

2
basis/io/encodings/strict/strict.factor
View File

@ -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 ;

2
basis/macros/macros.factor
View File

@ -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: \ ; ;

4
basis/tools/deploy/deploy.factor
View File

@ -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

4
basis/tools/scaffold/scaffold.factor
View File

@ -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* ;

6
basis/vocabs/metadata/metadata.factor
View File

@ -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

8
core/alien/alien.factor
View File

@ -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 ;
<PRIVATE

2
core/alien/strings/strings.factor
View File

@ -22,7 +22,7 @@ M: f alien>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 )

8
core/classes/algebra/algebra.factor
View File

@ -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 ;
: <anonymous-union> ( members -- classoid )
check-classoids
@ -47,7 +47,7 @@ TUPLE: anonymous-complement { class read-only } ;
INSTANCE: anonymous-complement classoid
: <anonymous-complement> ( 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

2
core/classes/builtin/builtin.factor
View File

@ -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

2
core/classes/classes.factor
View File

@ -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

2
core/classes/mixin/mixin.factor
View File

@ -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 ;
<PRIVATE

14
core/classes/tuple/parser/parser.factor
View File

@ -26,7 +26,7 @@ ERROR: duplicate-slot-names names ;
: check-duplicate-slots ( slots -- )
slot-names duplicates
[ duplicate-slot-names ] unless-empty ;
[ throw-duplicate-slot-names ] unless-empty ;
ERROR: invalid-slot-name name ;
@ -40,7 +40,7 @@ ERROR: invalid-slot-name name ;
!
! : ...
{
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ throw-invalid-slot-name ] }
{ [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond nip ;
@ -72,12 +72,12 @@ ERROR: bad-literal-tuple ;
ERROR: bad-slot-name class slot ;
: check-slot-name ( class slots name -- name )
2dup swap slot-named [ 2nip ] [ nip bad-slot-name ] if ;
2dup swap slot-named [ 2nip ] [ nip throw-bad-slot-name ] if ;
: parse-slot-value ( class slots -- )
scan-token check-slot-name scan-object 2array , scan-token {
{ "}" [ ] }
[ bad-literal-tuple ]
[ throw-bad-literal-tuple ]
} case ;
: (parse-slot-values) ( class slots -- )
@ -85,7 +85,7 @@ ERROR: bad-slot-name class slot ;
scan-token {
{ "{" [ (parse-slot-values) ] }
{ "}" [ 2drop ] }
[ 2nip bad-literal-tuple ]
[ 2nip throw-bad-literal-tuple ]
} case ;
: parse-slot-values ( class slots -- values )
@ -97,7 +97,7 @@ M: tuple-class boa>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 )

86
core/classes/tuple/tuple-tests.factor
View File

@ -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 ;

29
core/classes/tuple/tuple.factor
View File

@ -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
<PRIVATE
@ -24,7 +24,7 @@ ERROR: no-slot name tuple ;
: offset-of-slot ( name tuple -- n )
2dup class-of all-slots slot-named
[ 2nip offset>> ] [ 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 <effect> ;
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

2
core/classes/union/union.factor
View File

@ -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>

2
core/combinators/combinators.factor
View File

@ -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 ;

2
core/continuations/continuations.factor
View File

@ -52,7 +52,7 @@ C: <continuation> 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>

2
core/definitions/definitions.factor
View File

@ -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

2
core/destructors/destructors.factor
View File

@ -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>

2
core/effects/effects.factor
View File

@ -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 ;

8
core/effects/parser/parser.factor
View File

@ -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 ;

2
core/generic/generic.factor
View File

@ -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* ;
<PRIVATE

2
core/generic/math/math.factor
View File

@ -45,7 +45,7 @@ PRIVATE>
ERROR: no-math-method left right generic ;
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;
[ throw-no-math-method ] curry [ ] like ;
<PRIVATE

2
core/generic/parser/parser.factor
View File

@ -38,7 +38,7 @@ SYMBOL: current-method
ERROR: bad-method-effect ;
: check-method-effect ( effect -- )
last-word generic-effect method-effect= [ bad-method-effect ] unless ;
last-word generic-effect method-effect= [ throw-bad-method-effect ] unless ;
: ?execute-parsing ( word/number -- seq )
dup parsing-word?

8
core/generic/single/single.factor
View File

@ -23,7 +23,7 @@ TUPLE: single-combination ;
PREDICATE: single-generic < generic
"combination" word-prop single-combination? ;
M: single-generic make-inline cannot-be-inline ;
M: single-generic make-inline throw-cannot-be-inline ;
GENERIC: dispatch# ( word -- n )
@ -45,7 +45,7 @@ M: single-combination next-method-quot* ( class generic combination -- quot )
[
pick predicate-def %
1quotation ,
[ inconsistent-next-method ] 2curry ,
[ throw-inconsistent-next-method ] 2curry ,
\ if ,
] [ ] make picker prepend
] [ 3drop f ] if
@ -59,7 +59,7 @@ M: single-combination next-method-quot* ( class generic combination -- quot )
bi or ;
M: single-combination make-default-method
[ [ picker ] dip [ no-method ] curry append ] with-combination ;
[ [ picker ] dip [ throw-no-method ] curry append ] with-combination ;
! ! ! Build an engine ! ! !
@ -216,7 +216,7 @@ ERROR: unreachable ;
: prune-redundant-predicates ( assoc -- default assoc' )
{
{ [ dup empty? ] [ drop [ unreachable ] { } ] }
{ [ dup empty? ] [ drop [ throw-unreachable ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
[ [ first second ] [ rest-slice ] bi ]

2
core/hashtables/hashtables.factor
View File

@ -194,7 +194,7 @@ M: hashtable assoc-like
ERROR: malformed-hashtable-pair seq pair ;
: check-hashtable ( seq -- seq )
dup [ dup length 2 = [ drop ] [ malformed-hashtable-pair ] if ] each ;
dup [ dup length 2 = [ drop ] [ throw-malformed-hashtable-pair ] if ] each ;
: parse-hashtable ( seq -- hashtable )
check-hashtable H{ } assoc-clone-like ;

4
core/io/encodings/ascii/ascii.factor
View File

@ -8,7 +8,7 @@ SINGLETON: ascii
M: ascii encode-char
drop
over 127 <= [ stream-write1 ] [ encode-error ] if ; inline
over 127 <= [ stream-write1 ] [ throw-encode-error ] if ; inline
<PRIVATE
@ -16,7 +16,7 @@ GENERIC: ascii> ( 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>

2
core/io/encodings/utf16/utf16.factor
View File

@ -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 <decoder> ( stream utf16 -- decoder )

4
core/io/pathnames/pathnames.factor
View File

@ -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 ;

2
core/kernel/kernel.factor
View File

@ -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 ;
<PRIVATE

2
core/lexer/lexer.factor
View File

@ -18,7 +18,7 @@ TUPLE: lexer-parsing-word word line line-text column ;
ERROR: not-a-lexer object ;
: check-lexer ( lexer -- lexer )
dup lexer? [ not-a-lexer ] unless ; inline
dup lexer? [ throw-not-a-lexer ] unless ; inline
: next-line ( lexer -- )
check-lexer

2
core/math/math.factor
View File

@ -134,7 +134,7 @@ PRIVATE>
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

4
core/math/parser/parser.factor
View File

@ -454,7 +454,7 @@ M: fixnum (positive>dec)
1 over (count-digits) <sbuf> (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 )

4
core/math/ratios/ratios.factor
View File

@ -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 ;

6
core/parser/parser.factor
View File

@ -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 )

12
core/sequences/sequences.factor
View File

@ -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> copy-state
3dup nip new-sequence 0 swap <copy> ; 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
<PRIVATE
@ -753,7 +753,7 @@ PRIVATE>
: 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 ]

4
core/slots/slots.factor
View File

@ -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 ;

2
core/source-files/source-files.factor
View File

@ -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 [ <source-file> ] cache ;
: reset-checksums ( -- )

6
core/strings/parser/parser.factor
View File

@ -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? [

6
core/syntax/syntax-docs.factor
View File

@ -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 ;"
}
} ;

10
core/syntax/syntax.factor
View File

@ -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

2
core/vocabs/loader/loader-docs.factor
View File

@ -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?

4
core/vocabs/loader/loader.factor
View File

@ -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

8
core/vocabs/parser/parser.factor
View File

@ -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 ;
: <rename> ( 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 -- )

4
core/vocabs/vocabs.factor
View File

@ -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 ;

6
core/words/words.factor
View File

@ -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