Change PREDICATE: syntax

core/alien/alien.factor

@@ -7,7 +7,7 @@ IN: alien
 
 ! Some predicate classes used by the compiler for optimization
 ! purposes
-PREDICATE: alien simple-alien
+PREDICATE: simple-alien < alien
     underlying-alien not ;
 
 UNION: simple-c-ptr
@@ -18,7 +18,7 @@ alien POSTPONE: f byte-array bit-array float-array ;
 
 DEFER: pinned-c-ptr?
 
-PREDICATE: alien pinned-alien
+PREDICATE: pinned-alien < alien
     underlying-alien pinned-c-ptr? ;
 
 UNION: pinned-c-ptr

core/arrays/arrays.factor

@@ -31,4 +31,4 @@ INSTANCE: array sequence
 
 : 4array ( w x y z -- array ) { } 4sequence ; flushable
 
-PREDICATE: array pair length 2 number= ;
+PREDICATE: pair < array length 2 number= ;

core/classes/algebra/algebra-docs.factor

@@ -39,15 +39,15 @@ HELP: sort-classes
 { $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
 
 HELP: class-or
-{ $values { "class1" class } { "class2" class } { "class" class } }
+{ $values { "first" class } { "second" class } { "class" class } }
 { $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
 
 HELP: class-and
-{ $values { "class1" class } { "class2" class } { "class" class } }
+{ $values { "first" class } { "second" class } { "class" class } }
 { $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
 
 HELP: classes-intersect?
-{ $values { "class1" class } { "class2" class } { "?" "a boolean" } }
+{ $values { "first" class } { "second" class } { "?" "a boolean" } }
 { $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
 
 HELP: min-class

core/classes/algebra/algebra-tests.factor

@@ -51,7 +51,7 @@ UNION: both first-one union-class ;
 [ f ] [ \ reversed \ slice class< ] unit-test
 [ f ] [ \ slice \ reversed class< ] unit-test
 
-PREDICATE: word no-docs "documentation" word-prop not ;
+PREDICATE: no-docs < word "documentation" word-prop not ;
 
 UNION: no-docs-union no-docs integer ;
 

core/classes/classes-tests.factor

@@ -28,7 +28,7 @@ M: union-1 generic-update-test drop "union-1" ;
 [ f ] [ union-1 number class< ] unit-test
 [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
 
-"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
+"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
 
 [ f ] [ union-1 union-class? ] unit-test
 [ t ] [ union-1 predicate-class? ] unit-test

core/classes/classes.factor

@@ -25,15 +25,15 @@ SYMBOL: class-or-cache
     class-and-cache get clear-assoc
     class-or-cache get clear-assoc ;
 
-PREDICATE: word class ( obj -- ? ) "class" word-prop ;
+PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
 
 SYMBOL: update-map
 SYMBOL: builtins
 
-PREDICATE: class builtin-class
+PREDICATE: builtin-class < class
     "metaclass" word-prop builtin-class eq? ;
 
-PREDICATE: class tuple-class
+PREDICATE: tuple-class < class
     "metaclass" word-prop tuple-class eq? ;
 
 : classes ( -- seq ) all-words [ class? ] subset ;
@@ -47,7 +47,7 @@ PREDICATE: class tuple-class
 
 : predicate-effect 1 { "?" } <effect> ;
 
-PREDICATE: word predicate "predicating" word-prop >boolean ;
+PREDICATE: predicate < word "predicating" word-prop >boolean ;
 
 : define-predicate ( class quot -- )
     >r "predicate" word-prop first

core/classes/mixin/mixin.factor

@@ -4,7 +4,7 @@ USING: classes classes.union words kernel sequences
 definitions combinators arrays ;
 IN: classes.mixin
 
-PREDICATE: union-class mixin-class "mixin" word-prop ;
+PREDICATE: mixin-class < union-class "mixin" word-prop ;
 
 M: mixin-class reset-class
     { "metaclass" "members" "mixin" } reset-props ;

core/classes/predicate/predicate-docs.factor

@@ -14,7 +14,7 @@ ARTICLE: "predicates" "Predicate classes"
 ABOUT: "predicates"
 
 HELP: define-predicate-class
-{ $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
+{ $values { "class" class } { "superclass" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
 { $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." }
 { $notes "This word must be called from inside " { $link with-compilation-unit } "." }
 { $side-effects "class" } ;

core/classes/predicate/predicate.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes kernel namespaces words ;
 IN: classes.predicate
 
-PREDICATE: class predicate-class
+PREDICATE: predicate-class < class
     "metaclass" word-prop predicate-class eq? ;
 
 : predicate-quot ( class -- quot )
@@ -13,8 +13,8 @@ PREDICATE: class predicate-class
         "predicate-definition" word-prop , [ drop f ] , \ if ,
     ] [ ] make ;
 
-: define-predicate-class ( superclass class definition -- )
-    >r dup f roll predicate-class define-class r>
+: define-predicate-class ( class superclass definition -- )
+    >r >r dup f r> predicate-class define-class r>
     dupd "predicate-definition" set-word-prop
     dup predicate-quot define-predicate ;
 

core/classes/union/union.factor

@@ -4,7 +4,7 @@ USING: words sequences kernel assocs combinators classes
 generic.standard namespaces arrays math quotations ;
 IN: classes.union
 
-PREDICATE: class union-class
+PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
 ! Union classes for dispatch on multiple classes.

core/cpu/architecture/architecture.factor

@@ -153,11 +153,11 @@ M: f v>operand drop \ f tag-number ;
 
 M: object load-literal v>operand load-indirect ;
 
-PREDICATE: integer small-slot cells small-enough? ;
+PREDICATE: small-slot < integer cells small-enough? ;
 
-PREDICATE: integer small-tagged v>operand small-enough? ;
+PREDICATE: small-tagged < integer v>operand small-enough? ;
 
-PREDICATE: integer inline-array 32 < ;
+PREDICATE: inline-array < integer 32 < ;
 
 : if-small-struct ( n size true false -- ? )
     >r >r over not over struct-small-enough? and

core/cpu/arm/assembler/assembler.factor

@@ -27,7 +27,7 @@ SYMBOL: R15
 { R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
 define-registers
 
-PREDICATE: word register register >boolean ;
+PREDICATE: register < word register >boolean ;
 
 GENERIC: register ( register -- n )
 M: word register "register" word-prop ;

core/cpu/x86/32/32.factor

@@ -8,7 +8,7 @@ alien.compiler combinators command-line
 compiler compiler.units io vocabs.loader accessors ;
 IN: cpu.x86.32
 
-PREDICATE: x86-backend x86-32-backend
+PREDICATE: x86-32-backend < x86-backend
     x86-backend-cell 4 = ;
 
 ! We implement the FFI for Linux, OS X and Windows all at once.

core/cpu/x86/64/64.factor

@@ -8,7 +8,7 @@ layouts alien alien.accessors alien.compiler alien.structs slots
 splitting assocs ;
 IN: cpu.x86.64
 
-PREDICATE: x86-backend amd64-backend
+PREDICATE: amd64-backend < x86-backend
     x86-backend-cell 8 = ;
 
 M: amd64-backend ds-reg R14 ;

core/cpu/x86/assembler/assembler.factor

@@ -52,13 +52,23 @@ GENERIC: extended? ( op -- ? )
 
 M: object extended? drop f ;
 
-PREDICATE: word register "register" word-prop ;
+PREDICATE: register < word
+    "register" word-prop ;
 
-PREDICATE: register register-8 "register-size" word-prop 8 = ;
-PREDICATE: register register-16 "register-size" word-prop 16 = ;
-PREDICATE: register register-32 "register-size" word-prop 32 = ;
-PREDICATE: register register-64 "register-size" word-prop 64 = ;
-PREDICATE: register register-128 "register-size" word-prop 128 = ;
+PREDICATE: register-8 < register
+    "register-size" word-prop 8 = ;
+
+PREDICATE: register-16 < register
+    "register-size" word-prop 16 = ;
+
+PREDICATE: register-32 < register
+    "register-size" word-prop 32 = ;
+
+PREDICATE: register-64 < register
+    "register-size" word-prop 64 = ;
+
+PREDICATE: register-128 < register
+    "register-size" word-prop 128 = ;
 
 M: register extended? "register" word-prop 7 > ;
 
@@ -285,7 +295,7 @@ GENERIC: (MOV-I) ( src dst -- )
 M: register (MOV-I) t HEX: b8 short-operand cell, ;
 M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
 
-PREDICATE: word callable register? not ;
+PREDICATE: callable < word register? not ;
 
 GENERIC: MOV ( dst src -- )
 M: integer MOV swap (MOV-I) ;

core/debugger/debugger.factor

@@ -156,7 +156,7 @@ M: relative-overflow summary
 : primitive-error.
     "Unimplemented primitive" print drop ;
 
-PREDICATE: array kernel-error ( obj -- ? )
+PREDICATE: kernel-error < array
     {
         { [ dup empty? ] [ drop f ] }
         { [ dup first "kernel-error" = not ] [ drop f ] }

core/generic/generic-tests.factor

@@ -44,7 +44,7 @@ M: object funny drop 0 ;
 [ 2 ] [ [ { } ] funny ] unit-test
 [ 0 ] [ { } funny ] unit-test
 
-PREDICATE: funnies very-funny number? ;
+PREDICATE: very-funny < funnies number? ;
 
 GENERIC: gooey ( x -- y )
 M: very-funny gooey sq ;

core/generic/generic.factor

@@ -19,7 +19,8 @@ M: object perform-combination
 
 GENERIC: make-default-method ( generic combination -- method )
 
-PREDICATE: word generic "combination" word-prop >boolean ;
+PREDICATE: generic < word
+    "combination" word-prop >boolean ;
 
 M: generic definition drop f ;
 
@@ -30,7 +31,7 @@ M: generic definition drop f ;
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
-PREDICATE: pair method-spec
+PREDICATE: method-spec < pair
     first2 generic? swap class? and ;
 
 : order ( generic -- seq )
@@ -55,7 +56,7 @@ TUPLE: check-method class generic ;
 : method-word-name ( class word -- string )
     word-name "/" rot word-name 3append ;
 
-PREDICATE: word method-body
+PREDICATE: method-body < word
     "method-generic" word-prop >boolean ;
 
 M: method-body stack-effect

core/generic/math/math.factor

@@ -5,7 +5,7 @@ math namespaces sequences words quotations layouts combinators
 sequences.private classes classes.algebra definitions ;
 IN: generic.math
 
-PREDICATE: class math-class ( object -- ? )
+PREDICATE: math-class < class
     dup null bootstrap-word eq? [
         drop f
     ] [
@@ -79,7 +79,7 @@ M: math-combination perform-combination
         ] if nip
     ] math-vtable nip ;
 
-PREDICATE: generic math-generic ( word -- ? )
+PREDICATE: math-generic < generic ( word -- ? )
     "combination" word-prop math-combination? ;
 
 M: math-generic definer drop \ MATH: f ;

core/generic/standard/standard.factor

@@ -174,13 +174,13 @@ M: hook-combination perform-combination
 : define-simple-generic ( word -- )
     T{ standard-combination f 0 } define-generic ;
 
-PREDICATE: generic standard-generic
+PREDICATE: standard-generic < generic
     "combination" word-prop standard-combination? ;
 
-PREDICATE: standard-generic simple-generic
+PREDICATE: simple-generic < standard-generic
     "combination" word-prop standard-combination-# zero? ;
 
-PREDICATE: generic hook-generic
+PREDICATE: hook-generic < generic
     "combination" word-prop hook-combination? ;
 
 GENERIC: dispatch# ( word -- n )

core/inference/dataflow/dataflow.factor

@@ -102,7 +102,7 @@ TUPLE: #label word loop? ;
 : #label ( word label -- node )
     \ #label param-node [ set-#label-word ] keep ;
 
-PREDICATE: #label #loop #label-loop? ;
+PREDICATE: #loop < #label #label-loop? ;
 
 TUPLE: #entry ;
 
@@ -309,9 +309,9 @@ SYMBOL: node-stack
 
 DEFER: #tail?
 
-PREDICATE: #merge #tail-merge node-successor #tail? ;
+PREDICATE: #tail-merge < #merge node-successor #tail? ;
 
-PREDICATE: #values #tail-values node-successor #tail? ;
+PREDICATE: #tail-values < #values node-successor #tail? ;
 
 UNION: #tail
     POSTPONE: f #return #tail-values #tail-merge #terminate ;

core/parser/parser-tests.factor

@@ -389,7 +389,7 @@ IN: parser.tests
 ] with-scope
 
 [ ] [
-    "IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
+    "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
 ] unit-test
 
 [ t ] [

core/parser/parser.factor

@@ -214,7 +214,7 @@ SYMBOL: in
 
 ERROR: unexpected want got ;
 
-PREDICATE: unexpected unexpected-eof
+PREDICATE: unexpected-eof < unexpected
     unexpected-got not ;
 
 : unexpected-eof ( word -- * ) f unexpected ;

core/prettyprint/prettyprint-tests.factor

@@ -329,3 +329,9 @@ M: f generic-see-test-with-f ;
 [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
     [ \ f \ generic-see-test-with-f method see ] with-string-writer
 ] unit-test
+
+PREDICATE: predicate-see-test < integer even? ;
+
+[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
+    [ \ predicate-see-test see ] with-string-writer
+] unit-test

core/prettyprint/prettyprint.factor

@@ -247,8 +247,9 @@ M: mixin-class see-class*
 
 M: predicate-class see-class*
     <colon \ PREDICATE: pprint-word
-    dup superclass pprint-word
     dup pprint-word
+    "<" text
+    dup superclass pprint-word
     <block
     "predicate-definition" word-prop pprint-elements
     pprint-; block> block> ;

core/sequences/sequences.factor

@@ -60,7 +60,7 @@ INSTANCE: immutable-sequence sequence
     #! A bit of a pain; can't call cell-bits here
     7 getenv 8 * 5 - 2^ 1- ; foldable
 
-PREDICATE: fixnum array-capacity
+PREDICATE: array-capacity < fixnum
     0 max-array-capacity between? ;
 
 : array-capacity ( array -- n )

core/slots/deprecated/deprecated.factor

@@ -8,7 +8,7 @@ IN: slots.deprecated
 : reader-effect ( class spec -- effect )
     >r ?word-name 1array r> slot-spec-name 1array <effect> ;
 
-PREDICATE: word slot-reader "reading" word-prop >boolean ;
+PREDICATE: slot-reader < word "reading" word-prop >boolean ;
 
 : set-reader-props ( class spec -- )
     2dup reader-effect
@@ -30,7 +30,7 @@ PREDICATE: word slot-reader "reading" word-prop >boolean ;
 : writer-effect ( class spec -- effect )
     slot-spec-name swap ?word-name 2array 0 <effect> ;
 
-PREDICATE: word slot-writer "writing" word-prop >boolean ;
+PREDICATE: slot-writer < word "writing" word-prop >boolean ;
 
 : set-writer-props ( class spec -- )
     2dup writer-effect

core/syntax/syntax-docs.factor

@@ -543,8 +543,8 @@ HELP: INSTANCE:
 { $description "Makes " { $snippet "instance" } " an instance of " { $snippet "mixin" } "." } ;
 
 HELP: PREDICATE:
-{ $syntax "PREDICATE: superclass class predicate... ;" }
-{ $values { "superclass" "an existing class word" } { "class" "a new class word to define" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } }
+{ $syntax "PREDICATE: class < superclass predicate... ;" }
+{ $values { "class" "a new class word to define" } { "superclass" "an existing class word" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } }
 { $description
     "Defines a predicate class deriving from " { $snippet "superclass" } "."
     $nl
@@ -557,11 +557,9 @@ HELP: PREDICATE:
 } ;
 
 HELP: TUPLE:
-{ $syntax "TUPLE: class slots... ;" }
+{ $syntax "TUPLE: class slots... ;" "TUPLE: class < superclass slots ... ;" }
 { $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
-{ $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." } ;
+{ $description "Defines a new tuple class. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ;
 
 HELP: ERROR:
 { $syntax "ERROR: class slots... ;" }

core/syntax/syntax.factor

@@ -6,7 +6,7 @@ namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting tuples generic.standard
 generic.math classes io.files vocabs float-arrays float-vectors
 classes.union classes.mixin classes.predicate compiler.units
-combinators ;
+combinators debugger ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -148,8 +148,9 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "PREDICATE:" [
-        scan-word
         CREATE-CLASS
+        scan "<" assert=
+        scan-word
         parse-definition define-predicate-class
     ] define-syntax
 

core/tuples/tuples-docs.factor

@@ -165,7 +165,7 @@ HELP: reshape-tuples
 { $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
 { $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
 
-HELP: old-slots
+HELP: removed-slots
 { $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
 { $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
 
@@ -190,8 +190,8 @@ HELP: define-tuple-predicate
 { $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
 $low-level-note ;
 
-HELP: check-shape
-{ $values { "class" class } { "newslots" "a sequence of strings" } }
+HELP: redefine-tuple-class
+{ $values { "class" class } { "superclass" class } { "newslots" "a sequence of strings" } }
 { $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
 $nl
 "If the class is not a tuple class word, this word does nothing." }
@@ -214,8 +214,8 @@ HELP: check-tuple
 { $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
 
 HELP: define-tuple-class
-{ $values { "class" word } { "slots" "a sequence of strings" } }
-{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
+{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } }
+{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
 { $notes "This word must be called from inside " { $link with-compilation-unit } "." }
 { $side-effects "class" } ;
 

core/tuples/tuples-tests.factor

@@ -2,7 +2,8 @@ USING: definitions generic kernel kernel.private math
 math.constants parser sequences tools.test words assocs
 namespaces quotations sequences.private classes continuations
 generic.standard effects tuples tuples.private arrays vectors
-strings compiler.units accessors ;
+strings compiler.units accessors classes.algebra calendar
+prettyprint io.streams.string ;
 IN: tuples.tests
 
 TUPLE: rect x y w h ;
@@ -83,7 +84,7 @@ C: <predicate-test> predicate-test
 
 [ t ] [ <predicate-test> predicate-test? ] unit-test
 
-PREDICATE: tuple silly-pred
+PREDICATE: silly-pred < tuple
     class \ rect = ;
 
 GENERIC: area
@@ -243,6 +244,58 @@ C: <erg's-reshape-problem> erg's-reshape-problem
     "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
 ] [ [ no-tuple-class? ] is? ] must-fail-with
 
+! Inheritance
+TUPLE: computer cpu ram ;
+
+[ "IN: tuples.tests TUPLE: computer cpu ram ;\n" ] [
+    [ \ computer see ] with-string-writer
+] unit-test
+
+TUPLE: laptop < computer battery ;
+C: <laptop> laptop
+
+[ t ] [ laptop tuple-class? ] unit-test
+[ t ] [ laptop tuple class< ] unit-test
+[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop computer classes-intersect? ] unit-test
+
+[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
+[ t ] [ "laptop" get laptop? ] unit-test
+[ t ] [ "laptop" get computer? ] unit-test
+[ t ] [ "laptop" get tuple? ] unit-test
+
+[ "IN: tuples.tests TUPLE: laptop < computer battery ;\n" ] [
+    [ \ laptop see ] with-string-writer
+] unit-test
+
+TUPLE: server < computer rackmount? ;
+C: <server> server
+
+[ t ] [ server tuple-class? ] unit-test
+[ t ] [ server tuple class< ] unit-test
+[ t ] [ server computer class< ] unit-test
+[ t ] [ server computer classes-intersect? ] unit-test
+
+[ ] [ "Pentium" 128 "1U" <server> "server" set ] unit-test
+[ t ] [ "server" get server? ] unit-test
+[ t ] [ "server" get computer? ] unit-test
+[ t ] [ "server" get tuple? ] unit-test
+
+[ f ] [ "server" get laptop? ] unit-test
+[ f ] [ "laptop" get server? ] unit-test
+
+[ f ] [ server laptop class< ] unit-test
+[ f ] [ laptop server class< ] unit-test
+[ f ] [ laptop server classes-intersect? ] unit-test
+
+[ "IN: tuples.tests TUPLE: server < computer rackmount ;\n" ] [
+    [ \ server see ] with-string-writer
+] unit-test
+
+[
+    "IN: tuples.tests TUPLE: bad-superclass < word ;" eval
+] must-fail
+
 ! Hardcore unit tests
 USE: threads
 
@@ -250,14 +303,14 @@ USE: threads
 
 [ ] [
     [
-        \ thread { "xxx" } "slot-names" get append
+        \ thread tuple { "xxx" } "slot-names" get append
         define-tuple-class
     ] with-compilation-unit
 
     [ 1337 sleep ] "Test" spawn drop
 
     [
-        \ thread "slot-names" get
+        \ thread tuple "slot-names" get
         define-tuple-class
     ] with-compilation-unit
 ] unit-test
@@ -268,14 +321,14 @@ USE: vocabs
 
 [ ] [
     [
-        \ vocab { "xxx" } "slot-names" get append
+        \ vocab tuple { "xxx" } "slot-names" get append
         define-tuple-class
     ] with-compilation-unit
 
     all-words drop
 
     [
-        \ vocab "slot-names" get
+        \ vocab tuple "slot-names" get
         define-tuple-class
     ] with-compilation-unit
 ] unit-test

core/tuples/tuples.factor

@@ -110,8 +110,11 @@ M: tuple-class tuple-layout "layout" word-prop ;
     dup define-tuple-layout
     define-tuple-predicate ;
 
+: change-superclass "not supported" throw ;
+
 : redefine-tuple-class ( class superclass slots -- )
-    nip
+    >r 2dup swap superclass eq?
+    [ drop ] [ dupd change-superclass ] if r>
     2dup forget-slots
     2dup reshape-tuples
     over changed-word
@@ -119,8 +122,7 @@ M: tuple-class tuple-layout "layout" word-prop ;
     prepare-tuple-class ;
 
 : define-new-tuple-class ( class superclass slots -- )
-    nip
-    over f tuple tuple-class define-class
+    >r dupd f swap tuple-class define-class r>
     prepare-tuple-class ;
 
 PRIVATE>

core/words/words.factor

@@ -23,17 +23,17 @@ M: word definition word-def ;
 
 ERROR: undefined ;
 
-PREDICATE: word deferred ( obj -- ? )
+PREDICATE: deferred < word ( obj -- ? )
     word-def [ undefined ] = ;
 M: deferred definer drop \ DEFER: f ;
 M: deferred definition drop f ;
 
-PREDICATE: word symbol ( obj -- ? )
+PREDICATE: symbol < word ( obj -- ? )
     dup <wrapper> 1array swap word-def sequence= ;
 M: symbol definer drop \ SYMBOL: f ;
 M: symbol definition drop f ;
 
-PREDICATE: word primitive ( obj -- ? )
+PREDICATE: primitive < word ( obj -- ? )
     word-def [ do-primitive ] tail? ;
 M: primitive definer drop \ PRIMITIVE: f ;
 M: primitive definition drop f ;

extra/delegate/delegate.factor

@@ -10,7 +10,7 @@ IN: delegate
     CREATE-WORD dup define-symbol
     parse-definition swap define-protocol ; parsing
 
-PREDICATE: word protocol "protocol-words" word-prop ;
+PREDICATE: protocol < word "protocol-words" word-prop ;
 
 GENERIC: group-words ( group -- words )
 

extra/help/markup/markup.factor

@@ -14,7 +14,7 @@ IN: help.markup
 
 ! Element types are words whose name begins with $.
 
-PREDICATE: array simple-element
+PREDICATE: simple-element < array
     dup empty? [ drop t ] [ first word? not ] if ;
 
 SYMBOL: last-element

extra/help/topics/topics.factor

@@ -16,7 +16,7 @@ M: link >link ;
 M: vocab-spec >link ;
 M: object >link link construct-boa ;
 
-PREDICATE: link word-link link-name word? ;
+PREDICATE: word-link < link link-name word? ;
 
 M: link summary
     [

extra/inverse/inverse.factor

@@ -54,9 +54,9 @@ M: no-inverse summary
 : undo-literal ( object -- quot )
     [ =/fail ] curry ;
 
-PREDICATE: word normal-inverse "inverse" word-prop ;
-PREDICATE: word math-inverse "math-inverse" word-prop ;
-PREDICATE: word pop-inverse "pop-length" word-prop ;
+PREDICATE: normal-inverse < word "inverse" word-prop ;
+PREDICATE: math-inverse < word "math-inverse" word-prop ;
+PREDICATE: pop-inverse < word "pop-length" word-prop ;
 UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
 
 : inline-word ( word -- )

extra/io/nonblocking/nonblocking.factor

@@ -22,8 +22,8 @@ M: port set-timeout set-port-timeout ;
 
 SYMBOL: closed
 
-PREDICATE: port input-port port-type input-port eq? ;
-PREDICATE: port output-port port-type output-port eq? ;
+PREDICATE: input-port < port port-type input-port eq? ;
+PREDICATE: output-port < port port-type output-port eq? ;
 
 GENERIC: init-handle ( handle -- )
 GENERIC: close-handle ( handle -- )

extra/locals/locals.factor

@@ -29,23 +29,23 @@ TUPLE: wlet bindings body ;
 
 C: <wlet> wlet
 
-PREDICATE: word local "local?" word-prop ;
+PREDICATE: local < word "local?" word-prop ;
 
 : <local> ( name -- word )
     #! Create a local variable identifier
     f <word> dup t "local?" set-word-prop ;
 
-PREDICATE: word local-word "local-word?" word-prop ;
+PREDICATE: local-word < word "local-word?" word-prop ;
 
 : <local-word> ( name -- word )
     f <word> dup t "local-word?" set-word-prop ;
 
-PREDICATE: word local-reader "local-reader?" word-prop ;
+PREDICATE: local-reader < word "local-reader?" word-prop ;
 
 : <local-reader> ( name -- word )
     f <word> dup t "local-reader?" set-word-prop ;
 
-PREDICATE: word local-writer "local-writer?" word-prop ;
+PREDICATE: local-writer < word "local-writer?" word-prop ;
 
 : <local-writer> ( reader -- word )
     dup word-name "!" append f <word>
@@ -357,7 +357,7 @@ M: wlet pprint* \ [wlet pprint-let ;
 
 M: let* pprint* \ [let* pprint-let ;
 
-PREDICATE: word lambda-word
+PREDICATE: lambda-word < word
     "lambda" word-prop >boolean ;
 
 M: lambda-word definer drop \ :: \ ; ;
@@ -373,7 +373,7 @@ M: lambda-word definition
 
 M: lambda-word synopsis* lambda-word-synopsis ;
 
-PREDICATE: macro lambda-macro
+PREDICATE: lambda-macro < macro
     "lambda" word-prop >boolean ;
 
 M: lambda-macro definer drop \ MACRO:: \ ; ;
@@ -383,7 +383,7 @@ M: lambda-macro definition
 
 M: lambda-macro synopsis* lambda-word-synopsis ;
 
-PREDICATE: method-body lambda-method
+PREDICATE: lambda-method < method-body
     "lambda" word-prop >boolean ;
 
 M: lambda-method definer drop \ M:: \ ; ;

extra/macros/macros.factor

@@ -17,7 +17,7 @@ IN: macros
 : MACRO:
     (:) define-macro ; parsing
 
-PREDICATE: word macro "macro" word-prop >boolean ;
+PREDICATE: macro < word "macro" word-prop >boolean ;
 
 M: macro definer drop \ MACRO: \ ; ;
 

extra/memoize/memoize.factor

@@ -42,7 +42,7 @@ IN: memoize
 : MEMO:
     CREATE-WORD parse-definition define-memoized ; parsing
 
-PREDICATE: word memoized "memoize" word-prop ;
+PREDICATE: memoized < word "memoize" word-prop ;
 
 M: memoized definer drop \ MEMO: \ ; ;
 M: memoized definition "memo-quot" word-prop ;

extra/multi-methods/multi-methods.factor

@@ -64,7 +64,8 @@ GENERIC: method-prologue ( combination -- quot )
 
 TUPLE: method word def classes generic loc ;
 
-PREDICATE: word method-body "multi-method" word-prop >boolean ;
+PREDICATE: method-body < word
+    "multi-method" word-prop >boolean ;
 
 M: method-body stack-effect
     "multi-method" word-prop method-generic stack-effect ;
@@ -209,13 +210,13 @@ M: hook-combination generic-prologue
 USE: qualified
 QUALIFIED: syntax
 
-PREDICATE: word generic
+PREDICATE: generic < word
     "multi-combination" word-prop >boolean ;
 
-PREDICATE: word standard-generic
+PREDICATE: standard-generic < word
     "multi-combination" word-prop standard-combination? ;
 
-PREDICATE: word hook-generic
+PREDICATE: hook-generic < word
     "multi-combination" word-prop hook-combination? ;
 
 syntax:M: standard-generic definer drop \ GENERIC: f ;
@@ -233,7 +234,7 @@ syntax:M: hook-generic synopsis*
     dup "multi-combination" word-prop
     hook-combination-var pprint-word stack-effect. ;
 
-PREDICATE: array method-spec
+PREDICATE: method-spec < array
     unclip generic? >r [ class? ] all? r> and ;
 
 syntax:M: method-spec where

extra/opengl/shaders/shaders.factor

@@ -55,9 +55,9 @@ IN: opengl.shaders
 
 : delete-gl-shader ( shader -- ) glDeleteShader ; inline
 
-PREDICATE: integer gl-shader (gl-shader?) ;
-PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
-PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
+PREDICATE: gl-shader < integer (gl-shader?) ;
+PREDICATE: vertex-shader < gl-shader (vertex-shader?) ;
+PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
 
 ! Programs
 
@@ -126,7 +126,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
 MACRO: with-gl-program ( uniforms quot -- )
     (make-with-gl-program) ;
 
-PREDICATE: integer gl-program (gl-program?) ;
+PREDICATE: gl-program < integer (gl-program?) ;
 
 : <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
     >r <vertex-shader> check-gl-shader

extra/singleton/singleton.factor

@@ -5,8 +5,9 @@ sequences words ;
 IN: singleton
 
 : define-singleton ( token -- )
-    \ word swap create-class-in
-    dup [ eq? ] curry define-predicate-class ;
+    create-class-in
+    \ word
+    over [ eq? ] curry define-predicate-class ;
 
 : SINGLETON:
     scan define-singleton ; parsing

extra/ui/commands/commands.factor

@@ -9,7 +9,7 @@ SYMBOL: +nullary+
 SYMBOL: +listener+
 SYMBOL: +description+
 
-PREDICATE: word listener-command +listener+ word-prop ;
+PREDICATE: listener-command < word +listener+ word-prop ;
 
 GENERIC: invoke-command ( target command -- )
 

extra/ui/operations/operations.factor

@@ -19,7 +19,7 @@ TUPLE: operation predicate command translator hook listener? ;
         set-operation-hook
     } operation construct ;
 
-PREDICATE: operation listener-operation
+PREDICATE: listener-operation < operation
     dup operation-command listener-command?
     swap operation-listener? or ;
 

extra/unicode/syntax/syntax.factor

@@ -35,7 +35,7 @@ IN: unicode.syntax
     ] [ ] make ;
 
 : define-category ( word categories -- )
-    [category] fixnum -rot define-predicate-class ;
+    [category] integer swap define-predicate-class ;
 
 : CATEGORY:
     CREATE ";" parse-tokens define-category ; parsing

extra/xml-rpc/xml-rpc.factor

@@ -17,7 +17,7 @@ M: integer item>xml
     [ "Integers must fit in 32 bits" throw ] unless
     number>string "i4" build-tag ;
 
-PREDICATE: object boolean { t f } member? ;
+PREDICATE: boolean < object { t f } member? ;
 
 M: boolean item>xml
     "1" "0" ? "boolean" build-tag ;

extra/xml/data/data.factor

@@ -139,5 +139,5 @@ M: xml like
 : <contained-tag> ( name attrs -- tag )
     f <tag> ;
 
-PREDICATE: tag contained-tag tag-children not ;
-PREDICATE: tag open-tag tag-children ;
+PREDICATE: contained-tag < tag tag-children not ;
+PREDICATE: open-tag < tag tag-children ;