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