classes.union: Define a maybe: word that makes a tuple that acts as an anonymous union for a type and f. Updated all the places we define UNION: ?foo foo POSTPONE: f ;. Fixes #416 and lots of headaches.

basis/compiler/tests/redefine26.factor

@@ -0,0 +1,33 @@
+USING: accessors classes.tuple classes.union compiler.units
+kernel math slots tools.test ;
+IN: compiler.tests.redefine26
+
+TUPLE: yoo ;
+TUPLE: hoo ;
+
+UNION: foo integer yoo ;
+
+TUPLE: redefine-test-26 { a maybe: foo } ;
+
+: store-26 ( -- obj ) redefine-test-26 new 26 >>a ;
+: store-26. ( -- obj ) redefine-test-26 new 26. >>a ;
+: store-yoo ( -- obj ) redefine-test-26 new T{ yoo } >>a ;
+: store-hoo ( -- obj ) redefine-test-26 new T{ hoo } >>a ;
+
+[ f ] [ redefine-test-26 new a>> ] unit-test
+[ 26 ] [ store-26 a>> ] unit-test
+[ T{ yoo } ] [ store-yoo a>> ] unit-test
+[ store-26. a>> ] [ bad-slot-value? ] must-fail-with
+[ store-hoo a>> ] [ bad-slot-value? ] must-fail-with
+
+[ ] [
+    [
+        \ foo { integer hoo } define-union-class
+    ] with-compilation-unit
+] unit-test
+
+[ f ] [ redefine-test-26 new a>> ] unit-test
+[ 26 ] [ store-26 a>> ] unit-test
+[ T{ hoo } ] [ store-hoo a>> ] unit-test
+[ store-26. a>> ] [ bad-slot-value? ] must-fail-with
+[ store-yoo a>> ] [ bad-slot-value? ] must-fail-with

basis/compiler/tree/propagation/simple/simple.factor

@@ -5,6 +5,7 @@ words namespaces classes.algebra combinators
 combinators.short-circuit classes classes.tuple
 classes.tuple.private continuations arrays alien.c-types math
 math.private slots generic definitions stack-checker.dependencies
+classes.union classes.algebra.private
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -31,12 +32,20 @@ M: #push propagate-before
 : set-value-infos ( infos values -- )
     [ set-value-info ] 2each ;
 
+GENERIC: depends-on-class ( obj -- )
+
+M: class depends-on-class
+    depends-on-conditionally ;
+
+M: maybe depends-on-class
+    class>> depends-on-class ;
+
 M: #declare propagate-before
     #! We need to force the caller word to recompile when the
     #! classes mentioned in the declaration are redefined, since
     #! now we're making assumptions but their definitions.
     declaration>> [
-        [ depends-on-conditionally ]
+        [ depends-on-class ]
         [ <class-info> swap refine-value-info ]
         bi
     ] assoc-each ;

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -178,7 +178,7 @@ ERROR: bad-partial-eval quot word ;
 
 \ instance? [
     dup class?
-    [ "predicate" word-prop ] [ drop f ] if
+    [ predicate-def ] [ drop f ] if
 ] 1 define-partial-eval
 
 ! Shuffling

basis/hints/hints.factor

@@ -10,7 +10,7 @@ IN: hints
 
 GENERIC: specializer-predicate ( spec -- quot )
 
-M: class specializer-predicate "predicate" word-prop ;
+M: class specializer-predicate predicate-def ;
 
 M: object specializer-predicate '[ _ eq? ] ;
 

basis/inverse/inverse.factor

@@ -244,7 +244,7 @@ DEFER: __
 
 ! Constructor inverse
 : deconstruct-pred ( class -- quot )
-    "predicate" word-prop [ dupd call assure ] curry ;
+    predicate-def [ dupd call assure ] curry ;
 
 : slot-readers ( class -- quot )
     all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;

basis/io/sockets/sockets.factor

@@ -22,8 +22,6 @@ GENERIC# with-port 1 ( addrspec port -- addrspec )
 ! Addressing
 <PRIVATE
 
-UNION: ?string string POSTPONE: f ;
-
 GENERIC: protocol ( addrspec -- n )
 
 GENERIC: protocol-family ( addrspec -- af )
@@ -67,7 +65,7 @@ M: local protocol drop 0 ;
 
 SLOT: port
 
-TUPLE: ipv4 { host ?string read-only } ;
+TUPLE: ipv4 { host maybe: string read-only } ;
 
 <PRIVATE
 
@@ -133,7 +131,7 @@ M: inet4 present
 M: inet4 protocol drop 0 ;
 
 TUPLE: ipv6
-{ host ?string read-only }
+{ host maybe: string read-only }
 { scope-id integer read-only } ;
 
 <PRIVATE
@@ -395,7 +393,7 @@ GENERIC: resolve-host ( addrspec -- seq )
 
 HOOK: resolve-localhost os ( -- obj )
 
-TUPLE: hostname { host ?string read-only } ;
+TUPLE: hostname { host maybe: string read-only } ;
 
 TUPLE: inet < hostname port ;
 

basis/prettyprint/backend/backend.factor

@@ -6,7 +6,8 @@ combinators continuations effects generic hashtables io
 io.pathnames io.styles kernel make math math.order math.parser
 namespaces prettyprint.config prettyprint.custom
 prettyprint.sections prettyprint.stylesheet quotations sbufs
