Merge branch 'master' of git://factorcode.org/git/factor

core/alien/alien.factor

@@ -65,21 +65,21 @@ TUPLE: library path abi dll ;
 
 TUPLE: alien-callback return parameters abi quot xt ;
 
-TUPLE: alien-callback-error ;
+ERROR: alien-callback-error ;
 
 : alien-callback ( return parameters abi quot -- alien )
-    \ alien-callback-error construct-empty throw ;
+    alien-callback-error ;
 
 TUPLE: alien-indirect return parameters abi ;
 
-TUPLE: alien-indirect-error ;
+ERROR: alien-indirect-error ;
 
 : alien-indirect ( ... funcptr return parameters abi -- )
-    \ alien-indirect-error construct-empty throw ;
+    alien-indirect-error ;
 
 TUPLE: alien-invoke library function return parameters ;
 
-TUPLE: alien-invoke-error library symbol ;
+ERROR: alien-invoke-error library symbol ;
 
 : alien-invoke ( ... return library function parameters -- ... )
-    2over \ alien-invoke-error construct-boa throw ;
+    2over alien-invoke-error ;

core/alien/c-types/c-types.factor

@@ -26,9 +26,7 @@ global [
     c-types [ H{ } assoc-like ] change
 ] bind
 
-TUPLE: no-c-type name ;
-
-: no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
+ERROR: no-c-type name ;
 
 : (c-type) ( name -- type/f )
     c-types get-global at dup [

core/bootstrap/compiler/compiler.factor

@@ -79,7 +79,7 @@ nl
 "." write flush
 
 {
-    malloc free memcpy
+    malloc calloc free memcpy
 } compile
 
 " done" print flush

core/combinators/combinators.factor

@@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors
 hashtables sorting ;
 
-TUPLE: no-cond ;
-
-: no-cond ( -- * ) \ no-cond construct-empty throw ;
+ERROR: no-cond ;
 
 : cond ( assoc -- )
     [ first call ] find nip dup [ second call ] [ no-cond ] if ;
 
-TUPLE: no-case ;
-
-: no-case ( -- * ) \ no-case construct-empty throw ;
+ERROR: no-case ;
 
 : case ( obj assoc -- )
     [ dup array? [ dupd first = ] [ quotation? ] if ] find nip

core/debugger/debugger.factor

@@ -75,9 +75,7 @@ SYMBOL: error-hook
 : try ( quot -- )
     [ error-hook get call ] recover ;
 
-TUPLE: assert got expect ;
-
-: assert ( got expect -- * ) \ assert construct-boa throw ;
+ERROR: assert got expect ;
 
 : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
 
@@ -86,28 +84,22 @@ TUPLE: assert got expect ;
 : trim-datastacks ( seq1 seq2 -- seq1' seq2' )
     2dup [ length ] 2apply min tuck tail >r tail r> ;
 
-TUPLE: relative-underflow stack ;
-
-: relative-underflow ( before after -- * )
-    trim-datastacks nip \ relative-underflow construct-boa throw ;
+ERROR: relative-underflow stack ;
 
 M: relative-underflow summary
     drop "Too many items removed from data stack" ;
 
-TUPLE: relative-overflow stack ;
+ERROR: relative-overflow stack ;
 
 M: relative-overflow summary
     drop "Superfluous items pushed to data stack" ;
 
-: relative-overflow ( before after -- * )
-    trim-datastacks drop \ relative-overflow construct-boa throw ;
-
 : assert-depth ( quot -- )
     >r datastack r> swap slip >r datastack r>
     2dup [ length ] compare sgn {
-        { -1 [ relative-underflow ] }
+        { -1 [ trim-datastacks nip relative-underflow ] }
         { 0 [ 2drop ] }
-        { 1 [ relative-overflow ] }
+        { 1 [ trim-datastacks drop relative-overflow ] }
     } case ; inline
 
 : expired-error. ( obj -- )
@@ -210,13 +202,13 @@ M: no-method error.
 M: no-math-method summary
     drop "No suitable arithmetic method" ;
 
-M: check-closed summary
+M: stream-closed-twice summary
     drop "Attempt to perform I/O on closed stream" ;
 
 M: check-method summary
     drop "Invalid parameters for create-method" ;
 
-M: check-tuple summary
+M: no-tuple-class summary
     drop "Invalid class for define-constructor" ;
 
 M: no-cond summary
@@ -254,7 +246,7 @@ M: no-compilation-unit error.
 M: no-vocab summary
     drop "Vocabulary does not exist" ;
 
-M: check-ptr summary
+M: bad-ptr summary
     drop "Memory allocation failed" ;
 
 M: double-free summary

core/definitions/definitions.factor

@@ -3,10 +3,7 @@
 IN: definitions
 USING: kernel sequences namespaces assocs graphs ;
 
-TUPLE: no-compilation-unit definition ;
-
-: no-compilation-unit ( definition -- * )
-    \ no-compilation-unit construct-boa throw ;
+ERROR: no-compilation-unit definition ;
 
 GENERIC: where ( defspec -- loc )
 

core/generic/math/math.factor

@@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? )
     dup empty? [ [ dip ] curry [ ] like ] unless
     r> append ;
 
