--- /dev/null
+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
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
: 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 ;
\ instance? [
dup class?
- [ "predicate" word-prop ] [ drop f ] if
+ [ predicate-def ] [ drop f ] if
] 1 define-partial-eval
! Shuffling
GENERIC: specializer-predicate ( spec -- quot )
-M: class specializer-predicate "predicate" word-prop ;
+M: class specializer-predicate predicate-def ;
M: object specializer-predicate '[ _ eq? ] ;
! 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 ;
! Addressing
<PRIVATE
-UNION: ?string string POSTPONE: f ;
-
GENERIC: protocol ( addrspec -- n )
GENERIC: protocol-family ( addrspec -- af )
SLOT: port
-TUPLE: ipv4 { host ?string read-only } ;
+TUPLE: ipv4 { host maybe: string read-only } ;
<PRIVATE
M: inet4 protocol drop 0 ;
TUPLE: ipv6
-{ host ?string read-only }
+{ host maybe: string read-only }
{ scope-id integer read-only } ;
<PRIVATE
HOOK: resolve-localhost os ( -- obj )
-TUPLE: hostname { host ?string read-only } ;
+TUPLE: hostname { host maybe: string read-only } ;
TUPLE: inet < hostname port ;
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
{ [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
[ pprint-object ]
} cond ;
+
+M: maybe pprint*
+ <block \ maybe: pprint-word class>> pprint-word block> ;
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
] 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
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
} [ "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 ( -- )
"<<"
">>"
"call-next-method"
+ "maybe:"
"initial:"
"read-only"
"call("
[ 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 ;
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
M: class forget* ( class -- )
[ call-next-method ] [ forget-class ] bi ;
-
-GENERIC: class-of ( object -- class )
-
-GENERIC: instance? ( object class -- ? ) flushable
[
[ 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 ;
M: predicate-class predicate-quot
[
\ dup ,
- [ superclass "predicate" word-prop % ]
+ [ superclass predicate-def % ]
[ "predicate-definition" word-prop , ] bi
[ drop f ] , \ if ,
] [ ] make ;
! 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
over singleton-class? [ eq? ] [ call-next-method ] if ;
M: singleton-class predicate-quot
- singleton-predicate-quot ;
\ No newline at end of file
+ singleton-predicate-quot ;
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
[ ] [ "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
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 -- ? )
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 ;
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 )
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) ;
+
[ 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? )
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
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
: 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
[ 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
: (M:) ( -- method def )
scan-new-method [ parse-method-definition ] with-method-definition ;
-
[
2dup next-method dup [
[
- pick "predicate" word-prop %
+ pick predicate-def %
1quotation ,
[ inconsistent-next-method ] 2curry ,
\ if ,
} 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>
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 )
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 ] }
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 ;
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
: 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 ] }
: peel-off-class ( slot-spec array -- slot-spec array )
dup empty? [
- dup first class? [
+ dup first classoid? [
[ first init-slot-class ]
[ rest ]
bi
"PREDICATE:" [
scan-new-class
"<" expect
- scan-word
+ scan-class
parse-definition define-predicate-class
] define-core-syntax
not-in-a-method-error
] if*
] define-core-syntax
+
+ "maybe:" [
+ scan-class <maybe> suffix!
+ ] define-core-syntax
"initial:" "syntax" lookup-word define-symbol
IN: cuda.ptx
UNION: dim integer sequence ;
-UNION: ?integer POSTPONE: f integer ;
-UNION: ?string POSTPONE: f string ;
VARIANT: ptx-type
.s8 .s16 .s32 .s64
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 }
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 } ;
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 }
body ;
TUPLE: ptx-func < ptx-entry
- { return ?ptx-variable } ;
+ { return maybe: ptx-variable } ;
TUPLE: ptx-directive ;
.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 }
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 ;
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
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 ;
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
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 ;
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 ;
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 } ;
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 ;
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 ;
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 } } ;
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
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
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 } ;
PRIVATE>
-UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
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 } ;
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 }
{ 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 } ;
[ 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 <=
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
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 }
{ 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 }
- { 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> stencil-state
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
{ 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 }
- { alpha-mode ?blend-mode read-only } ;
+ { rgb-mode maybe: blend-mode read-only }
+ { alpha-mode maybe: blend-mode read-only } ;
C: <blend-state> blend-state
TUPLE: mask-state
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
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
{ 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
{ 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 ;
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 }
} case ;
: (multi-predicate) ( class picker -- quot )
- swap "predicate" word-prop append ;
+ swap predicate-quot append ;
: multi-predicate ( classes -- quot )
dup length iota <reversed>
projects / factor.git / commitdiff