From 067f9830ef3b259e9c8cbd2a6ced66b7d3f298e1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 21 Nov 2011 23:00:52 -0800 Subject: [PATCH] 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 | 33 +++++++++ .../tree/propagation/simple/simple.factor | 11 ++- .../propagation/transforms/transforms.factor | 2 +- basis/hints/hints.factor | 2 +- basis/inverse/inverse.factor | 2 +- basis/io/sockets/sockets.factor | 8 +-- basis/prettyprint/backend/backend.factor | 6 +- basis/prettyprint/prettyprint-tests.factor | 6 +- .../known-words/known-words.factor | 4 +- core/bootstrap/syntax.factor | 1 + core/classes/classes.factor | 20 ++++-- core/classes/intersection/intersection.factor | 4 +- core/classes/predicate/predicate.factor | 2 +- core/classes/singleton/singleton.factor | 4 +- core/classes/union/union-tests.factor | 43 +++++++++++- core/classes/union/union.factor | 30 +++++++- core/effects/parser/parser.factor | 7 +- core/generic/generic.factor | 13 ++-- core/generic/parser/parser.factor | 3 +- core/generic/single/single.factor | 4 +- core/parser/parser.factor | 8 ++- core/slots/slots.factor | 26 ++++--- core/syntax/syntax.factor | 6 +- extra/cuda/ptx/ptx.factor | 68 ++++++++----------- extra/gpu/framebuffers/framebuffers.factor | 12 ++-- extra/gpu/render/render.factor | 13 ++-- extra/gpu/shaders/shaders.factor | 9 +-- extra/gpu/state/state.factor | 29 +++----- extra/gpu/textures/textures.factor | 6 +- extra/multi-methods/multi-methods.factor | 2 +- 30 files changed, 240 insertions(+), 144 deletions(-) create mode 100644 basis/compiler/tests/redefine26.factor diff --git a/basis/compiler/tests/redefine26.factor b/basis/compiler/tests/redefine26.factor new file mode 100644 index 0000000000..9aa94b3a9c --- /dev/null +++ b/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 diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index d6fcc9cca4..d60cf50495 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/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 ] [ swap refine-value-info ] bi ] assoc-each ; diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 02fef39675..d1a5fa9a1f 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/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 diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 413922b71f..a75b018f25 100644 --- a/basis/hints/hints.factor +++ b/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? ] ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index aa970f4f4f..1f72abffcf 100644 --- a/basis/inverse/inverse.factor +++ b/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 ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 96c55889f9..fbae33a9f2 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -22,8 +22,6 @@ GENERIC# with-port 1 ( addrspec port -- addrspec ) ! Addressing members ; IN: prettyprint.backend @@ -243,3 +244,6 @@ M: wrapper pprint* { [ dup wrapped>> word? ] [ > pprint-word block> ] } [ pprint-object ] } cond ; + +M: maybe pprint* + > pprint-word block> ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index a9e39db8bb..7353cccb43 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/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 diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 4c94b9aec4..43885afc3f 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/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 ( -- ) diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a0ed21808f..8e9acd1507 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -85,6 +85,7 @@ IN: bootstrap.syntax "<<" ">>" "call-next-method" + "maybe:" "initial:" "read-only" "call(" diff --git a/core/classes/classes.factor b/core/classes/classes.factor index dd86586142..db49b97246 100644 --- a/core/classes/classes.factor +++ b/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 diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 3f0e581fd3..0ed4f4b636 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -14,8 +14,8 @@ PREDICATE: intersection-class < class [ [ drop t ] ] [ - unclip "predicate" word-prop swap [ - "predicate" word-prop [ dup ] [ not ] surround + unclip predicate-def swap [ + predicate-def [ dup ] [ not ] surround [ drop f ] ] { } map>assoc alist>quot ] if-empty ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index f387defcb8..5005a46878 100644 --- a/core/classes/predicate/predicate.factor +++ b/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 ; diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index 02ca405145..2ef42fd7e7 100644 --- a/core/classes/singleton/singleton.factor +++ b/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 > \ 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 diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index bee1e4c271..fc70ae06f7 100644 --- a/core/classes/union/union.factor +++ b/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 + +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 ; + > 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 normalize-class ; M: union-class (flatten-class) members (flatten-class) ; + diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 5b46cd516e..ea378b68c7 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -25,12 +25,7 @@ SYMBOL: effect-var [ invalid-row-variable ] if ; : parse-effect-value ( token -- value ) - ":" ?tail [ - scan-token { - { [ dup "(" = ] [ drop ")" parse-effect ] } - [ parse-word dup class? [ bad-effect ] unless ] - } cond 2array - ] when ; + ":" ?tail [ scan-object 2array ] when ; PRIVATE> : parse-effect-token ( first? var end -- var more? ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 03fb1115de..6bbba70882 100644 --- a/core/generic/generic.factor +++ b/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 ) - 2dup [ class? ] [ generic? ] bi* and [ +: check-method ( classoid generic -- class generic ) + 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 diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor index d12e3669c2..f1c709d112 100644 --- a/core/generic/parser/parser.factor +++ b/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 ; - diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index e1908bf09f..82d373c524 100644 --- a/core/generic/single/single.factor +++ b/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 ; : ( -- word ) generic-word get name>> "/predicate-engine" append f diff --git a/core/parser/parser.factor b/core/parser/parser.factor index f402d84941..0c72198fe6 100644 --- a/core/parser/parser.factor +++ b/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 ] } diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 26c7788933..adb0db5582 100644 --- a/core/slots/slots.factor +++ b/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 ) - [ - \ dup , - [ "predicate" word-prop % ] - [ [ bad-slot-value ] curry , ] bi - \ unless , - ] [ ] make ; +GENERIC: instance-check-quot ( obj -- quot ) -: 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 diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 6ed0a3330d..5efd0d8014 100644 --- a/core/syntax/syntax.factor +++ b/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 suffix! + ] define-core-syntax "initial:" "syntax" lookup-word define-symbol diff --git a/extra/cuda/ptx/ptx.factor b/extra/cuda/ptx/ptx.factor index 49a53d7fbf..6b6d27a793 100644 --- a/extra/cuda/ptx/ptx.factor +++ b/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 } ; -UNION: ?ptx-variable POSTPONE: f ptx-variable ; + { initializer maybe: string } ; 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 } - { predicate ?ptx-operand } ; + { label maybe: string } + { 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 } - { c ?ptx-operand } + { bool-op maybe: ptx-op } + { 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 } - { cache-op ?ptx-cache-op } ; + { storage-space maybe: ptx-storage-space } + { 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 } ; diff --git a/extra/gpu/framebuffers/framebuffers.factor b/extra/gpu/framebuffers/framebuffers.factor index 76f46e4fa7..b49db8c8b2 100644 --- a/extra/gpu/framebuffers/framebuffers.factor +++ b/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 } - { stencil-attachment ?framebuffer-attachment read-only initial: f } ; + { depth-attachment maybe: 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 } - { face ?framebuffer-attachment-face initial: back-face } + { side maybe: framebuffer-attachment-side initial: f } + { face maybe: framebuffer-attachment-face initial: back-face } } color-attachment: { { index integer } } ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index defede8a1e..116ef10274 100755 --- a/extra/gpu/render/render.factor +++ b/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 -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 } - { framebuffer ?any-framebuffer initial: system-framebuffer read-only } + { instances maybe: integer initial: f 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 } ; diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index 8302547b39..b68866145b 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/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: [ 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 <= diff --git a/extra/gpu/state/state.factor b/extra/gpu/state/state.factor index 3230787492..d92a04d308 100755 --- a/extra/gpu/state/state.factor +++ b/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 TUPLE: scissor-state - { rect ?rect read-only } ; + { rect maybe: rect read-only } ; C: 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 @@ -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 -UNION: ?stencil-mode stencil-mode POSTPONE: f ; - TUPLE: stencil-state - { front-mode ?stencil-mode initial: f read-only } - { back-mode ?stencil-mode initial: f read-only } ; + { front-mode maybe: stencil-mode initial: f read-only } + { back-mode maybe: stencil-mode initial: f read-only } ; C: stencil-state TUPLE: depth-range-state @@ -61,7 +54,7 @@ TUPLE: depth-range-state C: depth-range-state TUPLE: depth-state - { comparison ?comparison initial: f read-only } ; + { comparison maybe: comparison initial: f read-only } ; C: 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 -UNION: ?blend-mode blend-mode POSTPONE: f ; - TUPLE: blend-state { constant-color sequence initial: f read-only } - { rgb-mode ?blend-mode read-only } - { alpha-mode ?blend-mode read-only } ; + { rgb-mode maybe: blend-mode read-only } + { alpha-mode maybe: blend-mode read-only } ; C: 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 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 diff --git a/extra/gpu/textures/textures.factor b/extra/gpu/textures/textures.factor index 55e6f7c0f4..5752e4bcf5 100644 --- a/extra/gpu/textures/textures.factor +++ b/extra/gpu/textures/textures.factor @@ -46,8 +46,6 @@ TUPLE: texture-data { component-type component-type read-only initial: ubyte-components } ; C: 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 -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 } diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 921c316376..46511191ce 100644 --- a/extra/multi-methods/multi-methods.factor +++ b/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