-TUPLE: no-math-method left right generic ;
-
-: no-math-method ( left right generic -- * )
-    \ no-math-method construct-boa throw ;
+ERROR: no-math-method left right generic ;
 
 : default-math-method ( generic -- quot )
     [ no-math-method ] curry [ ] like ;

core/generic/standard/standard.factor

@@ -26,10 +26,7 @@ SYMBOL: (dispatch#)
 
 : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
 
-TUPLE: no-method object generic ;
-
-: no-method ( object generic -- * )
-    \ no-method construct-boa throw ;
+ERROR: no-method object generic ;
 
 : error-method ( word --  quot )
     picker swap [ no-method ] curry append ;

core/inference/inference-tests.factor

@@ -514,10 +514,10 @@ DEFER: an-inline-word
 
 { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
 
-TUPLE: custom-error ;
+ERROR: custom-error ;
 
 [ T{ effect f 0 0 t } ] [
-    [ custom-error construct-boa throw ] infer
+    [ custom-error ] infer
 ] unit-test
 
 : funny-throw throw ; inline

core/inference/transforms/transforms.factor

@@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot )
 
 \ get-slots [ [get-slots] ] 1 define-transform
 
-TUPLE: duplicated-slots-error names ;
+ERROR: duplicated-slots-error names ;
 
 M: duplicated-slots-error summary
     drop "Calling set-slots with duplicate slot setters" ;
 
-: duplicated-slots-error ( names -- * )
-    \ duplicated-slots-error construct-boa throw ;
-
 \ set-slots [
     dup all-unique?
     [ <reversed> [get-slots] ] [ duplicated-slots-error ] if

core/io/encodings/encodings.factor

@@ -18,17 +18,13 @@ GENERIC: <decoder> ( stream decoding -- newstream )
 
 TUPLE: decoder stream code cr ;
 
-TUPLE: decode-error ;
-
-: decode-error ( -- * ) \ decode-error construct-empty throw ;
+ERROR: decode-error ;
 
 GENERIC: <encoder> ( stream encoding -- newstream )
 
 TUPLE: encoder stream code ;
 
-TUPLE: encode-error ;
-
-: encode-error ( -- * ) \ encode-error construct-empty throw ;
+ERROR: encode-error ;
 
 ! Decoding
 

core/io/files/files.factor

@@ -48,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
 
 : special-directory? ( name -- ? ) { "." ".." } member? ;
 
-TUPLE: no-parent-directory path ;
-
-: no-parent-directory ( path -- * )
-    \ no-parent-directory construct-boa throw ;
+ERROR: no-parent-directory path ;
 
 : parent-directory ( path -- parent )
     right-trim-separators {

core/io/streams/duplex/duplex.factor

@@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ;
 : <duplex-stream> ( in out -- stream )
     f duplex-stream construct-boa ;
 
-TUPLE: check-closed ;
+ERROR: stream-closed-twice ;
 
 : check-closed ( stream -- )
-    duplex-stream-closed?
-    [ \ check-closed construct-boa throw ] when ;
+    duplex-stream-closed? [ stream-closed-twice ] when ;
 
 : duplex-stream-in+ ( duplex -- stream )
     dup check-closed duplex-stream-in ;

core/libc/libc.factor

@@ -23,20 +23,14 @@ SYMBOL: mallocs
 
 PRIVATE>
 
-TUPLE: check-ptr ;
+ERROR: bad-ptr ;
 
 : check-ptr ( c-ptr -- c-ptr )
-    [ \ check-ptr construct-boa throw ] unless* ;
+    [ bad-ptr ] unless* ;
 
-TUPLE: double-free ;
+ERROR: double-free ;
 
-: double-free ( -- * )
-    \ double-free construct-empty throw ;
-
-TUPLE: realloc-error ptr size ;
-
-: realloc-error ( alien size -- * )
-    \ realloc-error construct-boa throw ;
+ERROR: realloc-error ptr size ;
 
 <PRIVATE
 

core/parser/parser.factor

@@ -98,10 +98,7 @@ M: lexer skip-word ( lexer -- )
 
 : scan ( -- str/f ) lexer get parse-token ;
 
-TUPLE: bad-escape ;
-
-: bad-escape ( -- * )
-    \ bad-escape construct-empty throw ;
+ERROR: bad-escape ;
 
 M: bad-escape summary drop "Bad escape code" ;
 
@@ -215,10 +212,7 @@ SYMBOL: in
 : set-in ( name -- )
     check-vocab-string dup in set create-vocab (use+) ;
 
-TUPLE: unexpected want got ;
-
-: unexpected ( want got -- * )
-    \ unexpected construct-boa throw ;
+ERROR: unexpected want got ;
 
 PREDICATE: unexpected unexpected-eof
     unexpected-got not ;
@@ -294,10 +288,7 @@ M: no-word summary
 : CREATE-METHOD ( -- method )
     scan-word bootstrap-word scan-word create-method-in ;
 
-TUPLE: staging-violation word ;
-
-: staging-violation ( word -- * )
-    \ staging-violation construct-boa throw ;
+ERROR: staging-violation word ;
 
 M: staging-violation summary
     drop
@@ -352,9 +343,7 @@ SYMBOL: lexer-factory
         ] if
     ] if ;
 
-TUPLE: bad-number ;
-
-: bad-number ( -- * ) \ bad-number construct-boa throw ;
+ERROR: bad-number ;
 
 : parse-base ( parsed base -- parsed )
     scan swap base> [ bad-number ] unless* parsed ;

core/sequences/sequences.factor

@@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
 : bounds-check? ( n seq -- ? )
     length 1- 0 swap between? ; inline
 
-TUPLE: bounds-error index seq ;
-
-: bounds-error ( n seq -- * )
-    \ bounds-error construct-boa throw ;
+ERROR: bounds-error index seq ;
 
 : bounds-check ( n seq -- n seq )
     2dup bounds-check? [ bounds-error ] unless ; inline
 
 MIXIN: immutable-sequence
 
-TUPLE: immutable seq ;
-
-: immutable ( seq -- * ) \ immutable construct-boa throw ;
+ERROR: immutable seq ;
 
 M: immutable-sequence set-nth immutable ;
 
@@ -190,8 +185,7 @@ TUPLE: slice from to seq ;
 : collapse-slice ( m n slice -- m' n' seq )
     dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
 
-TUPLE: slice-error reason ;
-: slice-error ( str -- * ) \ slice-error construct-boa throw ;
+ERROR: slice-error reason ;
 
 : check-slice ( from to seq -- from to seq )
     pick 0 < [ "start < 0" slice-error ] when

core/syntax/syntax-docs.factor

@@ -560,6 +560,13 @@ HELP: TUPLE:
 $nl
 "Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
 
+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.  Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ;
+
+{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words
+
 HELP: C:
 { $syntax "C: constructor class" }
 { $values { "constructor" "a new word to define" } { "class" tuple-class } }

core/syntax/syntax.factor

@@ -165,6 +165,7 @@ IN: bootstrap.syntax
 
     "ERROR:" [
         CREATE-CLASS dup ";" parse-tokens define-tuple-class
+        dup save-location
         dup [ construct-boa throw ] curry define
     ] define-syntax
 

core/tuples/tuples-tests.factor

@@ -236,7 +236,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
 
 [
     "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ check-tuple? ] is? ] must-fail-with
+] [ [ no-tuple-class? ] is? ] must-fail-with
 
 ! Hardcore unit tests
 USE: threads

core/tuples/tuples.factor

@@ -89,11 +89,11 @@ PRIVATE>
     2dup define-slots
     define-accessors ;
 
-TUPLE: check-tuple class ;
+ERROR: no-tuple-class class ;
 
 : check-tuple ( class -- )
     dup tuple-class?
-    [ drop ] [ \ check-tuple construct-boa throw ] if ;
+    [ drop ] [ no-tuple-class ] if ;
 
 : define-tuple-class ( class slots -- )
     2dup check-shape

core/vocabs/vocabs.factor

@@ -59,16 +59,13 @@ M: f vocab-help ;
 : create-vocab ( name -- vocab )
     dictionary get [ <vocab> ] cache ;
 
-TUPLE: no-vocab name ;
-
-: no-vocab ( name -- * )
-    vocab-name \ no-vocab construct-boa throw ;
+ERROR: no-vocab name ;
 
 SYMBOL: load-vocab-hook ! ( name -- )
 
 : load-vocab ( name -- vocab )
     dup load-vocab-hook get call
-    dup vocab [ ] [ no-vocab ] ?if ;
+    dup vocab [ ] [ vocab-name no-vocab ] ?if ;
 
 : vocabs ( -- seq )
     dictionary get keys natural-sort ;

core/words/words.factor

@@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ;
 
 M: word definition word-def ;
 
-TUPLE: undefined ;
-
-: undefined ( -- * ) \ undefined construct-empty throw ;
+ERROR: undefined ;
 
 PREDICATE: word deferred ( obj -- ? )
     word-def [ undefined ] = ;
@@ -189,12 +187,11 @@ M: word subwords drop f ;
     [ ] [ no-vocab ] ?if
     set-at ;
 
-TUPLE: check-create name vocab ;
+ERROR: bad-create name vocab ;
 
 : check-create ( name vocab -- name vocab )
-    2dup [ string? ] both? [
-        \ check-create construct-boa throw
-    ] unless ;
+    2dup [ string? ] both?
+    [ bad-create ] unless ;
 
 : create ( name vocab -- word )
     check-create 2dup lookup