-sequences strings vectors words words.symbol hash-sets ;
+sequences strings vectors words words.symbol hash-sets
+classes.union ;
 FROM: sets => members ;
 IN: prettyprint.backend
 
@@ -243,3 +244,6 @@ M: wrapper pprint*
         { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
         [ pprint-object ]
     } cond ;
+
+M: maybe pprint*
+    <block \ maybe: pprint-word class>> pprint-word block> ;

basis/prettyprint/prettyprint-tests.factor

@@ -4,7 +4,7 @@ prettyprint.sections sequences tools.test vectors words
 effects splitting generic.standard prettyprint.private
 continuations generic compiler.units tools.continuations
 tools.continuations.private eval accessors make vocabs.parser see
-listener ;
+listener classes.union ;
 IN: prettyprint.tests
 
 [ "4" ] [ 4 unparse ] unit-test
@@ -387,3 +387,7 @@ TUPLE: final-tuple ; final
     ] with-variable
 ] unit-test
 
+[ "maybe: integer\n" ] [ [  maybe: integer . ] with-string-writer ] unit-test
+TUPLE: bob a b ;
+[ "maybe: bob\n" ] [ [  maybe: bob . ] with-string-writer ] unit-test
+[ "maybe: word\n" ] [ [  maybe: word . ] with-string-writer ] unit-test

basis/stack-checker/known-words/known-words.factor

@@ -14,7 +14,7 @@ compiler.units system.private combinators tools.memory.private
 combinators.short-circuit locals locals.backend locals.types
 combinators.private stack-checker.values generic.single
 generic.single.private alien.libraries tools.dispatch.private
-macros tools.profiler.sampling.private
+macros tools.profiler.sampling.private classes.algebra
 stack-checker.alien
 stack-checker.state
 stack-checker.errors
@@ -79,7 +79,7 @@ IN: stack-checker.known-words
 } [ "shuffle" set-word-prop ] assoc-each
 
 : check-declaration ( declaration -- declaration )
-    dup { [ array? ] [ [ class? ] all? ] } 1&&
+    dup { [ array? ] [ [ classoid? ] all? ] } 1&&
     [ bad-declaration-error ] unless ;
 
 : infer-declare ( -- )

core/bootstrap/syntax.factor

@@ -85,6 +85,7 @@ IN: bootstrap.syntax
         "<<"
         ">>"
         "call-next-method"
+        "maybe:"
         "initial:"
         "read-only"
         "call("

core/classes/classes.factor

@@ -66,8 +66,20 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     [ name>> "?" append ] [ vocabulary>> ] bi create
     dup predicate? [ dup reset-generic ] unless ;
 
+GENERIC: class-of ( object -- class )
+
+GENERIC: instance? ( object class -- ? ) flushable
+
+GENERIC: predicate-def ( obj -- quot )
+
+M: word predicate-def
+    "predicate" word-prop ;
+
+M: object predicate-def
+    [ instance? ] curry ;
+
 : predicate-word ( word -- predicate )
-    "predicate" word-prop first ;
+    predicate-def first ;
 
 M: predicate flushable? drop t ;
 
@@ -196,7 +208,7 @@ GENERIC: update-methods ( class seq -- )
     make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
 
 : forget-predicate ( class -- )
