diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 2c0db93522..cb7e4ee2b0 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,11 +1,11 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types alien.data ascii -assocs byte-arrays classes.struct classes.tuple.private +assocs byte-arrays classes.struct classes.tuple.private classes.tuple combinators compiler.tree.debugger compiler.units destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc literals math mirrors namespaces prettyprint prettyprint.config see sequences specialized-arrays system -tools.test parser lexer eval layouts ; +tools.test parser lexer eval layouts generic.single classes ; FROM: math => float ; QUALIFIED-WITH: alien.c-types c SPECIALIZED-ARRAY: char @@ -338,13 +338,28 @@ STRUCT: struct-that's-a-word { x int } ; [ "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }" eval( -- value ) -] must-fail +] [ error>> no-method? ] must-fail-with ! Subclassing a struct class should not be allowed [ - "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;" + "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;" eval( -- ) -] must-fail +] [ error>> bad-superclass? ] must-fail-with + +! Changing a superclass into a struct should reset the subclass +TUPLE: will-become-struct ; + +TUPLE: a-subclass < will-become-struct ; + +[ f ] [ will-become-struct struct-class? ] unit-test + +[ will-become-struct ] [ a-subclass superclass ] unit-test + +[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test + +[ t ] [ will-become-struct struct-class? ] unit-test + +[ tuple ] [ a-subclass superclass ] unit-test ! Remove c-type when struct class is forgotten [ ] [ diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index fae39cd229..a5711de609 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -32,8 +32,6 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec PREDICATE: struct-class < tuple-class superclass \ struct eq? ; -M: struct-class valid-superclass? drop f ; - SLOT: fields : struct-slots ( struct-class -- slots ) @@ -273,7 +271,7 @@ M: struct binary-zero? >c-ptr [ 0 = ] all? ; [ type>> c-type drop ] each ; : redefine-struct-tuple-class ( class -- ) - [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ; + [ struct f define-tuple-class ] [ make-final ] bi ; :: (define-struct-class) ( class slots offsets-quot -- ) slots empty? [ struct-must-have-slots ] when diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 815304b21f..b6497c52a9 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -194,7 +194,7 @@ M: not-a-tuple summary drop "Not a tuple" ; M: bad-superclass summary - drop "Tuple classes can only inherit from other tuple classes" ; + drop "Tuple classes can only inherit from non-final tuple classes" ; M: no-initial-value summary drop "Initial value must be provided for slots specialized to this class" ; diff --git a/basis/functors/backend/backend.factor b/basis/functors/backend/backend.factor index dd3d891f7b..331864417e 100644 --- a/basis/functors/backend/backend.factor +++ b/basis/functors/backend/backend.factor @@ -1,6 +1,6 @@ USING: accessors arrays assocs generic.standard kernel lexer locals.types namespaces parser quotations vocabs.parser -words ; +words classes.tuple ; IN: functors.backend DEFER: functor-words @@ -27,7 +27,11 @@ SYNTAX: FUNCTOR-SYNTAX: : define* ( word def -- ) over set-word define ; -: define-declared* ( word def effect -- ) pick set-word define-declared ; +: define-declared* ( word def effect -- ) + pick set-word define-declared ; -: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ; +: define-simple-generic* ( word effect -- ) + over set-word define-simple-generic ; +: define-tuple-class* ( class superclass slots -- ) + pick set-word define-tuple-class ; diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 544c2ed1e4..c756d1b83d 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,5 +1,5 @@ -USING: classes.struct functors tools.test math words kernel -multiline parser io.streams.string generic ; +USING: classes.struct classes.tuple functors tools.test math +words kernel multiline parser io.streams.string generic ; QUALIFIED-WITH: alien.c-types c IN: functors.tests @@ -36,7 +36,7 @@ WW DEFINES ${W}${W} WHERE -: WW ( a -- b ) \ W twice ; inline +: WW ( a -- b ) \ W twice ; ;FUNCTOR @@ -211,3 +211,44 @@ STRUCT: T-class } ] [ a-struct struct-slots ] unit-test +<< + +FUNCTOR: define-an-inline-word ( W -- ) + +W DEFINES ${W} +W-W DEFINES ${W}-${W} + +WHERE + +: W ( -- ) ; inline +: W-W ( -- ) W W ; + +;FUNCTOR + +"an-inline-word" define-an-inline-word + +>> + +[ t ] [ \ an-inline-word inline? ] unit-test +[ f ] [ \ an-inline-word-an-inline-word inline? ] unit-test + +<< + +FUNCTOR: define-a-final-class ( T W -- ) + +T DEFINES-CLASS ${T} +W DEFINES ${W} + +WHERE + +TUPLE: T ; final + +: W ( -- ) ; + +;FUNCTOR + +"a-final-tuple" "a-word" define-a-final-class + +>> + +[ t ] [ a-final-tuple final-class? ] unit-test diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index ac2e52f68e..1895c6e0f4 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -61,7 +61,10 @@ FUNCTOR-SYNTAX: TUPLE: make suffix! ] } case - \ define-tuple-class suffix! ; + \ define-tuple-class* suffix! ; + +FUNCTOR-SYNTAX: final + [ word make-final ] append! ; FUNCTOR-SYNTAX: SINGLETON: scan-param suffix! diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 75e6538243..f951f30b2f 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -129,8 +129,8 @@ ALIAS: $slot $snippet "Examples" $heading print-element ; : $example ( element -- ) - 1 cut* swap "\n" join dup [ - input-style get format nl print-element + 1 cut* [ "\n" join ] bi@ over [ + [ print ] [ output-style get format ] bi* ] ($code) ; : $unchecked-example ( element -- ) diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor index 8a119823cc..d5b783fef8 100644 --- a/basis/help/stylesheet/stylesheet.factor +++ b/basis/help/stylesheet/stylesheet.factor @@ -80,8 +80,11 @@ H{ { wrap-margin f } } code-style set-global -SYMBOL: input-style -H{ { font-style bold } } input-style set-global +SYMBOL: output-style +H{ + { font-style bold } + { foreground COLOR: dark-red } +} output-style set-global SYMBOL: url-style H{ diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index 77bec12c1a..bb014fef62 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -1,8 +1,9 @@ -USING: help.markup help.syntax kernel io system prettyprint continuations quotations ; +USING: help.markup help.syntax kernel io system prettyprint +continuations quotations vocabs.loader parser ; IN: listener ARTICLE: "listener-watch" "Watching variables in the listener" -"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:" +"The listener prints values of dynamic variables which are added to a watch list:" { $subsections visible-vars } "To add or remove a single variable:" { $subsections @@ -14,7 +15,7 @@ ARTICLE: "listener-watch" "Watching variables in the listener" show-vars hide-vars } -"Hiding all visible variables:" +"Clearing the watch list:" { $subsections hide-all-vars } ; HELP: only-use-vocabs @@ -46,21 +47,33 @@ HELP: hide-all-vars { $description "Removes all variables from the watch list." } ; ARTICLE: "listener" "The listener" -"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it." +"The listener evaluates Factor expressions read from the input stream. Typically, you write Factor code in a text editor, load it from the listener by calling " { $link require } ", " { $link reload } " or " { $link run-file } ", and then test it from interactively." $nl "The classical first program can be run in the listener:" { $example "\"Hello, world\" print" "Hello, world" } +"New words can also be defined in the listener:" +{ $example + "USE: math.functions" + ": twice ( word -- ) [ execute ] [ execute ] bi ; inline" + "81 \\ sqrt twice ." + "3.0" +} "Multi-line expressions are supported:" { $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" } -"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them." +"The listener will display the current contents of the datastack after every line of input." $nl -"The listener will display the current contents of the datastack after every expression is evaluated. The listener can additionally watch dynamic variables:" +"The listener can watch dynamic variables:" { $subsections "listener-watch" } -"To start a nested listener:" +"Nested listeners can be useful for testing code in other dynamic scopes. For example, when doing database maintanance using the " { $vocab-link "db.tuples" } " vocabulary, it can be useful to start a listener with a database connection:" +{ $code + "USING: db db.sqlite listener ;" + "\"data.db\" [ listener ] with-db" +} +"Starting a nested listener:" { $subsections listener } "To exit a listener, invoke the " { $link return } " word." $nl -"Multi-line quotations can be read independently of the rest of the listener:" +"The listener's mechanism for reading multi-line expressions from the input stream can be called from user code:" { $subsections read-quot } ; ABOUT: "listener" diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index acf13599c1..a60026317d 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -251,7 +251,7 @@ BOA-EFFECT [ N "n" { "v" } ] WHERE -TUPLE: A < simd-128 ; +TUPLE: A < simd-128 ; final M: A new-underlying drop \ A boa ; inline M: A simd-rep drop A-rep ; inline diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 8ba6e94a49..ec0e20a393 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -362,3 +362,15 @@ TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ; ] [ [ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split ] unit-test + +TUPLE: final-tuple ; final + +[ + { + "IN: prettyprint.tests" + "TUPLE: final-tuple ; final" + "" + } +] [ + [ \ final-tuple see ] with-string-writer "\n" split +] unit-test diff --git a/basis/see/see.factor b/basis/see/see.factor index 0d2388114a..326e051219 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.builtin classes.intersection classes.mixin classes.predicate classes.singleton @@ -182,14 +182,21 @@ M: array pprint-slot-name dup length 1 = [ first ] when pprint-slot-name ; +: tuple-declarations. ( class -- ) + \ final declaration. ; + +: superclass. ( class -- ) + superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ; + M: tuple-class see-class* - pprint-; block> ; + { + [ pprint-word ] + [ superclass. ] + [ pprint-; ] + [ tuple-declarations. ] + } cleave + block> ; M: word see-class* drop ; diff --git a/basis/sequences/cords/cords.factor b/basis/sequences/cords/cords.factor index fca005fa6e..4a2d267a12 100644 --- a/basis/sequences/cords/cords.factor +++ b/basis/sequences/cords/cords.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences sorting binary-search fry math math.order arrays classes combinators kernel functors math.functions @@ -8,7 +8,7 @@ IN: sequences.cords MIXIN: cord TUPLE: generic-cord - { head read-only } { tail read-only } ; + { head read-only } { tail read-only } ; final INSTANCE: generic-cord cord M: cord length @@ -34,7 +34,7 @@ T-cord DEFINES-CLASS ${C} WHERE TUPLE: T-cord - { head T read-only } { tail T read-only } ; + { head T read-only } { tail T read-only } ; final INSTANCE: T-cord cord M: T cord-append diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index eda793ff22..d3db93e788 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -47,7 +47,7 @@ WHERE TUPLE: A { underlying c-ptr read-only } -{ length array-capacity read-only } ; +{ length array-capacity read-only } ; final : ( alien len -- specialized-array ) A boa ; inline diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index d995354a52..df68fa8961 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors classes.algebra fry generic kernel math -namespaces sequences words sets combinators.short-circuit ; +namespaces sequences words sets combinators.short-circuit +classes.tuple ; FROM: classes.tuple.private => tuple-layout ; IN: stack-checker.dependencies @@ -122,6 +123,15 @@ TUPLE: depends-on-flushable word ; M: depends-on-flushable satisfied? word>> flushable? ; +TUPLE: depends-on-final class ; + +: depends-on-final ( word -- ) + [ depends-on-conditionally ] + [ \ depends-on-final add-conditional-dependency ] bi ; + +M: depends-on-final satisfied? + class>> final-class? ; + : init-dependencies ( -- ) H{ } clone dependencies set H{ } clone generic-dependencies set diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index fe63071998..9f25808c9e 100644 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make continuations.private kernel.private init assocs kernel vocabs words sequences memory io system arrays @@ -19,13 +19,12 @@ TUPLE: vocab-manifest vocabs libraries ; : copy-resources ( manifest name dir -- ) append-path swap vocabs>> [ copy-vocab-resources ] with each ; -ERROR: cant-deploy-library-file library ; - + [ swap over file-name append-path copy-file ] + [ can't-deploy-library-file ] ?if ; : copy-libraries ( manifest name dir -- ) append-path swap libraries>> [ copy-library ] with each ; diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor index 5e70e15aa7..72a5ae4df3 100644 --- a/basis/tuple-arrays/tuple-arrays-docs.factor +++ b/basis/tuple-arrays/tuple-arrays-docs.factor @@ -3,20 +3,24 @@ USING: help.markup help.syntax sequences ; HELP: TUPLE-ARRAY: { $syntax "TUPLE-ARRAY: class" } +{ $values { "class" "a final tuple class" } } { $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ; ARTICLE: "tuple-arrays" "Tuple arrays" -"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array." +"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of references to heap-allocated objects, a tuple array stores its elements as values." $nl -"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "." +"Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array." +$nl +"Since value semantics are incompatible with inheritance, the base type of a tuple array must be declared " { $link POSTPONE: final } ". A best practice that is not enforced is to have all slots in the tuple declared " { $link read-only } "." +$nl +"Tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays." $nl -"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays." { $subsections POSTPONE: TUPLE-ARRAY: } "An example:" { $example "USE: tuple-arrays" "IN: scratchpad" - "TUPLE: point x y ;" + "TUPLE: point x y ; final" "TUPLE-ARRAY: point" "{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short." "T{ point f 1 2 }" diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 2eeae20aa1..0fbf0eeaa0 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -1,9 +1,9 @@ USING: tuple-arrays sequences tools.test namespaces kernel -math accessors ; +math accessors classes.tuple eval ; IN: tuple-arrays.tests SYMBOL: mat -TUPLE: foo bar ; +TUPLE: foo bar ; final C: foo TUPLE-ARRAY: foo @@ -18,15 +18,27 @@ TUPLE-ARRAY: foo [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test -TUPLE: baz { bing integer } bong ; +TUPLE: baz { bing integer } bong ; final TUPLE-ARRAY: baz [ 0 ] [ 1 first bing>> ] unit-test [ f ] [ 1 first bong>> ] unit-test -TUPLE: broken x ; +TUPLE: broken x ; final : broken ( -- ) ; TUPLE-ARRAY: broken -[ 100 ] [ 100 length ] unit-test \ No newline at end of file +[ 100 ] [ 100 length ] unit-test + +! Can't define a tuple array for a non-tuple class +[ "IN: tuple-arrays.tests USING: tuple-arrays words ; TUPLE-ARRAY: word" eval( -- ) ] +[ error>> not-a-tuple? ] +must-fail-with + +! Can't define a tuple array for a non-final class +TUPLE: non-final x ; + +[ "IN: tuple-arrays.tests USE: tuple-arrays TUPLE-ARRAY: non-final" eval( -- ) ] +[ error>> not-final? ] +must-fail-with \ No newline at end of file diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index aea51f7820..1a3091c1e2 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -1,11 +1,13 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators.smart fry functors kernel kernel.private macros sequences combinators sequences.private -stack-checker parser math classes.tuple.private ; +stack-checker parser math classes.tuple classes.tuple.private ; FROM: inverse => undo ; IN: tuple-arrays +ERROR: not-final class ; + ] ; @@ -29,6 +31,13 @@ MACRO: write-tuple ( class -- quot ) [ tuple-arity iota [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] bi '[ _ dip @ ] ; +: check-final ( class -- ) + { + { [ dup tuple-class? not ] [ not-a-tuple ] } + { [ dup final-class? not ] [ not-final ] } + [ drop ] + } cond ; + PRIVATE> FUNCTOR: define-tuple-array ( CLASS -- ) @@ -43,6 +52,8 @@ CLASS-array? IS ${CLASS-array}? WHERE +CLASS check-final + TUPLE: CLASS-array { seq array read-only } { n array-capacity read-only } diff --git a/basis/typed/typed-docs.factor b/basis/typed/typed-docs.factor index 0b6838379c..c6f80a48bc 100644 --- a/basis/typed/typed-docs.factor +++ b/basis/typed/typed-docs.factor @@ -58,10 +58,18 @@ HELP: output-mismatch-error ARTICLE: "typed" "Strongly-typed word definitions" "The Factor compiler supports advanced compiler optimizations that take advantage of the type information it can glean from source code. The " { $vocab-link "typed" } " vocabulary provides syntax that allows words to provide checked type information about their inputs and outputs and improve the performance of compiled code." +$nl +"Parameters and return values of typed words where the type is declared to be a " { $link POSTPONE: final } " tuple class with all slots " { $link read-only } " are passed by value." { $subsections POSTPONE: TYPED: POSTPONE: TYPED:: +} +"Defining typed words at run time:" +{ $subsections define-typed +} +"Errors:" +{ $subsections input-mismatch-error output-mismatch-error } ; diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor index f7b853cff7..7f984ccaf2 100644 --- a/basis/typed/typed-tests.factor +++ b/basis/typed/typed-tests.factor @@ -14,8 +14,8 @@ TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum ) most-positive-fixnum neg 1 - 1quotation [ most-positive-fixnum 1 fix+ ] unit-test -TUPLE: tweedle-dee ; -TUPLE: tweedle-dum ; +TUPLE: tweedle-dee ; final +TUPLE: tweedle-dum ; final TYPED: dee ( x: tweedle-dee -- y ) drop \ tweedle-dee ; @@ -39,11 +39,11 @@ TYPED:: f+locals ( a: float b: float -- c: float ) TUPLE: unboxable { x fixnum read-only } - { y fixnum read-only } ; + { y fixnum read-only } ; final TUPLE: unboxable2 { u unboxable read-only } - { xy fixnum read-only } ; + { xy fixnum read-only } ; final TYPED: unboxy ( in: unboxable -- out: unboxable2 ) dup [ x>> ] [ y>> ] bi - unboxable2 boa ; @@ -63,7 +63,7 @@ IN: typed.tests TUPLE: unboxable { x fixnum read-only } { y fixnum read-only } - { z float read-only } ; + { z float read-only } ; final """ eval( -- ) """ @@ -79,13 +79,15 @@ TYPED: no-inputs ( -- out: integer ) [ 1 ] [ no-inputs ] unit-test TUPLE: unboxable3 - { x read-only } ; + { x read-only } ; final TYPED: no-inputs-unboxable-output ( -- out: unboxable3 ) T{ unboxable3 } ; [ T{ unboxable3 } ] [ no-inputs-unboxable-output ] unit-test +[ f ] [ no-inputs-unboxable-output no-inputs-unboxable-output eq? ] unit-test + SYMBOL: buh TYPED: no-outputs ( x: integer -- ) @@ -97,3 +99,26 @@ TYPED: no-outputs-unboxable-input ( x: unboxable3 -- ) buh set ; [ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test + +[ f ] [ + T{ unboxable3 } no-outputs-unboxable-input buh get + T{ unboxable3 } no-outputs-unboxable-input buh get + eq? +] unit-test + +! Reported by littledan +TUPLE: superclass { x read-only } ; +TUPLE: subclass < superclass { y read-only } ; final + +TYPED: unbox-fail ( a: superclass -- ? ) subclass? ; + +[ t ] [ subclass new unbox-fail ] unit-test + +! If a final class becomes non-final, typed words need to be recompiled +TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ; + +[ f ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test + +[ ] [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test + +[ t ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index e71196e3ee..8a85ca1afb 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -20,6 +20,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ; { [ all-slots empty? not ] [ immutable-tuple-class? ] + [ final-class? ] } 1&& ; ! typed inputs @@ -30,9 +31,14 @@ PREDICATE: typed-word < word "typed-word" word-prop ; : input-mismatch-quot ( word types -- quot ) [ input-mismatch-error ] 2curry ; +: depends-on-unboxing ( class -- ) + [ dup tuple-layout depends-on-tuple-layout ] + [ depends-on-final ] + bi ; + : (unboxer) ( type -- quot ) dup unboxable-tuple-class? [ - dup dup tuple-layout depends-on-tuple-layout + dup depends-on-unboxing all-slots [ [ name>> reader-word 1quotation ] [ class>> (unboxer) ] bi compose @@ -52,7 +58,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ; : (unboxed-types) ( type -- types ) dup unboxable-tuple-class? [ - dup dup tuple-layout depends-on-tuple-layout + dup depends-on-unboxing all-slots [ class>> (unboxed-types) ] map concat ] [ 1array ] if ; @@ -81,7 +87,7 @@ DEFER: make-boxer : boxer ( type -- quot ) dup unboxable-tuple-class? [ - dup dup tuple-layout depends-on-tuple-layout + dup depends-on-unboxing [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index fa4d4b2f69..62a0774444 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private math math.private sequences sequences.private ; @@ -9,24 +9,16 @@ M: array length length>> ; inline M: array nth-unsafe [ >fixnum ] dip array-nth ; inline M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline M: array resize resize-array ; inline - -: >array ( seq -- array ) { } clone-like ; - +M: array equal? over array? [ sequence= ] [ 2drop f ] if ; M: object new-sequence drop 0 ; inline - M: f new-sequence drop [ f ] [ 0 ] if-zero ; inline -M: array equal? - over array? [ sequence= ] [ 2drop f ] if ; - INSTANCE: array sequence +: >array ( seq -- array ) { } clone-like ; : 1array ( x -- array ) 1 swap ; inline - : 2array ( x y -- array ) { } 2sequence ; inline - : 3array ( x y z -- array ) { } 3sequence ; inline - : 4array ( w x y z -- array ) { } 4sequence ; inline PREDICATE: pair < array length 2 number= ; diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index bb159f04df..1870f4ac1b 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -49,6 +49,7 @@ IN: bootstrap.syntax "SYMBOLS:" "CONSTANT:" "TUPLE:" + "final" "SLOT:" "T{" "UNION:" diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor index 8233d8cff3..41ce32105d 100644 --- a/core/classes/parser/parser.factor +++ b/core/classes/parser/parser.factor @@ -8,8 +8,9 @@ IN: classes.parser : create-class-in ( string -- word ) current-vocab create + dup set-word dup save-class-location - dup create-predicate-word dup set-word save-location ; + dup create-predicate-word save-location ; : CREATE-CLASS ( -- word ) scan create-class-in ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 2b3e80da1d..7f6078e321 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -191,6 +191,8 @@ $nl "tuple-inheritance-example" "tuple-inheritance-anti-example" } +"Declaring a tuple class final prohibits other classes from subclassing it:" +{ $subsections POSTPONE: final } { $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ; ARTICLE: "tuple-introspection" "Tuple introspection" @@ -441,3 +443,6 @@ HELP: boa { $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." } { $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." } { $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ; + +HELP: bad-superclass +{ $error-description "Thrown if an attempt is made to subclass a class that is not a tuple class, or a tuple class declared " { $link POSTPONE: final } "." } ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 36d402c61d..276c6b407c 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -770,3 +770,30 @@ TUPLE: tuple-predicate-redefine-test ; [ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test [ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test + +! Final classes +TUPLE: final-superclass ; +TUPLE: final-subclass < final-superclass ; + +[ final-superclass ] [ final-subclass superclass ] unit-test + +! Making the superclass final should change the superclass of the subclass +[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test + +[ tuple ] [ final-subclass superclass ] unit-test + +[ f ] [ \ final-subclass final-class? ] unit-test + +! Subclassing a final class should fail +[ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ] +[ error>> bad-superclass? ] must-fail-with + +! Making a final class non-final should work +[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test + +! Changing a superclass should not change the final status of a subclass +[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test + +[ t ] [ \ final-subclass final-class? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 363c2879e9..64c34d221a 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -93,6 +93,14 @@ ERROR: bad-superclass class ; ] [ 2drop f ] if ] [ 2drop f ] if ; inline +GENERIC: final-class? ( class -- ? ) + +M: tuple-class final-class? "final" word-prop ; + +M: builtin-class final-class? tuple eq? not ; + +M: class final-class? drop t ; + : define-tuple-class ( class superclass slots -- ) @@ -268,10 +275,18 @@ PRIVATE> over prepare-slots (define-tuple-class) ; +GENERIC: make-final ( class -- ) + +M: tuple-class make-final + [ dup class-usage keys ?metaclass-changed ] + [ t "final" set-word-prop ] + bi ; + M: word (define-tuple-class) define-new-tuple-class ; M: tuple-class (define-tuple-class) + pick reset-final 3dup tuple-class-unchanged? [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ; @@ -301,7 +316,7 @@ M: tuple-class reset-class ] with each ] [ [ call-next-method ] - [ { "layout" "slots" "boa-check" "prototype" } reset-props ] + [ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ] bi ] bi ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 95b62fc3f3..7b9481825b 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -5,6 +5,10 @@ kernel kernel.private math assocs quotations vectors hashtables sorting words sets math.order make ; IN: combinators +! Most of these combinators have compile-time expansions in +! the optimizing compiler. See stack-checker.transforms and +! compiler.tree.propagation.call-effect + -ERROR: wrong-values quot effect ; +ERROR: wrong-values quot call-site ; ! We can't USE: effects here so we forward reference slots instead SLOT: in diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 3a9314fb56..8d4f1f61a5 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -166,7 +166,13 @@ HELP: create-method HELP: (call-next-method) { $values { "method" method } } { $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." } -{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ; +{ $notes + "The " { $link POSTPONE: call-next-method } " word parses into this word. The following are equivalent:" + { $code + "M: class generic call-next-method ;" + "M: class generic M\\ class generic (call-next-method) ;" + } +} ; HELP: no-next-method { $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." } diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index f30eb68684..266a65b957 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -339,7 +339,7 @@ IN: parser.tests ] unit-test [ t ] [ - "foo?" "parser.tests" lookup word eq? + "foo" "parser.tests" lookup word eq? ] unit-test [ ] [ diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 8ad6084188..4a1af4c578 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -792,6 +792,10 @@ $nl { $code "TUPLE: person" "{ age integer initial: 0 }" "{ department string initial: \"Marketing\" }" "manager ;" } } ; +HELP: final +{ $syntax "TUPLE: ... ; final" } +{ $description "Declares the most recently defined word as a final tuple class which cannot be subclassed. Attempting to subclass a final class raises a " { $link bad-superclass } " error." } ; + HELP: initial: { $syntax "TUPLE: ... { slot initial: value } ... ;" } { $values { "slot" "a slot name" } { "value" "any literal" } } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index cf2c49fff9..0b5b32e289 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -204,6 +204,10 @@ IN: bootstrap.syntax parse-tuple-definition define-tuple-class ] define-core-syntax + "final" [ + word make-final + ] define-core-syntax + "SLOT:" [ scan define-protocol-slot ] define-core-syntax diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor index 701db77135..80c31553c1 100644 --- a/extra/benchmark/tuple-arrays/tuple-arrays.factor +++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions tuple-arrays accessors fry sequences prettyprint ; IN: benchmark.tuple-arrays -TUPLE: point { x float } { y float } { z float } ; +TUPLE: point { x float } { y float } { z float } ; final TUPLE-ARRAY: point