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/functors.factor b/basis/functors/functors.factor index ac2e52f68e..6678613002 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -63,6 +63,9 @@ FUNCTOR-SYNTAX: TUPLE: } case \ define-tuple-class suffix! ; +FUNCTOR-SYNTAX: final + [ word make-final ] append! ; + FUNCTOR-SYNTAX: SINGLETON: scan-param suffix! \ define-singleton-class suffix! ; diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor index f7b853cff7..f1e151b985 100644 --- a/basis/typed/typed-tests.factor +++ b/basis/typed/typed-tests.factor @@ -97,3 +97,11 @@ TYPED: no-outputs-unboxable-input ( x: unboxable3 -- ) buh set ; [ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test + +! Reported by littledan +TUPLE: superclass x ; +TUPLE: subclass < superclass y ; + +TYPED: unbox-fail ( superclass: a -- ? ) subclass? ; + +[ t ] [ subclass new unbox-fail ] unit-test 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-tests.factor b/core/classes/tuple/tuple-tests.factor index 36d402c61d..6711c5705e 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 + +[ t ] [ \ final-subclass valid-superclass? ] 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 + +[ f ] [ \ final-subclass valid-superclass? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 363c2879e9..c7a3afdd6d 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -240,7 +240,7 @@ M: tuple-class update-class GENERIC: valid-superclass? ( class -- ? ) -M: tuple-class valid-superclass? drop t ; +M: tuple-class valid-superclass? "final" word-prop not ; M: builtin-class valid-superclass? tuple eq? ; @@ -266,8 +266,16 @@ PRIVATE> : define-tuple-class ( class superclass slots -- ) over check-superclass over prepare-slots + pick f "final" set-word-prop (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 ; @@ -301,7 +309,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/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