- 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

View File

@ -7,7 +7,7 @@ TUPLE: hoo ;
UNION: foo integer yoo ; 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 ;
: store-26. ( -- obj ) redefine-test-26 new 26. >>a ; : store-26. ( -- obj ) redefine-test-26 new 26. >>a ;

View File

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

View File

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

View File

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

View File

@ -7,8 +7,10 @@ colors.constants combinators continuations effects generic
hash-sets hashtables io io.pathnames io.styles kernel hash-sets hashtables io io.pathnames io.styles kernel
make math math.order math.parser namespaces prettyprint.config make math math.order math.parser namespaces prettyprint.config
prettyprint.custom prettyprint.sections prettyprint.stylesheet 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 ; FROM: sets => members ;
! QUALIFIED-WITH: classes.not cn
IN: prettyprint.backend IN: prettyprint.backend
M: effect pprint* effect>string text ; M: effect pprint* effect>string text ;
@ -26,13 +28,16 @@ M: effect pprint* effect>string text ;
GENERIC: word-name* ( obj -- str ) GENERIC: word-name* ( obj -- str )
M: maybe word-name* 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* M: anonymous-union word-name*
members>> [ word-name* ] map " " join "union{ " " }" surround ; class-name "union{ " " }" surround ;
M: anonymous-intersection word-name* M: anonymous-intersection word-name*
participants>> [ word-name* ] map " " join "intersection{ " " }" surround ; class-name "intersection{ " " }" surround ;
M: word word-name* ( word -- str ) M: word word-name* ( word -- str )
[ name>> "( no name )" or ] [ record-vocab ] bi ; [ 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: hash-set pprint-delims drop \ HS{ \ } ;
M: anonymous-union pprint-delims drop \ union{ \ } ; M: anonymous-union pprint-delims drop \ union{ \ } ;
M: anonymous-intersection pprint-delims drop \ intersection{ \ } ; 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: object >pprint-sequence ;
M: vector >pprint-sequence ; M: vector >pprint-sequence ;
@ -224,6 +231,8 @@ M: callstack >pprint-sequence callstack>array ;
M: hash-set >pprint-sequence members ; M: hash-set >pprint-sequence members ;
M: anonymous-union >pprint-sequence members>> ; M: anonymous-union >pprint-sequence members>> ;
M: anonymous-intersection >pprint-sequence participants>> ; 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 ) : class-slot-sequence ( class slots -- sequence )
[ 1array ] [ [ f 2array ] dip append ] if-empty ; [ 1array ] [ [ f 2array ] dip append ] if-empty ;
@ -264,6 +273,8 @@ M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ; M: hash-set pprint* pprint-object ;
M: anonymous-union pprint* pprint-object ; M: anonymous-union pprint* pprint-object ;
M: anonymous-intersection pprint* pprint-object ; M: anonymous-intersection pprint* pprint-object ;
M: anonymous-complement pprint* pprint-object ;
M: maybe pprint* pprint-object ;
M: wrapper pprint* M: wrapper pprint*
{ {
@ -271,6 +282,3 @@ M: wrapper pprint*
{ [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] } { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
[ pprint-object ] [ pprint-object ]
} cond ; } cond ;
M: maybe pprint*
<block \ maybe: pprint-word class>> pprint-class block> ;

View File

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

View File

@ -163,7 +163,7 @@ TYPED: forget-fail ( a: forget-class -- ) drop ;
[ ] [ [ \ forget-fail forget ] with-compilation-unit ] unit-test [ ] [ [ \ 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 [ f ] [ f typed-maybe ] unit-test
[ t ] [ 30 typed-maybe ] unit-test [ t ] [ 30 typed-maybe ] unit-test

View File

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

View File

@ -7,6 +7,8 @@ FROM: classes => members ;
RENAME: members sets => set-members RENAME: members sets => set-members
IN: classes.algebra IN: classes.algebra
DEFER: sort-classes
<PRIVATE <PRIVATE
TUPLE: anonymous-union { members read-only } ; TUPLE: anonymous-union { members read-only } ;
@ -15,7 +17,7 @@ INSTANCE: anonymous-union classoid
: <anonymous-union> ( members -- class ) : <anonymous-union> ( members -- class )
[ null eq? not ] filter set-members [ 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 ; M: anonymous-union rank-class drop 6 ;
@ -25,7 +27,7 @@ INSTANCE: anonymous-intersection classoid
: <anonymous-intersection> ( participants -- class ) : <anonymous-intersection> ( participants -- class )
set-members dup length 1 = 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 ; 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 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<=)
DEFER: (class-not) DEFER: (class-not)

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -53,7 +53,7 @@ ALIAS: mat4x4-uniform mat4-uniform
TUPLE: uniform TUPLE: uniform
{ name string read-only initial: "" } { name string read-only initial: "" }
{ uniform-type class read-only initial: float-uniform } { 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 VARIANT: index-type
ubyte-indexes ubyte-indexes
@ -80,7 +80,7 @@ TUPLE: index-elements
C: <index-elements> index-elements C: <index-elements> index-elements
TUPLE: multi-index-elements TUPLE: multi-index-elements
{ buffer maybe: buffer read-only } { buffer maybe{ buffer } read-only }
{ ptrs read-only } { ptrs read-only }
{ counts uint-array read-only } { counts uint-array read-only }
{ index-type index-type 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 } { vertex-array vertex-array initial: T{ vertex-array-collection } read-only }
{ uniforms uniform-tuple read-only } { uniforms uniform-tuple read-only }
{ indexes vertex-indexes initial: T{ index-range } read-only } { indexes vertex-indexes initial: T{ index-range } read-only }
{ instances maybe: integer initial: f read-only } { instances maybe{ integer } initial: f read-only }
{ framebuffer maybe: any-framebuffer initial: system-framebuffer read-only } { framebuffer maybe{ any-framebuffer } initial: system-framebuffer read-only }
{ output-attachments sequence initial: { default-attachment } read-only } { output-attachments sequence initial: { default-attachment } read-only }
{ transform-feedback-output transform-feedback-output initial: f read-only } ; { transform-feedback-output transform-feedback-output initial: f read-only } ;

View File

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

View File

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

View File

@ -69,7 +69,7 @@ UNION: wrap-set texture-wrap sequence ;
TUPLE: texture-parameters TUPLE: texture-parameters
{ wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } } { wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
{ min-filter texture-filter initial: filter-nearest } { 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 } { mag-filter texture-filter initial: filter-linear }
{ min-lod integer initial: -1000 } { min-lod integer initial: -1000 }
{ max-lod integer initial: 1000 } { max-lod integer initial: 1000 }