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
! 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
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 ;
h>b/b swap 2byte-array
swap stream-write
] if
- ] [ encode-error ] if* ;
+ ] [ throw-encode-error ] if* ;
: euc-multibyte? ( ch -- ? )
0x81 0xfe between? ;
: 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 [
{ [ 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 -- )
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 )
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 ;
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: \ ; ;
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
: 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* ;
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
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 ;
: 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
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
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 )
: 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
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 ;
: 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
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
[ 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
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
- check-mixin-class-error
+ throw-check-mixin-class-error
] unless ;
<PRIVATE
: check-duplicate-slots ( slots -- )
slot-names duplicates
- [ duplicate-slot-names ] unless-empty ;
+ [ throw-duplicate-slot-names ] unless-empty ;
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 ;
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 -- )
scan-token {
{ "{" [ (parse-slot-values) ] }
{ "}" [ 2drop ] }
- [ 2nip bad-literal-tuple ]
+ [ 2nip throw-bad-literal-tuple ]
} case ;
: parse-slot-values ( class slots -- values )
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 ;
{ "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 )
{ 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 ;"
drop
] unit-test
+
{ } [
"IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
] unit-test
+
TUPLE: bogus-hashcode-1 x ;
TUPLE: bogus-hashcode-2 x ;
{ 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 ;
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
: 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 ;
[ [ 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 ;
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
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>
check-datastack
] if
] 2dip rot
- [ 2drop ] [ wrong-values ] if ;
+ [ 2drop ] [ throw-wrong-values ] if ;
: execute-effect ( word effect -- )
[ [ execute ] curry ] dip call-effect ;
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>
ERROR: no-compilation-unit definition ;
: add-to-unit ( key set -- )
- [ adjoin ] [ no-compilation-unit ] if* ;
+ [ adjoin ] [ throw-no-compilation-unit ] if* ;
SYMBOL: changed-definitions
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>
: check-stack-effect ( word effect -- )
over stack-effect 2dup effect=
- [ 3drop ] [ bad-stack-effect ] if ;
+ [ 3drop ] [ throw-bad-stack-effect ] if ;
: 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 ;
: 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 ;
"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
ERROR: no-math-method left right generic ;
: default-math-method ( generic -- quot )
- [ no-math-method ] curry [ ] like ;
+ [ throw-no-math-method ] curry [ ] like ;
<PRIVATE
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?
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 )
[
pick predicate-def %
1quotation ,
- [ inconsistent-next-method ] 2curry ,
+ [ throw-inconsistent-next-method ] 2curry ,
\ if ,
] [ ] make picker prepend
] [ 3drop f ] if
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 ! ! !
: 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 ]
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 ;
M: ascii encode-char
drop
- over 127 <= [ stream-write1 ] [ encode-error ] if ; inline
+ over 127 <= [ stream-write1 ] [ throw-encode-error ] if ; inline
<PRIVATE
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>
: 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 )
drop "." swap
] if
{ "" "." ".." } member? [
- no-parent-directory
+ throw-no-parent-directory
] when
] unless ;
{ [ dup head.? ] [
rest trim-head-separators append-path-empty
] }
- { [ dup head..? ] [ drop no-parent-directory ] }
+ { [ dup head..? ] [ drop throw-no-parent-directory ] }
[ nip ]
} cond ;
ERROR: assert got expect ;
-: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
+: assert= ( a b -- ) 2dup = [ 2drop ] [ throw-assert ] if ;
<PRIVATE
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
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
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
{ 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 )
M: integer /
[
- division-by-zero
+ throw-division-by-zero
] [
dup 0 < [ [ neg ] bi@ ] when
2dup fast-gcd [ /i ] curry bi@ fraction>
M: integer recip
1 swap [
- division-by-zero
+ throw-division-by-zero
] [
dup 0 < [ [ neg ] bi@ ] when fraction>
] if-zero ;
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 [ ] [
: 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 ;
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 )
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
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
: last ( seq -- elt )
[ length 1 - ] keep
- over 0 < [ bounds-error ] [ nth-unsafe ] if ; inline
+ over 0 < [ throw-bounds-error ] [ nth-unsafe ] if ; inline
<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 ;
: 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 ]
[
\ dup ,
[ predicate-def % ]
- [ [ bad-slot-value ] curry , ] bi
+ [ [ throw-bad-slot-value ] curry , ] bi
\ unless ,
] [ ] make ;
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
- [ bad-slot-attribute ]
+ [ throw-bad-slot-attribute ]
} case
] unless ;
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 ( -- )
{ CHAR: 0 CHAR: \0 }
{ CHAR: \\ CHAR: \\ }
{ CHAR: \" CHAR: \" }
- } ?at [ bad-escape ] unless ;
+ } ?at [ throw-bad-escape ] unless ;
SYMBOL: name>char-hook
dup still-parsing-line? [
[ current-char ] [ advance-char ] bi
] [
- escaped-char-expected
+ throw-escaped-char-expected
] if ;
: lexer-head? ( lexer string -- ? )
] if
] if ;
-ERROR: trailing-characters string ;
-
: (parse-multiline-string-until) ( accum lexer string -- )
{ sbuf lexer fixnum } declare
over still-parsing? [
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 ;"
}
} ;
! 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
: 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 ;
literalize suffix!
\ (call-next-method) suffix!
] [
- not-in-a-method-error
+ throw-not-in-a-method-error
] if*
] define-core-syntax
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?
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>
[
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
: 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 ;
: 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? ;
: <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 -- )
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 ;
[ 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 ;
: 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
projects / factor.git / commitdiff