diff --git a/core/alien/alien.factor b/core/alien/alien.factor index fc89586b68..0afff0c497 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -65,21 +65,21 @@ TUPLE: library path abi dll ; TUPLE: alien-callback return parameters abi quot xt ; -TUPLE: alien-callback-error ; +ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) - \ alien-callback-error construct-empty throw ; + alien-callback-error ; TUPLE: alien-indirect return parameters abi ; -TUPLE: alien-indirect-error ; +ERROR: alien-indirect-error ; : alien-indirect ( ... funcptr return parameters abi -- ) - \ alien-indirect-error construct-empty throw ; + alien-indirect-error ; TUPLE: alien-invoke library function return parameters ; -TUPLE: alien-invoke-error library symbol ; +ERROR: alien-invoke-error library symbol ; : alien-invoke ( ... return library function parameters -- ... ) - 2over \ alien-invoke-error construct-boa throw ; + 2over alien-invoke-error ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f1d8abdc1e..d874243d71 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -26,9 +26,7 @@ global [ c-types [ H{ } assoc-like ] change ] bind -TUPLE: no-c-type name ; - -: no-c-type ( type -- * ) \ no-c-type construct-boa throw ; +ERROR: no-c-type name ; : (c-type) ( name -- type/f ) c-types get-global at dup [ diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 5ccde88e28..04d57dff16 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -79,7 +79,7 @@ nl "." write flush { - malloc free memcpy + malloc calloc free memcpy } compile " done" print flush diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 53d18b53ca..807b372e1d 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting ; -TUPLE: no-cond ; - -: no-cond ( -- * ) \ no-cond construct-empty throw ; +ERROR: no-cond ; : cond ( assoc -- ) [ first call ] find nip dup [ second call ] [ no-cond ] if ; -TUPLE: no-case ; - -: no-case ( -- * ) \ no-case construct-empty throw ; +ERROR: no-case ; : case ( obj assoc -- ) [ dup array? [ dupd first = ] [ quotation? ] if ] find nip diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index cfb696e724..4775093ba7 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -75,9 +75,7 @@ SYMBOL: error-hook : try ( quot -- ) [ error-hook get call ] recover ; -TUPLE: assert got expect ; - -: assert ( got expect -- * ) \ assert construct-boa throw ; +ERROR: assert got expect ; : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ; @@ -86,28 +84,22 @@ TUPLE: assert got expect ; : trim-datastacks ( seq1 seq2 -- seq1' seq2' ) 2dup [ length ] 2apply min tuck tail >r tail r> ; -TUPLE: relative-underflow stack ; - -: relative-underflow ( before after -- * ) - trim-datastacks nip \ relative-underflow construct-boa throw ; +ERROR: relative-underflow stack ; M: relative-underflow summary drop "Too many items removed from data stack" ; -TUPLE: relative-overflow stack ; +ERROR: relative-overflow stack ; M: relative-overflow summary drop "Superfluous items pushed to data stack" ; -: relative-overflow ( before after -- * ) - trim-datastacks drop \ relative-overflow construct-boa throw ; - : assert-depth ( quot -- ) >r datastack r> swap slip >r datastack r> 2dup [ length ] compare sgn { - { -1 [ relative-underflow ] } + { -1 [ trim-datastacks nip relative-underflow ] } { 0 [ 2drop ] } - { 1 [ relative-overflow ] } + { 1 [ trim-datastacks drop relative-overflow ] } } case ; inline : expired-error. ( obj -- ) @@ -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 diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 01f9643cdd..cec5109909 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -3,10 +3,7 @@ IN: definitions USING: kernel sequences namespaces assocs graphs ; -TUPLE: no-compilation-unit definition ; - -: no-compilation-unit ( definition -- * ) - \ no-compilation-unit construct-boa throw ; +ERROR: no-compilation-unit definition ; GENERIC: where ( defspec -- loc ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index b01fb87f72..46f57a1629 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? ) dup empty? [ [ dip ] curry [ ] like ] unless r> append ; -TUPLE: no-math-method left right generic ; - -: no-math-method ( left right generic -- * ) - \ no-math-method construct-boa throw ; +ERROR: no-math-method left right generic ; : default-math-method ( generic -- quot ) [ no-math-method ] curry [ ] like ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 35161319ef..37f72e7d95 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -26,10 +26,7 @@ SYMBOL: (dispatch#) : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ; -TUPLE: no-method object generic ; - -: no-method ( object generic -- * ) - \ no-method construct-boa throw ; +ERROR: no-method object generic ; : error-method ( word -- quot ) picker swap [ no-method ] curry append ; diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3c12e388c4..4f5d199264 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -514,10 +514,10 @@ DEFER: an-inline-word { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as -TUPLE: custom-error ; +ERROR: custom-error ; [ T{ effect f 0 0 t } ] [ - [ custom-error construct-boa throw ] infer + [ custom-error ] infer ] unit-test : funny-throw throw ; inline diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 240f39218b..a829bad47e 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot ) \ get-slots [ [get-slots] ] 1 define-transform -TUPLE: duplicated-slots-error names ; +ERROR: duplicated-slots-error names ; M: duplicated-slots-error summary drop "Calling set-slots with duplicate slot setters" ; -: duplicated-slots-error ( names -- * ) - \ duplicated-slots-error construct-boa throw ; - \ set-slots [ dup all-unique? [ [get-slots] ] [ duplicated-slots-error ] if diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 03ea2262a8..610d294bb6 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -18,17 +18,13 @@ GENERIC: ( stream decoding -- newstream ) TUPLE: decoder stream code cr ; -TUPLE: decode-error ; - -: decode-error ( -- * ) \ decode-error construct-empty throw ; +ERROR: decode-error ; GENERIC: ( stream encoding -- newstream ) TUPLE: encoder stream code ; -TUPLE: encode-error ; - -: encode-error ( -- * ) \ encode-error construct-empty throw ; +ERROR: encode-error ; ! Decoding diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3de7559303..f9116895e4 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -48,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ; : special-directory? ( name -- ? ) { "." ".." } member? ; -TUPLE: no-parent-directory path ; - -: no-parent-directory ( path -- * ) - \ no-parent-directory construct-boa throw ; +ERROR: no-parent-directory path ; : parent-directory ( path -- parent ) right-trim-separators { diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 22c942d2d9..8a9089a564 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -28,15 +28,6 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test -[ "" ] [ 0 read ] unit-test - -! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test - -[ - "/core/io/test/binary.txt" - [ 0.2 read ] with-stream -] must-fail - [ { { "It seems " CHAR: J } @@ -58,3 +49,12 @@ IN: io.tests 10 [ 65536 read drop ] times ] with-file-reader ] unit-test + +! [ "" ] [ 0 read ] unit-test + +! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test + +! [ +! "/core/io/test/binary.txt" +! [ 0.2 read ] with-stream +! ] must-fail diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor index 97e60b4a60..83e991b713 100755 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ; : ( in out -- stream ) f duplex-stream construct-boa ; -TUPLE: check-closed ; +ERROR: stream-closed-twice ; : check-closed ( stream -- ) - duplex-stream-closed? - [ \ check-closed construct-boa throw ] when ; + duplex-stream-closed? [ stream-closed-twice ] when ; : duplex-stream-in+ ( duplex -- stream ) dup check-closed duplex-stream-in ; diff --git a/core/libc/libc.factor b/core/libc/libc.factor index e82b244d6d..756d29e551 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -23,20 +23,14 @@ SYMBOL: mallocs PRIVATE> -TUPLE: check-ptr ; +ERROR: bad-ptr ; : check-ptr ( c-ptr -- c-ptr ) - [ \ check-ptr construct-boa throw ] unless* ; + [ bad-ptr ] unless* ; -TUPLE: double-free ; +ERROR: double-free ; -: double-free ( -- * ) - \ double-free construct-empty throw ; - -TUPLE: realloc-error ptr size ; - -: realloc-error ( alien size -- * ) - \ realloc-error construct-boa throw ; +ERROR: realloc-error ptr size ; } -"A view of a sequence as an associative structure:" +"An enum provides such a view of a sequence:" { $subsection enum } { $subsection } "Utility word used by developer tools which inspect objects:" -{ $subsection make-mirror } ; +{ $subsection make-mirror } +{ $see-also "slots" } ; ABOUT: "mirrors" diff --git a/core/parser/parser.factor b/core/parser/parser.factor index fd93479283..887747d7d8 100755 --- a/core/parser/parser.factor +++ b/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 ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 3c69bfa41c..14674ba2f2 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; : bounds-check? ( n seq -- ? ) length 1- 0 swap between? ; inline -TUPLE: bounds-error index seq ; - -: bounds-error ( n seq -- * ) - \ bounds-error construct-boa throw ; +ERROR: bounds-error index seq ; : bounds-check ( n seq -- n seq ) 2dup bounds-check? [ bounds-error ] unless ; inline MIXIN: immutable-sequence -TUPLE: immutable seq ; - -: immutable ( seq -- * ) \ immutable construct-boa throw ; +ERROR: immutable seq ; M: immutable-sequence set-nth immutable ; @@ -190,8 +185,7 @@ TUPLE: slice from to seq ; : collapse-slice ( m n slice -- m' n' seq ) dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline -TUPLE: slice-error reason ; -: slice-error ( str -- * ) \ slice-error construct-boa throw ; +ERROR: slice-error reason ; : check-slice ( from to seq -- from to seq ) pick 0 < [ "start < 0" slice-error ] when diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 8a1fb16fa9..55cff63963 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -4,21 +4,86 @@ effects generic.standard tuples slots.private classes strings math ; IN: slots +ARTICLE: "accessors" "Slot accessors" +"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:" +{ $list + { "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." } + { "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." } +} +"In addition, two utility words are defined for each distinct slot name used in the system:" +{ $list + { "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } + { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." } +} +"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names." +$nl +"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:" +{ $code + "" + " \"Happy birthday\" >>subject" + " { \"bob@bigcorp.com\" } >>to" + " \"alice@bigcorp.com\" >>from" + "send-email" +} +"The following uses writers, and requires some stack shuffling:" +{ $code + "" + " \"Happy birthday\" over (>>subject)" + " { \"bob@bigcorp.com\" } over (>>to)" + " \"alice@bigcorp.com\" over (>>from)" + "send-email" +} +"Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:" +{ $code + "" + " swap >>subject" + " swap >>to" + " \"alice@bigcorp.com\" >>from" + "send-email" +} +"This is because " { $link swap } " is easier to understand than " { $link tuck } ":" +{ $code + "" + " tuck (>>subject)" + " tuck (>>to)" + " \"alice@bigcorp.com\" over (>>from)" + "send-email" +} +"The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:" +{ $code + "find-manager" + " salary>> 0.75 * >>salary" +} +"The following version is preferred:" +{ $code + "find-manager" + " [ 0.75 * ] change-salary" +} +{ $see-also "slots" "mirrors" } ; + ARTICLE: "slots" "Slots" -"A " { $emphasis "slot" } " is a component of an object which can store a value. The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object." +"A " { $emphasis "slot" } " is a component of an object which can store a value." $nl { $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data." +"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object." $nl "The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance." { $subsection slot-spec } -"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not." +"The four words associated with a slot can be looked up in the " { $vocab-link "accessors" } " vocabulary:" { $subsection reader-word } { $subsection writer-word } { $subsection setter-word } { $subsection changer-word } -"Slot methods type check, then call unsafe primitives:" -{ $subsection slot } -{ $subsection set-slot } ; +"Looking up a slot by name:" +{ $subsection slot-named } +"Defining slots dynamically:" +{ $subsection define-reader } +{ $subsection define-writer } +{ $subsection define-setter } +{ $subsection define-changer } +{ $subsection define-slot-methods } +{ $subsection define-accessors } +{ $see-also "accessors" "mirrors" } ; ABOUT: "slots" diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index dc06a239de..26562a2178 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -556,10 +556,17 @@ HELP: PREDICATE: HELP: TUPLE: { $syntax "TUPLE: class slots... ;" } { $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } -{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "." +{ $description "Defines a new tuple class." $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 } } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 8cc9211599..843f372542 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -165,6 +165,7 @@ IN: bootstrap.syntax "ERROR:" [ CREATE-CLASS dup ";" parse-tokens define-tuple-class + dup save-location dup [ construct-boa throw ] curry define ] define-syntax diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 3af7d27d86..09d93884ad 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -3,11 +3,10 @@ tuples.private classes slots quotations words arrays generic.standard sequences definitions compiler.units ; IN: tuples -ARTICLE: "tuple-constructors" "Constructors and slots" -"Tuples are created by calling one of a number of words:" +ARTICLE: "tuple-constructors" "Constructors" +"Tuples are created by calling one of two words:" { $subsection construct-empty } { $subsection construct-boa } -{ $subsection construct } "By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "" } "." $nl "A shortcut for defining BOA constructors:" @@ -19,18 +18,13 @@ $nl "C: rgba" ": color construct-boa ; ! identical to above" "" - ": " - " { set-color-red set-color-green set-color-blue }" - " color construct ;" - ": f ; ! identical to above" + ": f ;" "" ": construct-empty ;" - ": { } color construct ; ! identical to above" ": f f f f ; ! identical to above" -} -"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ; +} ; -ARTICLE: "tuple-delegation" "Delegation" +ARTICLE: "tuple-delegation" "Tuple delegation" "If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown." { $subsection delegate } { $subsection set-delegate } @@ -48,7 +42,7 @@ $nl "{ 0 0 } 10 \"my-ellipse\" set" "{ 1 0 0 } \"my-shape\" set" "\"my-ellipse\" get \"my-shape\" get set-delegate" - "\"my-shape\" get dup colored-color swap ellipse-center .s" + "\"my-shape\" get dup color>> swap center>> .s" "{ 0 0 }\n{ 1 0 0 }" } ; @@ -58,25 +52,90 @@ ARTICLE: "tuple-introspection" "Tuple introspection" { $subsection tuple>array } { $subsection tuple-slots } "Tuple classes can also be defined at run time:" -{ $subsection define-tuple-class } ; +{ $subsection define-tuple-class } +{ $see-also "slots" "mirrors" } ; + +ARTICLE: "tuple-examples" "Tuple examples" +"An example:" +{ $code "TUPLE: employee name salary position ;" } +"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:" +{ $table + { "Reader" "Writer" "Setter" "Changer" } + { { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } } + { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } } + { { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } } +} +"We can define a constructor which makes an empty employee:" +{ $code ": ( -- employee )" + " employee construct-empty ;" } +"Or we may wish the default constructor to always give employees a starting salary:" +{ $code + ": ( -- employee )" + " employee construct-empty" + " 40000 >>salary ;" +} +"We can define more refined constructors:" +{ $code + ": ( -- manager )" + " \"project manager\" >>position ;" } +"An alternative strategy is to define the most general BOA constructor first:" +{ $code + ": ( name position -- person )" + " 40000 employee construct-boa ;" +} +"Now we can define more specific constructors:" +{ $code + ": ( name -- person )" + " \"manager\" ;" } +"An example using reader words:" +{ $code + "TUPLE: check to amount number ;" + "" + "SYMBOL: checks" + "" + ": ( to amount -- check )" + " checks counter check construct-boa ;" + "" + ": biweekly-paycheck ( employee -- check )" + " dup name>> swap salary>> 26 / ;" +} +"An example of using a changer:" +{ $code + ": positions" + " {" + " \"junior programmer\"" + " \"senior programmer\"" + " \"project manager\"" + " \"department manager\"" + " \"executive\"" + " \"CTO\"" + " \"CEO\"" + " \"enterprise Java world dictator\"" + " } ;" + "" + ": next-position ( role -- newrole )" + " positions [ index 1+ ] keep nth ;" + "" + ": promote ( person -- person )" + " [ 1.2 * ] change-salary" + " [ next-position ] change-position ;" +} ; ARTICLE: "tuples" "Tuples" -"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:" +"Tuples are user-defined classes composed of named slots." +{ $subsection "tuple-examples" } +"A parsing word defines tuple classes:" { $subsection POSTPONE: TUPLE: } -"An example:" -{ $code "TUPLE: person name address phone ;" "C: person" } -"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "" } ", and the following reader/writer words:" -{ $table - { "Reader" "Writer" } - { { $snippet "person-name" } { $snippet "set-person-name" } } - { { $snippet "person-address" } { $snippet "set-person-address" } } - { { $snippet "person-phone" } { $snippet "set-person-phone" } } -} +"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot." +$nl +"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:" +{ $subsection "accessors" } "Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:" { $subsection "tuple-constructors" } "Further topics:" { $subsection "tuple-delegation" } -{ $subsection "tuple-introspection" } ; +{ $subsection "tuple-introspection" } +"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ; ABOUT: "tuples" diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 63bb233654..b5076ea22b 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -236,7 +236,7 @@ C: erg's-reshape-problem [ "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval -] [ [ check-tuple? ] is? ] must-fail-with +] [ [ no-tuple-class? ] is? ] must-fail-with ! Hardcore unit tests USE: threads diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index d2d3d01c37..02ce49d779 100755 --- a/core/tuples/tuples.factor +++ b/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 diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index cf7018b652..38df17c0b5 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -59,16 +59,13 @@ M: f vocab-help ; : create-vocab ( name -- vocab ) dictionary get [ ] cache ; -TUPLE: no-vocab name ; - -: no-vocab ( name -- * ) - vocab-name \ no-vocab construct-boa throw ; +ERROR: no-vocab name ; SYMBOL: load-vocab-hook ! ( name -- ) : load-vocab ( name -- vocab ) dup load-vocab-hook get call - dup vocab [ ] [ no-vocab ] ?if ; + dup vocab [ ] [ vocab-name no-vocab ] ?if ; : vocabs ( -- seq ) dictionary get keys natural-sort ; diff --git a/core/words/words.factor b/core/words/words.factor index a36cca00ac..de253e6fee 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ; M: word definition word-def ; -TUPLE: undefined ; - -: undefined ( -- * ) \ undefined construct-empty throw ; +ERROR: undefined ; PREDICATE: word deferred ( obj -- ? ) word-def [ undefined ] = ; @@ -189,12 +187,11 @@ M: word subwords drop f ; [ ] [ no-vocab ] ?if set-at ; -TUPLE: check-create name vocab ; +ERROR: bad-create name vocab ; : check-create ( name vocab -- name vocab ) - 2dup [ string? ] both? [ - \ check-create construct-boa throw - ] unless ; + 2dup [ string? ] both? + [ bad-create ] unless ; : create ( name vocab -- word ) check-create 2dup lookup diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index d8a4f83169..b65e44fda4 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -39,8 +39,6 @@ IN: help.lint { $shuffle $values-x/y - $slot-reader - $slot-writer $predicate $class-description $error-description diff --git a/extra/help/markup/markup-tests.factor b/extra/help/markup/markup-tests.factor index 0b4b69bf59..6b138a18ab 100644 --- a/extra/help/markup/markup-tests.factor +++ b/extra/help/markup/markup-tests.factor @@ -4,18 +4,6 @@ IN: help.markup.tests TUPLE: blahblah quux ; -: test-slot blahblah "slots" word-prop second ; - -[ - { { "blahblah" { $instance blahblah } } { "quux" { $instance object } } } -] [ - test-slot blahblah ($spec-reader-values) -] unit-test - -[ ] [ - test-slot blahblah $spec-reader-values -] unit-test - [ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test [ ] [ \ blahblah-quux help ] unit-test diff --git a/extra/math/ranges/ranges-docs.factor b/extra/math/ranges/ranges-docs.factor new file mode 100644 index 0000000000..a8783ee410 --- /dev/null +++ b/extra/math/ranges/ranges-docs.factor @@ -0,0 +1,21 @@ +USING: help.syntax help.markup ; + +IN: math.ranges + +ARTICLE: "ranges" "Ranges" + + "A " { $emphasis "range" } " is a virtual sequence with elements " + "ranging from a to b by step." + + $nl + + "Creating ranges:" + + { $subsection } + { $subsection [a,b] } + { $subsection (a,b] } + { $subsection [a,b) } + { $subsection (a,b) } + { $subsection [0,b] } + { $subsection [1,b] } + { $subsection [0,b) } ; \ No newline at end of file diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor index ade3b63a5c..9215fc3acd 100755 --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -3,7 +3,7 @@ IN: math.ranges TUPLE: range from length step ; -: ( from to step -- range ) +: ( a b step -- range ) >r over - r> [ / 1+ 0 max >integer ] keep range construct-boa ; @@ -22,19 +22,19 @@ INSTANCE: range immutable-sequence : ,b) dup neg rot + swap ; inline -: [a,b] twiddle ; +: [a,b] ( a b -- range ) twiddle ; -: (a,b] twiddle (a, ; +: (a,b] ( a b -- range ) twiddle (a, ; -: [a,b) twiddle ,b) ; +: [a,b) ( a b -- range ) twiddle ,b) ; -: (a,b) twiddle (a, ,b) ; +: (a,b) ( a b -- range ) twiddle (a, ,b) ; -: [0,b] 0 swap [a,b] ; +: [0,b] ( b -- range ) 0 swap [a,b] ; -: [1,b] 1 swap [a,b] ; +: [1,b] ( b -- range ) 1 swap [a,b] ; -: [0,b) 0 swap [a,b) ; +: [0,b) ( b -- range ) 0 swap [a,b) ; : range-increasing? ( range -- ? ) range-step 0 > ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 44a64cc9dd..b086b30a5e 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -34,8 +34,13 @@ IN: tools.vocabs : source-modified? ( path -- ? ) dup source-files get at [ - dup source-file-path ?resource-path utf8 file-lines lines-crc32 - swap source-file-checksum = not + dup source-file-path ?resource-path + dup exists? [ + utf8 file-lines lines-crc32 + swap source-file-checksum = not + ] [ + 2drop f + ] if ] [ resource-exists? ] ?if ;