Add support for final tuple classes which cannot be subclassed: TUPLE: foo ... ;...

diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor
index 2c0db93522b8e411695cd9fe034ab1c5183eced2..cb7e4ee2b085b9f344856bcccf930e31602651cb 100644 (file)
--- 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 fae39cd229e42baadb61d4692cf60281be6824e8..a5711de609f67e83235ab8e89058865260d7cd57 100644 (file)
--- 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 815304b21f9a8e9e779ba2f1233055a142fc4dc4..b6497c52a92c52d4f6ea941b5a0dcfa1ba767917 100644 (file)
--- 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 ac2e52f68eb415e940bd2b10cc8cc9383b37540b..6678613002a18bf85a2f310a480c20ab58d318c5 100644 (file)
--- 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 f7b853cff796911ab36b3655984c3dc4f5cf3218..f1e151b98540c9476e4f81c65ebb00a0ccf89933 100644 (file)
--- 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 bb159f04df985a28c2826e6623cdf5ac2f5ac7f2..1870f4ac1bc5ad5e2a1ed33cddd20601a0c2f99b 100644 (file)
--- 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 8233d8cff367d2fd63ad2dbaa7bd01df88aa61b4..41ce32105da525f70528dc4923e3c4bb4e3faaf6 100644 (file)
--- 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 36d402c61dbec55d849e9b42a50bc566c07c025f..6711c5705e08ba71982b0cdb4f63564fb10bdf28 100644 (file)
--- 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 363c2879e98dbcc43a0c256376d302d91cc7f7b1..c7a3afdd6d64430e9c4f10506e183f9bd4d250fc 100644 (file)
--- 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 cf2c49fff989c22b20796d3ad5e1a0d76ae70a2f..0b5b32e289174a7336a8d64382c104f76af644e4 100644 (file)
--- 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