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

classes: 

- Allow methods to dispatch off union{ } and intersection{ } classes.
- Add not{ } anonymous-complement syntax.
- Define class-name for anonymous-union/intersection/complement and maybes, and clean up pprint.
- Change maybe: foo to maybe{ foo }
- Call sort-classes when making anonymous-union/anonymous-intersection classes so that they are canonicalized.
db4
Doug Coleman 2012-05-03 19:17:41 -07:00
parent 7fe0e95cd4
commit 3507b9bad7
22 changed files with 133 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/tests/redefine26.factor
View File

@ -7,7 +7,7 @@ TUPLE: hoo ;
UNION: foo integer yoo ;
TUPLE: redefine-test-26 { a maybe: foo } ;
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 ;

6
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -1008,12 +1008,12 @@ M: tuple-with-read-only-slot clone
] unit-test
[ t ] [
[ maybe: integer instance? ] { instance? } inlined?
[ maybe{ integer } instance? ] { instance? } inlined?
] unit-test
TUPLE: inline-please a ;
[ t ] [
[ maybe: inline-please instance? ] { instance? } inlined?
[ maybe{ inline-please } instance? ] { instance? } inlined?
] unit-test
GENERIC: derp ( obj -- obj' )
@ -1023,5 +1023,5 @@ M: f derp drop t ;
[ t ]
[
[ dup maybe: integer instance? [ derp ] when ] { instance? } inlined?
[ dup maybe{ integer } instance? [ derp ] when ] { instance? } inlined?
] unit-test

6
basis/dlists/dlists.factor
View File

@ -6,7 +6,7 @@ deques fry hashtables kernel parser search-deques sequences
summary vocabs.loader ;
IN: dlists
TUPLE: dlist-link { prev maybe: dlist-link } { next maybe: dlist-link } ;
TUPLE: dlist-link { prev maybe{ dlist-link } } { next maybe{ dlist-link } } ;
TUPLE: dlist-node < dlist-link obj ;
@ -22,8 +22,8 @@ M: dlist-link obj>> ;
\ dlist-node new-dlist-link ; inline
TUPLE: dlist
{ front maybe: dlist-link }
{ back maybe: dlist-link } ;
{ front maybe{ dlist-link } }
{ back maybe{ dlist-link } } ;
: <dlist> ( -- list )
dlist new ; inline

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

@ -65,7 +65,7 @@ M: local protocol drop 0 ;
SLOT: port
TUPLE: ipv4 { host maybe: string read-only } ;
TUPLE: ipv4 { host maybe{ string } read-only } ;
<PRIVATE
@ -131,7 +131,7 @@ M: inet4 present
M: inet4 protocol drop 0 ;
TUPLE: ipv6
{ host maybe: string read-only }
{ host maybe{ string } read-only }
{ scope-id integer read-only } ;
<PRIVATE
@ -393,7 +393,7 @@ GENERIC: resolve-host ( addrspec -- seq )
HOOK: resolve-localhost os ( -- obj )
TUPLE: hostname { host maybe: string read-only } ;
TUPLE: hostname { host maybe{ string } read-only } ;
TUPLE: inet < hostname port ;

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

@ -7,8 +7,10 @@ colors.constants combinators continuations effects generic
hash-sets 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 ;
quotations sbufs sequences strings vectors words words.symbol
classes.private ;
FROM: sets => members ;
! QUALIFIED-WITH: classes.not cn
IN: prettyprint.backend
M: effect pprint* effect>string text ;
@ -26,13 +28,16 @@ M: effect pprint* effect>string text ;
GENERIC: word-name* ( obj -- str )
M: maybe word-name*
class>> word-name* "maybe: " prepend ;
class-name "maybe{ " " }" surround ;
M: anonymous-complement word-name*
class-name "not{ " " }" surround ;
M: anonymous-union word-name*
members>> [ word-name* ] map " " join "union{ " " }" surround ;
class-name "union{ " " }" surround ;
M: anonymous-intersection word-name*
participants>> [ word-name* ] map " " join "intersection{ " " }" surround ;
class-name "intersection{ " " }" surround ;
M: word word-name* ( word -- str )
[ name>> "( no name )" or ] [ record-vocab ] bi ;
@ -213,6 +218,8 @@ M: callstack pprint-delims drop \ CS{ \ } ;
M: hash-set pprint-delims drop \ HS{ \ } ;
M: anonymous-union pprint-delims drop \ union{ \ } ;
M: anonymous-intersection pprint-delims drop \ intersection{ \ } ;
M: anonymous-complement pprint-delims drop \ not{ \ } ;
M: maybe pprint-delims drop \ maybe{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
@ -224,6 +231,8 @@ M: callstack >pprint-sequence callstack>array ;
M: hash-set >pprint-sequence members ;
M: anonymous-union >pprint-sequence members>> ;
M: anonymous-intersection >pprint-sequence participants>> ;
M: anonymous-complement >pprint-sequence class>> 1array ;
M: maybe >pprint-sequence class>> 1array ;
: class-slot-sequence ( class slots -- sequence )
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
@ -264,6 +273,8 @@ M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ;
M: anonymous-union pprint* pprint-object ;
M: anonymous-intersection pprint* pprint-object ;
M: anonymous-complement pprint* pprint-object ;
M: maybe pprint* pprint-object ;
M: wrapper pprint*
{
@ -271,6 +282,3 @@ 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-class block> ;

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

@ -388,18 +388,18 @@ TUPLE: final-tuple ; final
] with-variable
] unit-test
[ "maybe: integer\n" ] [ [ maybe: integer . ] with-string-writer ] 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
[ "maybe{ bob }\n" ] [ [ maybe{ bob } . ] with-string-writer ] unit-test
[ "maybe{ word }\n" ] [ [ maybe{ word } . ] with-string-writer ] unit-test
TUPLE: har a ;
GENERIC: harhar ( obj -- obj )
M: maybe: har harhar ;
M: maybe{ har } harhar ;
M: integer harhar M\ integer harhar drop ;
[
"""USING: prettyprint.tests ;
M: maybe: har harhar ;
M: maybe{ har } harhar ;
USING: kernel math prettyprint.tests ;
M: integer harhar M\\ integer harhar drop ;\n"""
@ -445,13 +445,13 @@ TUPLE: fo { a intersection{ fixnum integer } initial: 0 } ;
] [ [ intersection{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test
[
"""maybe: union{ float integer }\n"""
"""maybe{ union{ float integer } }\n"""
] [
[ maybe: union{ float integer } . ] with-string-writer
[ maybe{ union{ float integer } } . ] with-string-writer
] unit-test
[
"""maybe: maybe: integer\n"""
"""maybe{ maybe{ integer } }\n"""
] [
[ maybe: maybe: integer . ] with-string-writer
[ maybe{ maybe{ integer } } . ] with-string-writer
] unit-test

2
basis/typed/typed-tests.factor
View File

@ -163,7 +163,7 @@ TYPED: forget-fail ( a: forget-class -- ) drop ;
[ ] [ [ \ forget-fail forget ] with-compilation-unit ] unit-test
TYPED: typed-maybe ( x: maybe: integer -- ? ) >boolean ;
TYPED: typed-maybe ( x: maybe{ integer } -- ? ) >boolean ;
[ f ] [ f typed-maybe ] unit-test
[ t ] [ 30 typed-maybe ] unit-test

3
core/bootstrap/syntax.factor
View File

@ -82,7 +82,8 @@ IN: bootstrap.syntax
"<<"
">>"
"call-next-method"
"maybe:"
"not{"
"maybe{"
"union{"
"intersection{"
"initial:"

12
core/classes/algebra/algebra.factor
View File

@ -7,6 +7,8 @@ FROM: classes => members ;
RENAME: members sets => set-members
IN: classes.algebra
DEFER: sort-classes
<PRIVATE
TUPLE: anonymous-union { members read-only } ;
@ -15,7 +17,7 @@ INSTANCE: anonymous-union classoid
: <anonymous-union> ( members -- class )
[ null eq? not ] filter set-members
dup length 1 = [ first ] [ anonymous-union boa ] if ;
dup length 1 = [ first ] [ sort-classes f like anonymous-union boa ] if ;
M: anonymous-union rank-class drop 6 ;
@ -25,7 +27,7 @@ INSTANCE: anonymous-intersection classoid
: <anonymous-intersection> ( participants -- class )
set-members dup length 1 =
[ first ] [ anonymous-intersection boa ] if ;
[ first ] [ sort-classes f like anonymous-intersection boa ] if ;
M: anonymous-intersection rank-class drop 4 ;
@ -37,6 +39,12 @@ C: <anonymous-complement> anonymous-complement
M: anonymous-complement rank-class drop 3 ;
M: anonymous-complement instance?
over [ class>> instance? not ] [ 2drop t ] if ;
M: anonymous-complement class-name
class>> class-name ;
DEFER: (class<=)
DEFER: (class-not)

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

@ -51,6 +51,9 @@ M: anonymous-intersection (flatten-class)
[ dup set ] each
] if-empty ;
M: anonymous-intersection class-name
participants>> [ class-name ] map " " join ;
PRIVATE>
: define-intersection-class ( class participants -- )

28
core/classes/maybe/maybe-tests.factor
View File

@ -4,41 +4,41 @@ USING: classes.maybe eval generic.single kernel tools.test
math classes accessors slots classes.algebra ;
IN: classes.maybe.tests
[ t ] [ 3 maybe: integer instance? ] unit-test
[ t ] [ f maybe: integer instance? ] unit-test
[ f ] [ 3.0 maybe: integer instance? ] unit-test
[ 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 } ;
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 } ;
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
[ t ] [ f maybe{ POSTPONE: f } instance? ] unit-test
PREDICATE: natural < maybe: integer
PREDICATE: natural < maybe{ integer }
0 > ;
[ f ] [ -1 natural? ] unit-test
[ f ] [ 0 natural? ] unit-test
[ t ] [ 1 natural? ] unit-test
[ t ] [ f maybe: maybe: integer instance? ] unit-test
[ t ] [ 3 maybe: maybe: integer instance? ] unit-test
[ f ] [ 3.03 maybe: maybe: integer instance? ] unit-test
[ t ] [ f maybe{ maybe{ integer } } instance? ] unit-test
[ t ] [ 3 maybe{ maybe{ integer } } instance? ] unit-test
[ f ] [ 3.03 maybe{ maybe{ integer } } instance? ] unit-test
INTERSECTION: only-f maybe: integer POSTPONE: f ;
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 ;
UNION: ?integer-float maybe{ integer } maybe{ float } ;
[ t ] [ 30 ?integer-float instance? ] unit-test
[ t ] [ 30.0 ?integer-float instance? ] unit-test
@ -47,7 +47,7 @@ UNION: ?integer-float maybe: integer maybe: float ;
TUPLE: foo ;
GENERIC: lol ( obj -- string )
M: maybe: foo lol drop "lol" ;
M: maybe{ foo } lol drop "lol" ;
[ "lol" ] [ foo new lol ] unit-test
[ "lol" ] [ f lol ] unit-test
@ -55,7 +55,7 @@ M: maybe: foo lol drop "lol" ;
TUPLE: foo2 a ;
GENERIC: lol2 ( obj -- string )
M: maybe: foo lol2 drop "lol2" ;
M: maybe{ foo } lol2 drop "lol2" ;
M: f lol2 drop "lol22" ;
[ "lol2" ] [ foo new lol2 ] unit-test

9
core/classes/maybe/maybe.factor
View File

@ -2,12 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes classes.algebra
classes.algebra.private classes.private classes.union.private
effects kernel words ;
effects kernel words sequences arrays ;
IN: classes.maybe
! The class slot has to be a union of a word and a classoid
! for TUPLE: foo { a maybe: foo } ; and maybe: union{ integer float } to work.
! In the first case, foo is not yet a tuple-class when maybe: is reached,
! for TUPLE: foo { a maybe{ foo } } ; and maybe{ union{ integer float } }
! to work.
! In the first case, foo is not yet a tuple-class when maybe{ is reached,
! thus it's not a classoid yet. union{ is a classoid, so the second case works.
! words are not generally classoids, so classoid alone is insufficient.
TUPLE: maybe { class union{ word classoid } initial: object read-only } ;
@ -36,7 +37,7 @@ M: maybe union-of-builtins?
class>> union-of-builtins? ;
M: maybe class-name
class>> name>> ;
class>> class-name ;
M: maybe predicate-def
class>> predicate-def [ [ t ] if* ] curry ;

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

@ -69,6 +69,9 @@ M: union-class instance?
M: anonymous-union instance?
members>> [ instance? ] with any? ;
M: anonymous-union class-name
members>> [ class-name ] map " " join ;
M: union-class normalize-class
members <anonymous-union> normalize-class ;

3
core/compiler/units/units.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays assocs classes classes.private
classes.tuple classes.tuple.private continuations definitions
generic init kernel kernel.private math namespaces sequences
sets source-files.errors vocabs words ;
sets source-files.errors vocabs words classes.algebra ;
FROM: namespaces => set ;
IN: compiler.units
@ -18,6 +18,7 @@ TUPLE: redefine-error def ;
<PRIVATE
: add-once ( key assoc -- )
! 2dup keys swap [ class= ] curry any? [ over redefine-error ] when conjoin ;
2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )

9
core/generic/generic.factor
View File

@ -107,13 +107,8 @@ GENERIC: update-generic ( class generic -- )
: with-methods ( class generic quot -- )
[ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
GENERIC# method-word-name 1 ( class generic -- string )
M: class method-word-name ( class generic -- string )
[ name>> ] bi@ "=>" glue ;
M: maybe method-word-name
[ class>> name>> ] [ name>> ] bi* "=>" glue ;
: method-word-name ( class generic -- string )
[ class-name ] [ name>> ] bi* "=>" glue ;
M: method parent-word
"method-generic" word-prop ;

8
core/syntax/syntax.factor
View File

@ -246,8 +246,12 @@ IN: bootstrap.syntax
] if*
] define-core-syntax
"maybe:" [
scan-class <maybe> suffix!
"maybe{" [
\ } [ <anonymous-union> <maybe> ] parse-literal
] define-core-syntax
"not{" [
\ } [ <anonymous-union> <anonymous-complement> ] parse-literal
] define-core-syntax
"intersection{" [

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

@ -26,7 +26,7 @@ VARIANT: ptx-texmode
VARIANT: ptx-storage-space
.reg
.sreg
.const: { { bank maybe: integer } }
.const: { { bank maybe{ integer } } }
.global
.local
.param
@ -34,9 +34,9 @@ VARIANT: ptx-storage-space
.tex ;
TUPLE: ptx-target
{ arch maybe: ptx-arch }
{ arch maybe{ ptx-arch } }
{ map_f64_to_f32? boolean }
{ texmode maybe: ptx-texmode } ;
{ texmode maybe{ ptx-texmode } } ;
TUPLE: ptx
{ version string }
@ -50,13 +50,13 @@ TUPLE: ptx-struct-definition
TUPLE: ptx-variable
{ extern? boolean }
{ visible? boolean }
{ align maybe: integer }
{ align maybe{ integer } }
{ storage-space ptx-storage-space }
{ type ptx-type }
{ name string }
{ parameter maybe: integer }
{ parameter maybe{ integer } }
{ dim dim }
{ initializer maybe: string } ;
{ initializer maybe{ string } } ;
TUPLE: ptx-negation
{ var string } ;
@ -79,8 +79,8 @@ UNION: ptx-operand
integer float ptx-var ptx-negation ptx-vector ptx-indirect ;
TUPLE: ptx-instruction
{ label maybe: string }
{ predicate maybe: ptx-operand } ;
{ label maybe{ string } }
{ predicate maybe{ ptx-operand } } ;
TUPLE: ptx-entry
{ name string }
@ -89,7 +89,7 @@ TUPLE: ptx-entry
body ;
TUPLE: ptx-func < ptx-entry
{ return maybe: ptx-variable } ;
{ return maybe{ ptx-variable } } ;
TUPLE: ptx-directive ;
@ -146,10 +146,10 @@ VARIANT: ptx-mul-mode
.wide ;
TUPLE: ptx-mul-instruction < ptx-3op-instruction
{ mode maybe: ptx-mul-mode } ;
{ mode maybe{ ptx-mul-mode } } ;
TUPLE: ptx-mad-instruction < ptx-4op-instruction
{ mode maybe: ptx-mul-mode }
{ mode maybe{ ptx-mul-mode } }
{ sat? boolean } ;
VARIANT: ptx-prmt-mode
@ -158,7 +158,7 @@ VARIANT: ptx-prmt-mode
ROLE: ptx-float-ftz
{ ftz? boolean } ;
ROLE: ptx-float-env < ptx-float-ftz
{ round maybe: ptx-float-rounding-mode } ;
{ round maybe{ ptx-float-rounding-mode } } ;
VARIANT: ptx-testp-op
.finite .infinite .number .notanumber .normal .subnormal ;
@ -183,8 +183,8 @@ INSTANCE: .hi ptx-cmp-op
TUPLE: ptx-set-instruction < ptx-3op-instruction
{ cmp-op ptx-cmp-op }
{ bool-op maybe: ptx-op }
{ c maybe: ptx-operand }
{ bool-op maybe{ ptx-op } }
{ c maybe{ ptx-operand } }
{ ftz? boolean } ;
VARIANT: ptx-cache-op
@ -193,8 +193,8 @@ VARIANT: ptx-cache-op
TUPLE: ptx-ldst-instruction < ptx-2op-instruction
{ volatile? boolean }
{ storage-space maybe: ptx-storage-space }
{ cache-op maybe: ptx-cache-op } ;
{ storage-space maybe{ ptx-storage-space } }
{ cache-op maybe{ ptx-cache-op } } ;
VARIANT: ptx-cache-level
.L1 .L2 ;
@ -216,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 maybe: ptx-storage-space }
{ storage-space maybe{ ptx-storage-space } }
{ op ptx-op }
{ c maybe: 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 maybe: ptx-operand }
{ b maybe{ ptx-operand } }
{ c ptx-operand } ;
TUPLE: bar.sync < ptx-instruction
{ a ptx-operand }
{ b maybe: ptx-operand } ;
{ b maybe{ ptx-operand } } ;
TUPLE: bfe < ptx-4op-instruction ;
TUPLE: bfi < ptx-5op-instruction ;
TUPLE: bfind < ptx-2op-instruction
@ -237,20 +237,20 @@ TUPLE: bra < ptx-branch-instruction ;
TUPLE: brev < ptx-2op-instruction ;
TUPLE: brkpt < ptx-instruction ;
TUPLE: call < ptx-branch-instruction
{ return maybe: 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 maybe: 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 maybe: 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 ;
@ -279,16 +279,16 @@ TUPLE: pmevent < ptx-instruction
TUPLE: popc < ptx-2op-instruction ;
TUPLE: prefetch < ptx-instruction
{ a ptx-operand }
{ storage-space maybe: 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 maybe: ptx-prmt-mode } ;
{ mode maybe{ ptx-prmt-mode } } ;
TUPLE: rcp <{ ptx-2op-instruction ptx-float-env } ;
TUPLE: red < ptx-2op-instruction
{ storage-space maybe: ptx-storage-space }
{ storage-space maybe{ ptx-storage-space } }
{ op ptx-op } ;
TUPLE: rem < ptx-3op-instruction ;
TUPLE: ret < ptx-instruction ;
@ -298,7 +298,7 @@ TUPLE: selp < ptx-4op-instruction ;
TUPLE: set < ptx-set-instruction
{ dest-type ptx-type } ;
TUPLE: setp < ptx-set-instruction
{ |dest maybe: ptx-operand } ;
{ |dest maybe{ ptx-operand } } ;
TUPLE: shl < ptx-3op-instruction ;
TUPLE: shr < ptx-3op-instruction ;
TUPLE: sin <{ ptx-2op-instruction ptx-float-env } ;

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

@ -88,8 +88,8 @@ M: texture-attachment attachment-object texture>> texture-object ;
TUPLE: framebuffer < gpu-object
{ color-attachments array read-only }
{ depth-attachment maybe: framebuffer-attachment read-only initial: f }
{ stencil-attachment maybe: 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 ;
@ -102,8 +102,8 @@ VARIANT: framebuffer-attachment-face
VARIANT: color-attachment-ref
default-attachment
system-attachment: {
{ side maybe: framebuffer-attachment-side initial: f }
{ face maybe: 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 } } ;

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

@ -53,7 +53,7 @@ ALIAS: mat4x4-uniform mat4-uniform
TUPLE: uniform
{ name string read-only initial: "" }
{ uniform-type class read-only initial: float-uniform }
{ dim maybe: integer read-only initial: f } ;
{ dim maybe{ integer } read-only initial: f } ;
VARIANT: index-type
ubyte-indexes
@ -80,7 +80,7 @@ TUPLE: index-elements
C: <index-elements> index-elements
TUPLE: multi-index-elements
{ buffer maybe: buffer read-only }
{ buffer maybe{ buffer } read-only }
{ ptrs read-only }
{ counts uint-array read-only }
{ index-type index-type read-only } ;
@ -587,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 maybe: integer initial: f read-only }
{ framebuffer maybe: 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 } ;

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

@ -33,10 +33,10 @@ ERROR: invalid-link-feedback-format-error format ;
ERROR: inaccurate-feedback-attribute-error attribute ;
TUPLE: vertex-attribute
{ 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 } ;
{ 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
@ -54,7 +54,7 @@ TUPLE: program
{ line integer read-only }
{ shaders array read-only }
{ vertex-formats array read-only }
{ feedback-format maybe: vertex-format read-only }
{ feedback-format maybe{ vertex-format } read-only }
{ geometry-shader-parameters array read-only }
{ instances hashtable read-only } ;
@ -524,7 +524,7 @@ DEFER: <shader-instance>
[ nip ] [ drop link-program ] if ;
TUPLE: feedback-format
{ vertex-format maybe: vertex-format read-only } ;
{ vertex-format maybe{ vertex-format } read-only } ;
: validate-feedback-format ( sequence -- vertex-format/f )
dup length 1 <=

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

@ -13,14 +13,14 @@ TUPLE: viewport-state
C: <viewport-state> viewport-state
TUPLE: scissor-state
{ rect maybe: 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 maybe: float read-only }
{ sample-coverage maybe{ float } read-only }
{ invert-sample-coverage? boolean read-only } ;
C: <multisample-state> multisample-state
@ -44,8 +44,8 @@ TUPLE: stencil-mode
C: <stencil-mode> stencil-mode
TUPLE: stencil-state
{ front-mode maybe: stencil-mode initial: f read-only }
{ back-mode maybe: 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
@ -54,7 +54,7 @@ TUPLE: depth-range-state
C: <depth-range-state> depth-range-state
TUPLE: depth-state
{ comparison maybe: comparison initial: f read-only } ;
{ comparison maybe{ comparison } initial: f read-only } ;
C: <depth-state> depth-state
VARIANT: blend-equation
@ -81,8 +81,8 @@ C: <blend-mode> blend-mode
TUPLE: blend-state
{ constant-color sequence initial: f read-only }
{ rgb-mode maybe: blend-mode read-only }
{ alpha-mode maybe: 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
@ -101,7 +101,7 @@ VARIANT: triangle-mode
TUPLE: triangle-cull-state
{ front-face triangle-face initial: face-ccw read-only }
{ cull maybe: triangle-cull initial: f read-only } ;
{ cull maybe{ triangle-cull } initial: f read-only } ;
C: <triangle-cull-state> triangle-cull-state
TUPLE: triangle-state
@ -114,7 +114,7 @@ VARIANT: point-sprite-origin
origin-upper-left origin-lower-left ;
TUPLE: point-state
{ size maybe: 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

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

@ -69,7 +69,7 @@ UNION: wrap-set texture-wrap sequence ;
TUPLE: texture-parameters
{ wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
{ min-filter texture-filter initial: filter-nearest }
{ min-mipmap-filter maybe: 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 }