extra/gpu/shaders/shaders.factor

   1 ! Copyright (C) 2009 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.data alien.strings
   4 arrays assocs byte-arrays classes.mixin classes.parser
   5 classes.singleton classes.struct combinators
   6 combinators.short-circuit definitions destructors generic.parser
   7 gpu gpu.buffers gpu.private gpu.state hashtables images
   8 io.encodings.ascii io.files io.pathnames kernel lexer literals
   9 math math.floats.half math.parser memoize multiline namespaces
  10 opengl opengl.gl opengl.shaders parser quotations sequences
  11 specialized-arrays splitting strings tr typed ui.gadgets.worlds
  12 variants vocabs.loader words words.constant ;
  13 QUALIFIED-WITH: alien.c-types c
  14 SPECIALIZED-ARRAY: int
  15 SPECIALIZED-ARRAY: void*
  16 IN: gpu.shaders
  17
  18 VARIANT: shader-kind
  19     vertex-shader fragment-shader geometry-shader ;
  20
  21 VARIANT: geometry-shader-input
  22     points-input
  23     lines-input
  24     lines-with-adjacency-input
  25     triangles-input
  26     triangles-with-adjacency-input ;
  27 VARIANT: geometry-shader-output
  28     points-output
  29     line-strips-output
  30     triangle-strips-output ;
  31
  32 ERROR: too-many-feedback-formats-error formats ;
  33 ERROR: invalid-link-feedback-format-error format ;
  34 ERROR: inaccurate-feedback-attribute-error attribute ;
  35
  36 TUPLE: vertex-attribute
  37     { name            maybe{ string } read-only initial: f }
  38     { component-type  component-type  read-only initial: float-components }
  39     { dim             integer         read-only initial: 4 }
  40     { normalize?      boolean         read-only initial: f } ;
  41
  42 MIXIN: vertex-format
  43
  44 TUPLE: shader
  45     { name word read-only initial: t }
  46     { kind shader-kind read-only }
  47     { filename read-only }
  48     { line integer read-only }
  49     { source string }
  50     { instances hashtable read-only } ;
  51
  52 TUPLE: program
  53     { name word read-only initial: t }
  54     { filename read-only }
  55     { line integer read-only }
  56     { shaders array read-only }
  57     { vertex-formats array read-only }
  58     { feedback-format maybe{ vertex-format } read-only }
  59     { geometry-shader-parameters array read-only }
  60     { instances hashtable read-only } ;
  61
  62 TUPLE: shader-instance < gpu-object
  63     { shader shader }
  64     { world world } ;
  65
  66 TUPLE: program-instance < gpu-object
  67     { program program }
  68     { world world } ;
  69
  70 GENERIC: vertex-format-size ( format -- size )
  71
  72 MEMO: uniform-index ( program-instance uniform-name -- index )
  73     [ handle>> ] dip glGetUniformLocation ;
  74 MEMO: attribute-index ( program-instance attribute-name -- index )
  75     [ handle>> ] dip glGetAttribLocation ;
  76 MEMO: output-index ( program-instance output-name -- index )
  77     [ handle>> ] dip glGetFragDataLocation ;
  78
  79 : vertex-format-attributes ( vertex-format -- attributes )
  80     "vertex-format-attributes" word-prop ; inline
  81
  82 <PRIVATE
  83
  84 TR: hyphens>underscores "-" "_" ;
  85
  86 : gl-vertex-type ( component-type -- gl-type )
  87     {
  88         { ubyte-components          [ GL_UNSIGNED_BYTE  ] }
  89         { ushort-components         [ GL_UNSIGNED_SHORT ] }
  90         { uint-components           [ GL_UNSIGNED_INT   ] }
  91         { half-components           [ GL_HALF_FLOAT     ] }
  92         { float-components          [ GL_FLOAT          ] }
  93         { byte-integer-components   [ GL_BYTE           ] }
  94         { short-integer-components  [ GL_SHORT          ] }
  95         { int-integer-components    [ GL_INT            ] }
  96         { ubyte-integer-components  [ GL_UNSIGNED_BYTE  ] }
  97         { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
  98         { uint-integer-components   [ GL_UNSIGNED_INT   ] }
  99     } case ;
 100
 101 : vertex-type-size ( component-type -- size )
 102     {
 103         { ubyte-components          [ 1 ] }
 104         { ushort-components         [ 2 ] }
 105         { uint-components           [ 4 ] }
 106         { half-components           [ 2 ] }
 107         { float-components          [ 4 ] }
 108         { byte-integer-components   [ 1 ] }
 109         { short-integer-components  [ 2 ] }
 110         { int-integer-components    [ 4 ] }
 111         { ubyte-integer-components  [ 1 ] }
 112         { ushort-integer-components [ 2 ] }
 113         { uint-integer-components   [ 4 ] }
 114     } case ;
 115
 116 : vertex-attribute-size ( vertex-attribute -- size )
 117     [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
 118
 119 : vertex-attributes-size ( vertex-attributes -- size )
 120     [ vertex-attribute-size ] [ + ] map-reduce ;
 121
 122 : feedback-type= ( component-type dim gl-type -- ? )
 123     [ 2array ] dip {
 124         { $ GL_FLOAT             [ { float-components 1 } ] }
 125         { $ GL_FLOAT_VEC2        [ { float-components 2 } ] }
 126         { $ GL_FLOAT_VEC3        [ { float-components 3 } ] }
 127         { $ GL_FLOAT_VEC4        [ { float-components 4 } ] }
 128         { $ GL_INT               [ { int-integer-components 1 } ] }
 129         { $ GL_INT_VEC2          [ { int-integer-components 2 } ] }
 130         { $ GL_INT_VEC3          [ { int-integer-components 3 } ] }
 131         { $ GL_INT_VEC4          [ { int-integer-components 4 } ] }
 132         { $ GL_UNSIGNED_INT      [ { uint-integer-components 1 } ] }
 133         { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
 134         { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
 135         { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
 136     } case = ;
 137
 138 :: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
 139     {
 140         [ vertex-attribute name>> name = ]
 141         [ size 1 = ]
 142         [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
 143     } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
 144
 145 :: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
 146     program-instance name attribute-index :> idx
 147     idx 0 >= [
 148         idx glEnableVertexAttribArray
 149         idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
 150     ] when ; inline
 151
 152 :: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
 153     program-instance name attribute-index :> idx
 154     idx 0 >= [
 155         idx glEnableVertexAttribArray
 156         idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
 157     ] when ; inline
 158
 159 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
 160     vertex-attribute name>> hyphens>underscores :> name
 161     vertex-attribute component-type>>           :> type
 162     type gl-vertex-type                         :> gl-type
 163     vertex-attribute dim>>                      :> dim
 164     vertex-attribute normalize?>> >c-bool       :> normalize?
 165     vertex-attribute vertex-attribute-size      :> size
 166
 167     stride offset size +
 168     {
 169         { [ name not ] [ [ 2drop ] ] }
 170         {
 171             [ type unnormalized-integer-components? ]
 172             [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
 173         }
 174         [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
 175     } cond ;
 176
 177 :: [bind-vertex-format] ( vertex-attributes -- quot )
 178     vertex-attributes vertex-attributes-size :> stride
 179     stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
 180     { attributes-cleave 2cleave } >quotation :> with-block
 181
 182     { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
 183
 184 :: [link-feedback-format] ( vertex-attributes -- quot )
 185     vertex-attributes [ name>> not ] any?
 186     [ [ nip invalid-link-feedback-format-error ] ] [
 187         vertex-attributes
 188         [ name>> ascii malloc-string ]
 189         void*-array{ } map-as :> varying-names
 190         vertex-attributes length :> varying-count
 191         { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
 192         >quotation
 193     ] if ;
 194
 195 :: [verify-feedback-attribute] ( vertex-attribute index -- quot )
 196     vertex-attribute name>> :> name
 197     name length 1 + :> name-buffer-length
 198     {
 199         index name-buffer-length dup
 200         [ f 0 int <ref> 0 int <ref> ] dip <byte-array>
 201         [ glGetTransformFeedbackVarying ] 3keep
 202         ascii alien>string
 203         vertex-attribute assert-feedback-attribute
 204     } >quotation ;
 205
 206 :: [verify-feedback-format] ( vertex-attributes -- quot )
 207     vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
 208     { drop verify-cleave cleave } >quotation ;
 209
 210 : gl-geometry-shader-input ( input -- input )
 211     {
 212         { points-input [ GL_POINTS ] }
 213         { lines-input  [ GL_LINES ] }
 214         { lines-with-adjacency-input [ GL_LINES_ADJACENCY ] }
 215         { triangles-input [ GL_TRIANGLES ] }
 216         { triangles-with-adjacency-input [ GL_TRIANGLES_ADJACENCY ] }
 217     } case ; inline
 218
 219 : gl-geometry-shader-output ( output -- output )
 220     {
 221         { points-output [ GL_POINTS ] }
 222         { line-strips-output  [ GL_LINE_STRIP ] }
 223         { triangle-strips-output [ GL_TRIANGLE_STRIP ] }
 224     } case ; inline
 225
 226 TUPLE: geometry-shader-vertices-out
 227     { count integer read-only } ;
 228
 229 UNION: geometry-shader-parameter
 230     geometry-shader-input
 231     geometry-shader-output
 232     geometry-shader-vertices-out ;
 233
 234
 235 GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
 236
 237 GENERIC: link-feedback-format ( program-handle format -- )
 238
 239 M: f link-feedback-format
 240     2drop ;
 241
 242 : link-vertex-formats ( program-handle formats -- )
 243     [ vertex-format-attributes [ name>> ] map sift ] map concat
 244     swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
 245
 246 GENERIC: link-geometry-shader-parameter ( program-handle parameter -- )
 247
 248 M: geometry-shader-input link-geometry-shader-parameter
 249     [ GL_GEOMETRY_INPUT_TYPE ] dip gl-geometry-shader-input glProgramParameteriARB ;
 250 M: geometry-shader-output link-geometry-shader-parameter
 251     [ GL_GEOMETRY_OUTPUT_TYPE ] dip gl-geometry-shader-output glProgramParameteriARB ;
 252 M: geometry-shader-vertices-out link-geometry-shader-parameter
 253     [ GL_GEOMETRY_VERTICES_OUT ] dip count>> glProgramParameteriARB ;
 254
 255 : link-geometry-shader-parameters ( program-handle parameters -- )
 256     [ link-geometry-shader-parameter ] with each ;
 257
 258 GENERIC: (verify-feedback-format) ( program-instance format -- )
 259
 260 M: f (verify-feedback-format)
 261     2drop ;
 262
 263 : verify-feedback-format ( program-instance -- )
 264     dup program>> feedback-format>> (verify-feedback-format) ;
 265
 266 : define-vertex-format-methods ( class vertex-attributes -- )
 267     {
 268         [
 269             [ \ bind-vertex-format create-method-in ] dip
 270             [bind-vertex-format] define
 271         ] [
 272             [ \ link-feedback-format create-method-in ] dip
 273             [link-feedback-format] define
 274         ] [
 275             [ \ (verify-feedback-format) create-method-in ] dip
 276             [verify-feedback-format] define
 277         ] [
 278             [ \ vertex-format-size create-method-in ] dip
 279             [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
 280         ]
 281     } 2cleave ;
 282
 283 : component-type>c-type ( component-type -- c-type )
 284     {
 285         { ubyte-components [ c:uchar ] }
 286         { ushort-components [ c:ushort ] }
 287         { uint-components [ c:uint ] }
 288         { half-components [ half ] }
 289         { float-components [ c:float ] }
 290         { byte-integer-components [ c:char ] }
 291         { ubyte-integer-components [ c:uchar ] }
 292         { short-integer-components [ c:short ] }
 293         { ushort-integer-components [ c:ushort ] }
 294         { int-integer-components [ c:int ] }
 295         { uint-integer-components [ c:uint ] }
 296     } case ;
 297
 298 : c-array-dim ( type dim -- type' )
 299     dup 1 = [ drop ] [ 2array ] if ;
 300
 301 SYMBOL: padding-no
 302
 303 : padding-name ( -- name )
 304     "padding-"
 305     padding-no counter number>string append
 306     "(" ")" surround ;
 307
 308 : vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
 309     [ name>> [ padding-name ] unless* ]
 310     [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
 311     { } <struct-slot-spec> ;
 312
 313 : shader-filename ( shader/program -- filename )
 314     dup filename>> [ ] [ name>> where first ] ?if file-name ;
 315
 316 : numbered-log-line? ( log-line-components -- ? )
 317     {
 318         [ length 4 >= ]
 319         [ third string>number ]
 320     } 1&& ;
 321
 322 : replace-log-line-number ( object log-line -- log-line' )
 323     ":" split dup numbered-log-line? [
 324         {
 325             [ nip first ]
 326             [ drop shader-filename " " prepend ]
 327             [ [ line>> ] [ third string>number ] bi* + number>string ]
 328             [ nip 3 tail ]
 329         } 2cleave [ 3array ] dip append
 330     ] [ nip ] if ":" join ;
 331
 332 : replace-log-line-numbers ( object log -- log' )
 333     split-lines harvest
 334     [ replace-log-line-number ] with map
 335     join-lines ;
 336
 337 : gl-shader-kind ( shader-kind -- shader-kind )
 338     {
 339         { vertex-shader [ GL_VERTEX_SHADER ] }
 340         { fragment-shader [ GL_FRAGMENT_SHADER ] }
 341         { geometry-shader [ GL_GEOMETRY_SHADER ] }
 342     } case ; inline
 343
 344 PRIVATE>
 345
 346 : define-vertex-format ( class vertex-attributes -- )
 347     [
 348         [
 349             [ define-singleton-class ]
 350             [ vertex-format add-mixin-instance ]
 351             [ ] tri
 352         ] [ define-vertex-format-methods ] bi*
 353     ]
 354     [ "vertex-format-attributes" set-word-prop ] 2bi ;
 355
 356 SYNTAX: VERTEX-FORMAT:
 357     scan-new-class parse-definition
 358     [ first4 vertex-attribute boa ] map
 359     define-vertex-format ;
 360
 361 : define-vertex-struct ( class vertex-format -- )
 362     vertex-format-attributes [ vertex-attribute>struct-slot ] map
 363     define-struct-class ;
 364
 365 SYNTAX: VERTEX-STRUCT:
 366     scan-new-class scan-word define-vertex-struct ;
 367
 368 TUPLE: vertex-array-object < gpu-object
 369     { program-instance program-instance read-only }
 370     { vertex-buffers sequence read-only } ;
 371
 372 TUPLE: vertex-array-collection
 373     { vertex-formats sequence read-only }
 374     { program-instance program-instance read-only } ;
 375
 376 UNION: vertex-array
 377     vertex-array-object vertex-array-collection ;
 378
 379 M: vertex-array-object dispose
 380     [ [ delete-vertex-array ] when* f ] change-handle drop ;
 381
 382 : ?>buffer-ptr ( buffer/ptr -- buffer-ptr )
 383     dup buffer-ptr? [ 0 <buffer-ptr> ] unless ; inline
 384 : ?>buffer ( buffer/ptr -- buffer )
 385     dup buffer? [ buffer>> ] unless ; inline
 386
 387 <PRIVATE
 388
 389 : normalize-vertex-formats ( vertex-formats -- vertex-formats' )
 390     [ first2 [ ?>buffer-ptr ] dip 2array ] map ; inline
 391
 392 : (bind-vertex-array) ( vertex-formats program-instance -- )
 393     '[ _ swap first2 bind-vertex-format ] each ; inline
 394
 395 : (reset-vertex-array) ( -- )
 396     GL_MAX_VERTEX_ATTRIBS get-gl-int <iota> [ glDisableVertexAttribArray ] each ; inline
 397
 398 :: <multi-vertex-array-object> ( vertex-formats program-instance -- vertex-array )
 399     gen-vertex-array :> handle
 400     handle glBindVertexArray
 401
 402     vertex-formats normalize-vertex-formats program-instance (bind-vertex-array)
 403
 404     handle program-instance vertex-formats [ first ?>buffer ] map
 405     vertex-array-object boa window-resource ; inline
 406
 407 : <multi-vertex-array-collection> ( vertex-formats program-instance -- vertex-array )
 408     [ normalize-vertex-formats ] dip vertex-array-collection boa ; inline
 409
 410 :: <vertex-array-object> ( vertex-buffer program-instance format -- vertex-array )
 411     gen-vertex-array :> handle
 412     handle glBindVertexArray
 413     program-instance vertex-buffer ?>buffer-ptr format bind-vertex-format
 414     handle program-instance vertex-buffer ?>buffer 1array
 415     vertex-array-object boa window-resource ; inline
 416
 417 : <vertex-array-collection> ( vertex-buffer program-instance format -- vertex-array )
 418     swap [ [ ?>buffer-ptr ] dip 2array 1array ] dip <multi-vertex-array-collection> ; inline
 419
 420 PRIVATE>
 421
 422 GENERIC: bind-vertex-array ( vertex-array -- )
 423
 424 M: vertex-array-object bind-vertex-array
 425     handle>> glBindVertexArray ; inline
 426
 427 M: vertex-array-collection bind-vertex-array
 428     (reset-vertex-array)
 429     [ vertex-formats>> ] [ program-instance>> ] bi (bind-vertex-array) ; inline
 430
 431 : <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
 432     has-vertex-array-objects? get
 433     [ <multi-vertex-array-object> ]
 434     [ <multi-vertex-array-collection> ] if ; inline
 435
 436 : <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
 437     has-vertex-array-objects? get
 438     [ <vertex-array-object> ]
 439     [ <vertex-array-collection> ] if ; inline
 440
 441 : <vertex-array> ( vertex-buffer program-instance -- vertex-array )
 442     dup program>> vertex-formats>> first <vertex-array*> ; inline
 443
 444 GENERIC: vertex-array-buffers ( vertex-array -- buffers )
 445
 446 M: vertex-array-object vertex-array-buffers
 447     vertex-buffers>> ; inline
 448
 449 M: vertex-array-collection vertex-array-buffers
 450     vertex-formats>> [ first buffer>> ] map ; inline
 451
 452 : vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
 453     vertex-array-buffers first ; inline
 454
 455 TUPLE: compile-shader-error shader log ;
 456 TUPLE: link-program-error program log ;
 457
 458 : throw-compile-shader-error ( shader instance -- * )
 459     [ dup ] dip [ gl-shader-info-log ] [ glDeleteShader ] bi
 460     replace-log-line-numbers compile-shader-error boa throw ;
 461
 462 : throw-link-program-error ( program instance -- * )
 463     [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi
 464     replace-log-line-numbers link-program-error boa throw ;
 465
 466 DEFER: <shader-instance>
 467
 468 <PRIVATE
 469
 470 : valid-handle? ( handle -- ? )
 471     { [ ] [ zero? not ] } 1&& ;
 472
 473 : compile-shader ( shader -- instance )
 474     [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
 475     dup gl-shader-ok?
 476     [ swap world get \ shader-instance boa window-resource ]
 477     [ throw-compile-shader-error ] if ;
 478
 479 : (link-program) ( program shader-instances -- program-instance )
 480     '[ _ [ handle>> ] map ]
 481     [
 482         [ vertex-formats>> ] [ feedback-format>> ] [ geometry-shader-parameters>> ] tri
 483         '[
 484             [ _ link-vertex-formats ]
 485             [ _ link-feedback-format ]
 486             [ _ link-geometry-shader-parameters ] tri
 487         ]
 488     ] bi (gl-program)
 489     dup gl-program-ok?  [
 490         [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
 491         with-destructors window-resource
 492     ] [ throw-link-program-error ] if ;
 493
 494 : link-program ( program -- program-instance )
 495     dup shaders>> [ <shader-instance> ] map (link-program) ;
 496
 497 : word-directory ( word -- directory )
 498     where first parent-directory ;
 499
 500 : in-word's-path ( word kind filename -- word kind filename' )
 501     pick word-directory prepend-path ;
 502
 503 : become-shader-instance ( shader-instance new-shader-instance -- )
 504     handle>> [ swap glDeleteShader ] curry change-handle drop ;
 505
 506 : refresh-shader-source ( shader -- )
 507     dup filename>>
 508     [ ascii file-contents >>source drop ]
 509     [ drop ] if* ;
 510
 511 : become-program-instance ( program-instance new-program-instance -- )
 512     handle>> [ swap glDeleteProgram ] curry change-handle drop ;
 513
 514 : reset-memos ( -- )
 515     \ uniform-index reset-memoized
 516     \ attribute-index reset-memoized
 517     \ output-index reset-memoized ;
 518
 519 : ?delete-at ( key assoc value -- )
 520     2over at = [ delete-at ] [ 2drop ] if ;
 521
 522 : find-shader-instance ( shader -- instance )
 523     world get over instances>> at*
 524     [ nip ] [ drop compile-shader ] if ;
 525
 526 : find-program-instance ( program -- instance )
 527     world get over instances>> at*
 528     [ nip ] [ drop link-program ] if ;
 529
 530 TUPLE: feedback-format
 531     { vertex-format maybe{ vertex-format } read-only } ;
 532
 533 : validate-feedback-format ( sequence -- vertex-format/f )
 534     dup length 1 <=
 535     [ [ f ] [ first vertex-format>> ] if-empty ]
 536     [ too-many-feedback-formats-error ] if ;
 537
 538 : ?shader ( object -- shader/f )
 539     dup word? [ def>> first dup shader? [ drop f ] unless ] [ drop f ] if ;
 540
 541 : shaders-and-formats ( words -- shaders vertex-formats feedback-format geom-parameters )
 542     {
 543         [ [ ?shader ] map sift ]
 544         [ [ vertex-format-attributes ] filter ]
 545         [ [ feedback-format? ] filter validate-feedback-format ]
 546         [ [ geometry-shader-parameter? ] filter ]
 547     } cleave ;
 548
 549 PRIVATE>
 550
 551 SYNTAX: feedback-format:
 552     scan-object feedback-format boa suffix! ;
 553 SYNTAX: geometry-shader-vertices-out:
 554     scan-object geometry-shader-vertices-out boa suffix! ;
 555
 556 TYPED:: refresh-program ( program: program -- )
 557     program shaders>> [ refresh-shader-source ] each
 558     program instances>> [| world old-instance |
 559         old-instance valid-handle? [
 560             world [
 561                 [
 562                     program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
 563                     program new-shader-instances (link-program) |dispose :> new-program-instance
 564
 565                     old-instance new-program-instance become-program-instance
 566                     new-shader-instances [| new-shader-instance |
 567                         world new-shader-instance shader>> instances>> at
 568                             new-shader-instance become-shader-instance
 569                     ] each
 570                 ] with-destructors
 571             ] with-gl-context
 572         ] when
 573     ] assoc-each
 574     reset-memos ;
 575
 576 TYPED: <shader-instance> ( shader: shader -- instance: shader-instance )
 577     [ find-shader-instance dup world get ] keep instances>> set-at ;
 578
 579 TYPED: <program-instance> ( program: program -- instance: program-instance )
 580     [ find-program-instance dup world get ] keep instances>> set-at ;
 581
 582 <PRIVATE
 583
 584 : old-instances ( name -- instances )
 585     dup constant? [
 586         execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
 587         [ instances>> ] [ drop H{ } clone ] if
 588     ] [ drop H{ } clone ] if ;
 589
 590 PRIVATE>
 591
 592 SYNTAX: GLSL-SHADER:
 593     scan-new dup
 594     dup old-instances [
 595         scan-word
 596         f
 597         lexer get line>>
 598         parse-here
 599     ] dip
 600     shader boa
 601     over reset-generic
 602     define-constant ;
 603
 604 SYNTAX: GLSL-SHADER-FILE:
 605     scan-new dup
 606     dup old-instances [
 607         scan-word execute( -- kind )
 608         scan-object in-word's-path
 609         0
 610         over ascii file-contents
 611     ] dip
 612     shader boa
 613     over reset-generic
 614     define-constant ;
 615
 616 SYNTAX: GLSL-PROGRAM:
 617     scan-new dup
 618     dup old-instances [
 619         f
 620         lexer get line>>
 621         parse-array-def shaders-and-formats
 622     ] dip
 623     program boa
 624     over reset-generic
 625     define-constant ;
 626
 627 M: shader-instance dispose
 628     [ dup valid-handle? [ glDeleteShader ] [ drop ] if f ] change-handle
 629     [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
 630
 631 M: program-instance dispose
 632     [ dup valid-handle? [ glDeleteProgram ] [ drop ] if f ] change-handle
 633     [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
 634     reset-memos ;
 635
 636 { "gpu.shaders" "prettyprint" } "gpu.shaders.prettyprint" require-when