steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.

db4
Doug Coleman 2011-11-21 23:00:52 -08:00
parent cb119568d3
commit 067f9830ef
30 changed files with 240 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
basis/compiler/tests/redefine26.factor Normal file
View File

@ -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

11
basis/compiler/tree/propagation/simple/simple.factor
View File

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

2
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -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

2
basis/hints/hints.factor
View File

@ -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? ] ;

2
basis/inverse/inverse.factor
View File

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

8
basis/io/sockets/sockets.factor
View File

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

6
basis/prettyprint/backend/backend.factor
View File

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

6
basis/prettyprint/prettyprint-tests.factor
View File

@ -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

4
basis/stack-checker/known-words/known-words.factor
View File

@ -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 ( -- )

1
core/bootstrap/syntax.factor
View File

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

20
core/classes/classes.factor
View File

@ -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

4
core/classes/intersection/intersection.factor
View File

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

2
core/classes/predicate/predicate.factor
View File

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

4
core/classes/singleton/singleton.factor
View File

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

43
core/classes/union/union-tests.factor
View File

@ -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

30
core/classes/union/union.factor
View File

@ -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) ;

7
core/effects/parser/parser.factor
View File

@ -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? )

13
core/generic/generic.factor
View File

@ -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

3
core/generic/parser/parser.factor
View File

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

4
core/generic/single/single.factor
View File

@ -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>

8
core/parser/parser.factor
View File

@ -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 ] }

26
core/slots/slots.factor
View File

@ -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

6
core/syntax/syntax.factor
View File

@ -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

68
extra/cuda/ptx/ptx.factor
View File

@ -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 } ;

12
extra/gpu/framebuffers/framebuffers.factor
View File

@ -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 } } ;

13
extra/gpu/render/render.factor
View File

@ -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 }
{ 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 } ;

9
extra/gpu/shaders/shaders.factor
View File

@ -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 <=

29
extra/gpu/state/state.factor
View File

@ -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 }
{ 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
@ -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 }
{ 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
@ -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

6
extra/gpu/textures/textures.factor
View File

@ -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 }

2
extra/multi-methods/multi-methods.factor
View File

@ -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>