├── .gitattributes ├── LICENSE ├── README.md ├── docs └── index.html ├── documentation.lisp ├── glsl-toolkit.asd ├── grammar.lisp ├── merge.lisp ├── method-combination.lisp ├── package.lisp ├── parser.lisp ├── printer.lisp ├── sexpr.lisp ├── toolkit.lisp ├── transform.lisp └── walker.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | 2 | doc/ linguist-vendored 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Yukari Hafner 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would be 14 | appreciated but is not required. 15 | 2. Altered source versions must be plainly marked as such, and must not be 16 | misrepresented as being the original software. 17 | 3. This notice may not be removed or altered from any source distribution. 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # This repository has [moved](https://shirakumo.org/projects/glsl-toolkit)! 2 | Due to Microsoft's continued enshittification of the platform this repository has been moved to [Codeberg](https://shirakumo.org/projects/glsl-toolkit) in August of 2025. It will not receive further updates or patches. **Issues and pull requests will not be looked at here either**, please submit your patches and issue tickets on Codeberg, or send them directly via good old email patches to [shirakumo@tymoon.eu](mailto:shirakumo@tymoon.eu). 3 | 4 | Thanks. -------------------------------------------------------------------------------- /documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | ;; grammar.lisp 4 | (docs:define-docs 5 | (function define-operator-objects 6 | "Shorthand to define an object that parses a string and returns the keyword version of that string. 7 | 8 | Used to define the various token objects. 9 | 10 | See DEFINE-OBJECT") 11 | 12 | (function define-binary-op 13 | "Shorthand to define a binary operator object. 14 | 15 | This takes care to avoid duplicate parsing of the same sequence 16 | if the subsequence should succeed. Meaning that if the left 17 | expression matches, but the operator or the right one does not 18 | it simply returns the left expression, instead of failing to 19 | match and causing a re-matching lower down in the tree. 20 | 21 | Without this optimisation, performance would suffer greatly. 22 | 23 | See DEFINE-OBJECT")) 24 | 25 | ;; merge.lisp 26 | (docs:define-docs 27 | (variable *unique-counter* 28 | "Counter to hold the current index used to compute names for unique identifiers. 29 | 30 | See UNIQUIFY") 31 | 32 | (function uniquify 33 | "Create a (hopefully) unique identifier for the given name. 34 | 35 | The returned name is prefixed by two underscores. Identifiers 36 | like that are reserved for use by the underlying library or 37 | framework (us), so there should not be any clash with user 38 | identifiers unless the shader is not conforming to begin with. 39 | 40 | See *UNIQUE-COUNTER*") 41 | 42 | (function matching-qualifiers-p 43 | "Returns true if the two given qualifier lists are considered to match. 44 | 45 | The following qualifier parts are not considered: 46 | :HIGHP :MEDIUMP :LOWP :INVARIANT :PRECISE :SMOOTH :FLAT :NOPERSPECTIVE 47 | 48 | All other qualifiers must match by EQUAL, but don't have to be 49 | in the same order. 50 | 51 | See https://www.khronos.org/opengl/wiki/Shader_Compilation#Qualifier_matching") 52 | 53 | (function matching-specifiers-p 54 | "Returns true if the two given specifier lists are considered to match. 55 | 56 | In order to match, the two lists have to be EQUAL.") 57 | 58 | (function matching-declarators-p 59 | "Returns true if the two variable declarations are considered to match. 60 | 61 | This is true if: 62 | - The first of both lists (qualifiers) match by MATCHING-QUALIFIERS-P 63 | - The second of both lists (specifiers) match by MATCHING-SPECIFIERS-P 64 | - The fourth of both lists (array-identifiers) match by EQUAL 65 | 66 | The third of both lists (identifiers) must not match. 67 | The fifth of both lists (initializers) must not match.") 68 | 69 | (function find-layout-qualifier 70 | "Find the layout qualifier object in the qualifiers list.") 71 | 72 | (function find-direction-qualifier 73 | "Find the direction qualifier keyword in the qualifiers list.") 74 | 75 | (function handle-declaration 76 | "Handles a declaration during a shader merging operation. 77 | 78 | This will take care of registering the identifier with the global 79 | environment, substituting the name if necessary, merging the 80 | declarations if possible, and erroring if there is a severe 81 | mismatch that cannot be resolved. 82 | 83 | The merging of variable declarations is in part according to the 84 | OpenGL specification on interface matching between shader stages. 85 | More specifically, the following strategy is employed here: 86 | - If the declaration is a pipeline declaration (in/out/inout) 87 | - If it has a layout qualifier 88 | - If there is no known matching layout qualifier, register it 89 | - If there is one and the declarations match, map the name to 90 | that of the previous declaration and remove the current one 91 | - Otherwise error as there are conflicting declarations that 92 | cannot be rectified 93 | - If the identifier is already known 94 | - If the declarations of this one and the previous declaration 95 | of the same identifier match, map the name to that of the 96 | previous declaration and remove the current one 97 | - Otherwise warn about the possible mismatch and remap the 98 | current identifier to a new one 99 | - Store the identifier directly and return the AST as-is 100 | - If the identifier is already known 101 | - Remap the identifier to a new one 102 | - Otherwise store the identifier directly and return the AST as-is 103 | 104 | See https://www.khronos.org/opengl/wiki/Shader_Compilation#Interface_matching 105 | See FIND-DIRECTION-QUALIFIER 106 | See FIND-LAYOUT-QUALIFIER 107 | See MATCHING-DECLARATORS-P 108 | See MERGE-SHADERS") 109 | 110 | (function handle-identifier 111 | "Handles an identifier during a shader merging operation. 112 | 113 | This will take care of substituting the identifier if it has 114 | been remapped globally. 115 | 116 | See GLOBAL-IDENTIFIER-P 117 | See MERGE-SHADERS") 118 | 119 | (function merge-shaders 120 | "Merge the given shader ASTs into a single AST. 121 | 122 | The top-level AST nodes must be AST objects of type SHADER. 123 | 124 | The merging will attempt to conflate declarations where 125 | possible and rename variables where necessary, in order to 126 | create a single shader that is internally consistent. 127 | 128 | It also emits a single main function at the end, which 129 | does nothing but call the main function of each 130 | sub-shader in the sequence that the shaders were passed. 131 | 132 | See HANDLE-DECLARATION 133 | See HANDLE-IDENTIFIER 134 | See WALK 135 | See MERGE-SHADER-SOURCES") 136 | 137 | (function merge-shader-sources 138 | "Convenience function to merge the sources of multiple shaders into a single one. 139 | 140 | Each source may be a string, pathname, or shader AST. 141 | 142 | See PARSE 143 | See MERGE-SHADERS 144 | See SERIALIZE")) 145 | 146 | ;; method-combination.lisp 147 | (docs:define-docs 148 | (function combine-methods 149 | "Performs method combination on the listed shader parts. 150 | 151 | Each shader in SHADERS may be a string, pathname, stream, or shader AST. 152 | 153 | The method combination replicates the CLOS standard method 154 | combination, including before/after/around, call-next-method, and 155 | next-method-p. 156 | 157 | Any standard function definition is assumed to be a primary 158 | method. Before, after, and around methods can be defined by suffixing 159 | the name with @before/@after/@around, respectively. Note that aside 160 | from the suffix the function signatures (including qualifiers, return 161 | type, and argument types, but not argument names) have to match 162 | exactly, as otherwise the functions are considered separate units. 163 | 164 | Within any primary or around method body, the variable next_method_p 165 | is statically replaced with 1 or 0 depending on whether a next method 166 | is available or not, and a call to call_next_method is replaced with a 167 | call to the next method function. If no arguments are passed to 168 | call_next_method, the arguments are copied automatically. You can also 169 | make use of maybe_call_next_method, which is semantically the same as 170 | if(next_method_p) call_next_method(...); 171 | 172 | If methods are defined without a single corresponding primary method, 173 | an error is signalled. 174 | 175 | The order of method definitions is relevant in the following way: 176 | - For @before, the later methods are called *first* 177 | - For @after, the later methods are called *last* 178 | - For @around, the later methods are called *first* 179 | - For @primary, the later methods are called *first* 180 | 181 | Example: 182 | 183 | void foo@after(int x){ 1; } 184 | int foo(int y){ return 2; } 185 | int foo(int z){ 186 | if(next_method_p) return call_next_method(); 187 | return -1; 188 | } 189 | void foo@before(int w){ 0; } 190 | 191 | See PARSE")) 192 | 193 | ;; parser.lisp 194 | (docs:define-docs 195 | (variable *token-array* 196 | "Holds a vector of tokens to be processed by the parser. 197 | 198 | See PEEK 199 | See CONSUME 200 | See *TOKEN-INDEX* 201 | See WITH-TOKEN-INPUT") 202 | 203 | (variable *token-index* 204 | "Holds the index into the token array that represents the current parser position. 205 | 206 | See ADVANCE 207 | See BACKTRACK 208 | See *TOKEN-ARRAY* 209 | See WITH-TOKEN-INPUT") 210 | 211 | (variable no-value 212 | "Evaluates to itself, namely the symbol NO-VALUE 213 | 214 | Represents the absence of a value in AST objects.") 215 | 216 | (type index 217 | "Type specifier for a token index.") 218 | 219 | (function end-of-tokens-p 220 | "Returns true if the end of the token array has been reached. 221 | 222 | See *TOKEN-ARRAY* 223 | See *TOKEN-INDEX*") 224 | 225 | (function advance 226 | "Advances the current token index. 227 | 228 | See *TOKEN-INDEX* 229 | See BACKTRACK") 230 | 231 | (function backtrack 232 | "Reduces the current token index. 233 | 234 | See *TOKEN-INDEX* 235 | See ADVANCE") 236 | 237 | (function peek 238 | "Returns the token at the index relative to the current position. 239 | 240 | See *TOKEN-ARRAY* 241 | See *TOKEN-INDEX*") 242 | 243 | (function consume 244 | "Returns the token at the current index and advances the index by one. 245 | 246 | See PEEK 247 | See ADVANCE") 248 | 249 | (function with-token-input 250 | "Readies the environment for token parsing. 251 | 252 | This binds *TOKEN-ARRAY* to the given vector and binds *TOKEN-INDEX* to 0. 253 | 254 | See *TOKEN-ARRAY* 255 | See *TOKEN-INDEX*") 256 | 257 | (function rule 258 | "Returns the symbol that identifies the parsing rule of the given name. 259 | 260 | This is a place that can be set with the function object 261 | that should be used to parse the rule of the given name. 262 | 263 | If no such rule exists, an error is signalled.") 264 | 265 | (function remove-rule 266 | "Removes the parsing rule of the given name.") 267 | 268 | (function consume-whitespace 269 | "Consumes all spaces and newlines in the token array from the current position on.") 270 | 271 | (function consume-string 272 | "Attempts to consume the given string from the token array. 273 | 274 | If the string matches, it is returned. Otherwise, NIL is 275 | returned instead. If the match succeeds, the token index 276 | is modified. Otherwise it is reset to the point where it 277 | was before the match was attempted.") 278 | 279 | (function consume-any 280 | "Consume any of the tokens in the choices sequence, if possible. 281 | 282 | If a token matches, it is returned. Otherwise NIL is 283 | returned instead. The index is only modified if a match 284 | occurs.") 285 | 286 | (function consume-notany 287 | "Consume any token that is not one of the tokens in the choices sequence. 288 | 289 | If a token matches, it is returned. Otherwise NIL is 290 | returned instead. The index is only modified if a match 291 | occurs.") 292 | 293 | (function compile-rule 294 | "Compile the rule s-expression. 295 | 296 | The following types are handled specially: 297 | - NULL NIL is returned 298 | - KEYWORD Attempts to match a token that is EQ to this 299 | keyword. On success returns the keyword. 300 | - SYMBOL Attempts to match the rule given named by the 301 | symbol. Returns whatever the rule returns. 302 | - CHARACTER Attempts to match a token that is EQL to this 303 | character. Returns the character on match. 304 | - STRING Attempts to match the string against the tokens. 305 | Returns the string on successful match. 306 | - CONS One of the following compound, identified by the 307 | first symbol. 308 | - AND Matches if all of the sub-rules match. Returns 309 | the last rule's return value on successful match. 310 | - OR Matches if any of the sub-rules match. 311 | Returns the first successful rule's return value. 312 | - NOTANY Matches if none of the choices match. 313 | Returns the token that did not match. 314 | - ANY Matches if any of the choices match. 315 | Returns the token that did match. 316 | - WHEN Performs all the other sub-rules only if the 317 | first sub-rule matches. Returns the last sub-rule's 318 | return value. 319 | - V Makes sure the result of the sub-rule is added to 320 | the values list if the sub-rule matches. Returns 321 | what the sub-rule returned. 322 | - * Repeatedly matches the sub-rule as many times as 323 | possible. Returns T. 324 | - + Attempts to match the sub-rule at least once. 325 | Returns T on success. 326 | - ? Attempts to match the sub-rule. If it does not 327 | match the secondary form is returned, or NO-VALUE. 328 | - ! Evaluates the sub-rule and returns its result, but 329 | always resets the token index to its initial value. 330 | - Otherwise the rule is returned unchanged. 331 | 332 | See CONSUME-STRING 333 | See CONSUME-ANY 334 | See CONSUME-NOTANY 335 | See DEFINE-RULE") 336 | 337 | (function define-rule 338 | "Defines a new parsing rule of the given name. 339 | 340 | This will create a function definition in the 341 | ORG.SHIRAKUMO.TRIAL.GLSL.RULES package by 342 | re-interning the symbol in that package. 343 | 344 | A default lexical binding named V is provided. 345 | 346 | See DEFINE-REFERENCE 347 | See DEFINE-OBJECT") 348 | 349 | (function define-reference 350 | "Defines a reference parsing rule. 351 | 352 | The body should be a number of sub-rules that may be matched 353 | in order to match this rule. Either the value stored in V 354 | by the V function, or the return value of the first matching 355 | sub-rule is returned. 356 | 357 | See DEFINE-RULE") 358 | 359 | (function define-object 360 | "Defines a parsing object. 361 | 362 | The RULE should be a parsing rule to match against. It should 363 | probably contain calls to the V rule in order to populate the 364 | V values list. This list is used to store the return values 365 | of the object. 366 | 367 | TRANSFORM is an optional list of forms to be evaluated to 368 | transform the values list on a successful match. It acts as 369 | an implicit PROGN and the last value is returned as the value 370 | of the rule. 371 | 372 | If no TRANSFORM is given, the return value is the V values 373 | list prepended with the name of the rule. 374 | 375 | See DEFINE-RULE") 376 | 377 | (function newline-p 378 | "Returns true if the input is a newline character and thus either CR or LF.") 379 | 380 | (function normalize-shader-source 381 | "Attempts to normalise the shader source code. 382 | 383 | This does the following: 384 | - Removes any and all comments from the code 385 | - Handles the backslash-before-newline trick to get multiple 386 | lines to act as one. 387 | - Converts CRLF/LFCR/LFLF/CRCR into NEWLINE 388 | - Converts TAB to SPACE 389 | - Converts consecutive whitespace into singular whitespace 390 | while preserving newlines. 391 | 392 | The input may be one of the following types: 393 | - PATHNAME 394 | - STRING 395 | - STREAM 396 | 397 | See NEWLINE-P") 398 | 399 | (function lex 400 | "Lex the input string into a token array for use in parsing. 401 | 402 | See NORMALIZE-SHADER-SOURCE 403 | See RULE 404 | See PARSE") 405 | 406 | (function parse 407 | "Parses the given GLSL shader source input into an AST. 408 | 409 | The input may be of the following types: 410 | - STRING STREAM PATHNAME 411 | The input is lexed before parsing as by LEX 412 | - LIST 413 | The input is converted into a vector 414 | - VECTOR 415 | The input is parsed by the given toplevel parsing rule. 416 | 417 | See LEX 418 | See RULE") 419 | 420 | (variable *traced* 421 | "Hash table to hold associate names with the original function definitions.") 422 | 423 | (variable *trace-level* 424 | "Integer to represent the current stack level during tracing.") 425 | 426 | (function call-traced-function 427 | "Wrapper to output trace information around the call to the given function. 428 | 429 | See *TRACE-LEVEL* 430 | See *TRACED*") 431 | 432 | (function trace-parse-func 433 | "Ensures the given function is being traced for parsing, if it isn't already. 434 | 435 | This replaces the global function definition. 436 | 437 | See CALL-TRACED-FUNCTION 438 | See *TRACED* 439 | See UNTRACE-PARSE-FUNC") 440 | 441 | (function untrace-parse-func 442 | "Ensures the given functions restored to its original definition, if it isn't already. 443 | 444 | This replaces the global function definition. 445 | 446 | See *TRACED* 447 | See TRACE-PARSE-FUNC") 448 | 449 | (function trace-parse 450 | "Cause all parse rule functions to emit tracing information. 451 | 452 | See UNTRACE-PARSE 453 | See TRACE-PARSE-FUNC") 454 | 455 | (function untrace-parse 456 | "Make all parse rule functions cease to emit tracing information. 457 | 458 | See TRACE-PARSE 459 | See UNTRACE-PARSE-FUNC")) 460 | 461 | ;; printer.lisp 462 | (docs:define-docs 463 | (variable *serialize-stream* 464 | "The stream to which the serializing output is sent to. 465 | 466 | This has to be bound when SERIALIZE-PART is called.") 467 | 468 | (function serialize 469 | "Serializes the AST part to shader source. 470 | 471 | TO may be one of the following: 472 | - NULL 473 | The output is gathered into a string and returned. 474 | - T 475 | The output is sent to *STANDARD-OUTPUT*. 476 | - STREAM 477 | The output is sent to this stream. 478 | - PATHNAME 479 | The output is written to the file. If the file already 480 | exists, an error is signalled. 481 | 482 | See *SERIALIZE-STREAM* 483 | See SERIALIZE-PART") 484 | 485 | (function sformat 486 | "Convenience function used to format to the serializing stream. 487 | 488 | A special format directive ~O is provided as well, which 489 | causes SERIALIZE-PART to be called on the respective object.") 490 | 491 | (function %format-object 492 | "Helper function to call SERIALIZE-PART in a format string.") 493 | 494 | (variable *indent* 495 | "Variable to represent the current indenting level. 496 | 497 | See WITH-INDENTATION 498 | See INDENT") 499 | 500 | (function with-indentation 501 | "Makes sure the body is evaluated with an increased indentation level. 502 | 503 | See *INDENT* 504 | See INDENT") 505 | 506 | (function indent 507 | "Starts a fresh line and emits as many spaces as the *INDENT* variable dictates.") 508 | 509 | (function compile-format-string 510 | "Rewrite the format string so that the ~O directive is acceptable.") 511 | 512 | (variable *serializers* 513 | "Hash table associating AST object types to serializer functions. 514 | 515 | The function must accept a single argument, which is the 516 | AST object itself. 517 | 518 | See SERIALIZER 519 | See REMOVE-SERIALIZER") 520 | 521 | (function serializer 522 | "Accessor to the serializing function for AST objects of the given type. 523 | 524 | See *SERIALIZERS* 525 | See DEFINE-SERIALIZER 526 | See REMOVE-SERIALIZER") 527 | 528 | (function remove-serializer 529 | "Removes the serializer function for AST objects of the given type. 530 | 531 | See *SERIALIZERS* 532 | See SERIALIZER") 533 | 534 | (function define-serializer 535 | "Convenience function to define a serializer function for AST objects of the given type. 536 | 537 | See SERIALIZER") 538 | 539 | (function define-serialization 540 | "Convenience function to define the serialization of AST objects of the given type. 541 | 542 | ARGS must be a lambda-list to destructure the contents of the 543 | AST object. 544 | 545 | See SERIALIZER") 546 | 547 | (function serialize-part 548 | "Serializes the AST part. 549 | 550 | This appropriately handles all values that can be contained in the AST. 551 | For AST objects, an appropriate serializer function is called if possible. 552 | Should an unknown AST object occur, an error is signalled. 553 | 554 | See SERIALIZER")) 555 | 556 | ;; toolkit.lisp 557 | (docs:define-docs 558 | (function enlist 559 | "Ensures that LIST is a list. 560 | 561 | If it is not, it is combined with ITEMS to form a list.") 562 | 563 | (function mapcar* 564 | "Like CL:MAPCAR, but only gathers non-NIL results.") 565 | 566 | (function find-any 567 | "Like CL:FIND, but the item to find is a sequence of things that can be found.") 568 | 569 | (function merge-plists 570 | "Merges the two plists together by appending their values for the same keys. 571 | 572 | Returns a fresh plist.") 573 | 574 | (variable *glsl-keywords* 575 | "List to all the keywords in GLSL shader files. 576 | 577 | This does not include terminals and other keywords 578 | such as {}/*+ etc.") 579 | 580 | (variable *glsl-keyword-symbols* 581 | "List to all the keywords in GLSL shader files but as interned and upcased keyword symbols. 582 | 583 | See *GLSL-KEYWORDS*")) 584 | 585 | ;; walker.lisp 586 | (docs:define-docs 587 | (type environment 588 | "Struct to hold information about the lexical environment during code walking. 589 | 590 | See MAKE-ENVIRONMENT 591 | See ROOT 592 | See BINDINGS") 593 | 594 | (function %make-environment 595 | "Construct a new environment object. 596 | 597 | See ENVIRONMENT 598 | See MAKE-ENVIRONMENT") 599 | 600 | (function root 601 | "Accessor to the root environment. 602 | 603 | The root environment is the top-level lexical environment that 604 | holds all global definitions. On root environments, this must 605 | resolve to the environment instance itself. 606 | 607 | See ENVIRONMENT") 608 | 609 | (function bindings 610 | "Accessor to the table associating identifiers to bindings. 611 | 612 | The values must be lists where the first item is a keyword 613 | that identifies the type of binding as either a :FUNCTION 614 | or :VARIABLE binding. 615 | 616 | See ENVIRONMENT 617 | See BINDING") 618 | 619 | (function binding 620 | "Accessor to the binding in the environment for the given name. 621 | 622 | See BINDINGS 623 | See ENVIRONMENT") 624 | 625 | (function make-environment 626 | "Create a new environment object. 627 | 628 | If not parent environment is passed in, the environment is 629 | assumed to be a top-level root environment. 630 | 631 | See ENVIRONMENT") 632 | 633 | (function root-environment-p 634 | "Returns T if the environment is a top-level root environment. 635 | 636 | See ENVIRONMENT 637 | See ROOT") 638 | 639 | (function preprocessor-p 640 | "Returns T if the given AST node is a preprocessor instruction.") 641 | 642 | (function constant-p 643 | "Returns T if the given AST node is a constant value.") 644 | 645 | (function declaration-p 646 | "Returns T if the given AST node is a declaration statement.") 647 | 648 | (function expression-p 649 | "Returns T if the given AST node is an expression.") 650 | 651 | (function control-flow-p 652 | "Returns T if the given AST node is a control-flow instruction.") 653 | 654 | (function keyword-p 655 | "Returns T if the given AST node is a GLSL keyword. 656 | 657 | See *GLSL-KEYWORD-SYMBOLS*") 658 | 659 | (function statement-p 660 | "Returns T if the given AST node is a statement. 661 | 662 | See DECLARATION-P 663 | See EXPRESSION-P 664 | See CONTROL-FLOW-P") 665 | 666 | (function identifier-p 667 | "Returns T if the given AST node might be an identifier. 668 | 669 | This is not always accurate, as some identifiers can also be 670 | types at the same time. It thus depends on the context.") 671 | 672 | (function global-identifier-p 673 | "Returns T if the given AST node is an identifier that refers to a global definition.") 674 | 675 | (function local-identifier-p 676 | "Returns T if the given AST node is an identifier that refers to a local definition.") 677 | 678 | (function variable-identifier-p 679 | "Returns T if the given AST node is an identifier for a variable.") 680 | 681 | (function function-identifier-p 682 | "Returns T if the given AST node is an identifier for a function.") 683 | 684 | (function walk 685 | "Walk over the AST, calling FUNCTION on each interesting node. 686 | 687 | Returns a fresh AST that was constructed by the function. 688 | 689 | The function will be called with three arguments: 690 | - The AST node at the current point 691 | - The surrounding context in which the AST node is 692 | - The environment object that maintains lexical information 693 | 694 | The function should return a single value, which is the 695 | value that should be put into a fresh AST in place of the 696 | original node. 697 | 698 | Note that calling any of the environment inspection functions 699 | on an identifier in a lower level than the current AST node 700 | that the function received is not going to work. The lexical 701 | information is only guaranteed to be ready by the time the 702 | function is called with the identifier itself. 703 | 704 | See ROOT-ENVIRONMENT-P 705 | See PREPROCESSOR-P 706 | See CONSTANT-P 707 | See DECLARATION-P 708 | See EXPRESSION-P 709 | See CONTROL-FLOW-P 710 | See KEYWORD-P 711 | See STATEMENT-P 712 | See IDENTIFIER-P 713 | See GLOBAL-IDENTIFIER-P 714 | See LOCAL-IDENTIFIER-P 715 | See VARIABLE-IDENTIFIER-P 716 | See FUNCTION-IDENTIFIER-P 717 | See ENVIRONMENT 718 | See WALK-PART") 719 | 720 | (function walk-part 721 | "Walk over the given AST node. 722 | 723 | On AST objects, this will call out to the respective 724 | walker function. 725 | 726 | See WALKER") 727 | 728 | (variable *walkers* 729 | "Hash table associating AST object types to walker functions. 730 | 731 | A walker function must accept three arguments: 732 | - The AST object to process 733 | - The function that should walk over the AST 734 | - The current lexical environment 735 | It must return an AST object to use in place of the 736 | current one in the resulting AST. 737 | 738 | See WALKER 739 | See REMOVE-WALKER 740 | See DEFINE-WALKER") 741 | 742 | (function walker 743 | "Accessor to the walker function for AST objects of the given type. 744 | 745 | See *WALKERS* 746 | See REMOVE-WALKER 747 | See DEFINE-WALKER") 748 | 749 | (function remove-walker 750 | "Removes the walker function for AST objects of the given type. 751 | 752 | See WALKER 753 | See *WALKERS*") 754 | 755 | (function define-walker 756 | "Define a new walker function that is responsible for walking over a particular type of AST object node. 757 | 758 | See *WALKERS* 759 | See WALKER 760 | See DEFINE-WALKING-BODY") 761 | 762 | (function define-walking-body 763 | "Convenience definition macro. 764 | 765 | The ARGS should be a destructuring-bind lambda-list to 766 | destructure the contents of the object. 767 | 768 | The body should be forms that provide the values to use in the 769 | resulting AST object. The last value should be the tail of the 770 | object's list. Thus this is about equivalent to 771 | 772 | (define-walker type (o) 773 | (destructuring-bind .. (o) 774 | (list* 'type body))) 775 | 776 | Within the body the WALK function is rebound to one that can 777 | be conveniently used to recursively walk the AST. It only needs 778 | the new node to walk over. It optionally takes a new environment 779 | to supply. 780 | 781 | You can reach the other function values like the full AST, the 782 | walk function, and the environment by changing the type to a 783 | list and providing the binding symbols as keyword arguments in 784 | it with :KEY :FUNC and :ENV. 785 | 786 | See DEFINE-WALKER") 787 | 788 | (function define-empty-op-walker 789 | "Define a walker for an empty AST object. 790 | 791 | This walker function does nothing but construct a fresh return 792 | value.") 793 | 794 | (function define-unary-op-walker 795 | "Define a walker for a unary AST object. 796 | 797 | This walker recurses over the single node in the object 798 | and returns a fresh value constructed from it.") 799 | 800 | (function define-binary-op-walker 801 | "Define a walker for a binary AST object. 802 | 803 | This walker recurses over the left and right nodes in the object 804 | and returns a fresh value constructed from them.")) 805 | -------------------------------------------------------------------------------- /glsl-toolkit.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem glsl-toolkit 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "A library to parse and modify OpenGL Shader Language (GLSL) source code" 7 | :homepage "https://shirakumo.org/docs/glsl-toolkit/" 8 | :bug-tracker "https://shirakumo.org/project/glsl-toolkit/issues" 9 | :source-control (:git "https://shirakumo.org/project/glsl-toolkit.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "toolkit") 13 | (:file "parser") 14 | (:file "grammar") 15 | (:file "printer") 16 | (:file "walker") 17 | (:file "merge") 18 | (:file "sexpr") 19 | (:file "transform") 20 | (:file "method-combination") 21 | (:file "documentation")) 22 | :depends-on (:documentation-utils 23 | :parse-float 24 | :trivial-indent 25 | :cl-ppcre)) 26 | -------------------------------------------------------------------------------- /grammar.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | ;;; Lexer 4 | (define-reference whitespace 5 | #\Linefeed #\Return #\Space #\Tab) 6 | 7 | (define-object integer-token 8 | (and (v (or decimal-token 9 | hexadecimal-token 10 | octal-token)) 11 | (v (? (any "uU") "s")))) 12 | 13 | (define-object decimal-token 14 | (or (and (v (any "123456789")) (* (v (any "0123456789"))))) 15 | (parse-integer (coerce v 'string) :radix 10)) 16 | 17 | (define-object octal-token 18 | (and (v (any "0")) (* (v (any "01234567")))) 19 | (parse-integer (coerce v 'string) :radix 8)) 20 | 21 | (define-object hexadecimal-token 22 | (and "0x" (* (v (any "0123456789abcdefABCDEF")))) 23 | (parse-integer (coerce v 'string) :radix 16)) 24 | 25 | (define-object float-token 26 | (and (or (and (+ (v (any "0123456789"))) (v #\.) (* (v (any "0123456789")))) 27 | (and (* (v (any "0123456789"))) (v #\.) (+ (v (any "0123456789"))))) 28 | (? (when (v (any "eE")) (v (any "+-")) (* (v (any "0123456789"))))) 29 | (v (? (or "f" "F" "lf" "LF") "f"))) 30 | (let ((type (if (string-equal "f" (car (last v))) 31 | 'single-float 'double-float))) 32 | (parse-float:parse-float (coerce (butlast v) 'string) :type type))) 33 | 34 | (define-object identifier-token 35 | (and (v (any "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_@")) 36 | (* (v (any "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789@")))) 37 | (coerce v 'string)) 38 | 39 | (define-object keyword-token 40 | (and (v #.(list* 'or *glsl-keywords*)) 41 | (! (or whitespace operator))) 42 | (intern (string-upcase (first v)) :keyword)) 43 | 44 | (define-object preprocessor-token 45 | (and (v #\#) (* (v (notany (#\Return #\Linefeed))))) 46 | (list 'preprocessor-directive (coerce v 'string))) 47 | 48 | (defmacro define-operator-objects (&body names) 49 | `(progn 50 | ,@(loop for name in names 51 | collect `(define-object ,name ,(string name) ,(intern (string name) :keyword))) 52 | (define-reference operator 53 | ,@names))) 54 | 55 | (define-operator-objects 56 | == != = += -= *= /= %= <<= >>= &= ^= \|= 57 | ++ -- << >> ^^ \|\| && <= >= < > 58 | + - * / % & ^ ! \| 59 | \( \) \[ \] \{ \} \; \. ? \: \,) 60 | 61 | (define-reference token 62 | (and (* whitespace) 63 | (or keyword-token 64 | identifier-token 65 | float-token 66 | integer-token 67 | operator 68 | preprocessor-token))) 69 | 70 | (define-object tokenize 71 | (* (v token)) 72 | v) 73 | 74 | ;;; Parser 75 | (define-object integer-constant 76 | (and (consp (peek)) 77 | (integerp (second (peek)))) 78 | (destructuring-bind (type int sign) (consume) 79 | (declare (ignore type)) 80 | (if (string= "s" sign) 81 | int 82 | `(unsigned-int ,int)))) 83 | 84 | (define-object float-constant 85 | (floatp (peek)) 86 | (consume)) 87 | 88 | (define-object boolean-constant 89 | (v (or :true :false)) 90 | (first v)) 91 | 92 | (define-object identifier 93 | (and (not (end-of-tokens-p)) (stringp (peek))) 94 | (consume)) 95 | 96 | (define-object preprocessor-directive 97 | (and (consp (peek)) 98 | (stringp (second (peek)))) 99 | (consume)) 100 | 101 | (define-reference primary-expression 102 | integer-constant 103 | float-constant 104 | boolean-constant 105 | (and :\( (v expression) :\)) 106 | identifier 107 | basic-type) 108 | 109 | (define-reference postfix-expression 110 | modified-reference 111 | primary-expression) 112 | 113 | (define-object modified-reference 114 | (and (v primary-expression) 115 | (v reference-modifier) 116 | (* (v reference-modifier)))) 117 | 118 | (define-reference reference-modifier 119 | call-modifier 120 | field-modifier 121 | array-modifier 122 | increment-modifier 123 | decrement-modifier) 124 | 125 | (define-object field-modifier 126 | (and :\. (v identifier))) 127 | 128 | (define-object array-modifier 129 | (and :\[ (v expression) :\])) 130 | 131 | (define-object increment-modifier 132 | :++) 133 | 134 | (define-object decrement-modifier 135 | :--) 136 | 137 | (define-object call-modifier 138 | (and :\( (or :void 139 | (? (and (v assignment-expression) 140 | (* (and :\, (v assignment-expression)))))) 141 | :\))) 142 | 143 | (define-object same-+ 144 | (and :+ (v unary-expression))) 145 | 146 | (define-object negation 147 | (and :- (v unary-expression))) 148 | 149 | (define-object inversion 150 | (and :! (v unary-expression))) 151 | 152 | (define-object bit-inversion 153 | (and :~ (v unary-expression))) 154 | 155 | (define-object prefix-increment 156 | (and :++ (v unary-expression))) 157 | 158 | (define-object prefix-decrement 159 | (and :-- (v unary-expression))) 160 | 161 | (define-reference unary-expression 162 | postfix-expression 163 | prefix-increment 164 | prefix-decrement 165 | same-+ 166 | negation 167 | inversion 168 | bit-inversion) 169 | 170 | (defmacro define-binary-op (name left op right) 171 | `(define-object ,name 172 | (and (v ,left) (? (and ,op (v ,right)))) 173 | (if (second v) 174 | (list* ',name v) 175 | (first v)))) 176 | 177 | (define-binary-op multiplication 178 | unary-expression :* multiplication) 179 | 180 | (define-binary-op division 181 | multiplication :/ division) 182 | 183 | (define-binary-op modulus 184 | division :% modulus) 185 | 186 | (define-binary-op addition 187 | modulus :+ addition) 188 | 189 | (define-binary-op subtraction 190 | addition :- subtraction) 191 | 192 | (define-binary-op left-shift 193 | subtraction :<< left-shift) 194 | 195 | (define-binary-op right-shift 196 | left-shift :>> right-shift) 197 | 198 | (define-binary-op less-than 199 | right-shift :< less-than) 200 | 201 | (define-binary-op greater-than 202 | less-than :> greater-than) 203 | 204 | (define-binary-op less-equal-than 205 | greater-than :<= less-equal-than) 206 | 207 | (define-binary-op greater-equal-than 208 | less-equal-than :>= greater-equal-than) 209 | 210 | (define-binary-op equal 211 | greater-equal-than :== equal) 212 | 213 | (define-binary-op not-equal 214 | equal :!= not-equal) 215 | 216 | (define-binary-op bitwise-and 217 | not-equal :& bitwise-and) 218 | 219 | (define-binary-op exclusive-or 220 | bitwise-and :^ exclusive-or) 221 | 222 | (define-binary-op inclusive-or 223 | exclusive-or :\| inclusive-or) 224 | 225 | (define-binary-op logical-and 226 | inclusive-or :&& logical-and) 227 | 228 | (define-binary-op logical-xor 229 | logical-and :^^ logical-xor) 230 | 231 | (define-binary-op logical-or 232 | logical-xor :\|\| logical-or) 233 | 234 | (define-reference conditional-expression 235 | conditional 236 | logical-or) 237 | 238 | (define-object conditional 239 | (and (v logical-or) :? (v expression) :\: (v assignment-expression))) 240 | 241 | (define-reference assignment-expression 242 | assignment 243 | conditional-expression) 244 | 245 | (define-object assignment 246 | (and (v unary-expression) 247 | (v (or := :*= :/= :%= :+= :<<= :>>= :-= :&= :^= :\|=)) 248 | (v assignment-expression))) 249 | 250 | (define-reference expression 251 | assignment-expression 252 | multiple-expressions) 253 | 254 | (define-object multiple-expressions 255 | (and (v assignment-expression (+ (and :\, (v assignment-expression)))))) 256 | 257 | (define-reference constant-expression 258 | conditional-expression) 259 | 260 | (define-reference declaration 261 | (or function-declaration 262 | variable-declaration 263 | precision-declaration 264 | interface-declaration 265 | struct-declaration)) 266 | 267 | (define-object function-declaration 268 | (and (v function-prototype) :\;)) 269 | 270 | (define-object function-prototype 271 | (and (v (? type-qualifier)) (v type-specifier) (v identifier) 272 | :\( (? (v parameter-declaration)) (* (and :\, (v parameter-declaration))) :\))) 273 | 274 | (define-object parameter-declaration 275 | (and (? (v type-qualifier)) (v type-specifier) 276 | (? (v identifier)) (? (v array-specifier))) 277 | v) 278 | 279 | (define-object precision-declaration 280 | (and :precision (v (or :highp :mediump :lowp)) (v type-specifier) :\;)) 281 | 282 | (define-object variable-declaration 283 | (and (v (? type-qualifier)) (v type-specifier) 284 | (v variable-initializer) (* (and :\, (v variable-initializer))) 285 | :\;) 286 | (destructuring-bind (qualifier specifier &rest initializers) v 287 | (if (rest initializers) 288 | (list* 'multiple-statements 289 | (loop for initializer in initializers 290 | collect (list* 'variable-declaration qualifier specifier initializer))) 291 | (list* 'variable-declaration qualifier specifier (first initializers))))) 292 | 293 | (define-object variable-initializer 294 | (and (v identifier) (v (? array-specifier)) (? (v (and := initializer)))) 295 | v) 296 | 297 | (define-reference invariant-qualifier 298 | :invariant) 299 | 300 | (define-reference interpolation-qualifier 301 | (any (:smooth :flat :noperspective))) 302 | 303 | (define-object layout-qualifier 304 | (and :layout :\( (v layout-qualifier-id) (* (and :\, (v layout-qualifier-id))) :\))) 305 | 306 | (define-object layout-qualifier-id 307 | (or (v (any (:shared :packed :std140 :std430 :row_major :column_major 308 | :triangles :quads :isolines :equal_spacing :fractional_even_spacing 309 | :fractional_odd_spacing :cw :ccw :point_mode :points :lines :line_adjacency 310 | :triangles :triangles_adjaceney :origin_upper_left :pixel_center_integer 311 | :early_fragment_tests :line_strip :triangle_strip :depth_any :depth_greater 312 | :depth_less :depth_unchanged))) 313 | (and (v identifier) (? (and := (v constant-expression)))))) 314 | 315 | (define-reference precise-qualifier 316 | :precise) 317 | 318 | (define-reference storage-qualifier 319 | (any (:const :inout :in :out :centroid :patch :sample 320 | :uniform :buffer :shared :coherent :volatile 321 | :restrict :readonly :writeonly))) 322 | 323 | (define-object subroutine-qualifier 324 | (and :subroutine (? (and :\( (v type-name) :\))))) 325 | 326 | (define-reference precision-qualifier 327 | (any (:highp :mediump :lowp))) 328 | 329 | (define-object type-qualifier 330 | (+ (v (or storage-qualifier 331 | subroutine-qualifier 332 | layout-qualifier 333 | precision-qualifier 334 | interpolation-qualifier 335 | invariant-qualifier 336 | precise-qualifier)))) 337 | 338 | (define-object type-specifier 339 | (and (v type-specifier-nonarray) (? (v array-specifier)))) 340 | 341 | (define-object array-specifier 342 | (+ (and :\[ (? (v constant-expression)) :\])) 343 | (list* 'array-specifier v)) 344 | 345 | (define-reference type-specifier-nonarray 346 | basic-type 347 | struct-specifier 348 | type-name) 349 | 350 | (define-object type-name 351 | (v identifier)) 352 | 353 | (define-reference basic-type 354 | (any (;; Transparent Types 355 | :void :bool :int :uint :float :double 356 | :vec2 :vec3 :vec4 :mat2 :mat3 :mat4 357 | :bvec2 :bvec3 :bvec4 :ivec2 :ivec3 :ivec4 358 | :uvec2 :uvec3 :uvec4 :dvec2 :dvec3 :dvec4 359 | :mat2x2 :mat2x3 :mat2x4 :mat3x2 :mat3x3 :mat3x4 360 | :mat4x2 :mat4x3 :mat4x4 :dmat2 :dmat3 :dmat4 361 | :dmat2x2 :dmat2x3 :dmat2x4 :dmat3x2 362 | :dmat3x3 :dmat3x4 :dmat4x2 :dmat4x3 :dmat4x4 363 | ;; Floating-Point Opaque Types 364 | :sampler1DShadow 365 | :sampler1D :image1D 366 | :sampler2D :image2D 367 | :sampler3D :image3D 368 | :samplerCube :imageCube 369 | :sampler2DRect :image2DRect 370 | :sampler1DArray :image1DArray 371 | :sampler2DArray :image2DArray 372 | :samplerBuffer :imageBuffer 373 | :sampler2DMS :image2DMS 374 | :sampler2DMSArray :image2DMSArray 375 | :samplerCubeArray :imageCubeArray 376 | :sampler2DShadow :smapler2DRectShadow 377 | :sampler1DArrayShadow :sampler2DArrayShadow 378 | :samplerCubeShadow :samplerCubeArrayShadow 379 | ;; Signed Integer Opaque Types 380 | :isampler1D :iimage1D 381 | :isampler2D :iimage2D 382 | :isampler3D :iimage3D 383 | :isamplerCube :iimageCube 384 | :isampler2DRect :iimage2DRect 385 | :isampler1DArray :iimage1DArray 386 | :isampler2DArray :iimage2DArray 387 | :isamplerBuffer :iimageBuffer 388 | :isampler2DMS :iimage2DMS 389 | :isampler2DMSArray :iimage2DMSArray 390 | :isamplerCubeArray :iimageCubeArray 391 | ;; Unsigned Integer Opaque Types 392 | :usampler1D :uimage1D 393 | :usampler2D :uimage2D 394 | :usampler3D :uimage3D 395 | :usamplerCube :uimageCube 396 | :usampler2DRect :uimage2DRect 397 | :usampler1DArray :uimage1DArray 398 | :usampler2DArray :uimage2DArray 399 | :usamplerBuffer :uimageBuffer 400 | :usampler2DMS :uimage2DMS 401 | :usampler2DMSArray :uimage2DMSArray 402 | :usamplerCubeArray :uimageCubeArray 403 | :atomic_uint))) 404 | 405 | (define-object struct-specifier 406 | (and :struct (v identifier))) 407 | 408 | (define-object struct-declaration 409 | (and :struct (v (? identifier)) 410 | (? (and :\{ (+ (v struct-declarator)) :\})) (v (? instance-name)) 411 | :\;) 412 | `(struct-declaration 413 | ,(first v) 414 | ,(when (cdr v) (car (last v))) 415 | ,@(loop for declarator in (butlast (rest v)) 416 | for (qualifier specifier . fields) = (rest declarator) 417 | appending (loop for field in fields 418 | collect (list* 'struct-declarator qualifier specifier field))))) 419 | 420 | (define-object struct-declarator 421 | (and (v (? type-qualifier)) (v type-specifier) 422 | (v struct-field-declarator) (* (and :\, (v struct-field-declarator))) :\;)) 423 | 424 | (define-object struct-field-declarator 425 | (and (v identifier) (? (v array-specifier))) 426 | v) 427 | 428 | (define-object interface-declaration 429 | (and (v (? type-qualifier)) 430 | (? (and (v identifier) :\{ (* (v struct-declarator)) :\} (v (? instance-name)))) 431 | :\;) 432 | `(interface-declaration 433 | ,(first v) 434 | ,(second v) 435 | ,(when (cddr v) (car (last v))) 436 | ,@(loop for declarator in (cddr (butlast v)) 437 | for (qualifier specifier . fields) = (rest declarator) 438 | appending (loop for field in fields 439 | collect (list* 'struct-declarator qualifier specifier field))))) 440 | 441 | (define-object instance-name 442 | (and (v identifier) (? (v array-specifier)))) 443 | 444 | (define-reference initializer 445 | array-initializer 446 | assignment-expression) 447 | 448 | (define-object array-initializer 449 | (and (v type-specifier-nonarray) :\[ :\] :\( (? (v initializer)) (* (and :\, (v initializer))) (? :\,) :\))) 450 | 451 | (define-reference statement 452 | simple-statement 453 | compound-statement 454 | preprocessor-directive) 455 | 456 | (define-reference simple-statement 457 | declaration 458 | expression-statement 459 | selection-statement 460 | switch-statement 461 | case-label 462 | iteration-statement 463 | jump-statement 464 | :\;) 465 | 466 | (define-object compound-statement 467 | (or (and :\{ (* (v statement)) :\}) 468 | (v simple-statement))) 469 | 470 | (define-reference expression-statement 471 | (and (v expression) :\;)) 472 | 473 | (define-object selection-statement 474 | (and :if :\( (v expression) :\) (v compound-statement) 475 | (? (and :else (v compound-statement))))) 476 | 477 | (define-reference condition 478 | expression 479 | condition-declarator) 480 | 481 | (define-object condition-declarator 482 | (and (v (? type-qualifier)) (v type-specifier) 483 | (v identifier) := (v initializer))) 484 | 485 | (define-object switch-statement 486 | (and :switch :\( (v expression) :\) 487 | (v compound-statement))) 488 | 489 | (define-object case-label 490 | (or (and :case (v expression) :\:) 491 | (and (v :default) :\:))) 492 | 493 | (define-reference iteration-statement 494 | while-statement 495 | do-statement 496 | for-statement) 497 | 498 | (define-object while-statement 499 | (and :while :\( (v condition) :\) (v compound-statement))) 500 | 501 | (define-object do-statement 502 | (and :do (v compound-statement) :while :\( (v expression) :\) :\;)) 503 | 504 | (define-object for-statement 505 | (and :for :\( 506 | (v (or expression-statement declaration)) 507 | (v (? condition)) :\; 508 | (v (? expression)) :\) 509 | (v compound-statement))) 510 | 511 | (define-reference jump-statement 512 | continue 513 | break 514 | return 515 | discard) 516 | 517 | (define-object continue 518 | (and :continue :\;)) 519 | 520 | (define-object break 521 | (and :break :\;)) 522 | 523 | (define-object return 524 | (and :return (? (v expression)) :\;)) 525 | 526 | (define-object discard 527 | (and :discard :\;)) 528 | 529 | (define-object function-definition 530 | (and (v function-prototype) (v compound-statement))) 531 | 532 | (define-object shader 533 | (* (or (v (or declaration function-definition preprocessor-directive)) 534 | :\;))) 535 | -------------------------------------------------------------------------------- /merge.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | (defvar *unique-counter* 0) 4 | 5 | (defun uniquify (table &optional name) 6 | (cl-ppcre:register-groups-bind (realname) ("^_GLSLTK_(.*)_\\d+$" name) 7 | (setf name realname)) 8 | (loop for ident = (format NIL "_GLSLTK_~@[~a_~]~d" name (incf *unique-counter*)) 9 | unless (gethash ident table) 10 | do (return ident))) 11 | 12 | (defun matching-qualifiers-p (a b) 13 | (let ((irrelevant '(:highp :mediump :lowp :invariant :precise :smooth :flat :noperspective))) 14 | (null (set-difference 15 | (set-difference a irrelevant) 16 | (set-difference b irrelevant) 17 | :test #'equal)))) 18 | 19 | (defun matching-specifiers-p (a b) 20 | (equal a b)) 21 | 22 | (defun matching-declarators-p (a b) 23 | (and (matching-qualifiers-p (first a) (first b)) 24 | (matching-specifiers-p (second a) (second b)) 25 | (equal (fourth a) (fourth a)))) 26 | 27 | (defun find-layout-qualifier (qualifiers) 28 | (find 'layout-qualifier qualifiers :key (lambda (a) (if (listp a) (first a) a)))) 29 | 30 | (defun find-direction-qualifier (qualifiers) 31 | (unless (eql no-value qualifiers) 32 | (find-any '(:in :out :inout :uniform) qualifiers))) 33 | 34 | (defun find-matching-layout-declaration (qualifiers declarations) 35 | (find (find-layout-qualifier qualifiers) 36 | (loop with direction = (find-direction-qualifier qualifiers) 37 | for declaration in declarations 38 | when (find direction (first declaration)) 39 | collect declaration) 40 | :test #'equal :key (lambda (a) (find-layout-qualifier (first a))))) 41 | 42 | ;; See https://www.khronos.org/opengl/wiki/Shader_Compilation#Interface_matching 43 | ;; it has some notes on how variables are matched up between shader stages. 44 | ;; We imitate that behaviour, to a degree. We don't match up the same types, 45 | ;; as that would probably lead to confusing merges in most cases. 46 | (defun handle-declaration (ast context environment global-env) 47 | (declare (ignore context)) 48 | (unless (root-environment-p environment) 49 | (return-from handle-declaration ast)) 50 | (flet ((store-identifier (from &optional (to from)) 51 | (setf (gethash from global-env) 52 | (if (loop for v being the hash-values of global-env 53 | thereis (equal v from)) 54 | (uniquify global-env to) 55 | to)))) 56 | (case (first ast) 57 | (function-declaration 58 | ast) 59 | (function-definition 60 | (let ((ident (fourth (second ast)))) 61 | (cond ((string= ident "main") 62 | (push (setf (gethash ident global-env) (uniquify global-env ident)) 63 | (gethash 'main global-env))) 64 | (T ;; FIXME: handle overloaded functions 65 | (store-identifier ident)))) 66 | ast) 67 | (struct-declaration 68 | (store-identifier `(:struct ,(second ast))) 69 | ast) 70 | (precision-declaration 71 | ast) 72 | ;; FIXME!!!! 73 | (interface-declaration 74 | ast) 75 | (variable-declaration 76 | (cond ((find-direction-qualifier (second ast)) 77 | (destructuring-bind (qualifiers specifiers identifier array &optional init) (rest ast) 78 | (cond ((find-layout-qualifier qualifiers) 79 | (let ((matching (find-matching-layout-declaration 80 | qualifiers 81 | (gethash 'declarations global-env)))) 82 | (cond ((not matching) 83 | (push (rest ast) (gethash 'declarations global-env)) 84 | ast) 85 | ((matching-declarators-p matching (rest ast)) 86 | (unless (equal init (fifth matching)) 87 | (warn "Mismatched initializers between duplicate variable declarations:~% ~a~% ~a" 88 | (serialize `(variable-declaration ,@matching) NIL) 89 | (serialize ast NIL))) 90 | (setf (gethash identifier global-env) (third matching)) 91 | (setf (binding identifier environment) (list :variable qualifiers specifiers array)) 92 | ;; We already have this declaration. 93 | NIL) 94 | (T 95 | (error "Found two mismatched declarations with the same layout qualifier:~% ~a~% ~a" 96 | (serialize `(variable-declaration ,@matching) NIL) 97 | (serialize ast NIL)))))) 98 | ((gethash identifier global-env) 99 | (let ((matching (find identifier 100 | (gethash 'declarations global-env) 101 | :test #'equal :key #'third))) 102 | (cond ((matching-declarators-p matching (rest ast)) 103 | (unless (equal init (fifth matching)) 104 | (warn "Mismatched initializers between duplicate variable declarations:~% ~a~% ~a" 105 | (serialize `(variable-declaration ,@matching) NIL) 106 | (serialize ast NIL))) 107 | (setf (gethash identifier global-env) (third matching)) 108 | (setf (binding identifier environment) (list :variable qualifiers specifiers array)) 109 | ;; We /probably/ already have this declaration. 110 | NIL) 111 | (T 112 | (error "Found two mismatched declarations with the same identifier:~% ~a~% ~a" 113 | (ignore-errors (serialize `(variable-declaration ,@matching) NIL)) 114 | (serialize ast NIL)) 115 | (store-identifier identifier) 116 | ast)))) 117 | (T 118 | (push (rest ast) (gethash 'declarations global-env)) 119 | (store-identifier identifier) 120 | ast)))) 121 | (T 122 | (store-identifier (fourth ast)) 123 | ast)))))) 124 | 125 | (defun handle-identifier (ast context environment global-env) 126 | (or (when (global-identifier-p ast environment) 127 | (case (first context) 128 | (struct-specifier (gethash `(:struct ,ast) global-env)) 129 | (struct-declarator ast) 130 | (field-modifier ast) 131 | (T (gethash ast global-env)))) 132 | ast)) 133 | 134 | (defun split-shader-into-groups (shader) 135 | (let ((groups (list 'precision-declaration () 136 | 'variable-declaration () 137 | 'struct-declaration () 138 | 'function-declaration () 139 | 'function-definition () 140 | 'interface-declaration ()))) 141 | (flet ((walker (ast context environment) 142 | (declare (ignore context)) 143 | (when (declaration-p ast environment) 144 | (push ast (getf groups (first ast)))) 145 | ast)) 146 | (walk shader #'walker)) 147 | groups)) 148 | 149 | ;; FIXME: track use relations to reorder definitions properly 150 | (defun merge-shaders (shaders &key (min-version "120") profile) 151 | (let ((*unique-counter* 0) 152 | (global-env (make-hash-table :test 'equal)) 153 | (version min-version) 154 | (extensions ())) 155 | (flet ((walker (ast context environment) 156 | (cond ((declaration-p ast environment) 157 | (handle-declaration ast context environment global-env)) 158 | ((stringp ast) 159 | (handle-identifier ast context environment global-env)) 160 | ((preprocessor-p ast environment) 161 | (cond ((starts-with "#version" (second ast)) 162 | (cl-ppcre:register-groups-bind (v NIL p) ("#version (\\d{3})( (.*))?" (second ast)) 163 | (when (or (null version) (< (parse-integer version) (parse-integer v))) 164 | (setf version v)) 165 | (when p 166 | (when (and profile (string/= profile p)) 167 | (warn "Incompatible OpenGL profiles requested: ~a and ~a." 168 | profile p)) 169 | (setf profile p)) 170 | NIL)) 171 | ((starts-with "#extension" (second ast)) 172 | (push ast extensions) 173 | NIL) 174 | (T ast))) 175 | (T 176 | ast)))) 177 | (let ((results (loop for shader in shaders 178 | appending (rest (walk shader #'walker))))) 179 | (append '(shader) 180 | (when version 181 | `((preprocessor-directive 182 | ,(format NIL "#version ~a~@[ ~a~]" version profile)))) 183 | (nreverse extensions) 184 | results 185 | `((function-definition 186 | (function-prototype 187 | ,no-value :void "main") 188 | (compound-statement 189 | ,@(loop for main in (nreverse (gethash 'main global-env)) 190 | collect `(modified-reference ,main (call-modifier))))))))))) 191 | 192 | (defun merge-shader-sources (sources &key to (min-version "120") profile) 193 | (serialize (merge-shaders 194 | (loop for source in (enlist sources) 195 | collect (typecase source 196 | (cons source) 197 | (T (parse source)))) 198 | :min-version min-version :profile profile) 199 | to)) 200 | -------------------------------------------------------------------------------- /method-combination.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | (defun definition-signature (def) 4 | (ecase (first def) 5 | (function-prototype 6 | (list (fourth def) 7 | (second def) 8 | (third def) 9 | (mapcar #'butlast (nthcdr 4 def)))) 10 | ((function-declaration function-definition) 11 | (definition-signature (second def))))) 12 | 13 | (defun definition-identifier (def) 14 | (ecase (first def) 15 | (function-prototype 16 | (fourth def)) 17 | ((function-declaration function-definition) 18 | (definition-identifier (second def))))) 19 | 20 | (defun definition-argvars (def) 21 | (ecase (first def) 22 | (function-prototype 23 | (loop for arg in (cddddr def) 24 | collect (car (last arg)))) 25 | ((function-declaration function-definition) 26 | (definition-argvars (second def))))) 27 | 28 | (defun (setf definition-identifier) (value def) 29 | (ecase (first def) 30 | (function-prototype 31 | (setf (fourth def) value)) 32 | (function-declaration 33 | (setf (definition-identifier (second def)) value)) 34 | (function-definition 35 | (setf (definition-identifier (second def)) value)))) 36 | 37 | (defun handle-function-definition (ast env) 38 | (let ((identifier (definition-identifier ast))) 39 | (cond ((find #\@ identifier) 40 | (let* ((name (subseq identifier 0 (position #\@ identifier))) 41 | (comb (subseq identifier (1+ (length name)))) 42 | (comb (cond ((string= comb "after") :after) 43 | ((string= comb "before") :before) 44 | ((string= comb "around") :around) 45 | ((string= comb "primary") :primary) 46 | (T (error "Unsupported method combination type: ~a" comb))))) 47 | (setf (fourth (second ast)) name) 48 | (push (cons comb ast) (gethash (definition-signature ast) env)))) 49 | (T 50 | (push (cons :primary ast) (gethash (definition-signature ast) env)))))) 51 | 52 | (defun resolve-method-definitions (identifier definitions) 53 | (let ((parts (list :before () :after () :primary () :around ())) 54 | (return-variable "_GLSLTK_return")) 55 | (loop for (comb . ast) in definitions 56 | do (push ast (getf parts comb))) 57 | (unless (getf parts :primary) 58 | (warn "No primary method for ~a, ignoring all methods." identifier) 59 | (return-from resolve-method-definitions ())) 60 | (let* ((proto (copy-tree (second (first (getf parts :primary))))) 61 | (return-type (third proto))) 62 | ;; Turn into unique function names 63 | (flet ((uniquify (comb defs) 64 | (loop for i from 1 65 | for def in defs 66 | do (setf (definition-identifier def) (format NIL "_~a_~(~a~)_~d" identifier comb i))))) 67 | (loop for (k v) on parts by #'cddr 68 | do (uniquify k v) 69 | (setf (getf parts k) (nreverse v)))) 70 | ;; Resolve next methods 71 | (setf (definition-identifier proto) (format NIL "_~a_primary" identifier)) 72 | (labels ((emit-call (identifier args) 73 | `(modified-reference ,identifier (call-modifier ,@args))) 74 | (resolve-next-method (def next) 75 | (let ((args (definition-argvars def))) 76 | (walk def (lambda (ast ctx env) 77 | (declare (ignore ctx env)) 78 | (cond ((and (consp ast) 79 | (eql 'modified-reference (first ast)) 80 | (equal "call_next_method" (second ast))) 81 | (cond ((null next) 82 | (error "No next method")) 83 | ((rest (third ast)) 84 | `(modified-reference ,next ,@(cddr ast))) 85 | (T 86 | (emit-call next args)))) 87 | ((and (consp ast) 88 | (eql 'modified-reference (first ast)) 89 | (equal "maybe_call_next_method" (second ast))) 90 | (cond ((not next) 91 | NIL) 92 | ((null (rest (third ast))) 93 | (emit-call next args)) 94 | (T 95 | `(modified-reference ,next ,@(cddr ast))))) 96 | ((equal ast "next_method_p") 97 | (if next :true :false)) 98 | (T 99 | ast))))))) 100 | (loop for cons on (getf parts :around) 101 | for next-def = (second cons) 102 | for next-fun = (definition-identifier (or next-def proto)) 103 | do (setf (car cons) (resolve-next-method (car cons) next-fun))) 104 | (loop for cons on (getf parts :primary) 105 | for next-def = (second cons) 106 | for next-fun = (if next-def (definition-identifier next-def) NIL) 107 | do (setf (car cons) (resolve-next-method (car cons) next-fun))) 108 | ;; Construct entry function 109 | (when (or (getf parts :before) (getf parts :after)) 110 | (setf (getf parts :after) (nreverse (getf parts :after))) 111 | (let ((args (definition-argvars proto))) 112 | (push `(function-definition 113 | ,proto 114 | (compound-statement 115 | ,@(loop for def in (getf parts :before) 116 | collect (emit-call (definition-identifier def) args)) 117 | ,(if (equal '(glsl-toolkit:type-specifier :void) return-type) 118 | (emit-call (definition-identifier (first (getf parts :primary))) args) 119 | `(variable-declaration no-value (type-specifier ,return-type) ,return-variable no-value 120 | ,(emit-call (definition-identifier (first (getf parts :primary))) args))) 121 | ,@(loop for def in (getf parts :after) 122 | collect (emit-call (definition-identifier def) args)) 123 | ,@(unless (equal '(glsl-toolkit:type-specifier :void) return-type) 124 | `((return ,return-variable))))) 125 | (getf parts :primary)))) 126 | (cond ((getf parts :around) 127 | (unless (or (getf parts :before) (getf parts :after)) 128 | (setf (definition-identifier (first (getf parts :primary))) (format NIL "_~a_primary" identifier))) 129 | (setf (definition-identifier (first (getf parts :around))) identifier)) 130 | (T 131 | (setf (definition-identifier (first (getf parts :primary))) identifier))) 132 | ;; Append the definitions together 133 | (append (getf parts :before) 134 | (reverse (rest (getf parts :primary))) 135 | (getf parts :after) 136 | (list (first (getf parts :primary))) 137 | (nreverse (getf parts :around))))))) 138 | 139 | (defun combine-methods (shaders) 140 | (let ((shaders (mapcar #'copy-tree (mapcar #'ensure-shader (enlist shaders)))) 141 | (env (make-hash-table :test 'equal)) 142 | (other-forms ())) 143 | (dolist (shader shaders) 144 | (loop for ast in (rest shader) 145 | do (case (first ast) 146 | (function-declaration) 147 | (function-definition 148 | (handle-function-definition ast env)) 149 | (T 150 | (push ast other-forms))))) 151 | (let ((prototypes ())) 152 | (loop for definitions being the hash-values of env 153 | for proto = (loop for (comb . def) in definitions 154 | do (when (eql :primary comb) 155 | (return (second def)))) 156 | do (pushnew (copy-tree proto) prototypes :key #'fourth)) 157 | `(shader 158 | ,@(nreverse other-forms) 159 | ;; Emit declarations first to handle the reordering of function definitions 160 | ,@(loop for proto in (reverse prototypes) 161 | collect `(function-declaration ,proto)) 162 | ,@(loop for definitions being the hash-values of env using (hash-key identifier) 163 | append (resolve-method-definitions (definition-identifier (cdr (first definitions))) definitions)))))) 164 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (defpackage #:glsl-toolkit 4 | (:nicknames #:org.shirakumo.trial.glsl) 5 | (:use #:cl) 6 | ;; grammar.lisp 7 | (:export 8 | #:whitespace 9 | #:integer-token 10 | #:decimal-token 11 | #:octal-token 12 | #:hexadecimal-token 13 | #:float-token 14 | #:identifier-token 15 | #:keyword-token 16 | #:preprocessor-token 17 | #:token 18 | #:tokenize 19 | #:integer-constant 20 | #:float-constant 21 | #:boolean-constant 22 | #:identifier 23 | #:preprocessor-directive 24 | #:primary-expression 25 | #:postfix-expression 26 | #:modified-reference 27 | #:reference-modifier 28 | #:field-modifier 29 | #:array-modifier 30 | #:increment-modifier 31 | #:decrement-modifier 32 | #:call-modifier 33 | #:same-+ 34 | #:negation 35 | #:inversion 36 | #:bit-inversion 37 | #:prefix-increment 38 | #:prefix-decrement 39 | #:unary-expression 40 | #:multiplication 41 | #:division 42 | #:modulus 43 | #:addition 44 | #:subtraction 45 | #:left-shift 46 | #:right-shift 47 | #:less-than 48 | #:greater-than 49 | #:less-equal-than 50 | #:greater-equal-than 51 | #:equal 52 | #:not-equal 53 | #:bitwise-and 54 | #:exclusive-or 55 | #:inclusive-or 56 | #:logical-and 57 | #:logical-xor 58 | #:logical-or 59 | #:conditional-expression 60 | #:conditional 61 | #:assignment-expression 62 | #:assignment 63 | #:expression 64 | #:multiple-expressions 65 | #:constant-expression 66 | #:declaration 67 | #:function-declaration 68 | #:function-prototype 69 | #:parameter-declaration 70 | #:precision-declaration 71 | #:variable-declaration 72 | #:variable-initializer 73 | #:invariant-qualifier 74 | #:interpolation-qualifier 75 | #:layout-qualifier 76 | #:layout-qualifier-id 77 | #:precise-qualifier 78 | #:storage-qualifier 79 | #:subroutine-qualifier 80 | #:precision-qualifier 81 | #:type-qualifier 82 | #:type-specifier 83 | #:array-specifier 84 | #:type-specifier-nonarray 85 | #:type-name 86 | #:instance-name 87 | #:basic-type 88 | #:struct-specifier 89 | #:struct-declaration 90 | #:struct-declarator 91 | #:struct-field-declarator 92 | #:interface-declaration 93 | #:initializer 94 | #:array-initializer 95 | #:statement 96 | #:simple-statement 97 | #:compound-statement 98 | #:expression-statement 99 | #:selection-statement 100 | #:condition 101 | #:condition-declarator 102 | #:switch-statement 103 | #:case-label 104 | #:iteration-statement 105 | #:while-statement 106 | #:do-statement 107 | #:for-statement 108 | #:jump-statement 109 | #:continue 110 | #:break 111 | #:return 112 | #:discard 113 | #:function-definition 114 | #:shader) 115 | ;; merge.lisp 116 | (:export 117 | #:uniquify 118 | #:matching-qualifiers-p 119 | #:matching-specifiers-p 120 | #:matching-declarators-p 121 | #:merge-shaders 122 | #:merge-shader-sources) 123 | ;; method-combination.lisp 124 | (:export 125 | #:combine-methods) 126 | ;; parser.lisp 127 | (:export 128 | #:no-value 129 | #:end-of-tokens-p 130 | #:advance 131 | #:backtrack 132 | #:peek 133 | #:consume 134 | #:with-token-input 135 | #:rule 136 | #:remove-rule 137 | #:consume-whitespace 138 | #:consume-string 139 | #:consume-any 140 | #:consume-notany 141 | #:compile-rule 142 | #:v 143 | #:define-rule 144 | #:define-reference 145 | #:define-object 146 | #:normalize-shader-source 147 | #:lex 148 | #:parse 149 | #:trace-parse 150 | #:untrace-parse) 151 | ;; printer.lisp 152 | (:export 153 | #:serialize 154 | #:sformat 155 | #:with-indentation 156 | #:indent 157 | #:serializer 158 | #:remove-serializer 159 | #:define-serializer 160 | #:define-serialization 161 | #:serialize-part) 162 | ;; toolkit.lisp 163 | (:export 164 | #:*glsl-keywords* 165 | #:*glsl-keyword-symbols*) 166 | ;; transform.lisp 167 | (:export 168 | #:preprocess 169 | #:transform) 170 | ;; walker.lisp 171 | (:export 172 | #:environment 173 | #:binding 174 | #:make-environment 175 | #:root-environment-p 176 | #:preprocessor-p 177 | #:constant-p 178 | #:declaration-p 179 | #:expression-p 180 | #:control-flow-p 181 | #:keyword-p 182 | #:statement-p 183 | #:identifier-p 184 | #:global-identifier-p 185 | #:local-identifier-p 186 | #:variable-identifier-p 187 | #:function-identifier-p 188 | #:walk 189 | #:walk-part 190 | #:walker 191 | #:remove-walker 192 | #:define-walker 193 | #:define-walking-body 194 | #:define-empty-op-walker 195 | #:define-unary-op-walker 196 | #:define-binary-op-walker)) 197 | 198 | (defpackage #:glsl-parser-rules 199 | (:nicknames #:org.shirakumo.trial.glsl.parser.rules) 200 | (:use)) 201 | -------------------------------------------------------------------------------- /parser.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | (defvar *token-array* "") 4 | (defvar *token-index* 0) 5 | (defvar *max-index* 0) 6 | 7 | (macrolet ((define-novalue () 8 | (let ((name 'no-value)) 9 | `(define-symbol-macro ,name ',name)))) 10 | (define-novalue)) 11 | 12 | (deftype index () 13 | `(integer 0 ,array-dimension-limit)) 14 | 15 | (defun end-of-tokens-p () 16 | (<= (length *token-array*) *token-index*)) 17 | 18 | (define-compiler-macro end-of-tokens-p () 19 | `(<= (length (the vector *token-array*)) 20 | (the index *token-index*))) 21 | 22 | (defun advance (&optional (offset 1)) 23 | (setf *max-index* (max *max-index* (+ *token-index* 1))) 24 | (incf *token-index* offset)) 25 | 26 | (define-compiler-macro advance (&optional (offset 1)) 27 | `(setf *max-index* (max (the index *max-index*) (+ (the index *token-index*) ,offset)) 28 | *token-index* (+ (the index *token-index*) ,offset))) 29 | 30 | (defun backtrack (&optional (offset 1)) 31 | (decf *token-index* offset)) 32 | 33 | (define-compiler-macro backtrack (&optional (offset 1)) 34 | `(setf *token-index* (- (the index *token-index*) ,offset))) 35 | 36 | (defun peek (&optional (offset 0)) 37 | (aref *token-array* (+ *token-index* offset))) 38 | 39 | (define-compiler-macro peek (&optional (offset 0)) 40 | `(aref (the vector *token-array*) (+ (the index *token-index*) ,offset))) 41 | 42 | (defun consume () 43 | (prog1 (peek) 44 | (advance))) 45 | 46 | (define-compiler-macro consume () 47 | `(prog1 (peek) 48 | (advance))) 49 | 50 | (defmacro with-token-input (vector &body body) 51 | `(let ((*token-array* ,vector) 52 | (*token-index* 0) 53 | (*max-index* 0)) 54 | ,@body)) 55 | 56 | (defun rule (name) 57 | (or (find-symbol (string name) '#:org.shirakumo.trial.glsl.parser.rules) 58 | (error "No rule named ~s is known." name))) 59 | 60 | (defun (setf rule) (parser name) 61 | (let ((symbol (intern (string name) '#:org.shirakumo.trial.glsl.parser.rules))) 62 | (export symbol (symbol-package symbol)) 63 | (setf (fdefinition symbol) parser))) 64 | 65 | (defun remove-rule (name) 66 | (let ((symbol (intern (string name) '#:org.shirakumo.trial.glsl.parser.rules))) 67 | (unexport symbol (symbol-package symbol)) 68 | (fmakunbound symbol) 69 | (unintern symbol (symbol-package symbol)))) 70 | 71 | (defun consume-whitespace () 72 | (loop until (end-of-tokens-p) 73 | do (let ((char (peek))) 74 | (if (or (char= char #\Space) 75 | (char= char #\Linefeed) 76 | (char= char #\Return)) 77 | (advance) 78 | (return))))) 79 | 80 | (defun consume-string (string) 81 | (let ((start *token-index*)) 82 | (loop for comp across string 83 | do (when (or (end-of-tokens-p) 84 | (char/= comp (consume))) 85 | (setf *token-index* start) 86 | (return NIL)) 87 | finally (return string)))) 88 | 89 | (defun consume-any (choices) 90 | (unless (end-of-tokens-p) 91 | (when (find (peek) choices) 92 | (consume)))) 93 | 94 | (defun consume-notany (choices) 95 | (unless (end-of-tokens-p) 96 | (unless (find (peek) choices) 97 | (consume)))) 98 | 99 | (defun compile-rule (rule) 100 | (etypecase rule 101 | (null) 102 | (keyword 103 | `(when (and (not (end-of-tokens-p)) (eq ,rule (peek))) 104 | (consume))) 105 | (symbol 106 | `(,(intern (string rule) '#:org.shirakumo.trial.glsl.parser.rules))) 107 | (character 108 | `(when (and (not (end-of-tokens-p)) (eql ,rule (peek))) 109 | (consume))) 110 | (string 111 | `(consume-string ,rule)) 112 | (cons 113 | (case (first rule) 114 | (and `(let ((index *token-index*) 115 | (preval v)) 116 | (or (and ,@(mapcar #'compile-rule (rest rule))) 117 | (prog1 NIL (setf *token-index* index 118 | v preval))))) 119 | (or `(or ,@(mapcar #'compile-rule (rest rule)))) 120 | (notany `(consume-notany ',(second rule))) 121 | (any `(consume-any ',(second rule))) 122 | (when `(when ,(compile-rule (second rule)) 123 | ,@(mapcar #'compile-rule (cddr rule)))) 124 | (v `(v ,(compile-rule (second rule)))) 125 | (* `(loop until (end-of-tokens-p) 126 | while ,(compile-rule (second rule)) 127 | finally (return T))) 128 | (+ (compile-rule `(and ,(second rule) (* ,(second rule))))) 129 | (? `(or ,(compile-rule (second rule)) ,(or (third rule) no-value))) 130 | (! `(let ((index *token-index*) 131 | (preval v)) 132 | (prog1 ,(compile-rule (second rule)) 133 | (setf *token-index* index 134 | v preval)))) 135 | (T rule))))) 136 | 137 | (defmacro define-rule (name &body body) 138 | (let ((name (intern (string name) '#:org.shirakumo.trial.glsl.parser.rules))) 139 | `(eval-when (:compile-toplevel :load-toplevel :execute) 140 | (defun ,name () 141 | (let ((v)) 142 | ,@body)) 143 | (export ',name '#:org.shirakumo.trial.glsl.parser.rules) 144 | ',name))) 145 | 146 | (defmacro define-reference (name &body rules) 147 | (let ((val (gensym "VALUE"))) 148 | `(define-rule ,name 149 | (flet ((v (value) 150 | (when value (setf v value)))) 151 | (declare (ignorable #'v) (inline v)) 152 | (let ((,val ,(compile-rule `(or ,@rules)))) 153 | (or v ,val)))))) 154 | 155 | (defmacro define-object (name rule &body transform) 156 | `(define-rule ,name 157 | (flet ((v (value) 158 | (when value (push value v) value))) 159 | (declare (ignorable #'v) (inline v)) 160 | (when ,(compile-rule rule) 161 | (setf v (nreverse v)) 162 | ,(if transform 163 | `(progn ,@transform) 164 | `(list* ',name v)))))) 165 | 166 | (defun newline-p (input) 167 | (or (eql input #\Linefeed) 168 | (eql input #\Return))) 169 | 170 | (defun normalize-shader-source (input) 171 | (etypecase input 172 | (pathname (with-open-file (stream input :direction :input) 173 | (normalize-shader-source stream))) 174 | (string (with-input-from-string (stream input) 175 | (normalize-shader-source stream))) 176 | (stream 177 | (string-trim 178 | '(#\Return #\Linefeed #\Space) 179 | (with-output-to-string (output) 180 | (loop for char = (read-char input NIL) 181 | while char 182 | do (case char 183 | ;; Handle backslash escape 184 | (#\\ 185 | (cond ((newline-p (peek-char NIL input NIL)) 186 | (read-char input) 187 | (when (newline-p (peek-char NIL input NIL)) 188 | (read-char input))) 189 | (T 190 | (error "Illegal backslash without newline.")))) 191 | ;; Handle newline behaviour and such 192 | ((#\Return #\Linefeed) 193 | (when (newline-p (peek-char NIL input NIL)) 194 | (read-char input)) 195 | (write-char #\Linefeed output)) 196 | ;; Handle comments 197 | (#\/ 198 | (case (peek-char NIL input) 199 | (#\/ (loop for prev = #\ then char 200 | for char = (read-char input NIL) 201 | until (or (not char) 202 | (and (not (char= #\\ prev)) 203 | (newline-p char)))) 204 | (write-char #\Linefeed output)) 205 | (#\* (loop for prev = #\ then char 206 | for char = (read-char input) 207 | until (and (char= #\* prev) 208 | (char= #\/ char)))) 209 | (T (write-char char output)))) 210 | ;; Handle consecutive whitespace 211 | ((#\Tab #\Space) 212 | (loop for char = (read-char input NIL) 213 | while (or (eql char #\Tab) 214 | (eql char #\Space)) 215 | finally (when char (unread-char char input))) 216 | (write-char #\Space output)) 217 | ;; Handle other chars 218 | (T (write-char char output))))))))) 219 | 220 | (defun discover-expr-around (point) 221 | (let ((terminators (if (stringp *token-array*) 222 | ";{}()" 223 | '(:\; :{ :} :\( :\))))) 224 | (subseq *token-array* 225 | (loop for i downfrom (1- point) to 0 226 | for token = (aref *token-array* i) 227 | when (find token terminators) 228 | do (return (1+ i)) 229 | finally (return 0)) 230 | (loop for i from point below (length *token-array*) 231 | for token = (aref *token-array* i) 232 | when (find token terminators) 233 | do (return i))))) 234 | 235 | (defun check-parse-complete (toplevel-rule) 236 | (when (/= *token-index* (length *token-array*)) 237 | (let ((problem (discover-expr-around *max-index*)) 238 | (*print-case* :downcase)) 239 | ;; FIXME: once we have the AST as a non-implicit thing with class instances, we can keep track of 240 | ;; lines and columns too. 241 | (cerror "Ignore the failure." 242 | "The parse rule ~a did not consume all of the tokens.~%~ 243 | It failed to continue parsing around ~s (position ~d):~%~% ~a" 244 | toplevel-rule (aref *token-array* *max-index*) *max-index* 245 | (if (stringp problem) 246 | problem 247 | (with-output-to-string (out) 248 | (loop for a across problem do (format out "~a " a)))))))) 249 | 250 | (defun lex (input &optional (toplevel-rule 'tokenize)) 251 | (with-token-input (normalize-shader-source input) 252 | (prog1 (funcall (rule toplevel-rule)) 253 | (check-parse-complete toplevel-rule)))) 254 | 255 | (defun parse (input &optional (toplevel-rule 'shader)) 256 | (etypecase input 257 | ((or string stream pathname) 258 | (parse (lex input) toplevel-rule)) 259 | (list 260 | (parse (coerce input 'vector) toplevel-rule)) 261 | (vector 262 | (with-token-input input 263 | (prog1 (funcall (rule toplevel-rule)) 264 | (check-parse-complete toplevel-rule)))))) 265 | 266 | (defvar *traced* (make-hash-table :test 'eql)) 267 | (defvar *trace-level* 0) 268 | 269 | (defun call-traced-function (name) 270 | (format T "~&~v{ ~}~2:* :~a > ~a : ~a~%" 271 | *trace-level* *token-index* name) 272 | (let* ((value (let ((*trace-level* (1+ *trace-level*))) 273 | (funcall (gethash name *traced*))))) 274 | (format T "~&~v{ ~}~2:* :~a < ~a : ~a ~a~%" 275 | *trace-level* *token-index* name value) 276 | value)) 277 | 278 | (defun trace-parse-func (name) 279 | (unless (gethash name *traced*) 280 | (setf (gethash name *traced*) (fdefinition name)) 281 | (setf (fdefinition name) 282 | (lambda () (call-traced-function name))))) 283 | 284 | (defun untrace-parse-func (name) 285 | (when (gethash name *traced*) 286 | (setf (fdefinition name) (gethash name *traced*)) 287 | (remhash name *traced*))) 288 | 289 | (defun trace-parse () 290 | (do-symbols (symbol '#:org.shirakumo.trial.glsl.parser.rules) 291 | (when (fboundp symbol) (trace-parse-func symbol)))) 292 | 293 | (defun untrace-parse () 294 | (do-symbols (symbol '#:org.shirakumo.trial.glsl.parser.rules) 295 | (when (fboundp symbol) (untrace-parse-func symbol)))) 296 | 297 | (defun ensure-shader (thing) 298 | (etypecase thing 299 | ((or string stream pathname) 300 | (parse thing)) 301 | (cons 302 | thing))) 303 | -------------------------------------------------------------------------------- /printer.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | (defvar *serialize-stream*) 4 | 5 | (defun serialize (part &optional to) 6 | (etypecase to 7 | (null 8 | (with-output-to-string (*serialize-stream*) 9 | (serialize-part part))) 10 | ((eql T) 11 | (let ((*serialize-stream* *standard-output*)) 12 | (serialize-part part) 13 | to)) 14 | (stream 15 | (let ((*serialize-stream* to)) 16 | (serialize-part part) 17 | to)) 18 | (pathname 19 | (with-open-file (*serialize-stream* to :direction :output) 20 | (serialize-part part) 21 | to)))) 22 | 23 | (defun sformat (string &rest args) 24 | (format *serialize-stream* "~?" (compile-format-string string) args)) 25 | 26 | (define-compiler-macro sformat (string &rest args) 27 | `(format *serialize-stream* ,(compile-format-string string) ,@args)) 28 | 29 | (defun %format-object (s a cp at) 30 | (declare (ignore cp at)) 31 | (let ((*serialize-stream* s)) 32 | (serialize-part a))) 33 | 34 | (defvar *indent* 0) 35 | 36 | (defmacro with-indentation ((&optional (step 2)) &body body) 37 | `(let ((*indent* (+ ,step *indent*))) 38 | ,@body)) 39 | 40 | (defun indent (&optional (offset 0)) 41 | (fresh-line *serialize-stream*) 42 | (format *serialize-stream* "~v{ ~}" (+ *indent* offset) '(0))) 43 | 44 | (eval-when (:compile-toplevel :load-toplevel :execute) 45 | (defun compile-format-string (string) 46 | (with-output-to-string (out) 47 | (loop for i from 0 below (length string) 48 | do (cond ((and (char= #\~ (char string i)) 49 | (char= #\o (char string (1+ i)))) 50 | (write-string "~/ORG.SHIRAKUMO.TRIAL.GLSL::%FORMAT-OBJECT/" out) 51 | (incf i)) 52 | (T 53 | (write-char (char string i) out))))))) 54 | 55 | (defvar *serializers* (make-hash-table :test 'eql)) 56 | 57 | (defun serializer (type) 58 | (gethash type *serializers*)) 59 | 60 | (defun (setf serializer) (function type) 61 | (setf (gethash type *serializers*) function)) 62 | 63 | (defun remove-serializer (type) 64 | (remhash type *serializers*)) 65 | 66 | (defmacro define-serializer (type (object) &body body) 67 | `(progn (setf (serializer ',type) 68 | (lambda (,object) 69 | ,@body)) 70 | ',type)) 71 | 72 | (defmacro define-serialization (type args &body body) 73 | (let ((object (gensym "OBJECT"))) 74 | `(define-serializer ,type (,object) 75 | (destructuring-bind ,args (rest ,object) 76 | ,@body)))) 77 | 78 | (defun serialize-part (part) 79 | (etypecase part 80 | (integer 81 | (sformat "~d" part)) 82 | (float 83 | (sformat "~f~@[lf~]" part (typep part 'double-float))) 84 | ((eql :\;)) 85 | (keyword 86 | (sformat "~a" (find part *glsl-keywords* :test #'string-equal))) 87 | (string 88 | (sformat "~a" part)) 89 | (null) 90 | ((eql #.no-value)) 91 | (cons 92 | (funcall (or (serializer (first part)) 93 | (error "Cannot serialize AST-object of type ~s." 94 | (first part))) 95 | part)))) 96 | 97 | (define-serialization unsigned-int (int) 98 | (serialize-part int) 99 | (sformat "u")) 100 | 101 | (define-serialization preprocessor-directive (directive) 102 | (sformat "~&~a~%" directive)) 103 | 104 | (define-serialization modified-reference (expression &rest modifiers) 105 | (sformat "~o~{~o~}" expression modifiers)) 106 | 107 | (define-serialization field-modifier (identifier) 108 | (sformat ".~o" identifier)) 109 | 110 | (define-serialization array-modifier (expression) 111 | (sformat "[~o]" expression)) 112 | 113 | (define-serialization increment-modifier () 114 | (sformat "++")) 115 | 116 | (define-serialization decrement-modifier () 117 | (sformat "--")) 118 | 119 | (define-serialization call-modifier (&rest values) 120 | (sformat "(~{~o~^, ~})" values)) 121 | 122 | (define-serialization same-+ (expression) 123 | (sformat "+~o" expression)) 124 | 125 | (define-serialization negation (expression) 126 | (sformat "-~o" expression)) 127 | 128 | (define-serialization inversion (expression) 129 | (sformat "!~o" expression)) 130 | 131 | (define-serialization bit-inversion (expression) 132 | (sformat "~~~o" expression)) 133 | 134 | (define-serialization prefix-increment (expression) 135 | (sformat "++~o" expression)) 136 | 137 | (define-serialization prefix-decrement (expression) 138 | (sformat "--~o" expression)) 139 | 140 | (define-serialization multiplication (left right) 141 | (sformat "(~o * ~o)" left right)) 142 | 143 | (define-serialization division (left right) 144 | (sformat "(~o / ~o)" left right)) 145 | 146 | (define-serialization modulus (left right) 147 | (sformat "(~o % ~o)" left right)) 148 | 149 | (define-serialization addition (left right) 150 | (sformat "(~o + ~o)" left right)) 151 | 152 | (define-serialization subtraction (left right) 153 | (sformat "(~o - ~o)" left right)) 154 | 155 | (define-serialization left-shift (left right) 156 | (sformat "(~o << ~o)" left right)) 157 | 158 | (define-serialization right-shift (left right) 159 | (sformat "(~o >> ~o)" left right)) 160 | 161 | (define-serialization less-than (left right) 162 | (sformat "(~o < ~o)" left right)) 163 | 164 | (define-serialization greater-than (left right) 165 | (sformat "(~o > ~o)" left right)) 166 | 167 | (define-serialization less-equal-than (left right) 168 | (sformat "(~o <= ~o)" left right)) 169 | 170 | (define-serialization greater-equal-than (left right) 171 | (sformat "(~o >= ~o)" left right)) 172 | 173 | (define-serialization equal (left right) 174 | (sformat "(~o == ~o)" left right)) 175 | 176 | (define-serialization not-equal (left right) 177 | (sformat "(~o != ~o)" left right)) 178 | 179 | (define-serialization bitwise-and (left right) 180 | (sformat "(~o & ~o)" left right)) 181 | 182 | (define-serialization exclusive-or (left right) 183 | (sformat "(~o ^ ~o)" left right)) 184 | 185 | (define-serialization inclusive-or (left right) 186 | (sformat "(~o | ~o)" left right)) 187 | 188 | (define-serialization logical-and (left right) 189 | (sformat "(~o && ~o)" left right)) 190 | 191 | (define-serialization logical-xor (left right) 192 | (sformat "(~o ^^ ~o)" left right)) 193 | 194 | (define-serialization logical-or (left right) 195 | (sformat "(~o || ~o)" left right)) 196 | 197 | (define-serialization conditional (condition expression else) 198 | (sformat "~o? ~o :~o" condition expression else)) 199 | 200 | (define-serialization assignment (place op value) 201 | (sformat "~o ~a ~o" place op value)) 202 | 203 | (define-serialization multiple-expressions (&rest expressions) 204 | (sformat "~{~o~^, ~}" expressions)) 205 | 206 | (define-serialization function-declaration (prototype) 207 | (sformat "~o" prototype)) 208 | 209 | (define-serialization function-prototype (qualifier specifier identifier &rest parameters) 210 | (sformat "~o~o ~o(~{~{~o~^ ~}~^, ~})" 211 | qualifier specifier identifier parameters)) 212 | 213 | (define-serialization precision-declarator (precision type) 214 | (sformat "precision ~o ~o" precision type)) 215 | 216 | (define-serialization variable-declaration (qualifier specifier identifier array &optional initializer) 217 | (sformat "~o~o ~o~o~@[ = ~o~]" qualifier specifier identifier array initializer)) 218 | 219 | (define-serialization layout-qualifier (&rest ids) 220 | (sformat "layout(~{~o~^, ~})" ids)) 221 | 222 | (define-serialization layout-qualifier-id (identifier &optional value) 223 | (sformat "~o~@[ = ~o~]" identifier value)) 224 | 225 | (define-serialization type-qualifier (&rest qualifiers) 226 | (sformat "~{~o ~}" qualifiers)) 227 | 228 | (define-serialization subroutine-qualifier (&optional type-name) 229 | (sformat "subroutine~@[(~o)~]" type-name)) 230 | 231 | (define-serialization type-specifier (type &optional array) 232 | (sformat "~o~@[~o~]" type array)) 233 | 234 | (define-serialization array-specifier (&rest specifiers) 235 | (sformat "~:[[]~;~:*~{[~o]~}~]" specifiers)) 236 | 237 | (define-serialization type-name (identifier) 238 | (sformat "~o" identifier)) 239 | 240 | (define-serialization struct-specifier (identifier) 241 | (sformat "struct ~o" identifier)) 242 | 243 | (define-serialization struct-declaration (identifier instance &rest declarators) 244 | (with-indentation () 245 | (sformat "struct ~o{~{~o~}" identifier declarators)) 246 | (indent) (sformat "} ~o" instance)) 247 | 248 | (define-serialization struct-declarator (qualifier specifier identifier &optional array) 249 | (indent) (sformat "~o~o ~o~o;" qualifier specifier identifier array)) 250 | 251 | (define-serialization interface-declaration (qualifier identifier instance &rest declarators) 252 | (cond (identifier 253 | (with-indentation () 254 | (sformat "~o~o{~{~o~}" qualifier identifier declarators)) 255 | (indent) (sformat "} ~o" instance)) 256 | (T 257 | (sformat "~o" qualifier)))) 258 | 259 | (define-serialization instance-name (identifier &optional array) 260 | (sformat "~o~o" identifier array)) 261 | 262 | (define-serialization array-initializer (type &optional initializer &rest initializers) 263 | (sformat "~o[](~@[~o~{, ~o~}~])" type initializer initializers)) 264 | 265 | (define-serialization multiple-statements (&optional statement &rest statements) 266 | (when statement 267 | (sformat "~o" statement) 268 | (loop for statement in statements 269 | do (sformat ";") (indent) (sformat "~o" statement)))) 270 | 271 | (define-serialization compound-statement (&rest statements) 272 | (sformat "{") 273 | (with-indentation () 274 | (dolist (statement statements) 275 | (cond ((preprocessor-p statement NIL) 276 | (sformat "~o" statement)) 277 | ((eql statement :\;)) 278 | ((and (listp statement) (eql 'case-label (car statement))) 279 | (indent -2) (sformat "~o" statement)) 280 | (T 281 | (indent) (sformat "~o;" statement))))) 282 | (indent) (sformat "}")) 283 | 284 | (define-serialization selection-statement (expression statement &optional else) 285 | (sformat "if(~o)~o~@[else~o~]" expression statement else)) 286 | 287 | (define-serialization condition-declarator (qualifier specifier identifier initializer) 288 | (sformat "~o~o ~o = ~o" qualifier specifier identifier initializer)) 289 | 290 | (define-serialization switch-statement (expression statement) 291 | (sformat "switch(~o)~o" expression statement)) 292 | 293 | (define-serialization case-label (case) 294 | (if (eql :default case) 295 | (sformat "default: ") 296 | (sformat "case ~o: " case))) 297 | 298 | (define-serialization while-statement (condition statement) 299 | (sformat "while(~o)~o" condition statement)) 300 | 301 | (define-serialization do-statement (statement expression) 302 | (sformat "do~o" statement) 303 | (indent) (sformat "while(~o)" expression)) 304 | 305 | (define-serialization for-statement (declaration condition expression statement) 306 | (sformat "for(~o; ~o; ~o)~o" declaration condition expression statement)) 307 | 308 | (define-serialization continue () 309 | (sformat "continue")) 310 | 311 | (define-serialization break () 312 | (sformat "break")) 313 | 314 | (define-serialization return (&optional value) 315 | (sformat "return~@[ ~o~]" value)) 316 | 317 | (define-serialization discard () 318 | (sformat "discard")) 319 | 320 | (define-serialization function-definition (prototype statement) 321 | (sformat "~%~o~o" prototype statement)) 322 | 323 | (define-serialization shader (&rest items) 324 | (dolist (item items) 325 | (cond ((preprocessor-p item NIL) 326 | (serialize-part item)) 327 | (T 328 | (indent) 329 | (serialize-part item) 330 | (unless (or (eql 'function-definition (first item)) 331 | (eql 'shader (first item)) 332 | (equal item '(interface-declaration no-value nil nil))) 333 | (sformat ";")))))) 334 | -------------------------------------------------------------------------------- /sexpr.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | (defun symbol->identifier (symbol) 4 | (with-output-to-string (out) 5 | (with-input-from-string (in (string symbol)) 6 | (loop for char = (read-char in NIL) 7 | while char 8 | do (case char 9 | (#\- (write-char (char-upcase (read-char in)) out)) 10 | (T (write-char (char-downcase char) out))))))) 11 | 12 | (defun sexpr->glsl-ast (form) 13 | (etypecase form 14 | ((or null integer float keyword string) 15 | form) 16 | (symbol 17 | (symbol->identifier form)) 18 | (cons 19 | (funcall (or (sexpr-transform (first form)) 20 | (error "No sexpr-transformer found for the following form:~% ~a" 21 | form)) 22 | form)))) 23 | 24 | (defmacro with-glsl-syntax (&body forms) 25 | (serialize 26 | `(shader 27 | ,@(mapcar #'sexpr->glsl-ast forms)))) 28 | 29 | (defvar *sexpr-transforms* (make-hash-table :test 'eql)) 30 | 31 | (defun sexpr-transform (op) 32 | (gethash op *sexpr-transforms*)) 33 | 34 | (defun (setf sexpr-transform) (function op) 35 | (setf (gethash op *sexpr-transforms*) function)) 36 | 37 | (defun remove-sexpr-transform (op) 38 | (remhash op *sexpr-transforms*)) 39 | 40 | (defmacro define-sexpr-transform (op args &body body) 41 | (let ((o (gensym "FORM"))) 42 | `(progn (setf (sexpr-transform ',op) 43 | (lambda (,o) 44 | (flet ((r (form) 45 | (sexpr->glsl-ast form))) 46 | (declare (ignorable #'r)) 47 | (destructuring-bind ,args (rest ,o) 48 | ,@body)))) 49 | ',op))) 50 | 51 | (define-sexpr-transform + (&rest values) 52 | (cond ((cdr values) 53 | `(addition ,(r (first values)) 54 | ,(r `(+ ,@(rest values))))) 55 | (values 56 | (r (first values))) 57 | (T 58 | 0))) 59 | 60 | (define-sexpr-transform - (first &rest values) 61 | (cond (values 62 | `(subtraction ,(r first) 63 | ,(r `(+ ,@values)))) 64 | (T 65 | `(negation ,(r first))))) 66 | 67 | (define-sexpr-transform * (&rest values) 68 | (cond ((cdr values) 69 | `(multiplication ,(r (first values)) 70 | ,(r `(* ,@(rest values))))) 71 | (values 72 | (r (first values))) 73 | (T 74 | 1))) 75 | 76 | (define-sexpr-transform / (first &rest values) 77 | (cond (values 78 | `(division ,(r first) 79 | ,(r `(* ,@values)))) 80 | (T 81 | `(division 1.0 ,(r first))))) 82 | 83 | (defmacro define-sexpr-comparator (name ast) 84 | `(define-sexpr-transform ,name (first &rest values) 85 | (cond ((cdr values) 86 | `(logical-and (,',ast ,(r first) ,(r (first values))) 87 | ,(r `(,',name ,(first values) ,(cdr values))))) 88 | (values 89 | `(,',ast ,(r first) ,(r (first values)))) 90 | (T 91 | :true)))) 92 | 93 | (define-sexpr-comparator = equal) 94 | (define-sexpr-comparator /= not-equal) 95 | (define-sexpr-comparator > greater-than) 96 | (define-sexpr-comparator < less-than) 97 | (define-sexpr-comparator >= greater-equal-than) 98 | (define-sexpr-comparator <= less-equal-than) 99 | 100 | (defmacro define-expr-binary (name ast default) 101 | `(define-sexpr-transform ,name (&rest values) 102 | (cond (values 103 | `(,',ast ,(r (first values)) 104 | ,(r `(,',name ,@(rest values))))) 105 | (T 106 | ,default)))) 107 | 108 | (define-expr-binary and logical-and :true) 109 | (define-expr-binary logand bitwise-and (1- (ash 1 32))) 110 | (define-expr-binary or logical-or :false) 111 | (define-expr-binary logior inclusive-or 0) 112 | ;; FIXME for uneven args case 113 | (define-expr-binary xor logical-xor :false) 114 | (define-expr-binary logxor exclusive-or 0) 115 | 116 | (define-sexpr-transform lognot (value) 117 | `(bit-inversion ,(r value))) 118 | 119 | (define-sexpr-transform ash (value amount) 120 | ;; This is leaky if VALUE is modifying. 121 | `(conditional 122 | (less-than 0 ,(r value)) 123 | (left-shift ,(r value) ,(r amount)) 124 | (right-shift ,(r value) ,(r amount)))) 125 | 126 | (define-sexpr-transform 1+ (value) 127 | `(addition 1 ,(r value))) 128 | 129 | (define-sexpr-transform 1- (value) 130 | `(subtraction ,(r value) 1)) 131 | 132 | (define-sexpr-transform incf (place &optional (amount 1)) 133 | `(assignment ,(r place) :+= ,(r amount))) 134 | 135 | (define-sexpr-transform decf (place &optional (amount 1)) 136 | `(assignment ,(r place) :-= ,(r amount))) 137 | 138 | (define-sexpr-transform dotimes ((var count) &rest body) 139 | `(for-statement 140 | (variable-declaration 141 | (type-qualifier) (type-specifier :int) ,(r var) 0) 142 | (less-than ,(r var) ,(r count)) 143 | (prefix-increment ,(r var)) 144 | (compound-statement ,@(mapcar #'r body)))) 145 | 146 | (define-sexpr-transform case (var &body cases) 147 | `(switch-statement ,var 148 | (compound-statement 149 | ,@(loop for (c . body) in cases 150 | appending (loop for case in (enlist c) 151 | collect `(case-label ,(if (eql T case) 152 | :default 153 | (r case)))) 154 | appending (mapcar #'r body) 155 | appending `((break)))))) 156 | 157 | (define-sexpr-transform return (&optional value) 158 | `(return ,(if value 159 | (r value) 160 | no-value))) 161 | 162 | (define-sexpr-transform discard () 163 | `(discard)) 164 | 165 | (define-sexpr-transform continue () 166 | `(continue)) 167 | 168 | (define-sexpr-transform break () 169 | `(break)) 170 | 171 | (defun separate-qualifier-specifier (types) 172 | (let ((qualifiers ()) 173 | (specifiers ())) 174 | (dolist (type (enlist types)) 175 | (cond ((consp type) 176 | (push (ecase (first type) 177 | (layout `(layout-qualifier ,(rest type))) 178 | (subroutine `(subroutine-qualifier ,(second type)))) 179 | qualifiers)) 180 | ((find type '(:invariant :smooth :flat :noperspective 181 | :precise :const :inout :in :out :centroid 182 | :patch :sample :uniform :buffer :shared 183 | :coherent :volatile :restrict :readonly 184 | :writeonly :highp :mediump :lowp) 185 | :test #'string=) 186 | (push (intern (string type) :keyword) qualifiers)) 187 | (T 188 | (push (intern (string type) :keyword) specifiers)))) 189 | (values (nreverse qualifiers) 190 | (nreverse specifiers)))) 191 | 192 | (define-sexpr-transform defvar (type ident &optional value) 193 | (multiple-value-bind (qualifiers specifiers) 194 | (separate-qualifier-specifier type) 195 | `(variable-declaration 196 | ,(if qualifiers `(type-qualifier ,@qualifiers) no-value) 197 | (type-specifier ,@specifiers) 198 | ,(r ident) 199 | ,no-value 200 | ,value))) 201 | 202 | (define-sexpr-transform let (bindings &body body) 203 | `(compound-statement 204 | ,@(loop for binding in bindings 205 | collect (r `(defvar ,@binding))) 206 | ,@(mapcar #'r body))) 207 | 208 | (define-sexpr-transform defun (identifier arglist type &body body) 209 | (let ((prototype (multiple-value-bind (qualifiers specifiers) 210 | (separate-qualifier-specifier type) 211 | `(function-prototype 212 | (type-qualifier ,@qualifiers) 213 | (type-specifier ,@specifiers) 214 | ,(r identifier) 215 | ,@(loop for (type ident array) in arglist 216 | collect `((type-specifier ,(intern (string type) :keyword)) 217 | ,(r ident) 218 | ,@(when array (list array)))))))) 219 | (if body 220 | `(function-definition 221 | ,prototype 222 | (compound-statement 223 | ,@(mapcar #'r body))) 224 | `(function-declaration 225 | ,prototype)))) 226 | 227 | (define-sexpr-transform setf (&rest pairs) 228 | (if (cddr pairs) 229 | `(multiple-statements 230 | ,@(loop for (place value) on pairs by #'cddr 231 | collect (r `(setf ,place ,value)))) 232 | `(assignment ,(r (first pairs)) 233 | := 234 | ,(r (second pairs))))) 235 | -------------------------------------------------------------------------------- /toolkit.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | (defun starts-with (start sequence) 4 | (and (<= (length start) (length sequence)) 5 | (loop for a across start 6 | for b across sequence 7 | always (eql a b)))) 8 | 9 | (defun ends-with (end sequence) 10 | (and (<= (length end) (length sequence)) 11 | (loop for a across end 12 | for j from (- (length sequence) (length end)) 13 | for b = (aref sequence b) 14 | always (eql a b)))) 15 | 16 | (defun enlist (list &rest items) 17 | (if (listp list) list (list* list items))) 18 | 19 | (defun unlist (listish) 20 | (if (listp listish) (first listish) listish)) 21 | 22 | (defun mapcar* (function list) 23 | (loop for item in list 24 | for result = (funcall function item) 25 | when result collect result)) 26 | 27 | (defun find-any (choices sequence) 28 | (find choices sequence :test (lambda (a b) (find b a)))) 29 | 30 | (defun merge-plists (a b) 31 | (let ((res (copy-list a))) 32 | (loop for (key val) on b by #'cddr 33 | do (setf (getf key res) 34 | (append (getf key res) val))) 35 | res)) 36 | 37 | (defparameter *glsl-keywords* 38 | '("writeonly" "while" "volatile" "void" "vec4" "vec3" "vec2" "varying" "uvec4" 39 | "uvec3" "uvec2" "using" "usamplerCubeArray" "usamplerCube" "usamplerBuffer" 40 | "usampler3D" "usampler2DRect" "usampler2DMSArray" "usampler2DMS" 41 | "usampler2DArray" "usampler2D" "usampler1DArray" "usampler1D" "unsigned" 42 | "union" "uniform" "uint" "uimageCubeArray" "uimageCube" "uimageBuffer" 43 | "uimage3D" "uimage2DRect" "uimage2DMSArray" "uimage2DMS" "uimage2DArray" 44 | "uimage2D" "uimage1DArray" "uimage1D" "typedef" "true" "this" "template" 45 | "switch" "superp" "subroutine" "struct" "static" "smooth" 46 | "smapler2DRectShadow" "sizeof" "short" "shared" "samplerCubeShadow" 47 | "samplerCubeArrayShadow" "samplerCubeArray" "samplerCube" "samplerBuffer" 48 | "sampler3DRect" "sampler3D" "sampler2DShadow" "sampler2DRect" 49 | "sampler2DMSArray" "sampler2DMS" "sampler2DArrayShadow" "sampler2DArray" 50 | "sampler2D" "sampler1DShadow" "sampler1DArrayShadow" "sampler1DArray" 51 | "sampler1D" "sample" "return" "restrict" "resource" "readonly" "public" 52 | "precision" "precise" "patch" "partition" "out" "output" "notinline" 53 | "noperspective" "namespace" "mediump" "mat4x4" "mat4x3" "mat4x2" "mat4" 54 | "mat3x4" "mat3x3" "mat3x2" "mat3" "mat2x4" "mat2x3" "mat2x2" "mat2" "lowp" 55 | "long" "layout" "ivec4" "ivec3" "ivec2" "isamplerCubeArray" "isamplerCube" 56 | "isamplerBuffer" "isampler3D" "isampler2DRect" "isampler2DMSArray" 57 | "isampler2DMS" "isampler2DArray" "isampler2D" "isampler1DArray" "isampler1D" 58 | "invariant" "interface" "int" "input" "inout" "inline" "in" "imageCubeArray" 59 | "imageCube" "imageBuffer" "image3D" "image2DRect" "image2DMSArray" "image2DMS" 60 | "image2DArray" "image2D" "image1DArray" "image1D" "iimageCubeArray" 61 | "iimageCube" "iimageBuffer" "iimage3D" "iimage2DRect" "iimage2DMSArray" 62 | "iimage2DMS" "iimage2DArray" "iimage2D" "iimage1DArray" "iimage1D" "if" 63 | "hvec4" "hvec3" "hvec2" "highp" "half" "goto" "fvec4" "fvec3" "fvec2" "for" 64 | "float" "flat" "fixed" "filter" "false" "external" "extern" "enum" "else" 65 | "dvec4" "dvec3" "dvec2" "double" "do" "dmat4x4" "dmat4x3" "dmat4x2" "dmat4" 66 | "dmat3x4" "dmat3x3" "dmat3x2" "dmat3" "dmat2x4" "dmat2x3" "dmat2x2" "dmat2" 67 | "discard" "default" "continue" "cont" "common" "coherent" "class" "centroid" 68 | "cast" "case" "bvec4" "bvec3" "bvec2" "buffer" "break" "bool" "attribute" 69 | "atomic_uint" "asm" "active" "const" "packed" "std140" "std430")) 70 | 71 | (defvar *glsl-keyword-symbols* 72 | (loop for item in *glsl-keywords* 73 | collect (intern (string-upcase item) :keyword))) 74 | -------------------------------------------------------------------------------- /transform.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | ;;; FIXME: this sucks. Ideally we'd be able to define a preprocessor class 4 | ;;; and use class-based dispatch. But that would require having an AST 5 | ;;; composed out of instances, rather than lists. 6 | 7 | (defun preprocess (source &key include-resolution) 8 | (let ((shader (etypecase source 9 | ((or string pathname) (parse source)) 10 | (cons source))) 11 | (accumulator (list 'shader)) 12 | (parts ()) 13 | (section :global)) 14 | (flet ((finish-section () 15 | (setf (getf parts section) (append (getf parts :global) 16 | (nreverse accumulator))) 17 | (setf accumulator ()))) 18 | (dolist (form (rest shader)) 19 | (cond ((and (eql 'preprocessor-directive (first form)) 20 | (starts-with "#section " (second form))) 21 | (finish-section) 22 | (setf section (let ((name (subseq (second form) (length "#section ")))) 23 | (cond ((string-equal name "VERTEX_SHADER") :vertex-shader) 24 | ((string-equal name "FRAGMENT_SHADER") :fragment-shader) 25 | ((string-equal name "COMPUTE_SHADER") :compute-shader) 26 | ((string-equal name "TESS_CONTROL_SHADER") :tess-control-shader) 27 | ((string-equal name "TESS_EVALUATION_SHADER") :tess-evaluation-shader) 28 | ((string-equal name "GEOMETRY_SHADER") :geometry-shadder) 29 | (T (error "Unknown shader section: ~s" name)))))) 30 | ((and (eql 'preprocessor-directive (first form)) 31 | (starts-with "#include " (second form))) 32 | (let ((include (funcall include-resolution (subseq (second form) (length "#include "))))) 33 | (dolist (form (if (eql 'shader (first include)) 34 | (rest include) 35 | include)) 36 | (push form accumulator)))) 37 | ((and (eql 'preprocessor-directive (first form)) 38 | (starts-with "#eval " (second form))) 39 | (let ((form (eval (read-from-string (subseq (second form) (length "#eval ")))))) 40 | (etypecase form 41 | (string (push (parse form) accumulator)) 42 | (list (push form accumulator))))) 43 | (T 44 | (push form accumulator)))) 45 | (finish-section)) 46 | (cond ((cddr parts) 47 | (remf parts :global) 48 | parts) 49 | (T 50 | (getf parts :global))) 51 | parts)) 52 | 53 | (defun transform-to-gles (version ast ctx env) 54 | (destructuring-bind (major minor) version 55 | (declare (ignore minor)) 56 | (labels ((replace-parts (statement &rest parts) 57 | (loop for part in statement 58 | for rep = (getf parts part part) 59 | collect rep)) 60 | (type-qualifier (qualifier) 61 | (if (listp qualifier) 62 | (case (first qualifier) 63 | (type-qualifier 64 | (append (if (< major 3) 65 | (if (find 'layout-qualifier qualifier :key #'unlist) 66 | (replace-parts qualifier (second qualifier) :attribute) 67 | (replace-parts qualifier :in :varying :out :varying)) 68 | qualifier) 69 | (unless (find-any '(:mediump :highp :lowp) qualifier) 70 | '(:mediump))))) 71 | '(type-qualifier :mediump)))) 72 | (typecase ast 73 | (cons 74 | (case (first ast) 75 | (variable-declaration 76 | (destructuring-bind (qualifier specifier identifier array &optional initializer) 77 | (rest ast) 78 | (list (first ast) 79 | (type-qualifier qualifier) 80 | specifier 81 | identifier 82 | array 83 | (when (eq qualifier no-value) 84 | initializer)))) 85 | (function-prototype 86 | (destructuring-bind (qualifier specifier identifier &rest parameters) 87 | (rest ast) 88 | (list* (first ast) 89 | (type-qualifier qualifier) 90 | specifier 91 | identifier 92 | (loop for parameter in parameters 93 | collect (if (find 'type-qualifier parameter :key #'unlist) 94 | parameter 95 | `((type-qualifier :mediump) ,@parameter)))))) 96 | (T 97 | ast))) 98 | (T 99 | ast))))) 100 | 101 | (defun transform-to-core (version ast ctx env) 102 | (error "IMPLEMENT")) 103 | 104 | (defun transform (source profile version) 105 | (let* ((shader (etypecase source 106 | ((or string pathname) (parse source)) 107 | (cons source))) 108 | (shader (walk shader (ecase profile 109 | (:es (lambda (ast ctx env) (transform-to-gles version ast ctx env))) 110 | (:core (lambda (ast ctx env) (transform-to-core version ast ctx env))) 111 | ((NIL) #'identity))))) 112 | (etypecase source 113 | (string (serialize shader)) 114 | (cons shader)))) 115 | -------------------------------------------------------------------------------- /walker.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.trial.glsl) 2 | 3 | (defclass environment () 4 | ((root :initform NIL :reader root) 5 | (bindings :initform (make-hash-table :test 'equal) :reader bindings) 6 | (typedefs :initform (make-hash-table :test 'equal) :reader typedefs))) 7 | 8 | ;; FIXME: all this stuff could as well be generic 9 | (defun binding (name environment) 10 | (gethash name (bindings environment))) 11 | 12 | (defun (setf binding) (value name environment) 13 | (setf (gethash name (bindings environment)) value)) 14 | 15 | (defun typedef (name environment) 16 | (gethash name (typedefs environment))) 17 | 18 | (defun (setf typedef) (value name environment) 19 | (setf (gethash name (typedefs environment)) value)) 20 | 21 | (defun make-environment (&optional parent) 22 | (let ((environment (make-instance 'environment))) 23 | (cond (parent 24 | (setf (slot-value environment 'root) (root parent)) 25 | (loop for k being the hash-keys of (bindings parent) using (hash-value v) 26 | do (setf (binding k environment) v)) 27 | (loop for k being the hash-keys of (typedefs parent) using (hash-value v) 28 | do (setf (typedef k environment) v))) 29 | (T 30 | (setf (slot-value environment 'root) environment) 31 | ;; FIXME: inject standard function and variable defs 32 | )) 33 | environment)) 34 | 35 | (defun root-environment-p (environment) 36 | (eql environment (root environment))) 37 | 38 | (defun preprocessor-p (value environment) 39 | (declare (ignore environment)) 40 | (and (consp value) 41 | (eql (first value) 'preprocessor-directive))) 42 | 43 | (defun constant-p (value environment) 44 | (declare (ignore environment)) 45 | (or (integerp value) 46 | (floatp value) 47 | (and (consp value) (eql 'unsigned-int (first value))) 48 | (eql value :true) 49 | (eql value :false))) 50 | 51 | (defun declaration-p (value environment) 52 | (declare (ignore environment)) 53 | (and (consp value) 54 | (find (first value) '(function-declaration 55 | function-definition 56 | variable-declaration 57 | precision-declaration 58 | struct-declaration 59 | interface-declaration)))) 60 | 61 | (defun expression-p (value environment) 62 | (or (constant-p value environment) 63 | (identifier-p value environment) 64 | (and (consp value) 65 | (find (first value) '(assignment 66 | conditional 67 | logical-or 68 | logical-xor 69 | logical-and 70 | inclusive-or 71 | exclusive-or 72 | bitwise-and 73 | not-equal 74 | equal 75 | greater-equal-than 76 | less-equal-than 77 | greater-than 78 | less-than 79 | right-shift 80 | left-shift 81 | subtraction 82 | addition 83 | modulus 84 | division 85 | multiplication 86 | prefix-decrement 87 | prefix-increment 88 | bit-inversion 89 | inversion 90 | negation 91 | same-+ 92 | modified-reference))))) 93 | 94 | (defun boolean-expression-p (value environment) 95 | (declare (ignore environment)) 96 | (if (consp value) 97 | (find (first value) '(logical-or 98 | logical-and 99 | logical-xor 100 | not-equal 101 | equal 102 | less-than 103 | less-equal-than 104 | greater-than 105 | greater-equal-than)) 106 | (or (eql :true value) (eql :false value)))) 107 | 108 | (defun numeric-expression-p (value environment) 109 | (declare (ignore environment)) 110 | (if (consp value) 111 | (find (first value) '(right-shift 112 | left-shift 113 | subtraction 114 | addition 115 | multiplication 116 | division 117 | modulus)) 118 | (numberp value))) 119 | 120 | (defun control-flow-p (value environment) 121 | (declare (ignore environment)) 122 | (and (consp value) 123 | (find (first value) '(selection-statement 124 | case-label 125 | switch-statement 126 | while-statement 127 | do-statement 128 | for-statement 129 | continue 130 | break 131 | return 132 | discard)))) 133 | 134 | (defun keyword-p (value environment) 135 | (declare (ignore environment)) 136 | (find value *glsl-keyword-symbols*)) 137 | 138 | (defun statement-p (value environment) 139 | (or (declaration-p value environment) 140 | (expression-p value environment) 141 | (control-flow-p value environment) 142 | (eql value :\;))) 143 | 144 | (defun function-call-p (value environment) 145 | (declare (ignore environment)) 146 | (and (consp value) 147 | (eql (first value) 'modified-reference) 148 | (member 'call-modifier (cddr value) :key #'car))) 149 | 150 | (defun identifier-p (value environment) 151 | (declare (ignore environment)) 152 | (or (keywordp value) (stringp value))) 153 | 154 | (defun global-identifier-p (value environment) 155 | (not (null (binding value (root environment))))) 156 | 157 | (defun local-identifier-p (value environment) 158 | (not (eql (binding value environment) 159 | (binding value (root environment))))) 160 | 161 | (defun variable-identifier-p (value environment) 162 | (let ((binding (binding value environment))) 163 | (and binding 164 | (eql :variable (first binding))))) 165 | 166 | (defun function-identifier-p (value environment) 167 | (let ((binding (binding value environment))) 168 | (and binding 169 | (eql :function (first binding))))) 170 | 171 | (defun variable-type (value environment) 172 | (third (binding value environment))) 173 | 174 | (defun upgraded-type (a b) 175 | ;; NOTE: not sure this is entirely right for, say VEC+DOUBLE? Should it result in DVEC? 176 | (or (dolist (type '(:dmat :dvec :mat :vec :imat :ivec :umat :uvec :double :float :int)) 177 | (cond ((string= a type :end1 (min (length (string a)) (length (string type)))) 178 | (return a)) 179 | ((string= b type :end1 (min (length (string b)) (length (string type)))) 180 | (return b)))) 181 | a)) 182 | 183 | (defun derive-expression-type (value environment) 184 | (etypecase value 185 | (integer :int) 186 | (single-float :float) 187 | (double-float :double) 188 | (string (variable-type value environment)) 189 | (cons (cond ((boolean-expression-p value environment) 190 | :boolean) 191 | ((numeric-expression-p value environment) 192 | (upgraded-type (expression-type (second value) environment) 193 | (expression-type (third value) environment))) 194 | ((eql 'modified-reference (first value)) 195 | (let ((type (if (eql 'call-modifier (car (third value))) 196 | (error "FIXME: Derive call return type.") 197 | (derive-expression-type (second value) environment)))) 198 | (dolist (modifier (cddr value) type) 199 | (case (car modifier) 200 | (field-modifier 201 | (setf type (error "FIXME: Derive field type."))) 202 | (array-modifier 203 | (setf type (car type))))))))))) 204 | 205 | (defun overload-p (prototype environment) 206 | (destructuring-bind (qualifier specifier identifier &rest parameters) prototype 207 | (declare (ignore qualifier)) 208 | (when (eql :function (car (binding identifier environment))) 209 | (loop for binding on (binding identifier environment) by #'cddddr 210 | always (destructuring-bind (ex-qualifier ex-specifier ex-parameters) (rest binding) 211 | (declare (ignore ex-qualifier)) 212 | ;; It's an overload if: 213 | ;; 1. We have a different return type, or 214 | ;; 2. We have a different number of arguments, or 215 | ;; 3. The arguments have different type specifiers 216 | (or (not (equal ex-specifier specifier)) 217 | (not (= (length parameters) (length ex-parameters))) 218 | (loop for param in parameters 219 | for ex-param in ex-parameters 220 | thereis (or (not (equal (second param) (second ex-param))) 221 | (not (equal (fourth param) (fourth ex-param))))))))))) 222 | 223 | (defun walk (ast function &optional (environment (make-environment))) 224 | (walk-part ast ast function environment)) 225 | 226 | (defun walk-part (ast context function environment) 227 | (etypecase ast 228 | ((or integer float keyword string null (eql #.no-value)) 229 | (funcall function ast context environment)) 230 | (cons 231 | (setf ast (funcall function ast context environment)) 232 | (when ast 233 | (funcall (or (walker (first ast)) 234 | (error "Cannot walk AST-object of type ~s." 235 | (first ast))) 236 | ast function environment))))) 237 | 238 | (defvar *walkers* (make-hash-table :test 'eql)) 239 | 240 | (defun walker (type) 241 | (gethash type *walkers*)) 242 | 243 | (defun (setf walker) (function type) 244 | (setf (gethash type *walkers*) function)) 245 | 246 | (defun remove-walker (type) 247 | (remhash type *walkers*)) 248 | 249 | (defmacro define-walker (type (ast func env) &body body) 250 | `(progn (setf (walker ',type) 251 | (lambda (,ast ,func ,env) 252 | ,@body)) 253 | ',type)) 254 | 255 | (defmacro define-walking-body (type args &body body) 256 | (destructuring-bind (type &key (ast (gensym "AST")) 257 | (func (gensym "FUNC")) 258 | (env (gensym "ENV"))) (enlist type) 259 | `(define-walker ,type (,ast ,func ,env) 260 | (flet ((walk (node &optional (,env ,env)) 261 | (walk-part node ,ast ,func ,env))) 262 | (destructuring-bind ,args (rest ,ast) 263 | (list* ',type 264 | ,@body)))))) 265 | 266 | (defmacro define-empty-op-walker (type) 267 | `(define-walking-body ,type () 268 | NIL)) 269 | 270 | (defmacro define-unary-op-walker (type) 271 | `(define-walking-body ,type (inner) 272 | (walk inner) 273 | NIL)) 274 | 275 | (defmacro define-binary-op-walker (type) 276 | `(define-walking-body ,type (left right) 277 | (walk left) 278 | (walk right) 279 | NIL)) 280 | 281 | (define-walking-body unsigned-int (int) 282 | int 283 | NIL) 284 | 285 | (define-walking-body preprocessor-directive (directive) 286 | directive 287 | NIL) 288 | 289 | (define-walking-body modified-reference (expression &rest modifiers) 290 | (walk expression) 291 | (mapcar* #'walk modifiers)) 292 | 293 | (define-walking-body field-modifier (identifier) 294 | (walk identifier) 295 | NIL) 296 | 297 | (define-walking-body array-modifier (expression) 298 | (walk expression) 299 | NIL) 300 | 301 | (define-walking-body increment-modifier () 302 | NIL) 303 | 304 | (define-walking-body decrement-modifier () 305 | NIL) 306 | 307 | (define-walking-body call-modifier (&rest values) 308 | (mapcar* #'walk values)) 309 | 310 | (define-unary-op-walker same-+) 311 | (define-unary-op-walker negation) 312 | (define-unary-op-walker inversion) 313 | (define-unary-op-walker bit-inversion) 314 | (define-unary-op-walker prefix-increment) 315 | (define-unary-op-walker prefix-decrement) 316 | 317 | (define-binary-op-walker multiplication) 318 | (define-binary-op-walker division) 319 | (define-binary-op-walker modulus) 320 | (define-binary-op-walker addition) 321 | (define-binary-op-walker subtraction) 322 | (define-binary-op-walker left-shift) 323 | (define-binary-op-walker right-shift) 324 | (define-binary-op-walker less-than) 325 | (define-binary-op-walker greater-than) 326 | (define-binary-op-walker less-equal-than) 327 | (define-binary-op-walker greater-equal-than) 328 | (define-binary-op-walker equal) 329 | (define-binary-op-walker not-equal) 330 | (define-binary-op-walker bitwise-and) 331 | (define-binary-op-walker exclusive-or) 332 | (define-binary-op-walker inclusive-or) 333 | (define-binary-op-walker logical-and) 334 | (define-binary-op-walker logical-xor) 335 | (define-binary-op-walker logical-or) 336 | 337 | (define-walking-body conditional (condition expression else) 338 | (walk condition) 339 | (walk expression) 340 | (walk else) 341 | NIL) 342 | 343 | (define-walking-body assignment (place op value) 344 | (walk place) 345 | op 346 | (walk value) 347 | NIL) 348 | 349 | (define-walking-body multiple-expressions (&rest expressions) 350 | (mapcar* #'walk expressions)) 351 | 352 | (define-walking-body function-declaration (prototype) 353 | (walk prototype) 354 | NIL) 355 | 356 | (define-walking-body (function-prototype :ast ast :env env) (qualifier specifier identifier &rest parameters) 357 | qualifier 358 | specifier 359 | (progn (let ((binding (list :function qualifier specifier parameters)) 360 | (existing (binding identifier env))) 361 | (cond ((null existing) 362 | (setf (binding identifier env) binding)) 363 | ((overload-p ast env) 364 | (setf (binding identifier env) (append binding existing))))) 365 | (walk identifier)) 366 | parameters) 367 | 368 | (define-walking-body precision-declarator (precision type) 369 | precision 370 | type 371 | NIL) 372 | 373 | (define-walking-body (variable-declaration :env env) (qualifier specifier identifier array &optional init) 374 | qualifier specifier 375 | (progn (setf (binding identifier env) 376 | (list :variable qualifier specifier array)) 377 | (walk identifier)) 378 | array (when init (list (walk init)))) 379 | 380 | (define-walking-body layout-qualifier (&rest ids) 381 | (mapcar #'walk ids)) 382 | 383 | (define-walking-body layout-qualifier-id (identifier &optional value) 384 | (walk identifier) 385 | (when value (list (walk value)))) 386 | 387 | (define-walking-body type-qualifier (&rest qualifiers) 388 | qualifiers) 389 | 390 | (define-walking-body subroutine-qualifier (&optional type-name) 391 | type-name 392 | NIL) 393 | 394 | (define-walking-body type-specifier (type &optional array) 395 | type 396 | (enlist array)) 397 | 398 | (define-walking-body array-specifier (&rest specifiers) 399 | specifiers) 400 | 401 | (define-walking-body type-name (identifier) 402 | (walk identifier) 403 | NIL) 404 | 405 | (define-walking-body struct-specifier (identifier) 406 | (walk identifier) 407 | NIL) 408 | 409 | (define-walking-body struct-declaration (identifier instance &rest declarators) 410 | (walk identifier) 411 | (walk instance) 412 | (mapcar* #'walk declarators)) 413 | 414 | (define-walking-body struct-declarator (qualifier specifier identifier &optional array) 415 | qualifier 416 | specifier 417 | (walk identifier) 418 | (if array (list array))) 419 | 420 | (define-walking-body interface-declaration (qualifier identifier instance &rest declarators) 421 | qualifier 422 | (walk identifier) 423 | (walk instance) 424 | (mapcar* #'walk declarators)) 425 | 426 | (define-walking-body instance-name (identifier &optional array) 427 | (walk identifier) 428 | (list 429 | (enlist array))) 430 | 431 | (define-walking-body array-initializer (&rest initializers) 432 | (mapcar* #'walk initializers)) 433 | 434 | (define-walking-body multiple-statements (&rest statements) 435 | (mapcar* #'walk statements)) 436 | 437 | (define-walking-body (compound-statement :env env) (&rest statements) 438 | (let ((env (make-environment env))) 439 | (loop for statement in statements 440 | for item = (walk statement env) 441 | when item collect item))) 442 | 443 | (define-walking-body selection-statement (expression statement &optional else) 444 | (walk expression) 445 | (walk statement) 446 | (when else (list (walk else)))) 447 | 448 | (define-walking-body (condition-declarator :env env) (qualifier specifier identifier initializer) 449 | qualifier 450 | specifier 451 | (progn (setf (binding identifier env) 452 | (list :variable qualifier specifier NIL)) 453 | (walk identifier)) 454 | (walk initializer) 455 | NIL) 456 | 457 | (define-walking-body switch-statement (expression statement) 458 | (walk expression) 459 | (walk statement) 460 | NIL) 461 | 462 | (define-walking-body case-label (expression) 463 | (if (eql expression :default) 464 | :default 465 | (walk expression)) 466 | NIL) 467 | 468 | (define-walking-body while-statement (condition statement) 469 | (walk condition) 470 | (walk statement) 471 | NIL) 472 | 473 | (define-walking-body do-statement (statement expression) 474 | (walk statement) 475 | (walk expression) 476 | NIL) 477 | 478 | (define-walking-body for-statement (declaration condition expression statement) 479 | (walk declaration) 480 | (walk condition) 481 | (walk expression) 482 | (walk statement) 483 | NIL) 484 | 485 | (define-empty-op-walker continue) 486 | (define-empty-op-walker break) 487 | (define-empty-op-walker discard) 488 | 489 | (define-walking-body return (&optional value) 490 | (when value (list (walk value)))) 491 | 492 | (define-walking-body function-definition (prototype statement) 493 | (walk prototype) 494 | (walk statement) 495 | NIL) 496 | 497 | (define-walking-body shader (&rest items) 498 | (mapcar* #'walk items)) 499 | --------------------------------------------------------------------------------