extra/gpu/shaders/shaders.factor

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