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

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
 [ ] [

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

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" ;

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! ;

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

core/bootstrap/syntax.factor

@@ -49,6 +49,7 @@ IN: bootstrap.syntax
         "SYMBOLS:"
         "CONSTANT:"
         "TUPLE:"
+        "final"
         "SLOT:"
         "T{"
         "UNION:"

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 ;

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

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 ;
 

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