-    dup "predicate" word-prop
+    dup predicate-def
     dup length 1 = [
         first
         [ nip ] [ "predicating" word-prop = ] 2bi
@@ -223,7 +235,3 @@ M: class metaclass-changed
 
 M: class forget* ( class -- )
     [ call-next-method ] [ forget-class ] bi ;
-
-GENERIC: class-of ( object -- class )
-
-GENERIC: instance? ( object class -- ? ) flushable

core/classes/intersection/intersection.factor

@@ -14,8 +14,8 @@ PREDICATE: intersection-class < class
     [
         [ drop t ]
     ] [
-        unclip "predicate" word-prop swap [
+        unclip predicate-def swap [
-            "predicate" word-prop [ dup ] [ not ] surround
+            predicate-def [ dup ] [ not ] surround
             [ drop f ]
         ] { } map>assoc alist>quot
     ] if-empty ;

core/classes/predicate/predicate.factor

@@ -15,7 +15,7 @@ GENERIC: predicate-quot ( class -- quot )
 M: predicate-class predicate-quot
     [
         \ dup ,
-        [ superclass "predicate" word-prop % ]
+        [ superclass predicate-def % ]
         [ "predicate-definition" word-prop , ] bi
         [ drop f ] , \ if ,
     ] [ ] make ;

core/classes/singleton/singleton.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes classes.algebra classes.algebra.private
 classes.predicate classes.predicate.private kernel sequences
-words ;
+words vocabs.parser accessors ;
 IN: classes.singleton
 
 <PRIVATE
@@ -25,4 +25,4 @@ M: singleton-class (classes-intersect?)
     over singleton-class? [ eq? ] [ call-next-method ] if ;
 
 M: singleton-class predicate-quot
-    singleton-predicate-quot ;
+    singleton-predicate-quot ;

core/classes/union/union-tests.factor

@@ -4,7 +4,7 @@ sequences strings tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
 classes.algebra classes.union.private source-files
 compiler.units kernel.private sorting vocabs io.streams.string
-eval see math.private ;
+eval see math.private slots ;
 IN: classes.union.tests
 
 ! DEFER: bah
@@ -107,3 +107,44 @@ M: a-union test-generic ;
 [ ] [ "IN: classes.union.tests USE: vectors UNION: fast-union-1 vector ;" eval( -- ) ] unit-test
 
 [ f ] [ "fast-union-2?" "classes.union.tests" lookup-word def>> \ fixnum-bitand swap member? ] unit-test
+
+! Test maybe
+
+[ t ] [ 3 maybe: integer instance? ] unit-test
+[ t ] [ f maybe: integer instance? ] unit-test
+[ f ] [ 3.0 maybe: integer instance? ] unit-test
+
+TUPLE: maybe-integer-container { something maybe: integer } ;
+
+[ f ] [ maybe-integer-container new something>> ] unit-test
+[ 3 ] [ maybe-integer-container new 3 >>something something>> ] unit-test
+[ maybe-integer-container new 3.0 >>something ] [ bad-slot-value? ] must-fail-with
+
+TUPLE: self-pointer { next maybe: self-pointer } ;
+
+[ T{ self-pointer { next T{ self-pointer } } } ]
+[ self-pointer new self-pointer new >>next ] unit-test
+
+[ t ] [ f maybe: f instance? ] unit-test
+
+PREDICATE: natural < maybe: integer
+    0 > ;
+
+[ f ] [ -1 natural? ] unit-test
+[ f ] [ 0 natural? ] unit-test
+[ t ] [ 1 natural? ] unit-test
+
+[ "USE: math maybe: maybe: integer" eval( -- obj ) ] [ error>> bad-slot-value? ] must-fail-with
+
+INTERSECTION: only-f maybe: integer POSTPONE: f ;
+
+[ t ] [ f only-f instance? ] unit-test
+[ f ] [ t only-f instance? ] unit-test
+[ f ] [ 30 only-f instance? ] unit-test
+
+UNION: ?integer-float maybe: integer maybe: float ;
+
+[ t ] [ 30 ?integer-float instance? ] unit-test
+[ t ] [ 30.0 ?integer-float instance? ] unit-test
+[ t ] [ f ?integer-float instance? ] unit-test
+[ f ] [ t ?integer-float instance? ] unit-test

core/classes/union/union.factor

@@ -3,12 +3,31 @@
 USING: words sequences kernel assocs combinators classes
 classes.private classes.algebra classes.algebra.private
 classes.builtin kernel.private math.private namespaces arrays
-math quotations definitions ;
+math quotations definitions accessors parser effects ;
 IN: classes.union
 
 PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
+TUPLE: maybe { class word initial: object read-only } ;
+
+C: <maybe> maybe
+
+M: maybe instance?
+    over [ class>> instance? ] [ 2drop t ] if ;
+
+M: maybe normalize-class
+    class>> \ f class-or ;
+
+M: maybe classoid? drop t ;
+
+M: maybe rank-class drop 6 ;
+
+M: maybe (flatten-class)
+    class>> (flatten-class) ;
+
+M: maybe effect>type ;
+
 <PRIVATE
 
 GENERIC: union-of-builtins? ( class -- ? )
@@ -18,6 +37,9 @@ M: builtin-class union-of-builtins? drop t ;
 M: union-class union-of-builtins?
     members [ union-of-builtins? ] all? ;
 
+M: maybe union-of-builtins?
+    class>> union-of-builtins? ;
+
 M: class union-of-builtins?
     drop f ;
 
@@ -35,7 +57,7 @@ M: class union-of-builtins?
     surround ;
 
 : slow-union-predicate-quot ( class -- quot )
-    members [ "predicate" word-prop ] map unclip swap
+    members [ predicate-def ] map unclip swap
     [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
 
 : union-predicate-quot ( class -- quot )
@@ -66,8 +88,12 @@ M: union-class rank-class drop 7 ;
 M: union-class instance?
     "members" word-prop [ instance? ] with any? ;
 
+M: anonymous-union instance?
+    members>> [ instance? ] with any? ;
+
 M: union-class normalize-class
     members <anonymous-union> normalize-class ;
 
 M: union-class (flatten-class)
     members <anonymous-union> (flatten-class) ;
+

core/effects/parser/parser.factor

@@ -25,12 +25,7 @@ SYMBOL: effect-var
     [ invalid-row-variable ] if ;
 
 : parse-effect-value ( token -- value )
-    ":" ?tail [
+    ":" ?tail [ scan-object 2array ] when ;
-        scan-token {
-            { [ dup "(" = ] [ drop ")" parse-effect ] }
-            [ parse-word dup class? [ bad-effect ] unless ]
-        } cond 2array
-    ] when ;
 PRIVATE>
 
 : parse-effect-token ( first? var end -- var more? )

core/generic/generic.factor

@@ -3,7 +3,7 @@
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
 classes.algebra quotations arrays vocabs effects combinators
-sets ;
+sets classes.union ;
 FROM: namespaces => set ;
 IN: generic
 
@@ -91,8 +91,8 @@ ERROR: no-next-method method ;
 
 TUPLE: check-method class generic ;
 
-: check-method ( class generic -- class generic )
+: check-method ( classoid generic -- class generic )
-    2dup [ class? ] [ generic? ] bi* and [
+    2dup [ classoid? ] [ generic? ] bi* and [
         \ check-method boa throw
     ] unless ; inline
 
@@ -107,7 +107,12 @@ GENERIC: update-generic ( class generic -- )
 : with-methods ( class generic quot -- )
     [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
 
-: method-word-name ( class generic -- string )
+GENERIC# method-word-name 1 ( class generic -- string )
+
+M: maybe method-word-name
+    [ class>> name>> ] [ name>> ] bi* "=>" glue ;
+
+M: class method-word-name ( class generic -- string )
     [ name>> ] bi@ "=>" glue ;
 
 M: method parent-word

core/generic/parser/parser.factor

@@ -18,7 +18,7 @@ ERROR: not-in-a-method-error ;
     [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
 
 : scan-new-method ( -- method )
-    scan-word bootstrap-word scan-word create-method-in ;
+    scan-class bootstrap-word scan-word create-method-in ;
 
 SYMBOL: current-method
 
@@ -55,4 +55,3 @@ PRIVATE>
 
 : (M:) ( -- method def )
     scan-new-method [ parse-method-definition ] with-method-definition ;
-

core/generic/single/single.factor

@@ -37,7 +37,7 @@ M: single-combination next-method-quot* ( class generic combination -- quot )
     [
         2dup next-method dup [
             [
-                pick "predicate" word-prop %
+                pick predicate-def %
                 1quotation ,
                 [ inconsistent-next-method ] 2curry ,
                 \ if ,
@@ -217,7 +217,7 @@ ERROR: unreachable ;
     } cond ;
 
 : class-predicates ( assoc -- assoc )
-    [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
+    [ [ predicate-def [ dup ] prepend ] dip ] assoc-map ;
 
 : <predicate-engine-word> ( -- word )
     generic-word get name>> "/predicate-engine" append f <word>

core/parser/parser.factor

@@ -5,7 +5,7 @@ sequences strings vectors words words.symbol quotations io
 combinators sorting splitting math.parser effects continuations
 io.files vocabs io.encodings.utf8 source-files classes
 hashtables compiler.units accessors sets lexer vocabs.parser
-slots parser.notes ;
+slots parser.notes classes.algebra ;
 IN: parser
 
 : location ( -- loc )
@@ -100,6 +100,12 @@ ERROR: staging-violation word ;
         V{ } clone swap execute-parsing first
     ] when ;
 
+ERROR: classoid-expected word ;
+
+: scan-class ( -- class )
+    scan-object \ f or
+    dup classoid? [ classoid-expected ] unless ;
+
 : parse-step ( accum end -- accum ? )
     (scan-datum) {
         { [ 2dup eq? ] [ 2drop f ] }

core/slots/slots.factor

@@ -3,7 +3,8 @@
 USING: arrays byte-arrays kernel kernel.private math namespaces
 make sequences strings effects generic generic.standard
 classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables ;
+words sequences.private assocs alien quotations hashtables
+classes.union ;
 IN: slots
 
 TUPLE: slot-spec name offset class initial read-only ;
@@ -64,22 +65,24 @@ M: object reader-quot
 
 ERROR: bad-slot-value value class ;
 
-: (instance-check-quot) ( class -- quot )
+GENERIC: instance-check-quot ( obj -- quot )
-    [
-        \ dup ,
-        [ "predicate" word-prop % ]
-        [ [ bad-slot-value ] curry , ] bi
-        \ unless ,
-    ] [ ] make ;
 
-: instance-check-quot ( class -- quot )
+M: class instance-check-quot ( class -- quot )
     {
         { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
         { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
         { [ dup integer bootstrap-word eq? ] [ drop [ >integer ] ] }
-        [ (instance-check-quot) ]
+        [ call-next-method ]
     } cond ;
 
+M: object instance-check-quot
+    [
+        \ dup ,
+        [ predicate-def % ]
+        [ [ bad-slot-value ] curry , ] bi
+        \ unless ,
+    ] [ ] make ;
+
 GENERIC# writer-quot 1 ( class slot-spec -- quot )
 
 M: object writer-quot
@@ -154,6 +157,7 @@ M: class initial-value* drop f f ;
 
 : initial-value ( class -- object ? )
     {
+        { [ dup maybe? ] [ f t ] }
         { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
         { [ \ f bootstrap-word over class<= ] [ f t ] }
         { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
@@ -180,7 +184,7 @@ M: string make-slot
 
 : peel-off-class ( slot-spec array -- slot-spec array )
     dup empty? [
-        dup first class? [
+        dup first classoid? [
             [ first init-slot-class ]
             [ rest ]
             bi

core/syntax/syntax.factor

@@ -190,7 +190,7 @@ IN: bootstrap.syntax
     "PREDICATE:" [
         scan-new-class
         "<" expect
-        scan-word
+        scan-class
         parse-definition define-predicate-class
     ] define-core-syntax
 
@@ -248,6 +248,10 @@ IN: bootstrap.syntax
             not-in-a-method-error
         ] if*
     ] define-core-syntax
+
+    "maybe:" [
+        scan-class <maybe> suffix!
+    ] define-core-syntax
     
     "initial:" "syntax" lookup-word define-symbol
 

extra/cuda/ptx/ptx.factor

@@ -5,8 +5,6 @@ FROM: roles => TUPLE: ;
 IN: cuda.ptx
 
 UNION: dim integer sequence ;
-UNION: ?integer POSTPONE: f integer ;
-UNION: ?string POSTPONE: f string ;
 
 VARIANT: ptx-type
     .s8 .s16 .s32 .s64
@@ -21,27 +19,24 @@ VARIANT: ptx-type
 
 VARIANT: ptx-arch
     sm_10 sm_11 sm_12 sm_13 sm_20 ;
-UNION: ?ptx-arch POSTPONE: f ptx-arch ;
 
 VARIANT: ptx-texmode
     .texmode_unified .texmode_independent ;
-UNION: ?ptx-texmode POSTPONE: f ptx-texmode ;
 
 VARIANT: ptx-storage-space
     .reg
     .sreg
-    .const: { { bank ?integer } }
+    .const: { { bank maybe: integer } }
     .global
     .local
     .param
     .shared
     .tex ;
-UNION: ?ptx-storage-space POSTPONE: f ptx-storage-space ;
 
 TUPLE: ptx-target
-    { arch ?ptx-arch }
+    { arch maybe: ptx-arch }
     { map_f64_to_f32? boolean }
-    { texmode ?ptx-texmode } ;
+    { texmode maybe: ptx-texmode } ;
 
 TUPLE: ptx
     { version string }
@@ -55,14 +50,13 @@ TUPLE: ptx-struct-definition
 TUPLE: ptx-variable
     { extern? boolean }
     { visible? boolean }
-    { align ?integer }
+    { align maybe: integer }
     { storage-space ptx-storage-space }
     { type ptx-type }
     { name string }
-    { parameter ?integer }
+    { parameter maybe: integer }
     { dim dim }
-    { initializer ?string } ;
+    { initializer maybe: string } ;
-UNION: ?ptx-variable POSTPONE: f ptx-variable ;
 
 TUPLE: ptx-negation
     { var string } ; 
@@ -83,11 +77,10 @@ TUPLE: ptx-indirect
 
 UNION: ptx-operand
     integer float ptx-var ptx-negation ptx-vector ptx-indirect ;
-UNION: ?ptx-operand POSTPONE: f ptx-operand ;
 
 TUPLE: ptx-instruction
-    { label ?string }
+    { label maybe: string }
-    { predicate ?ptx-operand } ;
+    { predicate maybe: ptx-operand } ;
 
 TUPLE: ptx-entry
     { name string }
@@ -96,7 +89,7 @@ TUPLE: ptx-entry
     body ;
 
 TUPLE: ptx-func < ptx-entry
-    { return ?ptx-variable } ;
+    { return maybe: ptx-variable } ;
 
 TUPLE: ptx-directive ;
 
@@ -119,12 +112,9 @@ VARIANT: ptx-float-rounding-mode
     .rn .rz .rm .rp .approx .full ;
 VARIANT: ptx-int-rounding-mode
     .rni .rzi .rmi .rpi ;
-UNION: ?ptx-float-rounding-mode POSTPONE: f ptx-float-rounding-mode ;
-UNION: ?ptx-int-rounding-mode POSTPONE: f ptx-int-rounding-mode ;
 
 UNION: ptx-rounding-mode
     ptx-float-rounding-mode ptx-int-rounding-mode ;
-UNION: ?ptx-rounding-mode POSTPONE: f ptx-rounding-mode ;
 
 TUPLE: ptx-typed-instruction < ptx-instruction
     { type ptx-type }
@@ -154,23 +144,21 @@ TUPLE: ptx-addsub-instruction < ptx-3op-instruction
 
 VARIANT: ptx-mul-mode
     .wide ;
-UNION: ?ptx-mul-mode POSTPONE: f ptx-mul-mode ;
 
 TUPLE: ptx-mul-instruction < ptx-3op-instruction
-    { mode ?ptx-mul-mode } ;
+    { mode maybe: ptx-mul-mode } ;
 
 TUPLE: ptx-mad-instruction < ptx-4op-instruction
-    { mode ?ptx-mul-mode }
+    { mode maybe: ptx-mul-mode }
     { sat? boolean } ;
 
 VARIANT: ptx-prmt-mode
     .f4e .b4e .rc8 .ecl .ecr .rc16 ;
-UNION: ?ptx-prmt-mode POSTPONE: f ptx-prmt-mode ;
 
 ROLE: ptx-float-ftz
     { ftz? boolean } ;
 ROLE: ptx-float-env < ptx-float-ftz
-    { round ?ptx-float-rounding-mode } ;
+    { round maybe: ptx-float-rounding-mode } ;
 
 VARIANT: ptx-testp-op
     .finite .infinite .number .notanumber .normal .subnormal ;
@@ -186,7 +174,6 @@ VARIANT: ptx-cmp-op
 VARIANT: ptx-op
     .and .or .xor .cas .exch .add .inc .dec .min .max
     .popc ;
-UNION: ?ptx-op POSTPONE: f ptx-op ;
 
 SINGLETONS: .lo .hi ;
 INSTANCE: .lo ptx-mul-mode
@@ -196,19 +183,18 @@ INSTANCE: .hi ptx-cmp-op
 
 TUPLE: ptx-set-instruction < ptx-3op-instruction
     { cmp-op ptx-cmp-op }
-    { bool-op ?ptx-op }
+    { bool-op maybe: ptx-op }
-    { c ?ptx-operand }
+    { c maybe: ptx-operand }
     { ftz? boolean } ;
 
 VARIANT: ptx-cache-op
     .ca .cg .cs .lu .cv
     .wb .wt ;
-UNION: ?ptx-cache-op POSTPONE: f ptx-cache-op ;
 
 TUPLE: ptx-ldst-instruction < ptx-2op-instruction
     { volatile? boolean }
-    { storage-space ?ptx-storage-space }
+    { storage-space maybe: ptx-storage-space }
-    { cache-op ?ptx-cache-op } ;
+    { cache-op maybe: ptx-cache-op } ;
 
 VARIANT: ptx-cache-level
     .L1 .L2 ;
@@ -230,19 +216,19 @@ TUPLE: add       <{ ptx-addsub-instruction ptx-float-env } ;
 TUPLE: addc      < ptx-addsub-instruction ;
 TUPLE: and       < ptx-3op-instruction ;
 TUPLE: atom      < ptx-3op-instruction
-    { storage-space ?ptx-storage-space }
+    { storage-space maybe: ptx-storage-space }
     { op ptx-op }
-    { c ?ptx-operand } ;
+    { c maybe: ptx-operand } ;
 TUPLE: bar.arrive < ptx-instruction
     { a ptx-operand }
     { b ptx-operand } ;
 TUPLE: bar.red   < ptx-2op-instruction
     { op ptx-op }
-    { b ?ptx-operand }
+    { b maybe: ptx-operand }
     { c ptx-operand } ;
 TUPLE: bar.sync  < ptx-instruction
     { a ptx-operand }
-    { b ?ptx-operand } ;
+    { b maybe: ptx-operand } ;
 TUPLE: bfe       < ptx-4op-instruction ;
 TUPLE: bfi       < ptx-5op-instruction ;
 TUPLE: bfind     < ptx-2op-instruction
@@ -251,20 +237,20 @@ TUPLE: bra       < ptx-branch-instruction ;
 TUPLE: brev      < ptx-2op-instruction ;
 TUPLE: brkpt     < ptx-instruction ;
 TUPLE: call      < ptx-branch-instruction
-    { return ?ptx-operand }
+    { return maybe: ptx-operand }
     params ;
 TUPLE: clz       < ptx-2op-instruction ;
 TUPLE: cnot      < ptx-2op-instruction ;
 TUPLE: copysign  < ptx-3op-instruction ;
 TUPLE: cos       <{ ptx-2op-instruction ptx-float-env } ;
 TUPLE: cvt       < ptx-2op-instruction
-    { round ?ptx-rounding-mode }
+    { round maybe: ptx-rounding-mode }
     { ftz? boolean }
     { sat? boolean }
     { dest-type ptx-type } ;
 TUPLE: cvta      < ptx-2op-instruction
     { to? boolean }
-    { storage-space ?ptx-storage-space } ;
+    { storage-space maybe: ptx-storage-space } ;
 TUPLE: div       <{ ptx-3op-instruction ptx-float-env } ;
 TUPLE: ex2       <{ ptx-2op-instruction ptx-float-env } ;
 TUPLE: exit      < ptx-instruction ;
@@ -293,16 +279,16 @@ TUPLE: pmevent   < ptx-instruction
 TUPLE: popc      < ptx-2op-instruction ;
 TUPLE: prefetch  < ptx-instruction
     { a ptx-operand }
-    { storage-space ?ptx-storage-space }
+    { storage-space maybe: ptx-storage-space }
     { level ptx-cache-level } ;
 TUPLE: prefetchu < ptx-instruction
     { a ptx-operand }
     { level ptx-cache-level } ;
 TUPLE: prmt      < ptx-4op-instruction
-    { mode ?ptx-prmt-mode } ;
+    { mode maybe: ptx-prmt-mode } ;
 TUPLE: rcp       <{ ptx-2op-instruction ptx-float-env } ;
 TUPLE: red       < ptx-2op-instruction
-    { storage-space ?ptx-storage-space }
+    { storage-space maybe: ptx-storage-space }
     { op ptx-op } ;
 TUPLE: rem       < ptx-3op-instruction ;
 TUPLE: ret       < ptx-instruction ;
@@ -312,7 +298,7 @@ TUPLE: selp      < ptx-4op-instruction ;
 TUPLE: set       < ptx-set-instruction
     { dest-type ptx-type } ;
 TUPLE: setp      < ptx-set-instruction
-    { |dest ?ptx-operand } ;
+    { |dest maybe: ptx-operand } ;
 TUPLE: shl       < ptx-3op-instruction ;
 TUPLE: shr       < ptx-3op-instruction ;
 TUPLE: sin       <{ ptx-2op-instruction ptx-float-env } ;

extra/gpu/framebuffers/framebuffers.factor

@@ -81,7 +81,6 @@ UNION: texture-attachment
 M: texture-attachment dispose texture>> dispose ;
 
 UNION: framebuffer-attachment renderbuffer texture-attachment ;
-UNION: ?framebuffer-attachment framebuffer-attachment POSTPONE: f ;
 
 GENERIC: attachment-object ( attachment -- object )
 M: renderbuffer attachment-object ;
@@ -89,8 +88,8 @@ M: texture-attachment attachment-object texture>> texture-object ;
 
 TUPLE: framebuffer < gpu-object
     { color-attachments array read-only }
-    { depth-attachment ?framebuffer-attachment read-only initial: f }
+    { depth-attachment maybe: framebuffer-attachment read-only initial: f }
-    { stencil-attachment ?framebuffer-attachment read-only initial: f } ;
+    { stencil-attachment maybe: framebuffer-attachment read-only initial: f } ;
 
 UNION: any-framebuffer system-framebuffer framebuffer ;
 
@@ -100,14 +99,11 @@ VARIANT: framebuffer-attachment-side
 VARIANT: framebuffer-attachment-face
     back-face front-face ;
 
-UNION: ?framebuffer-attachment-side framebuffer-attachment-side POSTPONE: f ;
-UNION: ?framebuffer-attachment-face framebuffer-attachment-face POSTPONE: f ;
-
 VARIANT: color-attachment-ref
     default-attachment
     system-attachment: {
-        { side ?framebuffer-attachment-side initial: f }
+        { side maybe: framebuffer-attachment-side initial: f }
-        { face ?framebuffer-attachment-face initial: back-face }
+        { face maybe: framebuffer-attachment-face initial: back-face }
     }
     color-attachment: { { index integer } } ;
 

extra/gpu/render/render.factor

@@ -14,8 +14,6 @@ QUALIFIED-WITH: alien.c-types c
 SPECIALIZED-ARRAYS: c:float c:int c:uchar c:ushort c:uint c:void* ;
 IN: gpu.render
 
-UNION: ?integer integer POSTPONE: f ;
-
 VARIANT: uniform-type
     bool-uniform
     bvec2-uniform
@@ -55,7 +53,7 @@ ALIAS: mat4x4-uniform mat4-uniform
 TUPLE: uniform
     { name         string   read-only initial: "" }
     { uniform-type class    read-only initial: float-uniform }
-    { dim          ?integer read-only initial: f } ;
+    { dim          maybe: integer read-only initial: f } ;
 
 VARIANT: index-type
     ubyte-indexes
@@ -81,10 +79,8 @@ TUPLE: index-elements
 
 C: <index-elements> index-elements
 
-UNION: ?buffer buffer POSTPONE: f ;
-
 TUPLE: multi-index-elements
-    { buffer ?buffer read-only }
+    { buffer maybe: buffer read-only }
     { ptrs   read-only }
     { counts uint-array read-only }
     { index-type index-type read-only } ;
@@ -584,7 +580,6 @@ M: buffer-ptr bind-transform-feedback-output
 
 PRIVATE>
 
-UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
 UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
 
 TUPLE: render-set
@@ -592,8 +587,8 @@ TUPLE: render-set
     { vertex-array vertex-array initial: T{ vertex-array-collection } read-only }
     { uniforms uniform-tuple read-only }
     { indexes vertex-indexes initial: T{ index-range } read-only } 
-    { instances ?integer initial: f read-only }
+    { instances maybe: integer initial: f read-only }
-    { framebuffer ?any-framebuffer initial: system-framebuffer read-only }
+    { framebuffer maybe: any-framebuffer initial: system-framebuffer read-only }
     { output-attachments sequence initial: { default-attachment } read-only }
     { transform-feedback-output transform-feedback-output initial: f read-only } ;
 

extra/gpu/shaders/shaders.factor

@@ -28,20 +28,17 @@ VARIANT: geometry-shader-output
     line-strips-output
     triangle-strips-output ;
 
-UNION: ?string string POSTPONE: f ;
-
 ERROR: too-many-feedback-formats-error formats ;
 ERROR: invalid-link-feedback-format-error format ;
 ERROR: inaccurate-feedback-attribute-error attribute ;
 
 TUPLE: vertex-attribute
-    { name            ?string        read-only initial: f }
+    { name            maybe: string  read-only initial: f }
     { component-type  component-type read-only initial: float-components }
     { dim             integer        read-only initial: 4 }
     { normalize?      boolean        read-only initial: f } ;
 
 MIXIN: vertex-format
-UNION: ?vertex-format vertex-format POSTPONE: f ;
 
 TUPLE: shader
     { name word read-only initial: t }
@@ -57,7 +54,7 @@ TUPLE: program
     { line integer read-only }
     { shaders array read-only }
     { vertex-formats array read-only }
-    { feedback-format ?vertex-format read-only }
+    { feedback-format maybe: vertex-format read-only }
     { geometry-shader-parameters array read-only }
     { instances hashtable read-only } ;
 
@@ -527,7 +524,7 @@ DEFER: <shader-instance>
     [ nip ] [ drop link-program ] if ;
 
 TUPLE: feedback-format
-    { vertex-format ?vertex-format read-only } ;
+    { vertex-format maybe: vertex-format read-only } ;
 
 : validate-feedback-format ( sequence -- vertex-format/f )
     dup length 1 <=

extra/gpu/state/state.factor

@@ -8,22 +8,19 @@ SPECIALIZED-ARRAY: c:int
 SPECIALIZED-ARRAY: c:float
 IN: gpu.state
 
-UNION: ?rect rect POSTPONE: f ;
-UNION: ?float float POSTPONE: f ;
-
 TUPLE: viewport-state
     { rect rect read-only } ;
 C: <viewport-state> viewport-state
 
 TUPLE: scissor-state
-    { rect ?rect read-only } ;
+    { rect maybe: rect read-only } ;
 C: <scissor-state> scissor-state
 
 TUPLE: multisample-state
     { multisample? boolean read-only }
     { sample-alpha-to-coverage? boolean read-only }
     { sample-alpha-to-one? boolean read-only }
-    { sample-coverage ?float read-only }
+    { sample-coverage maybe: float read-only }
     { invert-sample-coverage? boolean read-only } ;
 C: <multisample-state> multisample-state
 
@@ -37,8 +34,6 @@ VARIANT: stencil-op
     op-inc-sat op-dec-sat
     op-inc-wrap op-dec-wrap ;
 
-UNION: ?comparison comparison POSTPONE: f ;
-
 TUPLE: stencil-mode
     { value integer initial: 0 read-only }
     { mask integer initial: HEX: FFFFFFFF read-only }
@@ -48,11 +43,9 @@ TUPLE: stencil-mode
     { depth-pass-op stencil-op initial: op-keep read-only } ;
 C: <stencil-mode> stencil-mode
 
-UNION: ?stencil-mode stencil-mode POSTPONE: f ;
-
 TUPLE: stencil-state
-    { front-mode ?stencil-mode initial: f read-only }
+    { front-mode maybe: stencil-mode initial: f read-only }
-    { back-mode ?stencil-mode initial: f read-only } ;
+    { back-mode maybe: stencil-mode initial: f read-only } ;
 C: <stencil-state> stencil-state
 
 TUPLE: depth-range-state
@@ -61,7 +54,7 @@ TUPLE: depth-range-state
 C: <depth-range-state> depth-range-state
 
 TUPLE: depth-state
-    { comparison ?comparison initial: f read-only } ;
+    { comparison maybe: comparison initial: f read-only } ;
 C: <depth-state> depth-state
 
 VARIANT: blend-equation
@@ -86,12 +79,10 @@ TUPLE: blend-mode
     { dest-function blend-function initial: func-one-minus-source-alpha read-only } ;
 C: <blend-mode> blend-mode
 
-UNION: ?blend-mode blend-mode POSTPONE: f ;
-
 TUPLE: blend-state
     { constant-color sequence initial: f read-only }
-    { rgb-mode ?blend-mode read-only }
+    { rgb-mode maybe: blend-mode read-only }
-    { alpha-mode ?blend-mode read-only } ;
+    { alpha-mode maybe: blend-mode read-only } ;
 C: <blend-state> blend-state
 
 TUPLE: mask-state
@@ -108,11 +99,9 @@ VARIANT: triangle-cull
 VARIANT: triangle-mode
     triangle-points triangle-lines triangle-fill ;
 
-UNION: ?triangle-cull triangle-cull POSTPONE: f ;
-    
 TUPLE: triangle-cull-state
     { front-face triangle-face initial: face-ccw read-only }
-    { cull ?triangle-cull initial: f read-only } ;
+    { cull maybe: triangle-cull initial: f read-only } ;
 C: <triangle-cull-state> triangle-cull-state
 
 TUPLE: triangle-state
@@ -125,7 +114,7 @@ VARIANT: point-sprite-origin
     origin-upper-left origin-lower-left ;
 
 TUPLE: point-state
-    { size ?float initial: 1.0 read-only }
+    { size maybe: float initial: 1.0 read-only }
     { sprite-origin point-sprite-origin initial: origin-upper-left read-only }
     { fade-threshold float initial: 1.0 read-only } ;
 C: <point-state> point-state

extra/gpu/textures/textures.factor

@@ -46,8 +46,6 @@ TUPLE: texture-data
     { component-type component-type read-only initial: ubyte-components } ;
 
 C: <texture-data> texture-data
-UNION: ?texture-data texture-data POSTPONE: f ;
-UNION: ?float-array float-array POSTPONE: f ;
 
 VARIANT: compressed-texture-format
     DXT1-RGB DXT1-RGBA DXT3 DXT5
@@ -60,7 +58,6 @@ TUPLE: compressed-texture-data
     { length integer read-only } ;
 
 C: <compressed-texture-data> compressed-texture-data
-UNION: ?compressed-texture-data compressed-texture-data POSTPONE: f ;
 
 VARIANT: texture-wrap
     clamp-texcoord-to-edge clamp-texcoord-to-border repeat-texcoord repeat-texcoord-mirrored ;
@@ -68,12 +65,11 @@ VARIANT: texture-filter
     filter-nearest filter-linear ;
 
 UNION: wrap-set texture-wrap sequence ;
-UNION: ?texture-filter texture-filter POSTPONE: f ;
 
 TUPLE: texture-parameters
     { wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
     { min-filter texture-filter initial: filter-nearest }
-    { min-mipmap-filter ?texture-filter initial: filter-linear }
+    { min-mipmap-filter maybe: texture-filter initial: filter-linear }
     { mag-filter texture-filter initial: filter-linear }
     { min-lod integer initial: -1000 }
     { max-lod integer initial:  1000 }

extra/multi-methods/multi-methods.factor

@@ -109,7 +109,7 @@ SYMBOL: total
     } case ;
 
 : (multi-predicate) ( class picker -- quot )
-    swap "predicate" word-prop append ;
+    swap predicate-quot append ;
 
 : multi-predicate ( classes -- quot )
     dup length iota <reversed>