[ { "path": ".gitattributes", "content": "*.toc linguist-language=Clojure\n" }, { "path": ".gitignore", "content": "\n*.DS_Store\ndependencies\n*.dSYM\nbuild\ntoccata\n" }, { "path": "CMakeLists.txt", "content": "cmake_minimum_required(VERSION 3.9.4)\n\nproject(toccata)\n\nadd_definitions(-std=c99)\n\nset (CORE_LIBS pthread)\n\nadd_executable(toccata toccata.c core.c)\ntarget_link_libraries(toccata ${CORE_LIBS})" }, { "path": "HISTORY.md", "content": "# Rationale\n\nThe first (almost) usuable version of Toccata is finally nearing completion. By reading\nthrough the commits and the entries in this file, you should be able to watch Toccata\ngrow from nothing to a usable language. This is not a historical record. The real\ndevelopment effort (and resulting code) was very ugly with lots of dead ends, painful bugs,\nand tears. (Not really on the tears part, but close)\n\nThis repo is to capture the organizational structure of the code.\n\nNew entries will be added to the end, and so should be read from the top down.\n\nHappy Reading and Pull Requests welcome!\n\nJim Duey\n\n# Story\n\n## Entry 1:\n\nIn the beginning, God created the Heavens and the Earth. Gen. 1:1\n\nUnlike in Genesis, a lot of work has preceded this commit. Until this compiler is\nself-hosting, you won't be able to compile and run it. Nor compile the various regression\ntests. I'm using the previous version of Toccata to cross-compile this code until that point.\n\nNow, let us begin.\n\nThe `regression-tests` directory will contain a collection of Toccata programs that\nexercise various parts of the compiler. `main1.toc` is the simplest program possible.\nBut already, there's a ton of code required. We have to ...\n open the file\n read it\n parse the contents into a nested list structure\n convert the parsed structure to an AST (Abstract Syntax Tree)\n traverse the AST and emit C code to stdout\n\nIf the C code has been written to a file, it can be compiled to an executable using\nLLVM or GCC.\n\nSo `toccata.toc` is what it takes to do the above steps. This is about as simple a\ncompiler for Toccata as possible. Everything else builds from there.\n\n\n## Entry 2:\n\nWhen an expression is emitted, it is converted to a list of data structures. Each data structure\nhas the following\n A string that holds the C variable the result of the expression is assigned to\n A list of strings of C code to declare static C values\n A list of strings of C code that produces the expressions result\n A number that signifies the type of the result of the expression\n A hash-map of of C variables that are used in the expression to the number of times their used\n\nAlso, `inline` expressions can appear at the top level of a file just like the `main` expression\n\n## Entry 3:\n\nComment blocks are AST nodes also, this allows easy literate programming and code formatting\n\n## Entry 4:\n\nDefining symbols is the next step. Toccata source files are called modules and eventually there will be\na system for compiling multiple modules into a program. The C variable for each symbol in a module\nis added to the global context so it can be looked up later.\n\n## Entry 5:\n\nNow we're able to assign numbers to symbols\n\n## Entry 6:\n\nAnd now string literals to symbols\n\n## Entry 7:\n\nWhen doing the next commit, I discovered a need to refactor some code\n\n## Entry 8:\n\nAnd now we're finally getting somewhere. This is the first point that we can define a function and call it. Looking at this commit, you'll see the complexity start to increase. And we've just scratched the surface. This is where `core.c` makes it's appearance, which will hold all of the C code that is the foundation of Toccata. Watch it explode in successive commits.\n\n## Entry 9:\n\nSince we compile expressions that are calls to functions, we need to handle assiging the results to global static symbols. Which means we need to initialize them at run time before `main` runs. So this commit adds that machinery. It also adds the `core.toc` standard library.\n\n## Entry 10:\n\nNow we'll add a couple of low-level functions that we can call. We'll add the functionality to allocate and free a few primitive value types.\n\n## Entry 11:\n\nAdd a fn to compare integers for equality. Which means we need to add the Maybe type as well. And add malloc/free for Functions and Lists.\n\n## Entry 12:\n\nAdd `let` expressions to bind values to symbols\n\n## Entry 13:\n\nInline calls to `list` and `vector` so that those functions don't actually get called to create them. And test their destructuring in let and function parameters.\n\n## Entry 14:\n\nAdd `do` expressions for side-effecting code\n\n## Entry 15:\n\nSelecting an expression based on some condition is one of the fundamental features a language must have. So we add `and` & `or` expressions. `or` is the only expression that is lazy. Successive expressions in it's body are only executed after previous expressions evaluate to `nothing`. The first expression that evaluates to a `maybe` value produces the result of the `or` expression. Likewise, `and` is the only expression that short circuits when the first expression returns `nothing`. If all expressions return `maybe` values, the final one becomes the value the `and` expression evaluates to.\n\n## Entry 16:\n\nThough they don't do anything yet, 'assert' expressions are going to play a big role later on. The compiler will use them to do all kinds of static analysis.\n\n## Entry 17:\n\nAnd now we're finally into the good stuff. Toccata lifts/borrows/steals the idea of `protocols` from Clojure. This commit lets protocols be defined. Almost all of the core library is implemented as protocol functions, which has some very nice properties we'll see later. In Toccata, protocol functions can specify a default impleenation that will be executed if no type-specific protocol implementation is provided.\n\n## Entry 18:\n\nThe first hints of where I want to take Toccata appear in `core.toc`.\n\n## Entry 19:\n\nA rather large commit to enable extending types with additional protocol function implementations\n\n## Entry 20:\n\nWell that took longer than I expected. Which is a common occurance when writing a compiler. So many 'little' things lead to lots of other, bigger, things. Everything is connected and a lot has to be done before anything works. In any case, this commit adds variadic functions and fixes list/vector destructuring.\n\n## Entry 21:\n\nBeing able to create functions that close over values in their context is a key part of functional programming. This commit adds that.\n\n## Entry 22:\n\nAnd now, we can finally write ... 'println'!\n\n (defn println [& vs]\n (map (flat-map (interpose vs \" \") string-list) pr*)\n (pr* \"\\n\"))\n\nAs you can see, there's quite a lot of complexity in compiling such a simple looking function. OTOH, we've come a long ways towards a powerful language. Still quite a ways to go, though.\n\n## Entry 23:\n\nBefore moving on, we need to address some long standing ugliness. One of the unique things about Toccata is that it uses reference counting for garbage colleciton. But this conflicts with my desire to have tail call optimization. A good write up is [here](http://devetc.org/code/2014/05/24/tail-recursion-objc-and-arc.html). So I came up with a way for the compiler to \"precompute\" how many times a value will be used in a particular scope and generate code to increment it's ref count by that much all at once. Then at each use, it's ref count is decremented. This eliminates the need to do a final decrement at the end of the current scope, thus making TCO possible. However, the original code was written using trial and error, and had tentacles all through the compiler. This refactoring cleans all that up.\n\n## Entry 24:\n\nWe now have enough of the compiler working to start to expand the core library. Our first task is to implement the core protocols and functions for the basic data types. The first one we'll tackle is `Integer` since it's the simplest. Along the way, we'll be adding bits to the compiler as needed.\n\n## Entry 25:\n\nNext up is the core functionality for the `String`. It's a more complicated because a string can be thought of as a sequence of characters, so the Sequable protocol needs to be implemented as well.\n\n## Entry 26:\n\nSymbol literals are even simpler than strings. You create them by putting a `'` befoer a symbol. Useful as keys in hash-maps.\n\n## Entry 27:\n\n`Maybe` is the simplest type whose values can contain other values, so it's the first time we implement the very important `Container` protocol.\n\n## Entry 28:\n\nA slightly more complicated container value is the `List` type. In addition to containing 0, 1 or more values of any type, it also has a concept of sequence. The values are stored in a certain order. (And I forgot to add this note to the previous commit. Oops :) )\n\n## Entry 29:\n\nAnother container is the `Vector` type. Among other things, it adds the idea of accessing the values it contains by an integer index.\n\n## Entry 30:\n\nBeing able to create new datatypes by combining existing ones is a key form of abstraction. This commit adds the `deftype` form to allow this.\n\n## Entry 31:\n\nEnsure the Function type performs as expected\n\n## Entry 32:\n\nOne of the most-used data structures (in Clojure, at least) is the HashMap. Here's the implementation for it in Toccata.\n\n## Entry 33:\n\nNo modern programming language is complete without a concurrency story. For Toccata, that revolves around the Promise and Future datatypes. This is their story.\n\n## Entry 34:\n\nThe final 'built-in' datatype also rounds out the concurrency story. This commit implements the Agent functionality.\n\n## Entry 35:\n\nJust clean up some loose ends that were dangling before proceeding\n\n## Entry 36:\n\nFixed a bug in the recursive descent parser code.\n\n## Entry 37:\n\nA lot of work to enable and then to impleent the ability to break source code into different files and then compile them all to build an executable.\n\n## Entry 38:\n\nSharing libraries for others to use is a huge part of usability. This commit allows any git repository to be imported as a Toccata dependency.\n\n## Entry 39:\n\nOne of the most used special forms is 'for'.\n\n## Entry 40:\n\nAnother very useful special form is threading a value through successive function calls. Since Toccata doesn't have a macro system (yet!), a few of these useful forms have to be built into the compiler.\n\n## Entry 41:\n\nAdd some \"nice to haves\" to the core library\n\n## Entry 42:\n\nAdd 'gensym' to let you generate unique symbols.\n\n## Entry 43:\n\nA thread-safe, lazy list implementation\n\n## Entry 44:\n\nGoing down a rabbit trail, I implemented the core composition protocols for the Promise data type. This (along with the same for Future) will enable some awesome async programming.\n\n## Entry 45:\n\nAnd doing the same for the Future data type. Async programming in Toccata is going to be awesome!\n\n## Entry 46:\n\nSo close! Toccata can now compile it's compiler, which is my milestone for opening it up and letting other people get their hands on it. It's horribly slow, so the final step is to fix performance issues and clean up some TODO's.\n\n## Entry 47:\n\nAnd we finally have a compiler that will compile itself with not-too-bad performance.\n\nTo use it, compile toccata.c with\n\n clang -g -O3 -fno-objc-arc -std=c99 -c core.c\n clang -g -O3 -fno-objc-arc -o toccata -std=c99 core.o toccata.c -lpthread\n\nYou can leave off the `-fno-objc-arg` if you're on Linux\n\nAnd thus ends the history." }, { "path": "LICENSE", "content": "Mozilla Public License Version 2.0\n==================================\n\n1. Definitions\n--------------\n\n1.1. \"Contributor\"\n means each individual or legal entity that creates, contributes to\n the creation of, or owns Covered Software.\n\n1.2. \"Contributor Version\"\n means the combination of the Contributions of others (if any) used\n by a Contributor and that particular Contributor's Contribution.\n\n1.3. \"Contribution\"\n means Covered Software of a particular Contributor.\n\n1.4. \"Covered Software\"\n means Source Code Form to which the initial Contributor has attached\n the notice in Exhibit A, the Executable Form of such Source Code\n Form, and Modifications of such Source Code Form, in each case\n including portions thereof.\n\n1.5. \"Incompatible With Secondary Licenses\"\n means\n\n (a) that the initial Contributor has attached the notice described\n in Exhibit B to the Covered Software; or\n\n (b) that the Covered Software was made available under the terms of\n version 1.1 or earlier of the License, but not also under the\n terms of a Secondary License.\n\n1.6. \"Executable Form\"\n means any form of the work other than Source Code Form.\n\n1.7. \"Larger Work\"\n means a work that combines Covered Software with other material, in\n a separate file or files, that is not Covered Software.\n\n1.8. \"License\"\n means this document.\n\n1.9. \"Licensable\"\n means having the right to grant, to the maximum extent possible,\n whether at the time of the initial grant or subsequently, any and\n all of the rights conveyed by this License.\n\n1.10. \"Modifications\"\n means any of the following:\n\n (a) any file in Source Code Form that results from an addition to,\n deletion from, or modification of the contents of Covered\n Software; or\n\n (b) any new file in Source Code Form that contains any Covered\n Software.\n\n1.11. \"Patent Claims\" of a Contributor\n means any patent claim(s), including without limitation, method,\n process, and apparatus claims, in any patent Licensable by such\n Contributor that would be infringed, but for the grant of the\n License, by the making, using, selling, offering for sale, having\n made, import, or transfer of either its Contributions or its\n Contributor Version.\n\n1.12. \"Secondary License\"\n means either the GNU General Public License, Version 2.0, the GNU\n Lesser General Public License, Version 2.1, the GNU Affero General\n Public License, Version 3.0, or any later versions of those\n licenses.\n\n1.13. \"Source Code Form\"\n means the form of the work preferred for making modifications.\n\n1.14. \"You\" (or \"Your\")\n means an individual or a legal entity exercising rights under this\n License. For legal entities, \"You\" includes any entity that\n controls, is controlled by, or is under common control with You. For\n purposes of this definition, \"control\" means (a) the power, direct\n or indirect, to cause the direction or management of such entity,\n whether by contract or otherwise, or (b) ownership of more than\n fifty percent (50%) of the outstanding shares or beneficial\n ownership of such entity.\n\n2. License Grants and Conditions\n--------------------------------\n\n2.1. Grants\n\nEach Contributor hereby grants You a world-wide, royalty-free,\nnon-exclusive license:\n\n(a) under intellectual property rights (other than patent or trademark)\n Licensable by such Contributor to use, reproduce, make available,\n modify, display, perform, distribute, and otherwise exploit its\n Contributions, either on an unmodified basis, with Modifications, or\n as part of a Larger Work; and\n\n(b) under Patent Claims of such Contributor to make, use, sell, offer\n for sale, have made, import, and otherwise transfer either its\n Contributions or its Contributor Version.\n\n2.2. Effective Date\n\nThe licenses granted in Section 2.1 with respect to any Contribution\nbecome effective for each Contribution on the date the Contributor first\ndistributes such Contribution.\n\n2.3. Limitations on Grant Scope\n\nThe licenses granted in this Section 2 are the only rights granted under\nthis License. No additional rights or licenses will be implied from the\ndistribution or licensing of Covered Software under this License.\nNotwithstanding Section 2.1(b) above, no patent license is granted by a\nContributor:\n\n(a) for any code that a Contributor has removed from Covered Software;\n or\n\n(b) for infringements caused by: (i) Your and any other third party's\n modifications of Covered Software, or (ii) the combination of its\n Contributions with other software (except as part of its Contributor\n Version); or\n\n(c) under Patent Claims infringed by Covered Software in the absence of\n its Contributions.\n\nThis License does not grant any rights in the trademarks, service marks,\nor logos of any Contributor (except as may be necessary to comply with\nthe notice requirements in Section 3.4).\n\n2.4. Subsequent Licenses\n\nNo Contributor makes additional grants as a result of Your choice to\ndistribute the Covered Software under a subsequent version of this\nLicense (see Section 10.2) or under the terms of a Secondary License (if\npermitted under the terms of Section 3.3).\n\n2.5. Representation\n\nEach Contributor represents that the Contributor believes its\nContributions are its original creation(s) or it has sufficient rights\nto grant the rights to its Contributions conveyed by this License.\n\n2.6. Fair Use\n\nThis License is not intended to limit any rights You have under\napplicable copyright doctrines of fair use, fair dealing, or other\nequivalents.\n\n2.7. Conditions\n\nSections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted\nin Section 2.1.\n\n3. Responsibilities\n-------------------\n\n3.1. Distribution of Source Form\n\nAll distribution of Covered Software in Source Code Form, including any\nModifications that You create or to which You contribute, must be under\nthe terms of this License. You must inform recipients that the Source\nCode Form of the Covered Software is governed by the terms of this\nLicense, and how they can obtain a copy of this License. You may not\nattempt to alter or restrict the recipients' rights in the Source Code\nForm.\n\n3.2. Distribution of Executable Form\n\nIf You distribute Covered Software in Executable Form then:\n\n(a) such Covered Software must also be made available in Source Code\n Form, as described in Section 3.1, and You must inform recipients of\n the Executable Form how they can obtain a copy of such Source Code\n Form by reasonable means in a timely manner, at a charge no more\n than the cost of distribution to the recipient; and\n\n(b) You may distribute such Executable Form under the terms of this\n License, or sublicense it under different terms, provided that the\n license for the Executable Form does not attempt to limit or alter\n the recipients' rights in the Source Code Form under this License.\n\n3.3. Distribution of a Larger Work\n\nYou may create and distribute a Larger Work under terms of Your choice,\nprovided that You also comply with the requirements of this License for\nthe Covered Software. If the Larger Work is a combination of Covered\nSoftware with a work governed by one or more Secondary Licenses, and the\nCovered Software is not Incompatible With Secondary Licenses, this\nLicense permits You to additionally distribute such Covered Software\nunder the terms of such Secondary License(s), so that the recipient of\nthe Larger Work may, at their option, further distribute the Covered\nSoftware under the terms of either this License or such Secondary\nLicense(s).\n\n3.4. Notices\n\nYou may not remove or alter the substance of any license notices\n(including copyright notices, patent notices, disclaimers of warranty,\nor limitations of liability) contained within the Source Code Form of\nthe Covered Software, except that You may alter any license notices to\nthe extent required to remedy known factual inaccuracies.\n\n3.5. Application of Additional Terms\n\nYou may choose to offer, and to charge a fee for, warranty, support,\nindemnity or liability obligations to one or more recipients of Covered\nSoftware. However, You may do so only on Your own behalf, and not on\nbehalf of any Contributor. You must make it absolutely clear that any\nsuch warranty, support, indemnity, or liability obligation is offered by\nYou alone, and You hereby agree to indemnify every Contributor for any\nliability incurred by such Contributor as a result of warranty, support,\nindemnity or liability terms You offer. You may include additional\ndisclaimers of warranty and limitations of liability specific to any\njurisdiction.\n\n4. Inability to Comply Due to Statute or Regulation\n---------------------------------------------------\n\nIf it is impossible for You to comply with any of the terms of this\nLicense with respect to some or all of the Covered Software due to\nstatute, judicial order, or regulation then You must: (a) comply with\nthe terms of this License to the maximum extent possible; and (b)\ndescribe the limitations and the code they affect. Such description must\nbe placed in a text file included with all distributions of the Covered\nSoftware under this License. Except to the extent prohibited by statute\nor regulation, such description must be sufficiently detailed for a\nrecipient of ordinary skill to be able to understand it.\n\n5. Termination\n--------------\n\n5.1. The rights granted under this License will terminate automatically\nif You fail to comply with any of its terms. However, if You become\ncompliant, then the rights granted under this License from a particular\nContributor are reinstated (a) provisionally, unless and until such\nContributor explicitly and finally terminates Your grants, and (b) on an\nongoing basis, if such Contributor fails to notify You of the\nnon-compliance by some reasonable means prior to 60 days after You have\ncome back into compliance. Moreover, Your grants from a particular\nContributor are reinstated on an ongoing basis if such Contributor\nnotifies You of the non-compliance by some reasonable means, this is the\nfirst time You have received notice of non-compliance with this License\nfrom such Contributor, and You become compliant prior to 30 days after\nYour receipt of the notice.\n\n5.2. If You initiate litigation against any entity by asserting a patent\ninfringement claim (excluding declaratory judgment actions,\ncounter-claims, and cross-claims) alleging that a Contributor Version\ndirectly or indirectly infringes any patent, then the rights granted to\nYou by any and all Contributors for the Covered Software under Section\n2.1 of this License shall terminate.\n\n5.3. In the event of termination under Sections 5.1 or 5.2 above, all\nend user license agreements (excluding distributors and resellers) which\nhave been validly granted by You or Your distributors under this License\nprior to termination shall survive termination.\n\n************************************************************************\n* *\n* 6. Disclaimer of Warranty *\n* ------------------------- *\n* *\n* Covered Software is provided under this License on an \"as is\" *\n* basis, without warranty of any kind, either expressed, implied, or *\n* statutory, including, without limitation, warranties that the *\n* Covered Software is free of defects, merchantable, fit for a *\n* particular purpose or non-infringing. The entire risk as to the *\n* quality and performance of the Covered Software is with You. *\n* Should any Covered Software prove defective in any respect, You *\n* (not any Contributor) assume the cost of any necessary servicing, *\n* repair, or correction. This disclaimer of warranty constitutes an *\n* essential part of this License. No use of any Covered Software is *\n* authorized under this License except under this disclaimer. *\n* *\n************************************************************************\n\n************************************************************************\n* *\n* 7. Limitation of Liability *\n* -------------------------- *\n* *\n* Under no circumstances and under no legal theory, whether tort *\n* (including negligence), contract, or otherwise, shall any *\n* Contributor, or anyone who distributes Covered Software as *\n* permitted above, be liable to You for any direct, indirect, *\n* special, incidental, or consequential damages of any character *\n* including, without limitation, damages for lost profits, loss of *\n* goodwill, work stoppage, computer failure or malfunction, or any *\n* and all other commercial damages or losses, even if such party *\n* shall have been informed of the possibility of such damages. This *\n* limitation of liability shall not apply to liability for death or *\n* personal injury resulting from such party's negligence to the *\n* extent applicable law prohibits such limitation. Some *\n* jurisdictions do not allow the exclusion or limitation of *\n* incidental or consequential damages, so this exclusion and *\n* limitation may not apply to You. *\n* *\n************************************************************************\n\n8. Litigation\n-------------\n\nAny litigation relating to this License may be brought only in the\ncourts of a jurisdiction where the defendant maintains its principal\nplace of business and such litigation shall be governed by laws of that\njurisdiction, without reference to its conflict-of-law provisions.\nNothing in this Section shall prevent a party's ability to bring\ncross-claims or counter-claims.\n\n9. Miscellaneous\n----------------\n\nThis License represents the complete agreement concerning the subject\nmatter hereof. If any provision of this License is held to be\nunenforceable, such provision shall be reformed only to the extent\nnecessary to make it enforceable. Any law or regulation which provides\nthat the language of a contract shall be construed against the drafter\nshall not be used to construe this License against a Contributor.\n\n10. Versions of the License\n---------------------------\n\n10.1. New Versions\n\nMozilla Foundation is the license steward. Except as provided in Section\n10.3, no one other than the license steward has the right to modify or\npublish new versions of this License. Each version will be given a\ndistinguishing version number.\n\n10.2. Effect of New Versions\n\nYou may distribute the Covered Software under the terms of the version\nof the License under which You originally received the Covered Software,\nor under the terms of any subsequent version published by the license\nsteward.\n\n10.3. Modified Versions\n\nIf you create software not governed by this License, and you want to\ncreate a new license for such software, you may create and use a\nmodified version of this License if you rename the license and remove\nany references to the name of the license steward (except to note that\nsuch modified license differs from this License).\n\n10.4. Distributing Source Code Form that is Incompatible With Secondary\nLicenses\n\nIf You choose to distribute Source Code Form that is Incompatible With\nSecondary Licenses under the terms of this version of the License, the\nnotice described in Exhibit B of this License must be attached.\n\nExhibit A - Source Code Form License Notice\n-------------------------------------------\n\n This Source Code Form is subject to the terms of the Mozilla Public\n License, v. 2.0. If a copy of the MPL was not distributed with this\n file, You can obtain one at http://mozilla.org/MPL/2.0/.\n\nIf it is not possible or desirable to put the notice in a particular\nfile, then You may include the notice in a location (such as a LICENSE\nfile in a relevant directory) where a recipient would be likely to look\nfor such a notice.\n\nYou may add additional accurate notices of copyright ownership.\n\nExhibit B - \"Incompatible With Secondary Licenses\" Notice\n---------------------------------------------------------\n\n This Source Code Form is \"Incompatible With Secondary Licenses\", as\n defined by the Mozilla Public License, v. 2.0.\n" }, { "path": "README.md", "content": "Toccata\n=======\n\n> \"Pithy quote.\"\n> - Unknown\n\nAn incomplete, buggy, undocumented, Clojure-inspired Lisp dialect that compiles to native executable using the Clang compiler\n\n# Quick start (for macOS, Linux should be similar)\n\nMake sure you have `git` and `clang` installed. `clang` is part of the LLVM project and also installed as part of Xcode. Make sure that `/usr/bin/git` exists and points to the correct `git` executable.\n\n* Clone this repo and switch to the cloned directory\n* Compile `core.c`\n\n clang -O3 -g -fno-objc-arc -std=c99 -c core.c\n\n* Compile the Toccata compiler itself\n\n clang -O3 -g -fno-objc-arc -o toccata -std=c99 core.o toccata.c -lpthread -latomic\n \n* Set the TOCCATA_DIR environment variable to the directory that contains `core.toc`\n\n export TOCCATA_DIR=/Users/jduey/toccata\n \n* Add that same directory to the C_INCLUDE_PATH environment variable\n\n export C_INCLUDE_PATH=$C_INCLUDE_PATH:$TOCCATA_DIR\n\n* For convenience, make sure the `toccata` executable is on the $PATH.\n\n export PATH=$PATH:$TOCCATA_DIR\n \n# Compile your first program\n\n* Paste this text to a file named `hw.toc`\n\n (main [_]\n (println \"Howdy, folks\"))\n \n* Compile it to C code\n\n toccata hw.toc > hw.c\n\n* Compile the C code using `clang` and link with `core.o`\n\n clang -g -fno-objc-arc -o hw -std=c99 $TOCCATA_DIR/core.o hw.c -lpthread -latomic\n \n* Run it\n\n ./hw\n \n# But wait!\n\n## READ THIS SECTION! It will save you hours of frustration.\n\nSee that phrase at the very top? I'll put it here just to make sure\n\n \"inspired by Clojure\"\n\nToccata is not a copy or a port of Clojure. There are some very key differences. I'm going to list a few here, but there are others as well.\n\n* `for` is not just for sequences. It works on any data type that implements the `flat-map` protocol function\n\n* `map` is a protocol function. That means it can be implemented for any data type. Not just sequences. It also means the value that is being mapped over comes first and the mapping function comes second. This is the opposite order that Clojure uses.\n\n* There is no Boolean data type, no `true` or `false` values, no `if`, `cond` or `when` forms. This was a very speculative idea and I'm really happy how it worked. There will be a series of blog posts very soon explaining this in detail.\n\n* Comments are nodes in the AST. If you have an S expression that won't compile and it contains comments, try deleting the comments. I've got some rough edges to polish there.\n\n* Right now, documentation consists of this README, the comments and source code in `core.toc` and the programs in the `regression-tests`. Yes, that's pitiful. I'm working on getting blog posts out as quickly as possible.\n\n* Code is added to all C files that track the memory allocations and frees. The stats are printed at the end of each run. If there's a discrepancy, the return code will indicate failure. If you write a Toccata program that consistently fails, I'd be very interested in it. Also, any program that fails with an `incRef` error or a `dec_and_free` error. Those should definitely not happen.\n\n# And now ...\n\nThis is just the beginning of a long road to make Toccata into a useful programming language. I deeply appreciate your patience and assistance in making that happen.\n\nCheck the HISTORY.md file for a detailed description.\n\nYou can learn more about Toccata by following the [blog here](http://toccata.io)\n" }, { "path": "assertion-tests/add-items-list-1.toc", "content": "\n(def CrazyType (any-of List\n Vector\n Integer))\n\n(defn f [x]\n (assert (instance? CrazyType x))\n (str x))\n\n(defn g [[a b]]\n (inc b))\n\n(defn h [y]\n (g y)\n (f y))\n\n(main [_]\n (println (h ['a 'b]))\n (println 'bogus))\n\n" }, { "path": "assertion-tests/add-items-list-2.toc", "content": "\n(def CrazyType (any-of List\n Vector\n Integer))\n\n(defn f [x]\n (assert (instance? CrazyType x))\n (str x))\n\n(defn g [[a b]]\n (inc b))\n\n(defn h [y]\n (f y)\n (g y))\n\n(main [_]\n (println (h ['a 'b]))\n (println 'bogus))\n\n" }, { "path": "assertion-tests/and-constraints-1.toc", "content": "\n(defn foo [zs p]\n (let [mv (maybe zs)]\n (and (let [t (extract mv)]\n (maybe (inc p)))\n mv)))\n\n(main [_]\n (println (foo [\"xx\"] \"p\"))\n (println 'done))\n" }, { "path": "assertion-tests/and-constraints-2.toc", "content": "\n(defn foo [zs p]\n (let [mv (maybe zs)\n p (str p)]\n (and mv\n (let [t (extract mv)]\n (maybe (inc p)))\n (maybe (subs p 1)))))\n\n(main [_]\n (println (foo [\"xx\"] 72))\n (println 'done))\n" }, { "path": "assertion-tests/apply-constructor.toc", "content": "\n\n(deftype Popper [x y]\n (assert (instance? Symbol x))\n (assert (instance? Integer y)))\n\n(defn g [& vs]\n (apply Popper vs))\n\n(main [_]\n (print-err (g 's \"8\")))\n" }, { "path": "assertion-tests/bad-add.toc", "content": "\n(def a \"z\")\n(def b 's)\n\n(main [_]\n (+ 8 b a))\n" }, { "path": "assertion-tests/bad-and-1.toc", "content": "\n\n(defn f [x]\n (and nothing\n {'a 1}))\n\n(main [_]\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/bad-and-2.toc", "content": "\n\n(defn f [x]\n (and nothing\n 1)\n 'bogus)\n\n(main [_]\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/bad-and-clause.toc", "content": "(defn add-commas [x-str]\n (assert (instance? String x-str))\n (assert-result l (instance? List l))\n\n (let [prefix-len (mod (count x-str) 3)\n prefix (subs x-str 0 (mod (count x-str) 3))]\n (either (or (and (empty? x-str)\n (maybe empty-list))\n (and (= prefix-len 0)\n (list* \",\" (subs x-str 0 3)\n (add-commas (subs x-str 3)))))\n (list* \",\" (subs x-str 0 prefix-len)\n (add-commas (subs x-str prefix-len))))))\n\n(main [_]\n (print-err (add-commas \"140\"))\n (print-err 'done))\n" }, { "path": "assertion-tests/bad-apply-constructor.toc", "content": "\n(deftype Bogus [a b c]\n Stringable\n (string-list [_]\n (list \"\")))\n\n(main [_]\n (apply Bogus [4 5]))\n" }, { "path": "assertion-tests/bad-arity-1.toc", "content": "\n\n(defn bad [a b]\n a)\n\n(main [_]\n (bad \"Bogus\"))\n" }, { "path": "assertion-tests/bad-constructor-call.toc", "content": "\n(deftype AnotherType [x z]\n Stringable\n (string-list [_] (list \"\")))\n\n(def boomer (AnotherType 1))\n\n(main [_]\n (println \"Fail!!!!\"))\n" }, { "path": "assertion-tests/bad-constructor-param-1.toc", "content": "\n(deftype Boogie [xs]\n (assert (instance? (vector-of Integer) xs))\n\n Stringable\n (string-list [_]\n (list \"Boogie \" (str xs))))\n\n(main [_]\n (print-err 'bgi (Boogie [1 2 'p])))\n" }, { "path": "assertion-tests/bad-constructor-param-2.toc", "content": "\n(defprotocol Pookie\n (pook [_]\n (assert-result r (instance? (list-of (any-of StringBuffer\n SubString))\n r))))\n\n(deftype Boogie [xs]\n Stringable\n (string-list [_]\n (list \"Boogie \" (str xs)))\n\n Pookie\n (pook [_]\n (map xs (fn [n]\n (str (inc n))))))\n\n(main [_]\n (print-err 'bgi (Boogie [1 2 'p])))\n" }, { "path": "assertion-tests/bad-dipatch-type.toc", "content": "\n(defprotocol BogusProto\n (bogus [x]\n (assert (instance? String x))))\n\n(deftype BogusType [y]\n BogusProto\n (bogus [z]\n (str y)))\n\n(main [_]\n (print-err 'c1))\n" }, { "path": "assertion-tests/bad-enum-1.toc", "content": "\n(def en (enum r3 r1 2))\n\n(defn r-str [r]\n (assert (instance? en r))\n (print-err 'r r))\n\n(main [_]\n (r-str r3))\n" }, { "path": "assertion-tests/bad-enum-2.toc", "content": "\n(def en (enum r3 r1 Integer))\n\n(defn r-str [r]\n (assert (instance? en r))\n (print-err 'r r))\n\n(main [_]\n (r-str r3))\n" }, { "path": "assertion-tests/bad-enum-3.toc", "content": "\n(deftype Bogus [])\n\n(def en (enum r3 r1 Bogus))\n\n(defn r-str [r]\n (assert (instance? en r))\n (print-err 'r r))\n\n(main [_]\n (r-str r2))\n" }, { "path": "assertion-tests/bad-enum-4.toc", "content": "\n(def en (enum r3 r1 (+ 4 2)))\n\n(defn r-str [r]\n (assert (instance? en r))\n (print-err 'r r))\n\n(main [_]\n (r-str r2))\n" }, { "path": "assertion-tests/bad-field-1.toc", "content": "\n(deftype Ooops [not-there])\n\n(deftype Bogus [x-field])\n\n(main [_]\n (.not-there (Bogus 99)))\n" }, { "path": "assertion-tests/bad-field-2.toc", "content": "\n(deftype Ooops [not-there])\n\n(deftype Bogus [x-field])\n\n(defn f [x]\n (.not-there x))\n\n(defn g [v]\n (assert (instance? Bogus v))\n (.x-field v))\n\n(defn h [z]\n (g z)\n (f z))\n\n(main [_]\n (println 'bogus))\n" }, { "path": "assertion-tests/bad-field-3.toc", "content": "\n(deftype Ooops [not-there])\n\n(deftype Bogus [x-field])\n\n(defn f [x]\n (.not-there x))\n\n(defn g [v]\n (assert (instance? Bogus v))\n (.x-field v))\n\n(defn h [z]\n (f z)\n (g z))\n\n(main [_]\n (println 'bogus))\n" }, { "path": "assertion-tests/bad-field-4.toc", "content": "\n(deftype Ooops [not-there])\n\n(deftype Bogus [x-field])\n\n(main [_]\n (-> (Bogus 99)\n (.x-field 3)\n .not-there))\n" }, { "path": "assertion-tests/bad-field-5.toc", "content": "\n(deftype Ooops [not-there])\n\n(deftype Bogus [x-field])\n\n(defn f [x]\n (-> (.x-field 3)\n .not-there))\n\n(main [_]\n (f (Bogus 99)))\n" }, { "path": "assertion-tests/bad-flat-map-inner.toc", "content": "\n(defn f [s]\n (for [x (maybe (inc s))\n y (maybe (symbol x))]\n (str y)))\n\n(main [_]\n (print-err (for [x (f 8)]\n (subs x 1))))\n" }, { "path": "assertion-tests/bad-function-returns-1.toc", "content": "\n\n(deftype Failure [])\n\n(deftype new-se [invoke-fn]\n ;; (assert (instance? Fn invoke-fn))\n (assert (instance? (function-returns Vector) invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s)))\n\n(def state-error\n (reify\n Function\n (invoke [_ v]\n (new-se (fn [s] v)))))\n\n\n(main [_]\n\n (print-err (state-error 8)))\n" }, { "path": "assertion-tests/bad-function-returns-2.toc", "content": "\n(deftype Failure [])\n\n(deftype new-se [invoke-fn]\n ;; (assert (instance? Fn invoke-fn))\n (assert (instance? (function-returns Vector) invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s))\n\n Container\n (map [ev f]\n (new-se (fn [s]\n (let [x (invoke-fn s)]\n (either (= Failure x)\n (let [[v new-s] x]\n [(f v) new-s]))))))\n\n (wrap [_ v]\n (new-se (fn [s]\n [v s])))\n\n (flat-map [ev f]\n (new-se (fn [s]\n (let [x (invoke-fn s)]\n (either (= Failure x)\n (let [[v new-s] x]\n ((f v) new-s))))))))\n\n(def state-error\n (reify\n Function\n (invoke [_ v]\n (new-se (fn [s]\n [v s])))))\n\n\n(main [_]\n (print-err ((for [x (state-error 8)\n y (state-error 9)]\n (subs y 1))\n 'state)))\n" }, { "path": "assertion-tests/bad-impl-arity.toc", "content": "\n\n(main [_]\n (take \"Bogus\"))\n" }, { "path": "assertion-tests/bad-impl-return-value.toc", "content": "\n(defprotocol Proto\n (some-getter [tc]\n (assert-result r (instance? (maybe-of Symbol) r))\n\n nothing))\n\n(deftype KeysConstraint [fld]\n (assert (instance? (maybe-of Symbol) fld))\n\n Proto\n (some-getter [tc]\n (maybe fld)))\n\n(main [_]\n (print-err 'FAILURE))\n" }, { "path": "assertion-tests/bad-inline-result-type.toc", "content": "\n(defn bad-f [x]\n (inline C BogusType \"// shouldn't matter\n\"))\n\n(main [_]\n (println \"FAIL!!!\"))\n" }, { "path": "assertion-tests/bad-inner-1.toc", "content": "\n(main [_]\n (map [1 2 3] (fn [n]\n (subs n 1)))\n (print-err 'howdy))\n" }, { "path": "assertion-tests/bad-inner-10.toc", "content": "\n(defn f [vs]\n (reduce vs {} (fn [m [x y]]\n (assoc m x [(inc x) y]))))\n\n(main [_]\n (f [(list 1 2)\n ['x]\n [3 6]]))\n" }, { "path": "assertion-tests/bad-inner-11.toc", "content": "\n(defn f [x]\n (map x inc))\n\n(defn g [x]\n (maybe (subs x 1)))\n\n(main [_]\n (-> \"x\"\n g\n f))\n" }, { "path": "assertion-tests/bad-inner-12.toc", "content": "\n(defn f [x]\n (-> x\n (map str)\n first\n (map inc)))\n\n(main [_]\n (print-err 'howdy))\n" }, { "path": "assertion-tests/bad-inner-13.toc", "content": "\n(defn f [x]\n (-> x\n (map str)\n (map inc)))\n\n(main [_]\n (print-err 'howdy))\n" }, { "path": "assertion-tests/bad-inner-14.toc", "content": "\n(defn f [x]\n (-> x\n (map str)\n last\n (map inc)))\n\n(main [_]\n (print-err 'howdy))\n" }, { "path": "assertion-tests/bad-inner-15.toc", "content": "\n(main [_]\n (-> (maybe \"1\")\n extract\n inc))\n" }, { "path": "assertion-tests/bad-inner-16.toc", "content": "\n(defn f [x]\n (for [_ (maybe 3)]\n (inc x)))\n\n(defn g [x]\n (for [y (f x)]\n (do\n (assert (instance? Integer y))\n y)))\n\n(defn h [x]\n (for [_ (maybe 3)]\n (symbol x)))\n\n(defn i [x]\n (for [y (h x)]\n i))\n\n(defn j [x]\n (for [y (g x)\n _ (i y)]\n x))\n\n(main [_]\n (print-err (j 8)))\n" }, { "path": "assertion-tests/bad-inner-2.toc", "content": "\n(main [_]\n (map (list (inc 3)) (fn [n]\n (subs n 1)))\n (print-err 'howdy))\n" }, { "path": "assertion-tests/bad-inner-3.toc", "content": "\n(defn f [x]\n (map x inc))\n\n(defn g [x]\n (map x (fn [n] (subs n 1))))\n\n(defn h [x]\n (f x)\n (g x))\n\n(main [_]\n (print-err 'howdy))\n" }, { "path": "assertion-tests/bad-inner-4.toc", "content": "\n(main [_]\n (-> [1 2 3]\n (map inc)\n (drop-while (fn [n]\n (= \"\" (subs n 1)))))\n (print-err 'howdy))\n" }, { "path": "assertion-tests/bad-inner-5.toc", "content": "\n(defn f [x]\n (map x inc))\n\n(defn g [x]\n (map x (fn [n] (subs n 1))))\n\n(defn h [x]\n (-> x f g))\n\n(main [_]\n (print-err 'howdy))\n" }, { "path": "assertion-tests/bad-inner-6.toc", "content": "\n(defn f [vs]\n (map vs (fn [v]\n (map v inc))))\n\n(main [_]\n (f [[1 2]\n [3 5 \"bogus\"]\n [3 6]]))\n" }, { "path": "assertion-tests/bad-inner-7.toc", "content": "\n(defn f [vs]\n (flat-map vs\n (fn [v]\n (flat-map v inc))))\n\n(main [_]\n (f [[1 2]\n [3 5 \"bogus\"]\n [3 6]]))\n" }, { "path": "assertion-tests/bad-inner-8.toc", "content": "\n(defn f [vs]\n (for [v vs\n x v]\n (inc x)))\n\n(main [_]\n (f [[1 2]\n [3 5 \"bogus\"]\n [3 6]]))\n" }, { "path": "assertion-tests/bad-inner-9.toc", "content": "\n(defn f [vs]\n (map vs (fn [[x y]]\n [(inc x) y])))\n\n(main [_]\n (f [(list 1 2)\n []\n [3 6]]))\n" }, { "path": "assertion-tests/bad-inner-or.toc", "content": "\n(defn f []\n (maybe \"9\"))\n\n(defn g []\n (maybe \"88\"))\n\n(defn h []\n (map (or (f)\n (g))\n inc))\n\n(main [_]\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/bad-let.toc", "content": "\n(defn bad [x]\n (let [x (inc x)\n x (str x)]\n (subs x 1)))\n\n(main [_]\n (bad 99)\n (bad \"99\")\n (print-err 'done))\n" }, { "path": "assertion-tests/bad-list-of-1.toc", "content": "\n(defprotocol TestListOf\n (returns-list-of-string [x]\n (assert-result x (instance? (list-of String) x))))\n\n(deftype BogusType [x]\n (assert (instance? Integer x))\n \n TestListOf\n (returns-list-of-string [_]\n ;; TODO: error message needs improvement\n (list \"\")))\n\n(main [_]\n (print-err 'FAIL!!!!))\n" }, { "path": "assertion-tests/bad-nested-let.toc", "content": "\n(defn bad [x]\n (let [y (inc 8)]\n (let [x (inc x)\n x (str y)]\n (subs x 1))))\n\n(main [_]\n (println (bad 99))\n (println (bad \"99\"))\n (println 'done))\n" }, { "path": "assertion-tests/bad-or-1.toc", "content": "\n\n;; TODO: error message is unhelpful\n\n(defn g []\n {'a 1})\n\n(defn f [x]\n (or nothing\n (g)\n nothing))\n\n(main [_]\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/bad-or-2.toc", "content": "\n\n(defn f [x]\n (or nothing\n {'a 1}\n nothing)\n 'bogus)\n\n(main [_]\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/bad-result-sum-type.toc", "content": "\n(defprotocol Proto\n (proto-fn [_]\n (assert-result r (instance? (maybe-of Integer) r))))\n\n(deftype IC [x]\n Proto\n (proto-fn [c]\n (or (maybe 'bog)\n (maybe \"88\"))))\n\n(main [_]\n (print-err 'done (str \"'\" (proto-fn (IC 8)) \"'\" )))\n" }, { "path": "assertion-tests/bad-return-value.toc", "content": "\n;; TODO: the path on the error generated is incomplete\n\n(defprotocol C\n (eic [_]\n (assert-result r (instance? Vector r))\n []))\n\n(deftype IC [items]\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype MC [cs]\n C\n (eic [mc]\n (-> (.cs mc)\n (some (partial instance? IC))\n (map .items))))\n\n(defn b [_]\n (assert-result r (instance? Vector r))\n (some [1 2 4] (partial instance? String)))\n\n(main [_]\n (eic (MC [1 (IC 2) 3]))\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/bad-setter-call-1.toc", "content": "\n(deftype Bogus [x]\n Stringable\n (string-list [_]\n (list \"Bogus\" x)))\n\n(deftype Boogie [xs]\n (assert (instance? (vector-of Integer) xs))\n\n Stringable\n (string-list [_]\n (list \"Boogie \" (str xs))))\n\n(main [_]\n (.xs (Boogie [1 2 3]) [1 2 'plop]))\n" }, { "path": "assertion-tests/bad-setter-call-2.toc", "content": "\n(defprotocol Pookie\n (pook [_]\n (assert-result r (instance? (list-of (any-of StringBuffer\n SubString))\n r))))\n\n(deftype Boogie [xs]\n Stringable\n (string-list [_]\n (list \"Boogie \" (str xs)))\n\n Pookie\n (pook [_]\n (map xs (fn [n]\n (str (inc n))))))\n\n\n(main [_]\n (.xs (Boogie [1 2 3]) [1 2 'plop]))\n" }, { "path": "assertion-tests/bad-state-maybe-value-1.toc", "content": "\n(deftype new-sm [invoke-fn]\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s))\n\n Container\n (map [mv f]\n (new-sm (fn [s]\n (let [a (invoke-fn s)]\n (and a (let [[v new-s] (extract a)]\n (maybe [(f v) new-s])))))))\n\n (wrap [b v]\n (new-sm (fn [s]\n (maybe [v s]))))\n\n (flat-map [ev f]\n (new-sm (fn [s]\n (let [d (invoke-fn s)]\n (and d (let [[v ss] (extract d)]\n ((f v) ss)))))))\n\n Composition\n (zero [_] (new-sm (fn [_] nothing))))\n\n(def state-maybe\n (reify\n Type\n (type-name [_]\n \"*state-maybe wrapper*\")\n\n Container\n (apply [_ [v]]\n (new-sm (fn [s]\n (maybe [v s]))))\n\n Function\n (invoke [_ v]\n (new-sm (fn [s]\n (maybe [v s]))))\n\n Composition\n (zero [_] (new-sm (fn [_] nothing)))))\n\n(def zero-sm\n (zero state-maybe))\n\n(main [_]\n (flat-map (new-sm (fn [s]\n (maybe ['a s])))\n (fn [x]\n (state-maybe (inc x))))\n\n (print-err 'done))\n" }, { "path": "assertion-tests/bad-state-maybe-value-2.toc", "content": "\n(deftype new-sm [invoke-fn]\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s))\n\n Container\n (map [mv f]\n (new-sm (fn [s]\n (let [a (invoke-fn s)]\n (and a (let [[v new-s] (extract a)]\n (maybe [(f v) new-s])))))))\n\n (wrap [b v]\n (new-sm (fn [s]\n (maybe [v s]))))\n\n (flat-map [ev f]\n (new-sm (fn [s]\n (let [d (invoke-fn s)]\n (and d (let [[v ss] (extract d)]\n ((f v) ss)))))))\n\n Composition\n (zero [_] (new-sm (fn [_] nothing))))\n\n(def state-maybe\n (reify\n Type\n (type-name [_]\n \"*state-maybe wrapper*\")\n\n Container\n (apply [_ [v]]\n (new-sm (fn [s]\n (maybe [v s]))))\n\n Function\n (invoke [_ v]\n (new-sm (fn [s]\n (maybe [v s]))))\n\n Composition\n (zero [_] (new-sm (fn [_] nothing)))))\n\n(def zero-sm\n (zero state-maybe))\n\n(main [_]\n (map (wrap zero-sm 'a)\n (fn [x]\n (inc x)))\n\n (print-err 'done))\n" }, { "path": "assertion-tests/bad-type-comp.toc", "content": "\n(deftype Type1 [int]\n Stringable\n (string-list [_] (list (str int))))\n\n(deftype Type2 [int]\n Stringable\n (string-list [_] (list (str int))))\n\n(defn not-type [x]\n (inc x))\n\n(def Types (any-of Type1\n not-type\n Type2))\n\n(main [_]\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/bad-vector-of-1.toc", "content": "\n(defn g [v]\n (assert (instance? (vector-of Integer) v))\n\n (map v (fn [x]\n (subs x 1))))\n\n(main [_]\n (print-err 'FAIL!!!!))\n" }, { "path": "assertion-tests/checked-map-1.toc", "content": "\n(main [_]\n (let [m {}]\n (assert (instance? (map-of String Integer) m))\n (assoc m \"bogus\" 'bogus)\n (println 'done)))\n" }, { "path": "assertion-tests/checked-map-2.toc", "content": "\n(main [_]\n (let [m {}]\n (assert (instance? (map-of Integer Symbol) m))\n (assoc m \"bogus\" 'bogus)\n (println 'done)))\n" }, { "path": "assertion-tests/closure-1.toc", "content": "\n(defn foo [zs p]\n (flat-map (list zs)\n (fn [t]\n (list (subs p 1))))\n (flat-map (list zs)\n (fn [t]\n (list (inc p)))))\n\n(main [_]\n (println (foo [\"xx\"] \"p\"))\n (println 'done))\n" }, { "path": "assertion-tests/closure-2.toc", "content": "\n(defn foo [zs p]\n (flat-map (list zs)\n (fn [t]\n (list (inc p)))))\n\n(main [_]\n (println (foo [\"xx\"] \"p\"))\n (println 'done))\n" }, { "path": "assertion-tests/closure-constraint.toc", "content": "\n(defprotocol Boomer\n (boom [_ y]\n (print-err 'booooom)\n (abort)))\n\n(deftype Dummy [nope])\n\n(deftype Slider []\n Boomer\n (boom [_ y]\n (print-err 'pop (.nope y))))\n\n(defn f [marvelous]\n (assert (instance? Slider marvelous))\n\n (fn []\n (boom marvelous 8)))\n\n(main [_]\n (f (Slider))\n (print-err 'done ;; ((f 1) {})\n ))\n" }, { "path": "assertion-tests/closure-param.toc", "content": "\n(main [_]\n (let [x 8\n f (fn [z]\n (+ x z))]\n (println (f \"100\")))\n (println 'done))\n" }, { "path": "assertion-tests/comp-bad-type-1.toc", "content": "\n(def BadType (any-of NoType\n List))\n\n(main [_]\n (println \"FAIL!!!\"))\n" }, { "path": "assertion-tests/comp-bad-type-2.toc", "content": "\n(def BadType (any-of List\n NoType))\n\n(main [_]\n (println \"FAIL!!!\"))\n" }, { "path": "assertion-tests/conj-to-getter-result-1.toc", "content": "\n(deftype Boogie [xs]\n (assert (instance? (vector-of Integer) xs))\n\n Stringable\n (string-list [_]\n (list \"Boogie \" (str xs))))\n\n(main [_]\n (-> (.xs (Boogie [1 2 3]))\n (conj 'plop)))\n" }, { "path": "assertion-tests/conj-to-getter-result-2.toc", "content": "\n(defprotocol Pookie\n (pook [_]\n (assert-result r (instance? (list-of (any-of StringBuffer\n SubString))\n r))))\n\n(deftype Boogie [xs]\n Stringable\n (string-list [_]\n (list \"Boogie \" (str xs)))\n\n Pookie\n (pook [_]\n (map xs (fn [n]\n (str (inc n))))))\n\n(main [_]\n (let [bgi (Boogie [1 2 3])]\n (print-err 'pook (pook (.xs bgi (conj (.xs bgi) 'plop))))))\n" }, { "path": "assertion-tests/constructor-param-1.toc", "content": "\n(deftype SomeType [a b]\n (assert (instance? Symbol a))\n (assert (instance? String b)))\n\n(main [_]\n (SomeType (str 'symbol) \"9\"))\n" }, { "path": "assertion-tests/constructor-param-2.toc", "content": "\n(deftype SomeType [a b]\n (assert (instance? Symbol a))\n (assert (instance? String b)))\n\n(defn f [x]\n (SomeType x \"9\"))\n\n(main [_]\n (f (str 'symbol)))\n" }, { "path": "assertion-tests/constructor-param-3.toc", "content": "\n(deftype SomeType [a b]\n (assert (instance? (min-count 1) a))\n (assert (instance? String b)))\n\n(defn f [xs]\n (SomeType xs \"9\"))\n\n(main [_]\n (f []))\n" }, { "path": "assertion-tests/contents-2.toc", "content": "\n\n(defn f [x]\n (cons 'bogus x))\n\n(defn g [x]\n (map x inc))\n\n(main [_]\n (g (f empty-list)))\n" }, { "path": "assertion-tests/deeply-nested-vector-1.toc", "content": "\n(defn g []\n [\"str\"])\n\n(defn f [x]\n (assert (instance? Integer x))\n (assert-result r (instance? (vector-of String) r))\n\n (comp []\n [(g)]\n\n []))\n\n(main [_]\n (print-err 'strs (f 3)))\n" }, { "path": "assertion-tests/deeply-nested-vector-2.toc", "content": "\n(defn f [x]\n (assert (instance? Integer x))\n (assert-result r (instance? (vector-of String) r))\n\n TODO: this test needs to be fixed\n (cond (< 0 x)\n [(f (dec x))]\n\n []))\n\n(main [_]\n (print-err 'strs (f 3)))\n" }, { "path": "assertion-tests/destruct-variadic-tail-2.toc", "content": "\n;; TODO: error message is empty\n\n(defn f [x]\n (assert (instance? Integer x))\n (str x))\n\n(defn g [& y]\n (let [[x] y]\n (f x)))\n\n(main [_]\n (print-err \"Line number should be 12\")\n (print-err 'wut (g))\n (print-err 'done))\n" }, { "path": "assertion-tests/dup-protocol-name.toc", "content": "\n(defprotocol Stringable\n (pf [x y z]\n (assert (instance? Integer y))\n (subs z 1)))\n\n(defn f []\n (pf 'x 3 3))\n\n(main [_]\n (print-err \"FAIL!!!\"))\n" }, { "path": "assertion-tests/dynamic-call-1.toc", "content": "\n(deftype nougie [invoke-fn]\n (assert (instance? Fn invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s)))\n\n(main [_]\n (let [a 'a\n wrapper (nougie (fn [s]\n (maybe [a s])))]\n (nougie (fn [s]\n (let [d (wrapper s)]\n (and d (let [[v ss] (extract d)]\n (maybe [(inc v) ss])))))))\n\n (print-err 'done))\n\n" }, { "path": "assertion-tests/dynamic-call-2.toc", "content": "\n(defn g [f]\n (assert (instance? Fn f))\n \n (f 8))\n\n(defn f [n]\n (str n))\n\n(main [_]\n (inc (g f)))\n" }, { "path": "assertion-tests/dynamic-call-3.toc", "content": "\nTODO: make this test work\n(defn g [f]\n \n (f 8))\n\n(def f\n (reify\n Function\n (invoke [_ n]\n (str n))))\n\n(main [_]\n (inc (g f)))\n" }, { "path": "assertion-tests/dynamic-call-4.toc", "content": "\n(deftype nougie [invoke-fn]\n (assert (instance? Fn invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s)))\n\n(main [_]\n (let [a 'a\n wrapper (nougie (fn [s]\n (maybe ['a s])))]\n (nougie (fn [s]\n (let [d (wrapper s)]\n (and d (let [[v ss] (extract d)]\n (maybe [(inc v) ss])))))))\n\n (print-err 'done))\n\n" }, { "path": "assertion-tests/dynamic-call-5.toc", "content": "\nTODO: Detecting this error will require a much different technique\nProbably build a function to be executed at the call site\n(defn g [f]\n (assert (instance? Fn f))\n \n (f 'a))\n\n(defn f [n]\n [n])\n\n(main [_]\n (map (g f) inc))\n" }, { "path": "assertion-tests/dynamic-call-6.toc", "content": "\nTODO: Detecting this error will require a much different technique\nProbably build a function to be executed at the call site\n(defn g [f]\n (f 'a))\n\n(def f\n (reify\n Function\n (invoke [_ n]\n [n])))\n\n(main [_]\n (map (g f) inc))\n" }, { "path": "assertion-tests/dynamic-call-7.toc", "content": "\nTODO: make this test work\n(defn g [f]\n (f 8))\n\n(defn f [x]\n (reify\n Function\n (invoke [_ n]\n (str n \" \" x))))\n\n(main [_]\n (inc (g (f 77))))\n" }, { "path": "assertion-tests/dynamic-call-8.toc", "content": "\n(deftype nougie [invoke-fn]\n (assert (instance? Fn invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s)))\n\n(main [_]\n (let [a 'a\n wrapper (nougie (fn [s]\n (maybe [a s])))]\n (nougie (fn [s]\n (let [d (wrapper s)]\n (and d (let [[v ss] (extract d)]\n (maybe [(inc v) ss])))))))\n\n (print-err 'done))\n" }, { "path": "assertion-tests/dynamic-field-type-1.toc", "content": "\n(deftype AType [x])\n\n(main [_]\n (inc (.x (AType 'x)))\n (print-err 'FAIL))\n" }, { "path": "assertion-tests/dynamic-field-type-2.toc", "content": "\n(deftype AType [x])\n\nTODO: re-enable this test eventually\n(main [_]\n (-> (AType 9)\n (.x 'x)\n .x\n (inc)))\n" }, { "path": "assertion-tests/dynamic-nested-value-1.toc", "content": "\n\n(defn g [_ x]\n (maybe [x]))\n\n(main [_]\n (map (either (g 'nope 'bogus)\n ;; TODO: this should cause an assertion error\n ;; []\n ['nada])\n inc))\n\n" }, { "path": "assertion-tests/dynamic-proto-param-1.toc", "content": "\n(defprotocol AProto\n (dorf [x y]))\n\n(deftype AType [x]\n AProto\n (dorf [_ y]\n y))\n\n(main [_]\n (inc (dorf (AType 99) 'nope)))\n" }, { "path": "assertion-tests/empty-defn.toc", "content": "\n(defn f []\n )\n\n(main [_]\n (println \"FAIL\"))\n" }, { "path": "assertion-tests/field-and-seq-conflict.toc", "content": "\n(deftype Bogus [boom])\n\n(defn f [x]\n (.boom x))\n\n(defn g [[x y]]\n y)\n\n(defn h [x]\n (g x)\n (f x))\n\n(main [_]\n (print-err 'howdy))\n" }, { "path": "assertion-tests/field-constraint.toc", "content": "\n(defprotocol Proto\n (proto-f [_]))\n\n(deftype Bogus [x]\n (assert (instance? Integer x))\n\n Proto\n (proto-f [_]\n (subs x 1)))\n\n(main [_]\n (print-err 'FAIL))\n" }, { "path": "assertion-tests/field-shadow.toc", "content": "\n(defprotocol Foo\n (foor [v x]))\n\n(deftype OneType [x s]\n (assert (instance? Integer x))\n\n Foo\n (foor [v x]\n (print-err 'FAIL)\n (abort))\n\n Stringable\n (string-list [_] (list \"\")))\n\n\n(main [_]\n (print-err (foor (OneType (inc 8) (symbol (str \"1\" \"2\"))) 99)))\n" }, { "path": "assertion-tests/flat-map-param.toc", "content": "\n(deftype and-ast [clauses]\n (assert (instance? Vector clauses))\n\n Stringable\n (string-list [_]\n (comp (list \"\"))))\n\n(defn traverse [asts f]\n (reduce (reverse asts) (maybe empty-list)\n (fn [l ast]\n (flat-map (f ast)\n (fn [emitted]\n (map l (fn [x]\n (cons emitted x))))))))\n\n;; TODO: the error path has too much info in it\n(main [_]\n (let [aa (and-ast ['a 'b])]\n (println (map (traverse ['a 'b] maybe)\n (fn [nc]\n (.clauses aa nc)))))\n (println 'done))\n" }, { "path": "assertion-tests/impl-violates-proto.toc", "content": "\n(deftype FirstType [x y])\n\n(deftype SecondType [x])\n\n(defprotocol Proto\n (proto-fn [a b]\n (assert (instance? SecondType b))\n\n 'wtf))\n\n(extend-type FirstType\n Proto\n (proto-fn [a b]\n (let [n (print-err (.y b) (.x a))]\n (either (= n 99)\n (.y b n)))))\n\n(main [_]\n (print-err 'FAIL))\n\n" }, { "path": "assertion-tests/incompatible-tails.toc", "content": "\n(defn f [xs]\n (let [[x y & more] xs]\n (map more inc)\n (inc x)\n (subs y 1)))\n\n(defn g [xs]\n (let [[x y & more] xs]\n (map more (fn [m]\n (subs m 1)))\n (inc x)\n (subs y 1)))\n\n(defn h [ys]\n (f ys)\n (g ys))\n\n(main [_]\n (let [xs [1 \"33\" 8]]\n (print-err 'h (h xs))))\n" }, { "path": "assertion-tests/init-type.toc", "content": "\n(def ints [1 2 3])\n\n(def ints (-> ints\n (reverse)\n (take 2)\n (map inc)))\n\n(defn f [l]\n (cons 5 l))\n\n(main [_]\n (f ints))\n" }, { "path": "assertion-tests/insufficient-static-elements-1.toc", "content": "\n(defn f [[a b]]\n (inc a))\n\n(main [_]\n (f [9]))\n" }, { "path": "assertion-tests/insufficient-static-elements-2.toc", "content": "\n(defn f [y]\n (let [[[a x] b] '((a) 1)]\n (inc a)))\n\n(main [_]\n (f ['a 9]))\n" }, { "path": "assertion-tests/insufficient-static-elements-3.toc", "content": "\n(defn f [x]\n (let [[[a b x y z] c & d] [[2] 4 6]]\n a))\n\n(main [_]\n (f ['a 9]))\n" }, { "path": "assertion-tests/insufficient-static-elements-4.toc", "content": "\n(defn f [y]\n (let [[a b] y]\n (println 'a (inc a))))\n\n(main [_]\n (println (f [9])))\n" }, { "path": "assertion-tests/int-too-large.toc", "content": "\n(defn f [n]\n ;; TODO: can't read this assertion\n (assert (max 4) n)\n (inc n))\n\n(main [_]\n (f 5)\n (print-err 'howdy))\n" }, { "path": "assertion-tests/items-constraints-1.toc", "content": "\n(defn f []\n (let [[a b] ['a 9]]\n (inc a)))\n\n(main [_]\n (f))\n" }, { "path": "assertion-tests/items-constraints-2.toc", "content": "\n(defn f [y]\n (let [[a b] y]\n (inc a)))\n\n(main [_]\n (f ['a 9]))\n" }, { "path": "assertion-tests/items-constraints-3.toc", "content": "\n(defn f [y]\n (let [[a b] y\n a (inc a)]\n (str a)))\n\n(main [_]\n (f ['a 9]))\n" }, { "path": "assertion-tests/key-violation.toc", "content": "\n\n(defn f [m s v]\n (assert (instance? (map-of Symbol Integer) m))\n (assoc m s v))\n\n(main [_]\n (print-err 'FAIL (f {} \"7\" 88)))\n" }, { "path": "assertion-tests/list-items-types.toc", "content": "\n(defn f [[a b & c]]\n (inc b))\n\n(main [_]\n (f [1 'b]))\n" }, { "path": "assertion-tests/literal-hash-map-1.toc", "content": "\n(defn f []\n (assert-result r (instance? (map-of Symbol Integer) r))\n\n {'a 1\n \"b\" 2\n 'c 3})\n\n(main [_]\n (print-err (f)))\n" }, { "path": "assertion-tests/literal-hash-map-2.toc", "content": "\n(defn f []\n (assert-result r (instance? (map-of Symbol Integer) r))\n\n {'a 1\n 'b \"2\"\n 'c 3})\n\n(main [_]\n (print-err (f)))\n" }, { "path": "assertion-tests/min-count.toc", "content": "\n(defn f [x]\n (assert (min-count x 3))\n x)\n\n(main [_]\n (f [1 2]))\n" }, { "path": "assertion-tests/missing-namespaced-sym.toc", "content": "\n(def puke \"puke\")\n\n(main [_]\n (println 'puke ll/puke))\n" }, { "path": "assertion-tests/multi-constraint-violated.toc", "content": "\n(def Bands (all-of Integer\n (min 4)\n (max 8)))\n\n(defn pr-bands [n]\n (assert (instance? Bands n))\n\n (print-err 'bands n))\n\n(main [_]\n (pr-bands 4)\n (pr-bands 10)\n\n (print-err 'FAIL))\n" }, { "path": "assertion-tests/nested-destruct-1.toc", "content": "\n(defn f [[a b]]\n (println 'a (inc a) 'b b)\n nothing)\n\n(main [_]\n (f (either (maybe [[\"19\" 3] 4 6])\n nothing))\n (println 'done))\n" }, { "path": "assertion-tests/nested-destruct-2.toc", "content": "\n(defn f [[[a b] c & d]]\n (println 'a (inc a) 'b b 'c c)\n nothing)\n\n(main [_]\n (f (either (maybe [[\"19\" 3] 4 6])\n nothing))\n (println 'done))\n" }, { "path": "assertion-tests/nested-destruct.toc", "content": "\n(defn f [y]\n (let [[[a b] c & d] y]\n (inc a)\n (print-err 'a a 'b b 'c c)\n nothing))\n\n(main [_]\n (f [[\"2\" 3] 4 6]))\n" }, { "path": "assertion-tests/nested-items-conflict.toc", "content": "\n(defn f [[a b]]\n (inc a))\n\n(defn g [[a b]]\n (subs a 2))\n\n(defn h [x]\n (f x)\n (g x))\n\n(main [_]\n (print-err 'bogus))\n" }, { "path": "assertion-tests/or-prop.toc", "content": "\n(def SomeVal (any-of Integer\n String))\n\n(defn f [x y]\n (assert (instance? SomeVal x))\n (or (and (do\n (print-err 'y (inc y))\n (instance? Integer x))\n (maybe (inc x)))\n (and (do\n (print-err 'y (+ 4 y))\n (instance? String x))\n (maybe (subs x 1)))))\n\n(main [_]\n (print-err \"1)\" (f 4 9))\n (print-err \"2)\" (f \"212\" 3))\n (print-err \"3)\" (f \"212\" \"34\")))\n" }, { "path": "assertion-tests/param-in-and.toc", "content": "\n(defn f [x]\n (and nothing\n x))\n\n\n(main [_]\n (print-err (f 1)))\n" }, { "path": "assertion-tests/param-in-or.toc", "content": "\n(defn f [x]\n (or nothing\n x))\n\n\n(main [_]\n (print-err (f 1)))\n" }, { "path": "assertion-tests/partial-param.toc", "content": "\n(main [_]\n (partial subs 8))\n" }, { "path": "assertion-tests/preserve-asserts.toc", "content": "\n(deftype Checked [m]\n (assert (instance? HashMap m))\n\n Associative\n (assoc [_ k v]\n (assert (instance? HashSet v))\n\n (or (instance? HashSet v)\n (abort))\n (Checked (assoc m k v))))\n\n(main [_]\n (assoc (Checked {}) \"bogus\" 'bogus)\n (println 'done))\n" }, { "path": "assertion-tests/preserve-static-info-1.toc.test", "content": "\n(defn f [x]\n (let [y [2]]\n (and x (let [[[a b] c & d] y]\n (println 'a a 'b b 'c c)\n nothing))))\n\n(main [_]\n (f (maybe [1 2]))\n (println 'done))\n" }, { "path": "assertion-tests/preserve-static-info-2.toc.test", "content": "\n(defn f [x]\n (let [y [[2] 4 6]]\n (and x (let [;; [result new-s] (extract x)\n [[a b] c & d] y]\n (println 'a a 'b b 'c c)\n nothing))))\n\n(main [_]\n (f (maybe [1 2]))\n (println 'done))\n" }, { "path": "assertion-tests/preserve-static-info-3.toc.test", "content": "\n(defn f [x]\n (let [y [[\"2\" 3] 4 6]]\n (and x (let [;; [result new-s] (extract x)\n [[a b] c & d] y]\n (inc a)\n (println 'a a 'b b 'c c)\n nothing))))\n\n(main [_]\n (f (maybe [1 2]))\n (println 'done))\n" }, { "path": "assertion-tests/propogate-inner-1.toc", "content": "\n(defn f [l v]\n (assert (instance? (vector-of Integer) l))\n (conj l v))\n\n(main [_]\n (print-err (f [] \"99\")))\n" }, { "path": "assertion-tests/propogate-inner-2.toc", "content": "\n(defn f [m v]\n (assert (instance? (map-of Symbol Integer) m))\n (assoc m 'sym v))\n\n(main [_]\n (print-err (f {'sym 88} \"99\")))\n" }, { "path": "assertion-tests/propogate-through-let.toc", "content": "\n(defn f [vs]\n (let [v vs]\n (inc v)))\n\n(main [_]\n (f \"bogus\"))\n" }, { "path": "assertion-tests/propogate-through-seq.toc", "content": "\n(main [_]\n (map (seq (vector 'a 'b 2)) inc))\n" }, { "path": "assertion-tests/propogate-through-vec.toc", "content": "\n(main [_]\n (map (vec (list 'a 'b 2)) inc))\n" }, { "path": "assertion-tests/proto-fn-constraint-prop.toc", "content": "\n(defn f [x]\n (inc x))\n\n(defprotocol Proto\n (g [_ x]))\n\n(deftype SomeType [y]\n Proto\n (g [_ z]\n (f z)))\n\n(main [_]\n (g (SomeType 'nop) \"62\"))\n" }, { "path": "assertion-tests/proto-fn-min-count.toc", "content": "\n(defprotocol TempProto\n (bogus [z u]\n (assert (instance? (min-count 2) u))))\n\n(deftype Bogus [s]\n TempProto\n (bogus [_ y]\n (conj y 'a)))\n\n(main [_]\n (bogus (Bogus 1) [3]))\n" }, { "path": "assertion-tests/proto-fn-param.toc", "content": "\n(main [_]\n (nth [1 2 3] \"2\"))\n" }, { "path": "assertion-tests/restrict-conflict.toc", "content": "\n(deftype OneType [x]\n Stringable\n (string-list [_] (list \"\")))\n\n(deftype AnotherType [x z]\n Stringable\n (string-list [_] (list \"\")))\n\n(def BothTypes (any-of OneType\n AnotherType))\n\n(defn only-one [xtreme]\n (assert (instance? OneType xtreme))\n xtreme)\n\n(defn only-another [xtreme]\n (assert (instance? AnotherType xtreme))\n xtreme)\n\n(defn bad [xtreme]\n (assert (instance? BothTypes xtreme))\n [(only-one xtreme)\n (only-another xtreme)])\n\n(main [_]\n (println 'FAIL!!!))\n" }, { "path": "assertion-tests/restrict-nested-item.toc", "content": "\n(deftype OneType [x]\n Stringable\n (string-list [_] (list \"\")))\n\n(deftype AnotherType [x z]\n Stringable\n (string-list [_] (list \"\")))\n\n(def BothTypes (any-of OneType\n AnotherType))\n\n(defn only-one [[a b [c x]]]\n (assert (instance? OneType x))\n x)\n\n(defn only-another [[a b [c x]]]\n (assert (instance? AnotherType x))\n x)\n\n(defn bad [x]\n [(only-one x)\n (only-another x)])\n\n(main [_]\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/restrict-param.toc", "content": "\n(deftype OneType [x]\n Stringable\n (string-list [_] (list \"\")))\n\n(deftype AnotherType [x z]\n Stringable\n (string-list [_] (list \"\")))\n\n(def BothTypes (any-of OneType\n AnotherType))\n\n(defn only-one [x]\n (assert (instance? OneType x))\n x)\n\n(defn bad [x]\n (assert (instance? BothTypes x))\n (only-one x))\n\n(main [_]\n (bad (AnotherType 'x 'z))\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/return-bad-type.toc", "content": "\n(defprotocol SomeProto\n (f [x]\n (assert-result l (instance? List l))))\n\n(deftype SomeType [x]\n SomeProto\n (f [y]\n (assert-result l (instance? String l))\n \"\"))\n\n(main [_]\n (print-err \"FAIL!!!\"))\n" }, { "path": "assertion-tests/return-generic-1.toc", "content": "\n(defn bloop [x]\n (assert-result r (instance? (vector-of Integer) r))\n\n [x])\n\n(main [_]\n (print-err (bloop \"9\")))\n" }, { "path": "assertion-tests/return-list-of-1.toc", "content": "\n(defprotocol BProt\n (bloop [_ z]\n (assert-result r (instance? (list-of Integer) r))))\n\n(deftype Bogus [x]\n BProt\n (bloop [_ z]\n (list z 88)))\n\n(main [_]\n (print-err (bloop (Bogus \"9\") 'bogus)))\n" }, { "path": "assertion-tests/return-list-of-2.toc", "content": "\n(defprotocol BProt\n (bloop [_]\n (assert-result r (instance? (list-of Integer) r))))\n\n(deftype Bogus [x]\n Stringable\n (string-list [_]\n (list \"\"))\n\n BProt\n (bloop [_]\n (list x 88)))\n\n(main [_]\n (print-err (Bogus \"9\")))\n" }, { "path": "assertion-tests/return-sum-type.toc", "content": "\n(defn foo [x]\n (assert-result y (instance? HashMap y))\n \"\")\n\n(main [_]\n (println 'foo (foo 88)))\n" }, { "path": "assertion-tests/simple-conflict.toc", "content": "\n(defn bad [x]\n [(inc x)\n (subs x 1)])\n\n(main [_]\n (bad \"one\")\n (println 'done))\n" }, { "path": "assertion-tests/static-fixed-dynamic-result-type-1.toc", "content": "\n(defn f [x]\n [x])\n\n(main [_]\n (map (f 'bogus) inc)\n (print-err 'FAIL))\n" }, { "path": "assertion-tests/static-fixed-dynamic-result-type-2.toc", "content": "\n(defn f [x]\n ;; TODO: this line does not appear in the constraint path in the error message\n x)\n\n(defn g [_ x]\n (f x))\n\n(main [_]\n (inc (g 'nope 'bogus)))\n" }, { "path": "assertion-tests/unkown-field.toc", "content": "\n(deftype Bogus [int]\n (assert (instance? Integer string))\n\n Stringable\n (string-list [_] (list (str int))))\n\n(main [_]\n (print-err 'FAIL!!!))\n" }, { "path": "assertion-tests/update-field-1.toc", "content": "\n(deftype SomeType [x y]\n (assert (instance? String x))\n (assert (instance? Integer y))\n \n Stringable\n (string-list [_]\n (list \"\")))\n\n(main [_]\n (println (.x (SomeType \"string\" 7) 3))\n (println 'done))\n" }, { "path": "assertion-tests/variadic-constraints.toc", "content": "\n(defn f [x y & z]\n (subs y 1))\n\n(main [_]\n (f 1 2 3))\n" }, { "path": "assertion-tests/variadic-count-1.toc", "content": "\n(defn f [x y & t]\n (println 'x x))\n\n(main [_]\n (f 1))\n\n" }, { "path": "assertion-tests/variadic-count-2.toc", "content": "\n(main [_]\n (let [a 'bogus\n f (fn [x y & t]\n (println a x))]\n (print-err \"Line number should be\" (inc _LINE_))\n (f 1)))\n\n" }, { "path": "assertion-tests/vect-len.toc", "content": "\n(defn f [l]\n (let [[x y & z] l]\n (println 'x x)\n (println 'y y)\n (println 'z z)))\n\n(main [_]\n (f ['a])\n (println 'done))\n" }, { "path": "bin/build-toccata.sh", "content": "#! /bin/sh\n\nTOCCATA_DIR=\"$(cd -P -- $(dirname -- $0)/../ && pwd)\"\n\nclang -g \\\n -v \\\n -fno-objc-arc \\\n -o toccata \\\n -I$TOCCATA_DIR \\\n -std=c99 \\\n -DCHECK_MEM_LEAK=1 \\\n $TOCCATA_DIR/core.c \\\n toccata.c \\\n -lpthread\n" }, { "path": "bin/toccata.sh", "content": "#! /bin/sh\n\nexport TOCCATA_DIR=\"$(cd -P -- $(dirname -- $0)/../ && pwd)\"\nPATH=$PATH:$TOCCATA_DIR\n\nusage() {\n echo \"Usage: ./bin/toccata.sh input.toc > output.c\"\n exit 1\n}\n\nif [ \"$#\" -lt 1 ]; then\n usage\nfi\n\ntoccata \"$@\"\n" }, { "path": "core.c", "content": "\n#include \n#include \n#include \"core.h\"\n\nREFS_SIZE refsInit = 1;\nREFS_SIZE refsError = -10;\nREFS_SIZE refsConstant = -1;\nREFS_SIZE refsStatic = -2;\n\nValue *universalProtoFn = (Value *)0;\nInteger const0 = {IntegerType, -2, 0};\nValue *const0Ptr = (Value *)&const0;\nint cleaningUp = 0;\n\n// Immutable hash-map ported from Clojure\nBitmapIndexedNode emptyBMI = {BitmapIndexedType, -2, 0, 0};\n\n// threads that have been replaced, but haven't exited\npthread_mutex_t lingeringAccess = PTHREAD_MUTEX_INITIALIZER;\nValue *lingeringThreads = (Value *)&emptyBMI;\n\nvoid prefs(char *tag, Value *v) {\n if (v != (Value *)0)\n fprintf(stderr, \"%s: %p %d\\n\", tag, v, v->refs);\n else\n fprintf(stderr, \"%s: %p\\n\", tag, v);\n}\n\nint64_t malloc_count = 0;\nint64_t free_count = 0;\n\nint64_t type_mallocs[20] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};\nint64_t type_frees[20] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};\n\nvoid incTypeMalloc(TYPE_SIZE type, int delta) {\n if (type < 0) {\n fprintf(stderr, \"type malloc inc failure\\n\");\n abort();\n }\n else if (type == TypeCount)\n __atomic_fetch_add(&type_mallocs[19], delta, __ATOMIC_ACQ_REL);\n else if (type > OpaqueType)\n __atomic_fetch_add(&type_mallocs[0], delta, __ATOMIC_ACQ_REL);\n else if (type == SymbolType)\n __atomic_fetch_add(&type_mallocs[5], delta, __ATOMIC_ACQ_REL);\n else\n __atomic_fetch_add(&type_mallocs[type], delta, __ATOMIC_ACQ_REL);\n}\n\nvoid incTypeFree(TYPE_SIZE type, int delta) {\n if (type < 0) {\n fprintf(stderr, \"type free inc failure\\n\");\n abort();\n }\n else if (type == TypeCount)\n __atomic_fetch_add(&type_frees[19], delta, __ATOMIC_ACQ_REL);\n else if (type > OpaqueType)\n __atomic_fetch_add(&type_frees[0], delta, __ATOMIC_ACQ_REL);\n else if (type == SymbolType)\n __atomic_fetch_add(&type_frees[5], delta, __ATOMIC_ACQ_REL);\n else\n __atomic_fetch_add(&type_frees[type], delta, __ATOMIC_ACQ_REL);\n}\n\nMaybe nothing_struct = {MaybeType, -2, 0, 0};\nValue *nothing = (Value *)¬hing_struct;\nList empty_list_struct = (List){ListType,-2,0,0,0,0};\nList *empty_list = &empty_list_struct;\nVector empty_vect_struct = (Vector){VectorType,-2,0,0,5,0,0};\nVector *empty_vect = &empty_vect_struct;;\n\nReifiedVal all_values_struct = {AllValuesType, -2, 0};\nValue *all_values = (Value *)&all_values_struct;\n\n#ifdef SINGLE_THREADED\n#define NUM_WORKERS 1\n#else\n#ifndef NUM_WORKERS\n#define NUM_WORKERS 10\n#endif\n#endif\npthread_t workers[NUM_WORKERS];\nint32_t runningWorkers = NUM_WORKERS;\nint8_t mainThreadDone = 0;\n\nint mask(int64_t hash, int shift) {\n return (hash >> shift) & 0x1f;\n}\n\nint bitpos(int64_t hash, int shift) {\n return 1 << mask(hash, shift);\n}\n\nValue *my_malloc(int64_t sz) {\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 1, __ATOMIC_ACQ_REL);\n#endif\n Value *val = malloc(sz);\n if (sz > sizeof(Value)) {\n#ifndef SINGLE_THREADED\n#ifdef FAST_INCS\n fprintf(stderr, \"FAST_INCS can only be defined when SINGLE_THREADED is defined.\\n\");\n abort();\n#endif\n#ifdef FAST_DECS\n fprintf(stderr, \"FAST_DECS can only be defined when SINGLE_THREADED is defined.\\n\");\n abort();\n#endif\n#endif\n val->refs = refsInit;\n }\n return(val);\n}\n\nvoid cleanupMemory (Value *the_final_answer, Value *maybeNothing, List *argList) {\n#ifdef CHECK_MEM_LEAK\n dec_and_free(the_final_answer, 1);\n freeGlobal((Value *)argList);\n freeGlobal(maybeNothing);\n freeAll();\n#endif\n}\n\ntypedef struct {Value *head; uintptr_t aba;} FreeValList;\n\nValue *removeFreeValue(FreeValList *freeList) {\n Value *item = (Value *)0;\n FreeValList orig;\n#ifdef SINGLE_THREADED\n orig = *freeList;\n FreeValList next = orig;\n item = orig.head;\n if (item == (Value *)0) {\n return((Value *)0);\n } else {\n next.head = item->next;\n freeList = &next;\n if (item->refs != refsError) {\n fprintf(stderr, \"failure in removeFreeValue: %d\\n\", item->refs);\n abort();\n }\n return(item);\n }\n#else\n __atomic_load((FreeValList *)freeList, (FreeValList *)&orig, __ATOMIC_RELAXED);\n FreeValList next = orig;\n if (orig.head != (Value *)0) {\n do {\n item = orig.head;\n next.head = item->next;\n next.aba = orig.aba + 1;\n } while (!__atomic_compare_exchange((FreeValList *)freeList,\n\t\t\t\t\t(FreeValList *)&orig,\n\t\t\t\t\t(FreeValList *)&next, 1,\n\t\t\t\t\t__ATOMIC_RELAXED, __ATOMIC_RELAXED) &&\n\t orig.head != (Value *)0);\n if (orig.head == (Value *)0)\n item = (Value *)0;\n }\n\n if (item == (Value *)0) {\n return((Value *)0);\n } else {\n REFS_SIZE refs;\n __atomic_load(&item->refs, &refs, __ATOMIC_RELAXED);\n if (refs != refsError) {\n fprintf(stderr, \"failure in removeFreeValue: %d\\n\", refs);\n abort();\n }\n return(item);\n }\n#endif\n}\n\nint decRefs(Value *v, int deltaRefs) {\n#ifndef FAST_DECS\n#ifdef SINGLE_THREADED\n if (v->refs == refsConstant || v->refs == refsStatic)\n return(v->refs);\n\n if (v->refs < deltaRefs) {\n fprintf(stderr, \"\\nfailure in decRefs, refs too small: %d %p\\n\", v->refs, v);\n abort();\n } else if (v->refs == deltaRefs)\n v->refs = refsError;\n else\n v->refs -= deltaRefs;\n return(v->refs);\n#else\n if (v->refs == refsConstant || v->refs == refsStatic)\n return(v->refs);\n\n REFS_SIZE newRefs = __atomic_fetch_sub(&v->refs, deltaRefs, __ATOMIC_ACQ_REL);\n if (newRefs > deltaRefs)\n return(newRefs - deltaRefs);\n else if (newRefs == deltaRefs) {\n v->refs = refsError;\n return(refsError);\n }\n\n fprintf(stderr, \"\\nfailure in decRefs, refs too small: %d %d %p\\n\", deltaRefs, v->refs, v);\n abort();\n return(refsError);\n#endif\n#else\n if (v->refs == refsConstant ||\n v->refs == refsStatic)\n return(v->refs);\n\n if (v->refs == deltaRefs)\n v->refs = refsError;\n else\n v->refs -= deltaRefs;\n return(v->refs);\n#endif\n}\n\nvoid moveToCentral(FreeValList *freeList, FreeValList *centralList) {\n Value *tail = freeList->head;\n while (tail != (Value *)0 && tail->next != (Value *)0) {\n tail = tail->next;\n }\n\n if (tail == (Value *)0)\n return;\n else {\n FreeValList orig;\n#ifdef SINGLE_THREADED\n orig = *centralList;\n FreeValList next = orig;\n tail->next = orig.head;\n next.head = freeList->head;\n next.aba = orig.aba + 1;\n *centralList = next;\n#else\n FreeValList next;\n __atomic_load((FreeValList *)centralList, (FreeValList *)&orig, __ATOMIC_RELAXED);\n do {\n tail->next = orig.head;\n next.head = freeList->head;\n next.aba = orig.aba + 1;\n } while (!__atomic_compare_exchange((FreeValList *)centralList,\n\t\t\t\t\t(FreeValList *)&orig,\n\t\t\t\t\t(FreeValList *)&next,\n\t\t\t\t\t1, __ATOMIC_RELAXED, __ATOMIC_RELAXED));\n#endif\n freeList->head = (Value *)0;\n return;\n }\n}\n\nvoid decValuePtrRef(Value **ptr) {\n Value *toFree = (Value *)0;\n Value *oldPtr = (Value *)0;\n\n __atomic_exchange(ptr, &toFree, &oldPtr, __ATOMIC_RELAXED);\n if (oldPtr != (Value *)0) {\n dec_and_free((Value *)oldPtr, 1);\n }\n}\n\nFreeValList centralFreeIntegers = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeIntegers = {(Value *)0, 0};\nInteger *malloc_integer() {\n Integer *newInteger = (Integer *)freeIntegers.head;\n if (newInteger == (Integer *)0) {\n newInteger = (Integer *)removeFreeValue(¢ralFreeIntegers);\n if (newInteger == (Integer *)0) {\n Integer *numberStructs = (Integer *)my_malloc(sizeof(Integer) * 100);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 99, __ATOMIC_ACQ_REL);\n // incTypeMalloc(TypeCount, 1);\n#endif\n for (int i = 1; i < 99; i++) {\n\tnumberStructs[i].refs = refsError;\n ((Value *)&numberStructs[i])->next = (Value *)&numberStructs[i + 1];\n }\n numberStructs[99].refs = refsError;\n ((Value *)&numberStructs[99])->next = (Value *)0;\n freeIntegers.head = (Value *)&numberStructs[1];\n moveToCentral(&freeIntegers, ¢ralFreeIntegers);\n\n newInteger = numberStructs;\n }\n } else {\n freeIntegers.head = freeIntegers.head->next;\n }\n // incTypeMalloc(IntegerType, 1);\n newInteger->type = IntegerType;\n newInteger->refs = refsInit;\n return(newInteger);\n}\n\nvoid freeInteger(Value *v) {\n v->next = freeIntegers.head;\n freeIntegers.head = v;\n}\n\nFreeValList centralFreeStrings = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeStrings = {(Value *)0, 0};\n#define STRING_RECYCLE_LEN 100\nString *malloc_string(int len) {\n String *str;\n if (len > STRING_RECYCLE_LEN) {\n str = (String *)my_malloc(sizeof(String) + len + 4);\n memset(str->buffer, 0, len + 4);\n } else {\n str = (String *)freeStrings.head;\n if (str == (String *)0) {\n str = (String *)removeFreeValue(¢ralFreeStrings);\n if (str == (String *)0) {\n\tstr = (String *)my_malloc(sizeof(String) + STRING_RECYCLE_LEN + 4);\n\tmemset(str->buffer, 0, STRING_RECYCLE_LEN);\n }\n } else {\n freeStrings.head = freeStrings.head->next;\n }\n }\n // incTypeMalloc(StringBufferType, 1);\n str->refs = refsInit;\n str->hashVal = 0;\n str->type = StringBufferType;\n str->len = len;\n return(str);\n}\n\nvoid freeString(Value *v) {\n int64_t len = ((String *)v)->len;\n if (len <= STRING_RECYCLE_LEN) {\n v->next = freeStrings.head;\n freeStrings.head = v;\n } else {\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n#endif\n if (!cleaningUp)\n free(v);\n }\n}\n\nFreeValList centralFreeSubStrings = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeSubStrings = {(Value *)0, 0};\nSubString *malloc_substring() {\n SubString *subStr = (SubString *)freeSubStrings.head;\n if (subStr == (SubString *)0) {\n subStr = (SubString *)removeFreeValue(¢ralFreeSubStrings);\n if (subStr == (SubString *)0) {\n subStr = (SubString *)my_malloc(sizeof(SubString));\n }\n } else {\n freeSubStrings.head = freeSubStrings.head->next;\n }\n // incTypeMalloc(SubStringType, 1);\n subStr->refs = refsInit;\n subStr->hashVal = 0;\n return(subStr);\n}\n\nvoid freeSubString(Value *v) {\n Value *src = ((SubString *)v)->source;\n if (src != (Value *)0) {\n dec_and_free(src, 1);\n }\n\n v->next = freeSubStrings.head;\n freeSubStrings.head = v;\n}\n\nFreeValList centralFreeFnArities = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeFnArities = {(Value *)0, 0};\nFnArity *malloc_fnArity() {\n FnArity *newFnArity = (FnArity *)freeFnArities.head;\n if (newFnArity == (FnArity *)0) {\n newFnArity = (FnArity *)removeFreeValue(¢ralFreeFnArities);\n if (newFnArity == (FnArity *)0) {\n newFnArity = (FnArity *)my_malloc(sizeof(FnArity));\n }\n } else {\n freeFnArities.head = freeFnArities.head->next;\n }\n // incTypeMalloc(FnArityType, 1);\n newFnArity->parent = (Value *)0;\n newFnArity->type = FnArityType;\n newFnArity->refs = refsInit;\n return(newFnArity);\n}\n\nvoid freeFnArity(Value *v) {\n FnArity *arity = (FnArity *)v;\n dec_and_free((Value *)arity->closures, 1);\n v->next = freeFnArities.head;\n freeFnArities.head = v;\n}\n\nFreeValList centralFreeFunctions[10] = {(FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0}};\n__thread FreeValList freeFunctions[10] = {{(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0}};\nFunction *malloc_function(int arityCount) {\n Function *newFunction;\n if (arityCount > 9) {\n newFunction = (Function *)my_malloc(sizeof(Function) + sizeof(FnArity *) * arityCount);\n } else {\n newFunction = (Function *)freeFunctions[arityCount].head;\n if (newFunction == (Function *)0) {\n newFunction = (Function *)removeFreeValue(¢ralFreeFunctions[arityCount]);\n if (newFunction == (Function *)0) {\n newFunction = (Function *)my_malloc(sizeof(Function) + sizeof(FnArity *) * arityCount);\n }\n } else {\n freeFunctions[arityCount].head = freeFunctions[arityCount].head->next;\n }\n }\n // incTypeMalloc(FunctionType, 1);\n newFunction->type = FunctionType;\n ((Function *)newFunction)->refs = refsInit;\n return((Function *)newFunction);\n}\n\nvoid freeFunction(Value *v) {\n Function *f = (Function *)v;\n for (int i = 0; i < f->arityCount; i++) {\n dec_and_free((Value *)f->arities[i], 1);\n }\n // fprintf(stderr, \"%p freed\\n\", v);\n if (f->arityCount < 10) {\n v->next = freeFunctions[f->arityCount].head;\n freeFunctions[f->arityCount].head = v;\n } else {\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n#endif\n if (!cleaningUp)\n free(v);\n }\n}\n\nFreeValList centralFreeLists = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeLists = (FreeValList){(Value *)0, 0};\nList *malloc_list() {\n List *newList = (List *)freeLists.head;\n if (newList == (List *)0) {\n newList = (List *)removeFreeValue(¢ralFreeLists);\n if (newList == (List *)0) {\n List *listStructs = (List *)my_malloc(sizeof(List) * 100);\n#ifdef CHECK_MEM_LEAK\n // incTypeMalloc(TypeCount, 1);\n __atomic_fetch_add(&malloc_count, 99, __ATOMIC_ACQ_REL);\n#endif\n for (int i = 1; i < 99; i++) {\n listStructs[i].refs = refsError;\n ((Value *)&listStructs[i])->next = (Value *)&listStructs[i + 1];\n }\n listStructs[99].refs = refsError;\n ((Value *)&listStructs[99])->next = freeLists.head;\n freeLists.head = (Value *)&listStructs[1];\n moveToCentral(&freeLists, ¢ralFreeLists);\n\n newList = listStructs;\n }\n } else {\n freeLists.head = freeLists.head->next;\n }\n\n // incTypeMalloc(ListType, 1);\n newList->type = ListType;\n newList->refs = refsInit;\n newList->hashVal = 0;\n newList->head = (Value *)0;\n newList->tail = (List *)0;\n newList->len = 0;\n return(newList);\n}\n\nvoid freeList(Value *v) {\n List *l = (List *)v;\n Value *head = l->head;\n if (head != (Value *)0)\n dec_and_free(head, 1);\n List *tail = l->tail;\n l->tail = (List *)0;\n v->next = freeLists.head;\n freeLists.head = v;\n#ifdef SINGLE_THREADED\n if (tail != (List *)0) {\n if (tail->refs == 1) {\n tail->refs = refsError;\n freeList((Value *)tail);\n } else {\n decRefs((Value *)tail, 1);\n }\n }\n#else\n if (tail != (List *)0) {\n REFS_SIZE refs = tail->refs;\n if (refs != 1) {\n decRefs((Value *)tail, 1);\n } else {\n tail->refs = refsError;\n freeList((Value *)tail);\n }\n }\n#endif\n}\n\nFreeValList centralFreeMaybes = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeMaybes = {(Value *)0, 0};\nMaybe *malloc_maybe() {\n Maybe *newMaybe = (Maybe *)freeMaybes.head;\n if (newMaybe == (Maybe *)0) {\n newMaybe = (Maybe *)removeFreeValue(¢ralFreeMaybes);\n if (newMaybe == (Maybe *)0) {\n Maybe *maybeStructs = (Maybe *)my_malloc(sizeof(Maybe) * 50);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 49, __ATOMIC_ACQ_REL);\n#endif\n for (int i = 1; i < 49; i++) {\n maybeStructs[i].refs = refsError;\n ((Value *)&maybeStructs[i])->next = (Value *)&maybeStructs[i + 1];\n }\n maybeStructs[49].refs = refsError;\n ((Value*)&maybeStructs[49])->next = (Value *)0;\n freeMaybes.head = (Value *)&maybeStructs[1];\n moveToCentral(&freeMaybes, ¢ralFreeMaybes);\n\n newMaybe = maybeStructs;\n }\n } else {\n freeMaybes.head = freeMaybes.head->next;\n }\n // incTypeMalloc(MaybeType, 1);\n newMaybe->type = MaybeType;\n newMaybe->refs = refsInit;\n newMaybe->hashVal = 0;\n newMaybe->value = (Value *)0;\n return(newMaybe);\n}\n\nvoid freeMaybe(Value *v) {\n Value *value = ((Maybe *)v)->value;\n if (value != (Value *)0)\n dec_and_free(value, 1);\n\n v->next = freeMaybes.head;\n freeMaybes.head = v;\n}\n\nFreeValList centralFreeVectorNodes = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeVectorNodes = {(Value *)0, 0};\nVectorNode *malloc_vectorNode() {\n VectorNode *newVectorNode = (VectorNode *)freeVectorNodes.head;\n if (newVectorNode == (VectorNode *)0) {\n newVectorNode = (VectorNode *)removeFreeValue(¢ralFreeVectorNodes);\n if (newVectorNode == (VectorNode *)0) {\n VectorNode *nodeStructs = (VectorNode *)my_malloc(sizeof(VectorNode) * 50);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 49, __ATOMIC_ACQ_REL);\n#endif\n for (int i = 1; i < 49; i++) {\n nodeStructs[i].refs = refsError;\n ((Value *)&nodeStructs[i])->next = (Value *)&nodeStructs[i + 1];\n }\n nodeStructs[49].refs = refsError;\n ((Value*)&nodeStructs[49])->next = (Value *)0;\n freeVectorNodes.head = (Value *)&nodeStructs[1];\n moveToCentral(&freeVectorNodes, ¢ralFreeVectorNodes);\n\n newVectorNode = nodeStructs;\n }\n } else {\n freeVectorNodes.head = freeVectorNodes.head->next;\n }\n // incTypeMalloc(VectorNodeType, 1);\n newVectorNode->type = VectorNodeType;\n newVectorNode->refs = refsInit;\n memset(&newVectorNode->array, 0, sizeof(Value *) * VECTOR_ARRAY_LEN);\n return(newVectorNode);\n}\n\nvoid freeVectorNode(Value *v) {\n for (int i = 0; i < VECTOR_ARRAY_LEN; i++) {\n if (((VectorNode *)v)->array[i] != (Value *)0) {\n dec_and_free(((VectorNode *)v)->array[i], 1);\n }\n }\n v->next = freeVectorNodes.head;\n freeVectorNodes.head = v;\n}\n\nFreeValList centralFreeVectors = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeVectors = {(Value *)0, 0};\nVector *malloc_vector() {\n Vector *newVector = (Vector *)freeVectors.head;\n if (newVector == (Vector *)0) {\n newVector = (Vector *)removeFreeValue(¢ralFreeVectors);\n if (newVector == (Vector *)0) {\n Vector *vectorStructs = (Vector *)my_malloc(sizeof(Vector) * 300);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 299, __ATOMIC_ACQ_REL);\n#endif\n for (int i = 1; i < 299; i++) {\n vectorStructs[i].refs = refsError;\n ((Value *)&vectorStructs[i])->next = (Value *)&vectorStructs[i + 1];\n }\n vectorStructs[299].refs = refsError;\n ((Value*)&vectorStructs[299])->next = (Value *)0;\n freeVectors.head = (Value *)&vectorStructs[1];\n moveToCentral(&freeVectors, ¢ralFreeVectors);\n\n newVector = vectorStructs;\n }\n } else {\n freeVectors.head = freeVectors.head->next;\n }\n // incTypeMalloc(VectorType, 1);\n newVector->type = VectorType;\n newVector->refs = refsInit;\n newVector->count = 0;\n newVector->shift = 5;\n newVector->root = (VectorNode *)0;\n newVector->hashVal = 0;\n memset(&newVector->tail, 0, sizeof(Value *) * VECTOR_ARRAY_LEN);\n return(newVector);\n}\n\nvoid freeVector(Value *v) {\n Value *root = (Value *)((Vector *)v)->root;\n if (root != (Value *)0) {\n dec_and_free((Value *)root, 1);\n }\n\n for (int i = 0; i < VECTOR_ARRAY_LEN; i++) {\n if (((Vector *)v)->tail[i] != (Value *)0)\n dec_and_free(((Vector *)v)->tail[i], 1);\n }\n v->next = freeVectors.head;\n freeVectors.head = v;\n}\n\nFreeValList centralFreeReified[20] = {(FreeValList){(Value *)0, 0},\n\t\t\t\t (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0},\n (FreeValList){(Value *)0, 0}};\n__thread FreeValList freeReified[20] = {{(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0},\n {(Value *)0, 0}};\nReifiedVal *malloc_reified(int64_t implCount) {\n ReifiedVal *newReifiedVal;\n if (implCount > 19) {\n newReifiedVal = (ReifiedVal *)my_malloc(sizeof(ReifiedVal) + sizeof(Function *) * implCount);\n } else {\n newReifiedVal = (ReifiedVal *)freeReified[implCount].head;\n if (newReifiedVal == (ReifiedVal *)0) {\n newReifiedVal = (ReifiedVal *)removeFreeValue(¢ralFreeReified[implCount]);\n if (newReifiedVal == (ReifiedVal *)0) {\n\tint rvSize = sizeof(ReifiedVal) + sizeof(Function *) * implCount;\n\tint rvCount = 100000;\n\tchar *reifiedStructs = (char *)my_malloc(rvSize * rvCount);\n\tfor (int i = 1; i < (rvCount - 1); i++) {\n\t ((ReifiedVal *)&reifiedStructs[i * rvSize])->refs = refsError;\n\t ((Value *)&reifiedStructs[i * rvSize])->next = (Value *)&reifiedStructs[(i + 1) * rvSize];\n\t}\n\t((ReifiedVal *)&reifiedStructs[(rvCount - 1) * rvSize])->refs = refsError;\n\t((Value *)&reifiedStructs[(rvCount - 1) * rvSize])->next = (Value *)0;\n\tfreeReified[implCount].head = (Value *)&reifiedStructs[rvSize];\n\tmoveToCentral(&freeReified[implCount], ¢ralFreeReified[implCount]);\n\n\tnewReifiedVal = (ReifiedVal *)reifiedStructs;\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, (rvCount - 1), __ATOMIC_ACQ_REL);\n#endif\n }\n } else {\n freeReified[implCount].head = freeReified[implCount].head->next;\n }\n }\n // incTypeMalloc(0, 1);\n newReifiedVal->refs = refsInit;\n newReifiedVal->hashVal = 0;\n newReifiedVal->implCount = implCount;\n return(newReifiedVal);\n}\n\n#define BMI_RECYCLE_COUNT 20\nFreeValList centralFreeBMINodes[BMI_RECYCLE_COUNT] = {(FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0},\n\t\t\t\t\t\t (FreeValList){(Value *)0, 0}};\n__thread FreeValList freeBMINodes[BMI_RECYCLE_COUNT] = {{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0},\n\t\t\t\t\t\t\t{(Value *)0, 0}};\nBitmapIndexedNode *malloc_bmiNode(int itemCount) {\n int nodeSize = sizeof(BitmapIndexedNode) + sizeof(Value *) * (itemCount * 2);\n BitmapIndexedNode *bmiNode;\n\n if (itemCount >= BMI_RECYCLE_COUNT) {\n bmiNode = (BitmapIndexedNode *)my_malloc(nodeSize);\n } else {\n bmiNode = (BitmapIndexedNode *)freeBMINodes[itemCount].head;\n if (bmiNode == (BitmapIndexedNode *)0) {\n bmiNode = (BitmapIndexedNode *)removeFreeValue(¢ralFreeBMINodes[itemCount]);\n if (bmiNode == (BitmapIndexedNode *)0) {\n\tBitmapIndexedNode *bmiNodes;\n\tbmiNodes = (BitmapIndexedNode *)my_malloc(nodeSize * 10);\n#ifdef CHECK_MEM_LEAK\n\t__atomic_fetch_add(&malloc_count, 9, __ATOMIC_ACQ_REL);\n#endif\n\tbmiNode = (BitmapIndexedNode *)((void *)bmiNodes + nodeSize);\n\tfor (int i = 1; i < 9; i++) {\n\t bmiNode->refs = refsError;\n\t ((Value *)bmiNode)->next = (Value *)((void *)bmiNode + nodeSize);\n\t bmiNode = (BitmapIndexedNode *)((Value *)bmiNode)->next;\n\t}\n\tbmiNode = (BitmapIndexedNode *)((void *)bmiNodes + (9 * nodeSize));\n\tbmiNode->refs = refsError;\n\t((Value *)bmiNode)->next = (Value *)0;\n\tfreeBMINodes[itemCount].head = (Value *)((void *)bmiNodes + nodeSize);\n\tmoveToCentral(&freeBMINodes[itemCount], ¢ralFreeBMINodes[itemCount]);\n\n\tbmiNode = bmiNodes;\n }\n } else {\n // fprintf(stderr, \"%d from local node: %p\\n\", itemCount, bmiNode); \n freeBMINodes[itemCount].head = freeBMINodes[itemCount].head->next;\n }\n }\n // incTypeMalloc(BitmapIndexedType, 1);\n bmiNode->type = BitmapIndexedType;\n bmiNode->refs = refsInit;\n bmiNode->hashVal = 0;\n bmiNode->bitmap = 0;\n memset(&bmiNode->array, 0, sizeof(Value *) * (itemCount * 2));\n return(bmiNode);\n}\n\nvoid freeBitmapNode(Value *v) {\n BitmapIndexedNode *node = (BitmapIndexedNode *)v;\n int cnt = __builtin_popcount(node->bitmap);\n for (int i = 0; i < (2 * cnt); i++) {\n if (node->array[i] != (Value *)0) {\n dec_and_free(node->array[i], 1);\n }\n }\n if (cnt >= BMI_RECYCLE_COUNT) {\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n#endif\n if (!cleaningUp)\n free(v);\n } else {\n v->next = freeBMINodes[cnt].head;\n freeBMINodes[cnt].head = v;\n }\n}\n\nHashCollisionNode *malloc_hashCollisionNode(int itemCount) {\n if (itemCount > 30000) {\n fprintf(stderr, \"Catastrophic failure: Too many hash collisions\\n\");\n abort();\n }\n int nodeSize = sizeof(HashCollisionNode) + sizeof(Value *) * (itemCount * 2);\n HashCollisionNode *collisionNode;\n collisionNode = (HashCollisionNode *)my_malloc(nodeSize);\n // incTypeMalloc(HashCollisionNodeType, 1);\n memset(collisionNode, 0, nodeSize);\n collisionNode->type = HashCollisionNodeType;\n collisionNode->count = itemCount * 2;\n collisionNode->hashVal = 0;\n collisionNode->refs = refsInit;\n return(collisionNode);\n}\n\nvoid freeHashCollisionNode(Value *v) {\n HashCollisionNode *node = (HashCollisionNode *)v;\n for (int i = 0; i < node->count; i++) {\n if (node->array[i] != (Value *)0) {\n dec_and_free(node->array[i], 1);\n }\n }\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n#endif\n if (!cleaningUp)\n free(v);\n}\n\nFreeValList centralFreeArrayNodes = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeArrayNodes = {(Value *)0, 0};\nArrayNode *malloc_arrayNode() {\n ArrayNode *arrayNode = (ArrayNode *)freeArrayNodes.head;\n if (arrayNode == (ArrayNode *)0) {\n arrayNode = (ArrayNode *)removeFreeValue(¢ralFreeArrayNodes);\n if (arrayNode == (ArrayNode *)0) {\n ArrayNode *arrayNodes = (ArrayNode *)my_malloc(sizeof(ArrayNode) * 10);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 9, __ATOMIC_ACQ_REL);\n#endif\n for (int i = 1; i < 9; i++) {\n\tarrayNodes[i].refs = refsError;\n ((Value *)&arrayNodes[i])->next = (Value *)&arrayNodes[i + 1];\n }\n arrayNodes[9].refs = refsError;\n ((Value *)&arrayNodes[9])->next = (Value *)0;\n freeArrayNodes.head = (Value *)&arrayNodes[1];\n moveToCentral(&freeArrayNodes, ¢ralFreeArrayNodes);\n\n arrayNode = arrayNodes;\n }\n } else {\n freeArrayNodes.head = freeArrayNodes.head->next;\n }\n // incTypeMalloc(ArrayNodeType, 1);\n memset(arrayNode, 0, sizeof(ArrayNode));\n arrayNode->type = ArrayNodeType;\n arrayNode->hashVal = 0;\n arrayNode->refs = refsInit;\n return(arrayNode);\n}\n\nvoid freeArrayNode(Value *v) {\n ArrayNode *node = (ArrayNode *)v;\n for (int i = 0; i < ARRAY_NODE_LEN; i++) {\n if (node->array[i] != (Value *)0) {\n dec_and_free(node->array[i], 1);\n }\n }\n v->next = freeArrayNodes.head;\n freeArrayNodes.head = v;\n}\n\nFreeValList centralFreePromises = (FreeValList){(Value *)0, 0};\n__thread FreeValList freePromises = {(Value *)0, 0};\nPromise *malloc_promise() {\n Promise *newPromise = (Promise *)freePromises.head;\n if (newPromise == (Promise *)0) {\n newPromise = (Promise *)removeFreeValue(¢ralFreePromises);\n if (newPromise == (Promise *)0) {\n Promise *promises = (Promise *)my_malloc(sizeof(Promise) * 10);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 9, __ATOMIC_ACQ_REL);\n#endif\n for (int i = 1; i < 9; i++) {\n\tpromises[i].refs = refsError;\n ((Value *)&promises[i])->next = (Value *)&promises[i + 1];\n }\n promises[9].refs = refsError;\n ((Value *)&promises[9])->next = (Value *)0;\n freePromises.head = (Value *)&promises[1];\n moveToCentral(&freePromises, ¢ralFreePromises);\n\n newPromise = promises;\n }\n } else {\n freePromises.head = freePromises.head->next;\n }\n // incTypeMalloc(PromiseType, 1);\n memset(newPromise, 0, sizeof(Promise));\n newPromise->type = PromiseType;\n newPromise->refs = refsInit;\n newPromise->result = (Value *)0;\n newPromise->actions = empty_list;\n pthread_cond_init(&newPromise->delivered, NULL);\n pthread_mutex_init(&newPromise->access, NULL);\n return(newPromise);\n}\n\nvoid freePromise(Value *v) {\n // TODO: make sure this is thread safe\n Promise *p = (Promise *)v;\n if (p->actions != (List *)0) {\n Value *action = ((List *)p->actions)->head;\n dec_and_free((Value *)(p->actions), 1);\n }\n if (p->result != (Value *)0) {\n dec_and_free(p->result, 1);\n }\n v->next = freePromises.head;\n freePromises.head = v;\n}\n\nFreeValList centralFreeFutures = (FreeValList){(Value *)0, 0};\n__thread FreeValList freeFutures = {(Value *)0, 0};\nFuture *malloc_future(int line) {\n Future *newFuture = (Future *)freeFutures.head;\n if (newFuture == (Future *)0) {\n newFuture = (Future *)removeFreeValue(¢ralFreeFutures);\n if (newFuture == (Future *)0) {\n Future *futures = (Future *)my_malloc(sizeof(Future) * 10);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 9, __ATOMIC_ACQ_REL);\n#endif\n for (int i = 1; i < 9; i++) {\n\tfutures[i].refs = refsError;\n ((Value *)&futures[i])->next = (Value *)&futures[i + 1];\n }\n futures[9].refs = refsError;\n ((Value *)&futures[9])->next = (Value *)0;\n freeFutures.head = (Value *)&futures[1];\n moveToCentral(&freeFutures, ¢ralFreeFutures);\n\n newFuture = futures;\n }\n } else {\n freeFutures.head = freeFutures.head->next;\n }\n // incTypeMalloc(FutureType, 1);\n memset(newFuture, 0, sizeof(Future));\n newFuture->type = FutureType;\n newFuture->refs = refsInit;\n newFuture->result = (Value *)0;\n newFuture->action = (Value *)0;\n newFuture->errorCallback = (Value *)0;\n pthread_cond_init(&newFuture->delivered, NULL);\n pthread_mutex_init(&newFuture->access, NULL);\n return(newFuture);\n}\n\nvoid freeFuture(Value *v) {\n List *actions = ((Future *)v)->actions;\n if (actions != (List *)0)\n dec_and_free((Value *)actions, 1);\n Value *action = ((Future *)v)->action;\n if (action != (Value *)0)\n dec_and_free(action, 1);\n Value *result = ((Future *)v)->result;\n if (result != (Value *)0)\n dec_and_free(result, 1);\n v->next = freeFutures.head;\n freeFutures.head = v;\n}\n\nvoid emptyAgent(Agent *agent) {\n pthread_mutex_lock (&agent->access);\n REFS_SIZE refs;\n#ifdef SINGLE_THREADED\n refs = agent->output->refs;\n#else\n __atomic_load(&agent->output->refs, &refs, __ATOMIC_RELAXED);\n#endif\n if (refs != 1 &&\n refs != refsConstant &&\n refs != refsStatic) {\n fprintf(stderr, \"failure in emptyAgent()\\n\");\n abort();\n }\n dec_and_free((Value *)agent->output, 1);\n\n List *l;\n#ifdef SINGLE_THREADED\n l = agent->input;\n l->refs = refs;\n#else\n __atomic_load(&agent->input, &l, __ATOMIC_RELAXED);\n __atomic_load(&l->refs, &refs, __ATOMIC_RELAXED);\n#endif\n if (refs != 1 &&\n refs != refsConstant &&\n refs != refsStatic) {\n fprintf(stderr, \"failure in emptyAgent()\\n\");\n abort();\n }\n dec_and_free((Value *)l, 1);\n pthread_mutex_unlock (&agent->access);\n}\n\nvoid freeAgent(Value *v) {\n // TODO: must add loop detection. It's too easy to screw up and cause a cycle\n Value *val = ((Agent *)v)->val;\n REFS_SIZE refs;\n#ifdef SINGLE_THREADED\n refs = val->refs;\n#else\n __atomic_load(&val->refs, &refs, __ATOMIC_RELAXED);\n#endif\n emptyAgent((Agent *)v);\n if (val != (Value *)0) {\n dec_and_free(val, 1);\n }\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n#endif\n if (!cleaningUp)\n free(v);\n}\n\nvoid freeOpaquePtr(Value *v) {\n // call the destructor with the pointer\n Opaque *opaque = (Opaque *)v;\n if (opaque->destruct != NULL)\n opaque->destruct(opaque->ptr);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n#endif\n if (!cleaningUp)\n free(v);\n}\n\ntypedef void (*freeValFn)(Value *);\n\nfreeValFn freeJmpTbl[CoreTypeCount] = {NULL,\n\t\t\t\t &freeInteger,\n\t\t\t\t &freeString,\n\t\t\t\t &freeFnArity,\n\t\t\t\t &freeFunction,\n\t\t\t\t &freeSubString,\n\t\t\t\t &freeList,\n\t\t\t\t &freeMaybe,\n\t\t\t\t &freeVector,\n\t\t\t\t &freeVectorNode,\n\t\t\t\t &freeSubString,\n\t\t\t\t &freeBitmapNode,\n\t\t\t\t &freeArrayNode,\n\t\t\t\t &freeHashCollisionNode,\n\t\t\t\t NULL,\n\t\t\t\t &freePromise,\n\t\t\t\t &freeFuture,\n\t\t\t\t &freeAgent,\n\t\t\t\t &freeOpaquePtr};\n\nvoid dec_and_free(Value *v, int deltaRefs) {\n if (v == (Value *)0 ||\n v->refs == refsStatic ||\n v->refs == refsConstant ||\n decRefs(v, deltaRefs) >= refsConstant)\n return;\n\n if (v->type < CoreTypeCount) {\n // incTypeFree(v->type, 1);\n freeJmpTbl[v->type](v);\n } else {\n ReifiedVal *rv = (ReifiedVal *)v;\n for (int i = 0; i < rv->implCount; i++) {\n dec_and_free(rv->impls[i], 1);\n }\n\n // incTypeFree(0, 1);\n if (rv->implCount < 20) {\n int64_t implCount = rv->implCount;\n v->next = freeReified[implCount].head;\n freeReified[implCount].head = v;\n } else {\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n#endif\n if (!cleaningUp)\n\tfree(v);\n }\n }\n#ifdef CHECK_MEM_LEAK\n // fprintf(stderr, \"malloc_count: %ld free_count: %ld\\r\", malloc_count, free_count);\n#endif\n};\n\n#ifndef FAST_INCS\nValue *incRef(Value *v, int deltaRefs) {\n if ((Value *)v == 0) {\n fprintf(stderr, \"bad incRef value: %p\\n\", v);\n abort();\n }\n if (deltaRefs < 0) {\n fprintf(stderr, \"bad deltaRefs: %p\\n\", v);\n abort();\n } else if (deltaRefs < 1)\n return(v);\n\n#ifdef SINGLE_THREADED\n if (v->refs == refsStatic || v->refs == refsConstant)\n return(v);\n\n if (v->refs < refsStatic) {\n fprintf(stderr, \"failure in incRef: %d %p\\n\", v->refs, v);\n abort();\n }\n\n if (v->refs >= 0) {\n v->refs += deltaRefs;;\n }\n#else\n REFS_SIZE refs;\n __atomic_load(&v->refs, &refs, __ATOMIC_RELAXED);\n\n REFS_SIZE newRefs;\n do {\n if (refs == refsStatic || refs == refsConstant)\n return(v);\n\n if (refs < refsStatic) {\n fprintf(stderr, \"failure in incRef: %d %p\\n\", refs, v);\n abort();\n }\n\n newRefs = refs + deltaRefs;\n } while (!__atomic_compare_exchange(&v->refs, &refs, &newRefs, 1, __ATOMIC_RELAXED, __ATOMIC_RELAXED));\n#endif\n return(v);\n}\n#else\nValue *simpleIncRef(Value *v, int n) {\n v->refs += n;\n return(v);\n}\n#endif\n\nvoid moveFreeToCentral() {\n moveToCentral(&freeLists, ¢ralFreeLists);\n for (int i = 0; i < 10; i++) {\n moveToCentral(&freeFunctions[i], ¢ralFreeFunctions[i]);\n }\n for (int i = 0; i < BMI_RECYCLE_COUNT; i++) {\n moveToCentral(&freeBMINodes[i], ¢ralFreeBMINodes[i]);\n }\n for (int i = 0; i < 20; i++) {\n moveToCentral(&freeReified[i], ¢ralFreeReified[i]);\n }\n moveToCentral(&freeStrings, ¢ralFreeStrings);\n moveToCentral(&freeArrayNodes, ¢ralFreeArrayNodes);\n moveToCentral(&freeSubStrings, ¢ralFreeSubStrings);\n moveToCentral(&freeIntegers, ¢ralFreeIntegers);\n moveToCentral(&freeMaybes, ¢ralFreeMaybes);\n moveToCentral(&freeVectors, ¢ralFreeVectors);\n moveToCentral(&freeVectorNodes, ¢ralFreeVectorNodes);\n moveToCentral(&freeFnArities, ¢ralFreeFnArities);\n moveToCentral(&freePromises, ¢ralFreePromises);\n moveToCentral(&freeFutures, ¢ralFreeFutures);\n}\n\n\nvoid freeGlobal(Value *x) {\n if (x == (Value*)0 ||\n x->refs == refsError ||\n x->refs == refsStatic ||\n x == (Value *)&emptyBMI)\n return;\n x->refs = refsInit;\n dec_and_free(x, 1);\n x->refs = refsStatic;\n}\n\nvoid emptyFreeList(FreeValList *freeLinkedList) {\n FreeValList listHead;\n#ifdef SINGLE_THREADED\n listHead = *freeLinkedList;\n#else\n __atomic_load((FreeValList *)freeLinkedList, (FreeValList *)&listHead, __ATOMIC_RELAXED);\n#endif\n for(Value *item = listHead.head;\n item != (Value *)0;\n item = item->next) {\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n#endif\n }\n}\n\nvoid freeAll() {\n moveFreeToCentral();\n\n for (int i = 0; i < 10; i++) {\n emptyFreeList(¢ralFreeFunctions[i]);\n }\n for (int i = 0; i < 20; i++) {\n emptyFreeList(¢ralFreeReified[i]);\n }\n for (int i = 0; i < BMI_RECYCLE_COUNT; i++) {\n emptyFreeList(¢ralFreeBMINodes[i]);\n }\n emptyFreeList(¢ralFreeFutures);\n emptyFreeList(¢ralFreePromises);\n emptyFreeList(¢ralFreeArrayNodes);\n emptyFreeList(¢ralFreeSubStrings);\n emptyFreeList(¢ralFreeFnArities);\n emptyFreeList(¢ralFreeLists);\n emptyFreeList(¢ralFreeMaybes);\n emptyFreeList(¢ralFreeVectors);\n emptyFreeList(¢ralFreeVectorNodes);\n emptyFreeList(¢ralFreeStrings);\n emptyFreeList(¢ralFreeIntegers);\n\n//*\n#ifdef SINGLE_THREADED\n fprintf(stderr, \"\\nmalloc count: %\" PRId64 \" free count: %\" PRId64 \" diff: %\" PRId64 \"\\n\",\n malloc_count, free_count, malloc_count - free_count);\n#else\n int64_t mallocs;\n __atomic_load(&malloc_count, &mallocs, __ATOMIC_RELAXED);\n int64_t frees;\n __atomic_load(&free_count, &frees, __ATOMIC_RELAXED);\n fprintf(stderr, \"malloc count: %\" PRId64 \" free count: %\" PRId64 \" diff: %\" PRId64 \"\\n\",\n mallocs, frees, mallocs - frees);\n\n/*\n int64_t totalMallocs = 0;\n int64_t totalFrees = 0;\n for (int i = 0; i < 20; i++) {\n fprintf(stderr, \"%d %ld %ld %ld\\n\", i, type_mallocs[i], type_frees[i], type_mallocs[i] - type_frees[i]);\n if (i != 19) {\n totalMallocs += type_mallocs[i];\n totalFrees += type_frees[i];\n }\n }\n totalMallocs = totalMallocs - type_mallocs[19];\n fprintf(stderr, \"\\ntotalMallocs %ld\\n\", totalMallocs);\n fprintf(stderr, \"malloc diff %ld\\n\", mallocs - totalMallocs);\n fprintf(stderr, \"\\ntotalFrees %ld\\n\", totalFrees);\n fprintf(stderr, \"free diff %ld\\n\", frees - totalFrees);\n// */\n\n#endif\n// */\n}\n\nint64_t nakedSha1(Value *v1) {\n Integer *hashVal;\n int64_t hash;\n switch (v1->type) {\n case IntegerType:\n hash = integerSha1(v1);\n break;\n\n case StringBufferType:\n case SubStringType:\n case SymbolType:\n hash = strSha1(v1);\n break;\n\n case ListType:\n case MaybeType:\n case VectorType:\n case BitmapIndexedType:\n case ArrayNodeType:\n case HashCollisionNodeType:\n if (((HashedValue *)v1)->hashVal != 0) {\n hash = ((HashedValue *)v1)->hashVal;\n dec_and_free(v1, 1);\n } else {\n hashVal = (Integer *)sha1((FnArity *)0, v1);\n hash = hashVal->numVal;\n ((HashedValue *)v1)->hashVal = hash;\n dec_and_free((Value *)hashVal, 1);\n }\n break;\n \n default:\n if (v1->type > CoreTypeCount) {\n if (((HashedValue *)v1)->hashVal != 0) {\n\thash = ((HashedValue *)v1)->hashVal;\n\tdec_and_free(v1, 1);\n } else {\n\thashVal = (Integer *)sha1((FnArity *)0, v1);\n\thash = hashVal->numVal;\n\t((HashedValue *)v1)->hashVal = hash;\n\tdec_and_free((Value *)hashVal, 1);\n }\n } else {\n hashVal = (Integer *)sha1((FnArity *)0, v1);\n hash = hashVal->numVal;\n dec_and_free((Value *)hashVal, 1);\n }\n break;\n }\n return(hash);\n}\n\nList *reverseList(List *input) {\n List *output = empty_list;\n Value *item;\n List *l = input;\n while(l != (List *)0 && l->head != (Value *)0) {\n item = l->head;\n incRef(item, 1);\n output = listCons(item, output);\n l = l->tail;\n }\n dec_and_free((Value *)input, 1);\n return(output);\n}\n\nvoid scheduleFuture(Future *fut) {\n List *newList = malloc_list();\n newList->head = (Value *)fut;\n List *input;\n#ifdef SINGLE_THREADED\n input = futuresQueue.input;\n newList->len = input->len + 1;\n newList->tail = input;\n futuresQueue.input = newList;\n#else\n __atomic_load(&futuresQueue.input, &input, __ATOMIC_RELAXED);\n do {\n newList->len = input->len + 1;\n newList->tail = input;\n } while (!__atomic_compare_exchange(&futuresQueue.input, &input, &newList, 1,\n\t\t\t\t __ATOMIC_RELAXED, __ATOMIC_RELAXED));\n#endif\n\n // It is unusual to not hold the mutex when signalling the condition. But\n // in this case it's ok. All the threads waiting on the condition are of\n // equal priority, so it doesn't matter which one gets the next item in\n // the queue. See this explanation for the reasoning behind this:\n // https://groups.google.com/forum/?hl=ky#!msg/comp.programming.threads/wEUgPq541v8/ZByyyS8acqMJ\n pthread_cond_signal(&futuresQueue.notEmpty);\n}\n\nvoid waitForWorkers() {\n#ifdef SINGLE_THREADED\n // no need to wait\n#else\n pthread_cond_broadcast(&futuresQueue.notEmpty);\n for (int8_t i = 0; i < NUM_WORKERS; i++) {\n pthread_join(workers[i], NULL);\n }\n pthread_mutex_lock (&futuresQueue.mutex);\n List *l;\n __atomic_load(&futuresQueue.output, &l, __ATOMIC_RELAXED);\n dec_and_free((Value *)l, 1);\n\n __atomic_load(&futuresQueue.input, &l, __ATOMIC_RELAXED);\n dec_and_free((Value *)l, 1);\n pthread_mutex_unlock (&futuresQueue.mutex);\n\n int done = 0;\n do {\n pthread_mutex_lock (&lingeringAccess);\n List *lingering = (List *)vals((FnArity *)0, lingeringThreads);\n lingeringThreads = (Value *)&emptyBMI;\n pthread_mutex_unlock (&lingeringAccess);\n\n l = lingering;\n for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {\n pthread_t threadId = (pthread_t)((Integer *)x)->numVal;\n pthread_join(threadId, NULL);\n }\n if (lingering->len == 0)\n done = 1;\n dec_and_free((Value *)lingering, 1);\n } while(!done);\n#endif\n}\n\nValue *shutDown_impl(FnArity *arity) {\n Value *item;\n#ifdef CHECK_MEM_LEAK\n moveFreeToCentral();\n#endif\n pthread_exit(NULL);\n return(nothing);\n };\n\nFnArity shutDown_arity = {FnArityType, -2, 0, (Vector *)0, (Value *)0, 0, shutDown_impl};\nFunction shutDownFn = {FunctionType, -2, \"shutdown-workers\", 1, {&shutDown_arity}};\nFuture shutDown = {FutureType, -2, (Value *)&shutDownFn, (Value *)0, (List *)0, (Value *)0, 0};\n\nvoid stopWorkers() {\n for (int32_t i = 0; i < NUM_WORKERS; i++)\n scheduleFuture(&shutDown);\n}\n\nValue *readFuturesQueue() {\n List *output;\n#ifdef SINGLE_THREADED\n // do nothing with futures in a single threaded system\n return((Value *)0);\n#else\n __atomic_load(&futuresQueue.output, &output, __ATOMIC_RELAXED);\n while (output != (List *)0 && output->len != 0 &&\n !__atomic_compare_exchange(&futuresQueue.output,\n\t\t\t\t &output,\n\t\t\t\t &output->tail,\n\t\t\t\t 1, __ATOMIC_RELAXED, __ATOMIC_RELAXED))\n ;\n\n if (output != (List *)0 && output->len != 0) {\n Value *item = output->head;\n output->head = (Value *)0;\n output->tail = (List *)0;\n REFS_SIZE refs;\n __atomic_load(&output->refs, &refs, __ATOMIC_RELAXED);\n if (refs != 1) {\n fprintf(stderr, \"error reading futures queue 1 %d\\n\", refs);\n abort();\n }\n dec_and_free((Value *)output, 1);\n return(item);\n } else {\n pthread_mutex_lock (&futuresQueue.mutex);\n __atomic_load(&futuresQueue.output, &output, __ATOMIC_RELAXED);\n while (output != (List *)0 && output->len != 0 &&\n !__atomic_compare_exchange(&futuresQueue.output,\n\t\t\t\t &output,\n\t\t\t\t &output->tail,\n\t\t\t\t 1, __ATOMIC_RELAXED, __ATOMIC_RELAXED))\n ;\n if (output != (List *)0 && output->len != 0) {\n Value *item = output->head;\n output->head = (Value *)0;\n output->tail = (List *)0;\n REFS_SIZE refs;\n __atomic_load(&output->refs, &refs, __ATOMIC_RELAXED);\n if (refs != 1) {\n fprintf(stderr, \"error reading futures queue 2\\n\");\n abort();\n }\n dec_and_free((Value *)output, 1);\n pthread_mutex_unlock (&futuresQueue.mutex);\n return(item);\n } else {\n List *input;\n __atomic_exchange((List **)&futuresQueue.input,\n\t\t\t(List **)&empty_list,\n\t\t\t(List **)&input,\n\t\t\t__ATOMIC_RELAXED);\n\n if (input == (List *)0 || input->len == 0) {\n int32_t numRunning = __atomic_fetch_sub(&runningWorkers, 1, __ATOMIC_ACQ_REL);\n if (numRunning <= 1 && mainThreadDone) {\n stopWorkers();\n } else {\n#ifdef CHECK_MEM_LEAK\n\t moveFreeToCentral();\n#endif\n pthread_cond_wait(&futuresQueue.notEmpty, &futuresQueue.mutex);\n __atomic_fetch_add(&runningWorkers, 1, __ATOMIC_ACQ_REL);\n }\n pthread_mutex_unlock (&futuresQueue.mutex);\n return(readFuturesQueue());\n } else {\n output = reverseList(input);\n\n __atomic_store(&futuresQueue.output, &output->tail, __ATOMIC_RELAXED);\n pthread_cond_signal(&futuresQueue.notEmpty);\n pthread_mutex_unlock (&futuresQueue.mutex);\n\n Value *item = output->head;\n output->head = (Value *)0;\n output->tail = (List *)0;\n REFS_SIZE refs;\n __atomic_load(&output->refs, &refs, __ATOMIC_RELAXED);\n if (refs != 1) {\n fprintf(stderr, \"error reading futures queue 3\\n\");\n abort();\n }\n dec_and_free((Value *)output, 1);\n return(item);\n }\n }\n }\n#endif\n}\n\nValue *deliverFuture(Value *fut, Value *val) {\n Future *future = (Future *)fut;\n if (future->result == (Value *)0) {\n pthread_mutex_lock (&future->access);\n future->result = val;\n List *l = future->actions;\n List *head = l;\n future->actions = (List *)0;\n pthread_cond_broadcast(&future->delivered);\n pthread_mutex_unlock (&future->access);\n\n // perform actions\n if (l != (List *)0 && l->len != 0) {\n for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {\n\tincRef(x, 1);\n\tincRef(val, 1);\n\tValue *trash = dynamicCall1Arg(x, val);\n\tdec_and_free(trash, 1);\n }\n dec_and_free((Value *)head, 1);\n }\n } else {\n dec_and_free(val, 1);\n }\n return fut;\n}\n\n__thread int64_t workerIndex;\nvoid *futuresThread(void *input) {\n workerIndex = (int64_t)input;\n Future *future;\n Value *result;\n if (workerIndex >= 0)\n future = (Future *)readFuturesQueue();\n while(workerIndex >= 0 && future != (Future *)0) {\n Value *f = future->action;\n if(f->type != FunctionType) {\n result = invoke0Args((FnArity *)0, incRef(f, 1));\n } else {\n FnArity *arity = findFnArity(f, 0);\n if(arity != (FnArity *)0 && !arity->variadic) {\n\tFnType0 *fn = (FnType0 *)arity->fn;\n\tresult = fn(arity);\n } else if(arity != (FnArity *)0 && arity->variadic) {\n\tFnType1 *fn = (FnType1 *)arity->fn;\n\tresult = fn(arity, (Value *)empty_list);\n } else {\n\tfprintf(stderr, \"\\n*** no arity found for '%s'.\\n\", ((Function *)f)->name);\n\tabort();\n }\n }\n deliverFuture((Value *)future, result);\n dec_and_free((Value *)future, 1);\n if (workerIndex >= 0) {\n future = (Future *)readFuturesQueue();\n }\n }\n#ifdef SINGLE_THREADED\n runningWorkers--;\n#else\n __atomic_fetch_sub(&runningWorkers, 1, __ATOMIC_ACQ_REL);\n#endif\n Value *threadHandle = (Value *)integerValue((int64_t)pthread_self());\n\n pthread_mutex_lock (&lingeringAccess);\n lingeringThreads = baseDissoc(lingeringThreads, incRef(threadHandle, 1),\n\t\t\t\tnakedSha1(threadHandle), 0);\n pthread_mutex_unlock (&lingeringAccess);\n\n#ifdef CHECK_MEM_LEAK\n moveFreeToCentral();\n#endif\n return(NULL);\n}\n\nint32_t numWorkers = NUM_WORKERS;\nvoid startWorkers() {\n#ifdef SINGLE_THREADED\n runningWorkers = numWorkers;\n#else\n __atomic_store(&runningWorkers, &numWorkers, __ATOMIC_RELAXED);\n#endif\n for (int64_t i = 0; i < NUM_WORKERS; i++)\n pthread_create(&workers[i], NULL, futuresThread, (void *)i);\n}\n\nvoid replaceWorker() {\n pthread_t me = pthread_self();\n for (int64_t i = 0; i < NUM_WORKERS; i++) {\n if (pthread_equal(workers[i], me)) {\n pthread_create(&workers[workerIndex], NULL, futuresThread, (void *)i);\n workerIndex = -1;\n }\n }\n Value *threadHandle = (Value *)integerValue((int64_t)me);\n pthread_mutex_lock (&lingeringAccess);\n lingeringThreads = copyAssoc(lingeringThreads, incRef((Value *)threadHandle, 1),\n\t\t\t incRef((Value *)threadHandle, 1),\n\t\t\t nakedSha1(threadHandle), 0);\n pthread_mutex_unlock (&lingeringAccess);\n}\n\nchar *extractStr(Value *v) {\n // Should only be used to print an error meessage when calling 'abort'\n // Leaks a String value\n if (v->type == StringBufferType)\n return(((String *)v)->buffer);\n else if (v->type == SubStringType) {\n String *newStr = (String *)my_malloc(sizeof(String) + ((String *)v)->len + 5);\n // incTypeMalloc(StringBufferType, 1);\n newStr->hashVal = 0;\n snprintf(newStr->buffer, ((String *)v)->len + 1, \"%s\", ((SubString *)v)->buffer);\n return(newStr->buffer);\n } else {\n fprintf(stderr, \"\\ninvalid type for 'extractStr'\\n\");\n abort();\n }\n}\n\nFnArity *findFnArity(Value *fnVal, int64_t argCount) {\n Function *fn = (Function *)fnVal;\n int arityIndex = 0;\n FnArity *arity = (FnArity *)fn->arities[arityIndex];\n FnArity *variadic = (FnArity *)0;\n while(arityIndex < fn->arityCount) {\n arity = (FnArity *)fn->arities[arityIndex];\n if (arity->variadic) {\n variadic = arity;\n arityIndex++;\n } else if (arity->count != argCount) {\n arityIndex++;\n } else\n return(arity);\n }\n return(variadic);\n};\n\nint8_t isNothing(Value *v, char *fileName, int lineNumber) {\n return(v->type == MaybeType && ((Maybe *)v)->value == (Value *)0);\n}\n\nValue *maybe(FnArity *arity, Value *arg0, Value *arg1) {\n Maybe *mVal = malloc_maybe();\n mVal->value = arg1;\n return((Value *)mVal);\n}\n\nValue *prSTAR(Value *str) {\n int bytes;\n if (str->type == StringBufferType) {\n bytes = fprintf(outstream, \"%-.*s\", (int)((String *)str)->len, ((String *)str)->buffer);\n } else if (str->type == SubStringType) {\n bytes = fprintf(outstream, \"%-.*s\", (int)((SubString *)str)->len, ((SubString *)str)->buffer);\n }\n dec_and_free(str, 1);\n return(integerValue(bytes));\n}\n\nValue *defaultPrErrSTAR(Value *str) {\n int bytes;\n if (str->type == StringBufferType) {\n bytes = fprintf(stderr, \"%-.*s\", (int)((String *)str)->len, ((String *)str)->buffer);\n } else if (str->type == SubStringType) {\n bytes = fprintf(stderr, \"%-.*s\", (int)((SubString *)str)->len, ((SubString *)str)->buffer);\n }\n dec_and_free(str, 1);\n return(integerValue(bytes));\n}\n\nValue *add_ints(Value *arg0, Value *arg1) {\n Value *numVal = integerValue(((Integer *)arg0)->numVal + ((Integer *)arg1)->numVal);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(numVal);\n}\n\nValue *integerValue(int64_t n) {\n Integer *numVal = malloc_integer();\n numVal->numVal = n;\n return((Value *)numVal);\n};\n\nValue *integer_str(Value *arg0) {\n String *numStr = malloc_string(50);\n snprintf(numStr->buffer, 40, \"%\" PRId64 \"\", ((Integer *)arg0)->numVal);\n numStr->len = strlen(numStr->buffer);\n dec_and_free(arg0, 1);\n return((Value *)numStr);\n}\n\nValue *integer_EQ(Value *arg0, Value *arg1) {\n if (IntegerType != arg0->type || IntegerType != arg1->type) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n } else if (((Integer *)arg0)->numVal != ((Integer *)arg1)->numVal) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n } else {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n }\n}\n\nValue *isInstance(Value *arg0, Value *arg1) {\n TYPE_SIZE typeNum = ((Integer *)arg0)->numVal;\n if (typeNum == arg1->type) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n } else if (StringBufferType == typeNum && SubStringType == arg1->type) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n // } else if (HashMapType == typeNum && (BitmapIndexedType == arg1->type ||\n // ArrayNodeType == arg1->type ||\n // HashCollisionNodeType == arg1->type)) {\n // dec_and_free(arg1, 1);\n // return(maybe((FnArity *)0, (Value *)0, arg0));\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n}\n\nList *listCons(Value *x, List *l) {\n List *newList = malloc_list();\n newList->len = l->len + 1;\n newList->head = (Value *)x;\n newList->tail = l;\n return(newList);\n};\n\nVector *newVector(Value *array[], int indexToSkip) {\n Vector *ret = malloc_vector();\n for (int i = 0; i < VECTOR_ARRAY_LEN; i++) {\n if (array[i] != (Value *)0 && i != indexToSkip) {\n ret->tail[i] = array[i];\n incRef(array[i], 1);\n }\n }\n return(ret);\n}\n\nVectorNode *newVectorNode(Value *array[], int indexToSkip) {\n VectorNode *ret = malloc_vectorNode();\n for (int i = 0; i < VECTOR_ARRAY_LEN; i++) {\n if (array[i] != (Value *)0 && i != indexToSkip) {\n ret->array[i] = array[i];\n incRef(array[i], 1);\n }\n }\n return(ret);\n}\n\nValue **arrayFor(Vector *v, unsigned index) {\n if (index < v->count) {\n if (index >= v->tailOffset) {\n return(v->tail);\n } else {\n VectorNode *node = v->root;\n for (int level = v->shift; level > 0; level -= 5) {\n node = (VectorNode *)node->array[(index >> level) & 0x1f];\n }\n return(node->array);\n }\n } else {\n fprintf(stderr, \"Vector index out of bounds\\n\");\n abort();\n return((Value **)0);\n }\n}\n\nVectorNode *newPath(int level, VectorNode *node) {\n if (level == 0) {\n return(node);\n } else {\n VectorNode *ret = malloc_vectorNode();\n ret->array[0] = (Value *)newPath(level - 5, node);\n return(ret);\n }\n}\n\nVectorNode *pushTail(unsigned count, int level, VectorNode *parent, VectorNode *tailNode) {\n int subidx = ((count - 1) >> level) & 0x1f;\n VectorNode *ret;\n if (parent != (VectorNode *)0) {\n ret = newVectorNode(parent->array, subidx);\n } else {\n ret = malloc_vectorNode();\n }\n VectorNode *nodeToInsert;\n if (level == 5) {\n nodeToInsert = tailNode;\n } else {\n VectorNode *child = (VectorNode *)parent->array[subidx];\n if (child != (VectorNode *)0) {\n nodeToInsert = pushTail(count, level - 5, child, tailNode);\n } else {\n nodeToInsert = newPath(level - 5, tailNode);\n }\n }\n ret->array[subidx] = (Value *)nodeToInsert;\n return(ret);\n}\n\nVector *vectConj(Vector *vect, Value *val) {\n if (vect->refs == 1) {\n return(mutateVectConj((Vector *)incRef((Value *)vect, 1), val));\n // if there's room in the tail\n } else if (vect->count - vect->tailOffset < VECTOR_ARRAY_LEN) {\n // make a new vector and copy info over\n Vector *newVect = newVector(vect->tail, VECTOR_ARRAY_LEN);\n newVect->shift = vect->shift;\n newVect->count = vect->count + 1;\n if (newVect->count < VECTOR_ARRAY_LEN) {\n newVect->tailOffset = 0;\n } else {\n newVect->tailOffset = (newVect->count - 1) & ~0x1f;\n }\n newVect->root = vect->root;\n if (newVect->root != (VectorNode *)0) {\n incRef((Value *)newVect->root, 1);\n }\n\n // add value to tail of new vector\n newVect->tail[vect->count & 0x1F] = val;\n return(newVect);\n } else {\n // since tail is full, make a new node from the tail of 'vect'\n VectorNode *newRoot;\n VectorNode *tailNode = newVectorNode(vect->tail, VECTOR_ARRAY_LEN);\n int newShift = vect->shift;\n\n // if the root of 'vect' is completely full\n if ((vect->count >> 5) > (1 << vect->shift)) {\n // make new vector one level deeper\n newRoot = malloc_vectorNode();\n newRoot->array[0] = (Value *)vect->root;\n incRef(newRoot->array[0], 1);\n\n // and make a new path that includes that node\n newRoot->array[1] = (Value *)newPath(vect->shift, tailNode);\n newShift += 5;\n } else {\n // otherwise, push the tail node down, creating a new root\n newRoot = pushTail(vect->count, vect->shift, vect->root, tailNode);\n }\n Vector *newVect = malloc_vector();\n newVect->count = vect->count + 1;\n newVect->tailOffset = (newVect->count - 1) & ~0x1f;\n newVect->shift = newShift;\n newVect->root = newRoot;\n newVect->tail[0] = val;\n return(newVect);\n }\n}\n\nVector *mutateVectConj(Vector *vect, Value *val) {\n // if 'vect' is a static vector\n if (vect->refs <= refsConstant) {\n Vector *result = vectConj(vect, val);\n return(result);\n } else if (vect->count - vect->tailOffset < VECTOR_ARRAY_LEN) {\n // if there's room in the tail, add value to tail of vector\n vect->tail[vect->count & 0x1F] = val;\n vect->count += 1;\n return(vect);\n } else {\n // since tail is full, make a new node from the tail of 'vect'\n VectorNode *newRoot;\n VectorNode *tailNode = newVectorNode(vect->tail, VECTOR_ARRAY_LEN);\n for (unsigned i = 0; i < VECTOR_ARRAY_LEN; i++) {\n dec_and_free(vect->tail[i], 1);\n vect->tail[i] = (Value *)0;\n }\n int newShift = vect->shift;\n\n // if the root of 'vect' is completely full\n if ((vect->count >> 5) > (1 << vect->shift)) {\n // make new vector one level deeper\n newRoot = malloc_vectorNode();\n newRoot->array[0] = (Value *)vect->root;\n\n // and make a new path that includes that node\n newRoot->array[1] = (Value *)newPath(vect->shift, tailNode);\n newShift += 5;\n } else {\n // make new vector one level deeper\n // otherwise, push the tail node down, creating a new root\n newRoot = pushTail(vect->count, vect->shift, vect->root, tailNode);\n if (vect->root != (VectorNode *)0)\n dec_and_free((Value *)vect->root, 1);\n }\n vect->count += 1;\n vect->tailOffset = (vect->count - 1) & ~0x1f;\n vect->shift = newShift;\n vect->root = newRoot;\n vect->tail[0] = val;\n return(vect);\n }\n}\n\nVectorNode *copyVectStore(int level, VectorNode *node, unsigned index, Value *val) {\n if (level == 0) {\n int arrayIndex = index & 0x1f;\n VectorNode *newNode = newVectorNode(node->array, arrayIndex);\n newNode->array[arrayIndex] = val;\n return(newNode);\n } else {\n int arrayIndex = (index >> level) & 0x1f;\n VectorNode *newNode = newVectorNode(node->array, arrayIndex);\n newNode->array[arrayIndex] = (Value *)copyVectStore(level - 5, (VectorNode *)node->array[arrayIndex],\n\t\t\t\t\t\t\tindex, val);\n return(newNode);\n }\n}\n\nValue *vectStore(Vector *vect, unsigned index, Value *val) {\n // TODO: check the refs count and mutate if equal 1\n // but only if all nodes 'above' this one are mutate-able\n // and if you do mutate this vect, clear the cached hash value (once that's implemented)\n if (index < vect->count) {\n if (index >= vect->tailOffset) {\n unsigned newIndex = index & 0x1f;\n Vector *ret = newVector(vect->tail, newIndex);\n ret->tail[newIndex] = val;\n ret->count = vect->count;\n ret->tailOffset = vect->tailOffset;\n ret->shift = vect->shift;\n ret->root = vect->root;\n if (ret->root != (VectorNode *)0) {\n incRef((Value *)ret->root, 1);\n }\n Value *mval = maybe((FnArity *)0, (Value *)0, (Value *)ret);\n return(mval);\n } else {\n Vector *ret = newVector(vect->tail, VECTOR_ARRAY_LEN);\n ret->count = vect->count;\n ret->tailOffset = vect->tailOffset;\n ret->shift = vect->shift;\n ret->root = copyVectStore(vect->shift, vect->root, index, val);\n Value *mval = maybe((FnArity *)0, (Value *)0, (Value *)ret);\n return(mval);\n }\n } else if (index == vect->count) {\n Value *ret = (Value *)vectConj(vect, val);\n Value *mval = maybe((FnArity *)0, (Value *)0, (Value *)ret);\n return(mval);\n } else {\n dec_and_free(val, 1);\n return(nothing);\n }\n}\n\nValue *fastVectStore(Vector *vect, unsigned index, Value *val) {\n if (index < vect->count &&\n index >= vect->tailOffset &&\n vect->refs == 1) {\n unsigned newIndex = index & 0x1f;\n dec_and_free(vect->tail[newIndex], 1);\n\n vect->tail[newIndex] = val;\n return((Value *)vect);\n } else {\n Value *result = vectStore(vect, index, val);\n if (isNothing(result, \"\", 0)) {\n fprintf(stderr, \"*** Improper use of fastVectStore\\n\");\n abort();\n } else {\n Value *inner = ((Maybe *)result)->value;\n incRef(inner, 1);\n dec_and_free(result, 1);\n dec_and_free((Value *)vect, 1);\n return(inner);\n }\n }\n}\n\nValue *updateField(Value *rval, Value *field, int64_t idx) {\n ReifiedVal *template = (ReifiedVal *)rval;\n if (idx >= template->implCount) {\n fprintf(stderr, \"Field index for type '%s' out of bounds: %\" PRId64 \". Max: %\" PRId64 \"\\n\",\n\t extractStr(type_name((FnArity *)0, rval)), idx, template->implCount);\n abort();\n }\n if (rval->refs == 1) {\n dec_and_free(template->impls[idx], 1);\n template->impls[idx] = field;\n\n return(rval);\n } else {\n ReifiedVal *rv = malloc_reified(template->implCount);\n int rvSize = sizeof(ReifiedVal) + sizeof(Function *) * template->implCount;\n memcpy(rv, template, rvSize);\n#ifdef SINGLE_THREADED\n rv->refs = refsInit;\n#else\n __atomic_store(&rv->refs, &refsInit, __ATOMIC_RELAXED);\n#endif\n for (int i = 0; i < template->implCount; i++) {\n if (i != idx) {\n incRef(template->impls[i], 1);\n }\n }\n rv->impls[idx] = field;\n dec_and_free(rval, 1);\n return((Value *)rv);\n }\n}\n\nValue *vectGet(Vector *vect, unsigned index) {\n // this fn does not dec_and_free vect on purpose\n // it lets calling functions do that.\n Value **array = arrayFor(vect, index);\n return(array[index & 0x1f]);\n}\n\nValue *vectSeq(Vector *vect, int index) {\n List *ret = empty_list;\n if (vect->count > 0) {\n for (int i = vect->count - 1; i >= index; i -= 1) {\n Value *v = vectGet(vect, (unsigned)i);\n incRef(v, 1);\n ret = listCons(v, ret);\n }\n }\n dec_and_free((Value *)vect, 1);\n return((Value *)ret);\n}\n\nValue *vectorReverse(Value *arg0) {\n Vector *v = (Vector *)arg0;\n int i;\n Vector *newVect = empty_vect;\n for (i = v->count - 1; i >= 0; i--) {\n Value *val = vectGet(v, i);\n incRef(val, 1);\n newVect = mutateVectConj(newVect, val);\n }\n dec_and_free(arg0, 1);\n return((Value *)newVect);\n}\n\nvoid destructValue(char *fileName, char *lineNum, Value *val, int numArgs, Value **args[]) {\n if (val->type == ListType) {\n List *l = (List *)val;\n if (l->len < numArgs - 1) {\n fprintf(stderr, \"Insufficient values in list for destructuring at %s: %s\\n\",\n\t fileName, lineNum);\n abort();\n }\n int64_t len = l->len - numArgs + 1;\n for (int i = 0; i < numArgs - 1; i++) {\n *args[i] = l->head; l = l->tail;\n incRef(*args[i], 1);\n }\n l->len = len;\n *args[numArgs - 1] = (Value *)l;\n incRef(*args[numArgs - 1], 1);\n dec_and_free(val, 1);\n } else if (val->type == VectorType) {\n Vector *v = (Vector *)val;\n if (v->count < numArgs - 1) {\n fprintf(stderr, \"Insufficient values in vector for destructuring at %s: %s\\n\",\n\t fileName, lineNum);\n abort();\n }\n // unpack vector\n for (int i = 0; i < numArgs - 1; i++) {\n *args[i] = vectGet(v, i);\n incRef(*args[i], 1);\n }\n *args[numArgs - 1] = vectSeq(v, numArgs - 1);\n } else {\n fprintf(stderr, \"Could not unpack value at %s %s\\n\", fileName, lineNum);\n abort();\n }\n}\n\nValue *strEQ(Value *arg0, Value *arg1) {\n char *s1, *s2;\n long int len;\n\n if (arg0->type == StringBufferType &&\n arg1->type == StringBufferType &&\n ((String *)arg0)->len == ((String *)arg1)->len) {\n s1 = ((String *)arg0)->buffer;\n len = ((String *)arg0)->len;\n s2 = ((String *)arg1)->buffer;\n } else if (arg0->type == SubStringType &&\n arg1->type == SubStringType &&\n ((SubString *)arg0)->len == ((SubString *)arg1)->len) {\n s1 = ((SubString *)arg0)->buffer;\n len = ((SubString *)arg0)->len;\n s2 = ((SubString *)arg1)->buffer;\n } else if (arg0->type == StringBufferType &&\n arg1->type == SubStringType &&\n ((String *)arg0)->len == ((SubString *)arg1)->len) {\n s1 = ((String *)arg0)->buffer;\n len = ((String *)arg0)->len;\n s2 = ((SubString *)arg1)->buffer;\n } else if (arg0->type == SubStringType &&\n arg1->type == StringBufferType &&\n ((SubString *)arg0)->len == ((String *)arg1)->len) {\n s1 = ((SubString *)arg0)->buffer;\n len = ((SubString *)arg0)->len;\n s2 = ((String *)arg1)->buffer;\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n\n if (strncmp(s1, s2, len) == 0) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n}\n\nValue *strLT(Value *arg0, Value *arg1) {\n char *s1, *s2;\n long int len, s1Len, s2Len;\n\n if (arg0->type == StringBufferType &&\n arg1->type == StringBufferType) {\n s1 = ((String *)arg0)->buffer;\n s1Len = ((String *)arg0)->len;\n s2 = ((String *)arg1)->buffer;\n s2Len = ((String *)arg1)->len;\n if (s1Len < s2Len)\n len = s1Len;\n else\n len = s2Len;\n } else if (arg0->type == SubStringType &&\n arg1->type == SubStringType) {\n s1 = ((SubString *)arg0)->buffer;\n s1Len = ((SubString *)arg0)->len;\n s2 = ((SubString *)arg1)->buffer;\n s2Len = ((SubString *)arg1)->len;\n if (s1Len < s2Len)\n len = s1Len;\n else\n len = s2Len;\n } else if (arg0->type == StringBufferType &&\n arg1->type == SubStringType) {\n s1 = ((String *)arg0)->buffer;\n s1Len = ((String *)arg0)->len;\n s2 = ((SubString *)arg1)->buffer;\n s2Len = ((SubString *)arg1)->len;\n if (s1Len < s2Len)\n len = s1Len;\n else\n len = s2Len;\n } else if (arg0->type == SubStringType &&\n arg1->type == StringBufferType) {\n s1 = ((SubString *)arg0)->buffer;\n s1Len = ((SubString *)arg0)->len;\n s2 = ((String *)arg1)->buffer;\n s2Len = ((String *)arg1)->len;\n if (s1Len < s2Len)\n len = s1Len;\n else\n len = s2Len;\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n\n int cmp = strncmp(s1, s2, len);\n if (cmp < 0 || (cmp == 0 && s1Len < s2Len)) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n}\n\nValue *strCount(Value *arg0) {\n Value *numVal;\n if (arg0->type == StringBufferType)\n numVal = integerValue(((String *)arg0)->len);\n else\n numVal = integerValue(((SubString *)arg0)->len);\n dec_and_free(arg0, 1);\n return(numVal);\n}\n\nValue *strList(Value *arg0) {\n List *result = empty_list;\n if (arg0->type == StringBufferType) {\n String *s = (String *)arg0;\n for (int64_t i = s->len - 1; i >= 0; i--) {\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n subStr->len = 1;\n subStr->source = arg0;\n subStr->buffer = s->buffer + i;\n result = listCons((Value *)subStr, result);\n }\n incRef(arg0, s->len);\n } else if (arg0->type == SubStringType) {\n SubString *s = (SubString *)arg0;\n for (int64_t i = s->len - 1; i >= 0; i--) {\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n subStr->len = 1;\n subStr->source = arg0;\n subStr->buffer = s->buffer + i;\n result = listCons((Value *)subStr, result);\n }\n incRef(arg0, s->len);\n }\n dec_and_free(arg0, 1);\n return((Value *)result);\n}\n\nValue *integer_LT(Value *arg0, Value *arg1) {\n if (((Integer *)arg0)->numVal < ((Integer *)arg1)->numVal) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n}\n\nValue *checkInstance(TYPE_SIZE typeNum, Value *arg1) {\n if (typeNum == arg1->type) {\n return(maybe((FnArity *)0, (Value *)0, arg1));\n } else if (StringBufferType == typeNum && SubStringType == arg1->type) {\n return(maybe((FnArity *)0, (Value *)0, arg1));\n } else if (HashMapType == typeNum && (BitmapIndexedType == arg1->type ||\n ArrayNodeType == arg1->type ||\n HashCollisionNodeType == arg1->type)) {\n return(maybe((FnArity *)0, (Value *)0, arg1));\n } else {\n dec_and_free(arg1, 1);\n return(nothing);\n }\n}\n\nValue *listMap(Value *arg0, Value *f) {\n // List map\n List *l = (List *)arg0;\n if (l->len == 0) {\n dec_and_free(arg0, 1);\n dec_and_free(f, 1);\n return((Value *)empty_list);\n } else {\n List *head = empty_list;\n List *tail = empty_list;\n int mutate = 0;\n FnArity *arity2;\n if(f->type == FunctionType) {\n arity2 = findFnArity(f, 1);\n if(arity2 == (FnArity *)0) {\n fprintf(stderr, \"\\n*** no arity found for '%s'.\\n\", ((Function *)f)->name);\n abort();\n }\n }\n REFS_SIZE refs;\n __atomic_load(&arg0->refs, &refs, __ATOMIC_RELAXED);\n if (refs == 1) {\n mutate = 1;\n head = l;\n head->len = 0;\n\n tail = l;\n }\n for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {\n Value *y;\n if (mutate && l->refs > 1) {\n\tdec_and_free((Value *)l, 1);\n\tmutate = 0;\n }\n\n if (!mutate)\n\tincRef(x, 1);\n if(f->type != FunctionType) {\n incRef(f, 1);\n y = invoke1Arg((FnArity *)0, f, x);\n } else if(arity2->variadic) {\n FnType1 *fn4 = (FnType1 *)arity2->fn;\n List *varArgs3 = (List *)listCons(x, empty_list);\n y = fn4(arity2, (Value *)varArgs3);\n } else {\n FnType1 *fn4 = (FnType1 *)arity2->fn;\n y = fn4(arity2, x);\n }\n\n // 'y' is the value for the new list\n if (mutate) {\n\tl->head = y;\n\ttail = l;\n head->len++;\n } else if (head == empty_list) {\n // if we haven't started the new list yet\n head = malloc_list();\n head->len = 1;\n head->head = y;\n head->tail = empty_list;\n tail = head;\n } else {\n // otherwise, append to tail of list\n List *new_tail = malloc_list();\n new_tail->len = 1;\n new_tail->head = y;\n new_tail->tail = empty_list;\n tail->tail = new_tail;\n tail = new_tail;\n head->len++;\n }\n }\n if (refs != 1)\n dec_and_free(arg0, 1);\n dec_and_free(f, 1);\n return((Value *)head);\n }\n}\n\nValue *listConcat(Value *arg0) {\n // TODO: check refs count for each list and stitch them together\n List *ls = (List *)arg0;\n\n if (ls->len == 0) {\n dec_and_free(arg0, 1);\n return((Value *)empty_list);\n }\n else if (ls->len == 1) {\n Value *h = ls->head;\n incRef(h, 1);\n dec_and_free((Value *)ls, 1);\n if (h != (Value *)0 && h->type == VectorType) {\n return(vectSeq((Vector *)h, 0));\n } else {\n return(h);\n }\n } else {\n List *head = empty_list;\n List *tail = empty_list;\n for (; ls != (List *)0; ls = ls->tail) {\n List *l = (List *)ls->head;\n List *newL;\n int discard = 0;\n if (l != (List *)0 && l->type == VectorType) {\n l = (List *)vectSeq((Vector *)incRef((Value *)l, 1), 0);\n discard = 1;\n }\n Value *x;\n for(; l != (List *)0 && l->head != (Value *)0; l = newL) {\n x = l->head;\n if (head == empty_list) {\n // if we haven't started the new list yet\n head = malloc_list();\n head->len = 1;\n head->head = x;\n incRef(x, 1);\n head->tail = empty_list;\n tail = head;\n } else {\n // otherwise, append to tail of list\n List *new_tail = malloc_list();\n new_tail->len = 1;\n new_tail->head = x;\n incRef(x, 1);\n new_tail->tail = empty_list;\n tail->tail = new_tail;\n tail = new_tail;\n head->len++;\n }\n newL = l->tail;\n if(discard) {\n l->tail = (List *)0;\n dec_and_free((Value *)l, 1);\n }\n }\n }\n dec_and_free(arg0, 1);\n return((Value *)head);\n }\n}\n\nValue *car(Value *arg0) {\n List *lst = (List *)arg0;\n if (lst->len == 0) {\n return(nothing);\n } else {\n Value *h = lst->head;\n incRef(h, 1);\n dec_and_free(arg0, 1);\n return(maybe((FnArity *)0, (Value *)0, h));\n }\n}\n\nValue *cdr(Value *arg0) {\n List *lst = (List *)arg0;\n if (lst->len == 0) {\n dec_and_free(arg0, 1);\n return((Value *)empty_list);\n } else {\n List *tail = ((List *)arg0)->tail;\n tail->len = lst->len - 1;\n incRef((Value *)tail, 1);\n dec_and_free(arg0, 1);\n return((Value *)tail);\n }\n}\n\nValue *integerLT(Value *arg0, Value *arg1) {\n if (((Integer *)arg0)->numVal < ((Integer *)arg1)->numVal) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n}\n\n// SHA1 implementation courtesy of: Steve Reid \n// and others.\n// from http://waterjuice.org/c-source-code-for-sha1/\n\n#define SHA1_HASH_SIZE ( 64 / 8 )\n\ntypedef struct\n{\n uint8_t bytes [SHA1_HASH_SIZE];\n } SHA1_HASH;\n\ntypedef union\n{\n uint8_t c [64];\n uint32_t l [16];\n } CHAR64LONG16;\n\n#define rol(value, bits) (((value) << (bits)) | ((value) >> (32 - (bits))))\n#define blk0(i) (block->l[i] = (rol(block->l[i],24)&0xFF00FF00) |(rol(block->l[i],8)&0x00FF00FF))\n#define blk(i) (block->l[i&15] = rol(block->l[(i+13)&15]^block->l[(i+8)&15] ^block->l[(i+2)&15]^block->l[i&15],1))\n\n#define R0(v,w,x,y,z,i) z += ((w&(x^y))^y) + blk0(i)+ 0x5A827999 + rol(v,5); w=rol(w,30);\n#define R1(v,w,x,y,z,i) z += ((w&(x^y))^y) + blk(i) + 0x5A827999 + rol(v,5); w=rol(w,30);\n#define R2(v,w,x,y,z,i) z += (w^x^y) + blk(i) + 0x6ED9EBA1 + rol(v,5); w=rol(w,30);\n#define R3(v,w,x,y,z,i) z += (((w|x)&y)|(w&x)) + blk(i) + 0x8F1BBCDC + rol(v,5); w=rol(w,30);\n#define R4(v,w,x,y,z,i) z += (w^x^y) + blk(i) + 0xCA62C1D6 + rol(v,5); w=rol(w,30);\n\nstatic void TransformFunction(uint32_t state[5], const uint8_t buffer[64]) {\n uint32_t a;\n uint32_t b;\n uint32_t c;\n uint32_t d;\n uint32_t e;\n uint8_t workspace[64];\n CHAR64LONG16* block = (CHAR64LONG16*) workspace;\n\n memcpy( block, buffer, 64 );\n\n // Copy context->state[] to working vars\n a = state[0];\n b = state[1];\n c = state[2];\n d = state[3];\n e = state[4];\n\n // 4 rounds of 20 operations each. Loop unrolled.\n R0(a,b,c,d,e, 0); R0(e,a,b,c,d, 1); R0(d,e,a,b,c, 2); R0(c,d,e,a,b, 3);\n R0(b,c,d,e,a, 4); R0(a,b,c,d,e, 5); R0(e,a,b,c,d, 6); R0(d,e,a,b,c, 7);\n R0(c,d,e,a,b, 8); R0(b,c,d,e,a, 9); R0(a,b,c,d,e,10); R0(e,a,b,c,d,11);\n R0(d,e,a,b,c,12); R0(c,d,e,a,b,13); R0(b,c,d,e,a,14); R0(a,b,c,d,e,15);\n R1(e,a,b,c,d,16); R1(d,e,a,b,c,17); R1(c,d,e,a,b,18); R1(b,c,d,e,a,19);\n R2(a,b,c,d,e,20); R2(e,a,b,c,d,21); R2(d,e,a,b,c,22); R2(c,d,e,a,b,23);\n R2(b,c,d,e,a,24); R2(a,b,c,d,e,25); R2(e,a,b,c,d,26); R2(d,e,a,b,c,27);\n R2(c,d,e,a,b,28); R2(b,c,d,e,a,29); R2(a,b,c,d,e,30); R2(e,a,b,c,d,31);\n R2(d,e,a,b,c,32); R2(c,d,e,a,b,33); R2(b,c,d,e,a,34); R2(a,b,c,d,e,35);\n R2(e,a,b,c,d,36); R2(d,e,a,b,c,37); R2(c,d,e,a,b,38); R2(b,c,d,e,a,39);\n R3(a,b,c,d,e,40); R3(e,a,b,c,d,41); R3(d,e,a,b,c,42); R3(c,d,e,a,b,43);\n R3(b,c,d,e,a,44); R3(a,b,c,d,e,45); R3(e,a,b,c,d,46); R3(d,e,a,b,c,47);\n R3(c,d,e,a,b,48); R3(b,c,d,e,a,49); R3(a,b,c,d,e,50); R3(e,a,b,c,d,51);\n R3(d,e,a,b,c,52); R3(c,d,e,a,b,53); R3(b,c,d,e,a,54); R3(a,b,c,d,e,55);\n R3(e,a,b,c,d,56); R3(d,e,a,b,c,57); R3(c,d,e,a,b,58); R3(b,c,d,e,a,59);\n R4(a,b,c,d,e,60); R4(e,a,b,c,d,61); R4(d,e,a,b,c,62); R4(c,d,e,a,b,63);\n R4(b,c,d,e,a,64); R4(a,b,c,d,e,65); R4(e,a,b,c,d,66); R4(d,e,a,b,c,67);\n R4(c,d,e,a,b,68); R4(b,c,d,e,a,69); R4(a,b,c,d,e,70); R4(e,a,b,c,d,71);\n R4(d,e,a,b,c,72); R4(c,d,e,a,b,73); R4(b,c,d,e,a,74); R4(a,b,c,d,e,75);\n R4(e,a,b,c,d,76); R4(d,e,a,b,c,77); R4(c,d,e,a,b,78); R4(b,c,d,e,a,79);\n\n // Add the working vars back into context.state[]\n state[0] += a;\n state[1] += b;\n state[2] += c;\n state[3] += d;\n state[4] += e;\n }\n\nvoid Sha1Initialise (Sha1Context* Context) {\n // SHA1 initialization constants\n Context->State[0] = 0x67452301;\n Context->State[1] = 0xEFCDAB89;\n Context->State[2] = 0x98BADCFE;\n Context->State[3] = 0x10325476;\n Context->State[4] = 0xC3D2E1F0;\n Context->Count[0] = 0;\n Context->Count[1] = 0;\n }\n\nvoid Sha1Update (Sha1Context* Context, void* Buffer, int64_t BufferSize) {\n uint32_t i;\n uint32_t j;\n\n j = (Context->Count[0] >> 3) & 63;\n if( (Context->Count[0] += BufferSize << 3) < (BufferSize << 3) )\n {\n Context->Count[1]++;\n }\n\n Context->Count[1] += (BufferSize >> 29);\n if( (j + BufferSize) > 63 )\n {\n i = 64 - j;\n memcpy( &Context->Buffer[j], Buffer, i );\n TransformFunction(Context->State, Context->Buffer);\n for( ; i + 63 < BufferSize; i += 64 )\n {\n TransformFunction(Context->State, (uint8_t*)Buffer + i);\n }\n j = 0;\n }\n else\n {\n i = 0;\n }\n\n memcpy( &Context->Buffer[j], &((uint8_t*)Buffer)[i], BufferSize - i );\n}\n\nvoid Sha1Finalise (Sha1Context* Context, SHA1_HASH* Digest) {\n uint32_t i;\n uint8_t finalcount[8];\n\n for( i=0; i<8; i++ )\n {\n finalcount[i] = (unsigned char)((Context->Count[(i >= 4 ? 0 : 1)]\n >> ((3-(i & 3)) * 8) ) & 255); // Endian independent\n }\n Sha1Update( Context, (uint8_t*)\"\\x80\", 1 );\n while( (Context->Count[0] & 504) != 448 )\n {\n Sha1Update( Context, (uint8_t*)\"\\0\", 1 );\n }\n\nSha1Update( Context, finalcount, 8 ); // Should cause a Sha1TransformFunction()\n for( i=0; ibytes[i] = (uint8_t)((Context->State[i>>2] >> ((3-(i & 3)) * 8) ) & 255);\n }\n}\n\nvoid free_sha1(void *ptr) {\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n // incTypeFree(IntegerType, 1);\n#endif\n free(ptr);\n}\n\nValue *malloc_sha1() {\n Sha1Context *ctxt = (Sha1Context *)malloc(sizeof(Sha1Context));\n Sha1Initialise(ctxt);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&malloc_count, 1, __ATOMIC_ACQ_REL);\n // incTypeMalloc(IntegerType, 1);\n#endif\n return(opaqueValue(ctxt, free_sha1));\n}\n\nValue *finalize_sha1(Value *ctxt) {\n int64_t shaVal;\n Sha1Finalise(((Opaque *)ctxt)->ptr, (SHA1_HASH *)&shaVal);\n dec_and_free(ctxt, 1);\n return((Value *)integerValue(shaVal));\n}\n\nint64_t integerSha1(Value *arg0) {\n int64_t shaVal;\n Sha1Context context;\n Integer *numVal = (Integer *)arg0;\n\n Sha1Initialise(&context);\n Sha1Update(&context, (void *)&numVal->type, 8);\n Sha1Update(&context, (void *)&numVal->numVal, 8);\n Sha1Finalise(&context, (SHA1_HASH *)&shaVal);\n dec_and_free(arg0, 1);\n return(shaVal);\n}\n\nValue *bitAnd(Value *arg0, Value *arg1) {\n Value *result;\n result = integerValue(((Integer *)arg0)->numVal & ((Integer *)arg1)->numVal);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n}\n\nValue *bitOr(Value *arg0, Value *arg1) {\n Value *result;\n result = integerValue(((Integer *)arg0)->numVal | ((Integer *)arg1)->numVal);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n}\n\nValue *bitXor(Value *arg0, Value *arg1) {\n Value *result;\n result = integerValue(((Integer *)arg0)->numVal ^ ((Integer *)arg1)->numVal);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n}\n\nValue *bitShiftLeft(Value *arg0, Value *arg1) {\n Value *result;\n result = integerValue(((Integer *)arg0)->numVal << ((Integer *)arg1)->numVal);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n}\n\nValue *bitShiftRight(Value *arg0, Value *arg1) {\n Value *result;\n result = integerValue(((Integer *)arg0)->numVal >> ((Integer *)arg1)->numVal);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n}\n\nValue *bitNot(Value *arg0) {\n Value *result;\n result = integerValue(~((Integer *)arg0)->numVal);\n dec_and_free(arg0, 1);\n return(result);\n}\n\nValue *addIntegers(Value *arg0, Value *arg1) {\n Value *numVal = integerValue(((Integer *)arg0)->numVal + ((Integer *)arg1)->numVal);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(numVal);\n}\n\nValue *listEQ(Value *arg0, Value *arg1) {\n if (arg1->type != ListType ||\n ((List *)arg0)->len != ((List *)arg1)->len) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n } else {\n List *l0 = (List *)arg0;\n List *l1 = (List *)arg1;\n for (;\n l0 != (List *)0 && l0->head != (Value *)0 &&\n l1 != (List *)0 && l1->head != (Value *)0;\n l0 = l0->tail, l1 = l1->tail) {\n incRef(l0->head, 1);\n incRef(l1->head, 1);\n if (!equal(l0->head, l1->head)) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n }\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n }\n}\n\nint8_t equal(Value *v1, Value *v2) {\n Value *equals;\n switch (v1->type) {\n case IntegerType:\n equals = integer_EQ(v1, v2);\n break;\n case SymbolType:\n equals = symEQ(v1, v2);\n break;\n default:\n equals = equalSTAR((FnArity *)0, v1, v2);\n break;\n }\n int8_t notEquals = isNothing(equals, \"\", 0);\n dec_and_free(equals, 1);\n return(!notEquals);\n}\n\nValue *stringValue(char *s) {\n int64_t len = strlen(s);\n String *strVal = malloc_string(len);\n strncpy(strVal->buffer, s, len);\n strVal->buffer[len] = 0;\n return((Value *)strVal);\n};\n\nValue *maybeExtract(Value *arg0) {\n Maybe *mValue = (Maybe *)arg0;\n if (mValue->value == (Value *)0) {\n (*prErrSTAR)(stringValue(\"\\n*** The 'nothing' value can not be passed to 'extract'.\\n\"));\n abort();\n }\n incRef(mValue->value, 1);\n Value *result = mValue->value;\n dec_and_free(arg0, 1);\n return(result);\n}\n\nValue *fnApply(Value *arg0, Value *arg1) {\n List *argList = (List *)arg1;\n FnArity *_arity;\n if (arg0->type == FunctionType)\n _arity = findFnArity(arg0, argList->len);\n else\n _arity = (FnArity *)arg0;\n\n if (_arity == (FnArity *)0) {\n fprintf(stderr, \"\\n*** no arity of '%s' found to apply to %\" PRId64 \" args\\n\",\n ((Function *)arg0)->name, argList->len);\n abort();\n } else if(_arity->variadic) {\n FnType1 *_fn = (FnType1 *)_arity->fn;\n Value *result = _fn(_arity, arg1);\n dec_and_free(arg0, 1);\n return(result);\n } else if (argList->len == 0) {\n FnType0 *_fn = (FnType0 *)_arity->fn;\n Value *result = _fn(_arity);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 1) {\n FnType1 *_fn = (FnType1 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n Value *result = _fn(_arity, appArg0);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 2) {\n FnType2 *_fn = (FnType2 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n argList = argList->tail;\n Value *appArg1 = argList->head; incRef(appArg1, 1);\n Value *result = _fn(_arity, appArg0, appArg1);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 3) {\n FnType3 *_fn = (FnType3 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n argList = argList->tail;\n Value *appArg1 = argList->head; incRef(appArg1, 1);\n argList = argList->tail;\n Value *appArg2 = argList->head; incRef(appArg2, 1);\n Value *result = _fn(_arity, appArg0, appArg1, appArg2);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 4) {\n FnType4 *_fn = (FnType4 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n argList = argList->tail;\n Value *appArg1 = argList->head; incRef(appArg1, 1);\n argList = argList->tail;\n Value *appArg2 = argList->head; incRef(appArg2, 1);\n argList = argList->tail;\n Value *appArg3 = argList->head; incRef(appArg3, 1);\n Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 5) {\n FnType5 *_fn = (FnType5 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n argList = argList->tail;\n Value *appArg1 = argList->head; incRef(appArg1, 1);\n argList = argList->tail;\n Value *appArg2 = argList->head; incRef(appArg2, 1);\n argList = argList->tail;\n Value *appArg3 = argList->head; incRef(appArg3, 1);\n argList = argList->tail;\n Value *appArg4 = argList->head; incRef(appArg4, 1);\n Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 6) {\n FnType6 *_fn = (FnType6 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n argList = argList->tail;\n Value *appArg1 = argList->head; incRef(appArg1, 1);\n argList = argList->tail;\n Value *appArg2 = argList->head; incRef(appArg2, 1);\n argList = argList->tail;\n Value *appArg3 = argList->head; incRef(appArg3, 1);\n argList = argList->tail;\n Value *appArg4 = argList->head; incRef(appArg4, 1);\n argList = argList->tail;\n Value *appArg5 = argList->head; incRef(appArg5, 1);\n Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4, appArg5);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 7) {\n FnType7 *_fn = (FnType7 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n argList = argList->tail;\n Value *appArg1 = argList->head; incRef(appArg1, 1);\n argList = argList->tail;\n Value *appArg2 = argList->head; incRef(appArg2, 1);\n argList = argList->tail;\n Value *appArg3 = argList->head; incRef(appArg3, 1);\n argList = argList->tail;\n Value *appArg4 = argList->head; incRef(appArg4, 1);\n argList = argList->tail;\n Value *appArg5 = argList->head; incRef(appArg5, 1);\n argList = argList->tail;\n Value *appArg6 = argList->head; incRef(appArg6, 1);\n Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4, appArg5, appArg6);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 8) {\n FnType8 *_fn = (FnType8 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n argList = argList->tail;\n Value *appArg1 = argList->head; incRef(appArg1, 1);\n argList = argList->tail;\n Value *appArg2 = argList->head; incRef(appArg2, 1);\n argList = argList->tail;\n Value *appArg3 = argList->head; incRef(appArg3, 1);\n argList = argList->tail;\n Value *appArg4 = argList->head; incRef(appArg4, 1);\n argList = argList->tail;\n Value *appArg5 = argList->head; incRef(appArg5, 1);\n argList = argList->tail;\n Value *appArg6 = argList->head; incRef(appArg6, 1);\n argList = argList->tail;\n Value *appArg7 = argList->head; incRef(appArg7, 1);\n Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4, appArg5, appArg6, appArg7);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else if (argList->len == 9) {\n FnType9 *_fn = (FnType9 *)_arity->fn;\n Value *appArg0 = argList->head; incRef(appArg0, 1);\n argList = argList->tail;\n Value *appArg1 = argList->head; incRef(appArg1, 1);\n argList = argList->tail;\n Value *appArg2 = argList->head; incRef(appArg2, 1);\n argList = argList->tail;\n Value *appArg3 = argList->head; incRef(appArg3, 1);\n argList = argList->tail;\n Value *appArg4 = argList->head; incRef(appArg4, 1);\n argList = argList->tail;\n Value *appArg5 = argList->head; incRef(appArg5, 1);\n argList = argList->tail;\n Value *appArg6 = argList->head; incRef(appArg6, 1);\n argList = argList->tail;\n Value *appArg7 = argList->head; incRef(appArg7, 1);\n argList = argList->tail;\n Value *appArg8 = argList->head; incRef(appArg8, 1);\n Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4, appArg5, appArg6, appArg7,\n appArg8);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n } else {\n fprintf(stderr, \"error in 'fn-apply'\\n\");\n abort();\n }\n}\n\nValue *maybeEQ(Value *arg0, Value *arg1) {\n if (arg1->type == MaybeType &&\n ((Maybe *)arg0)->value == ((Maybe *)arg1)->value) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n } else if (arg1->type == MaybeType &&\n ((Maybe *)arg0)->value != (Value *)0 &&\n ((Maybe *)arg1)->value != (Value *)0) {\n incRef(((Maybe *)arg0)->value, 1);\n incRef(((Maybe *)arg1)->value, 1);\n Value *eqResult = equalSTAR((FnArity *)0, ((Maybe *)arg0)->value, ((Maybe *)arg1)->value);\n if (isNothing(eqResult, \"\", 0)) {\n dec_and_free(eqResult, 1);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n } else {\n dec_and_free(eqResult, 1);\n dec_and_free(arg1, 1);\n Value *result = maybe((FnArity *)0, (Value *)0, arg0);\n return(result);\n }\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n}\n\nValue *maybeMap(Value *arg0, Value *arg1) {\n Value *rslt6;\n Maybe *mValue = (Maybe *)arg0;\n if (mValue->value == (Value *)0) {\n dec_and_free(arg1, 1);\n return(arg0);\n } else if((arg1)->type != FunctionType) {\n incRef(arg1, 1);\n incRef(mValue->value, 1);\n rslt6 = invoke1Arg((FnArity *)0, arg1, mValue->value);\n } else {\n FnArity *arity3 = findFnArity(arg1, 1);\n if(arity3 != (FnArity *)0 && !arity3->variadic) {\n FnType1 *fn5 = (FnType1 *)arity3->fn;\n incRef(mValue->value, 1);\n rslt6 = fn5(arity3, mValue->value);\n } else if(arity3 != (FnArity *)0 && arity3->variadic) {\n FnType1 *fn5 = (FnType1 *)arity3->fn;\n List *varArgs4 = empty_list;\n incRef(mValue->value, 1);\n varArgs4 = (List *)listCons(mValue->value, varArgs4);\n rslt6 = fn5(arity3, (Value *)varArgs4);\n } else {\n fprintf(stderr, \"\\n*** no arity found for '%s'.\\n\", ((Function *)arg1)->name);\n abort();\n }\n }\n Value *result = maybe((FnArity *)0, (Value *)0, rslt6);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n}\n\nvoid strSha1Update(Sha1Context *ctxt, Value *arg0) {\n char *buffer;\n int64_t len;\n if (arg0->type == StringBufferType) {\n String *strVal = (String *)arg0;\n buffer = strVal->buffer;\n len = strVal->len;\n } else if (arg0->type == SubStringType) {\n SubString *strVal = (SubString *)arg0;\n buffer = strVal->buffer;\n len = strVal->len;\n }\n\n Sha1Update(ctxt, (void *)&arg0->type, 8);\n Sha1Update(ctxt, buffer, len);\n return;\n}\n\nint64_t strSha1(Value *arg0) {\n int64_t hash;\n char *buffer;\n int64_t len;\n\n if (arg0->type == StringBufferType) {\n String *strVal = (String *)arg0;\n hash = strVal->hashVal;\n buffer = strVal->buffer;\n len = strVal->len;\n } else if (arg0->type == SubStringType ||\n\t arg0->type == SymbolType) {\n SubString *strVal = (SubString *)arg0;\n hash = strVal->hashVal;\n buffer = strVal->buffer;\n len = strVal->len;\n }\n\n if (hash != 0) {\n dec_and_free(arg0, 1);\n return(hash);\n } else {\n int64_t shaVal;\n Sha1Context context;\n\n Sha1Initialise(&context);\n Sha1Update(&context, (void *)&arg0->type, 8);\n Sha1Update(&context, buffer, len);\n Sha1Finalise(&context, (SHA1_HASH *)&shaVal);\n\n ((String *)arg0)->hashVal = shaVal;\n dec_and_free(arg0, 1);\n return(shaVal);\n }\n}\n\nValue *escapeChars(Value *arg0) {\n if (arg0->type == StringBufferType) {\n String *s = (String *)arg0;\n String *result = malloc_string(s->len * 2);\n char *resultBuffer = result->buffer;\n int resultIndex = 0;\n for(int i = 0; i < s->len; i++) {\n if (s->buffer[i] == 10) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 110;\n } else if (s->buffer[i] == 34) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 34;\n } else if (s->buffer[i] == 13) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 114;\n } else if (s->buffer[i] == 12) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 102;\n } else if (s->buffer[i] == 8) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 98;\n } else if (s->buffer[i] == 9) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 116;\n } else if (s->buffer[i] == 92) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 92;\n } else\n resultBuffer[resultIndex++] = s->buffer[i];\n }\n resultBuffer[resultIndex] = 0;\n result->len = resultIndex;\n dec_and_free(arg0, 1);\n return((Value *)result);\n } else if (arg0->type == SubStringType) {\n SubString *s = (SubString *)arg0;\n String *result = malloc_string(s->len * 2);\n char *resultBuffer = result->buffer;\n int resultIndex = 0;\n for(int i = 0; i < s->len; i++) {\n if (s->buffer[i] == 10) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 110;\n } else if (s->buffer[i] == 34) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 34;\n } else if (s->buffer[i] == 13) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 114;\n } else if (s->buffer[i] == 12) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 102;\n } else if (s->buffer[i] == 8) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 98;\n } else if (s->buffer[i] == 9) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 116;\n } else if (s->buffer[i] == 92) {\n resultBuffer[resultIndex++] = 92;\n resultBuffer[resultIndex++] = 92;\n } else\n resultBuffer[resultIndex++] = s->buffer[i];\n }\n resultBuffer[resultIndex] = 0;\n result->len = resultIndex;\n dec_and_free(arg0, 1);\n return((Value *)result);\n }\n return(arg0);\n}\n\nValue *opaqueValue(void *ptr, Destructor *destruct) {\n Opaque *opVal = (Opaque *)my_malloc(sizeof(Opaque));\n // incTypeMalloc(OpaqueType, 1);\n opVal->type = OpaqueType;\n opVal->ptr = ptr;\n opVal->destruct = destruct;\n return((Value *)opVal);\n};\n\nValue *subs2(Value *arg0, Value *arg1) {\n int64_t idx = ((Integer *)arg1)->numVal;\n if (arg0->type == StringBufferType) {\n String *s = (String *)arg0;\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n if (idx < s->len) {\n subStr->len = s->len - idx;\n subStr->source = arg0;\n subStr->buffer = s->buffer + idx;\n } else {\n dec_and_free(arg0, 1);\n subStr->len = 0;\n subStr->source = (Value *)0;\n subStr->buffer = (char *)0;\n }\n dec_and_free(arg1, 1);\n return((Value *)subStr);\n } else if (arg0->type == SubStringType) {\n SubString *s = (SubString *)arg0;\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n if (idx < s->len) {\n subStr->len = s->len - idx;\n subStr->source = ((SubString *)arg0)->source;\n incRef(subStr->source, 1);\n subStr->buffer = s->buffer + idx;\n } else {\n subStr->len = 0;\n subStr->source = (Value *)0;\n subStr->buffer = (char *)0;\n }\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return((Value *)subStr);\n }\n return(arg0);\n}\n\nValue *subs3(Value *arg0, Value *arg1, Value *arg2) {\n int64_t idx = ((Integer *)arg1)->numVal;\n int64_t len = ((Integer *)arg2)->numVal;\n if (len <= 0) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n dec_and_free(arg2, 1);\n return(stringValue(\"\"));\n } else if (arg0->type == StringBufferType) {\n String *s = (String *)arg0;\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n if (idx + len <= s->len) {\n subStr->len = len;\n subStr->source = arg0;\n incRef(arg0, 1);\n subStr->buffer = s->buffer + idx;\n } else {\n subStr->len = 0;\n subStr->source = (Value *)0;\n subStr->buffer = (char *)0;\n }\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n dec_and_free(arg2, 1);\n return((Value *)subStr);\n } else if (arg0->type == SubStringType) {\n SubString *s = (SubString *)arg0;\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n if (idx + len <= s->len) {\n subStr->len = len;\n subStr->source = ((SubString *)arg0)->source;\n incRef((Value *)subStr->source, 1);\n subStr->buffer = s->buffer + idx;\n } else {\n subStr->len = 0;\n subStr->source = (Value *)0;\n subStr->buffer = (char *)0;\n }\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n dec_and_free(arg2, 1);\n return((Value *)subStr);\n }\n return(arg0);\n}\n\nValue *strSeq(Value *arg0) {\n List *result = empty_list;\n if (arg0->type == StringBufferType) {\n String *s = (String *)arg0;\n for (int64_t i = s->len - 1; i >= 0; i--) {\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n subStr->len = 1;\n subStr->source = arg0;\n subStr->buffer = s->buffer + i;\n result = listCons((Value *)subStr, result);\n }\n incRef(arg0, s->len);\n } else if (arg0->type == SubStringType) {\n SubString *s = (SubString *)arg0;\n for (int64_t i = s->len - 1; i >= 0; i--) {\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n subStr->len = 1;\n subStr->source = arg0;\n subStr->buffer = s->buffer + i;\n result = listCons((Value *)subStr, result);\n }\n incRef(arg0, s->len);\n }\n dec_and_free(arg0, 1);\n return((Value *)result);\n}\n\nValue *dynamicCall2Arg(Value *f, Value *arg0, Value *arg1) {\n Value *rslt;\n if(f->type != FunctionType) {\n rslt = invoke2Args((FnArity *)0, f, arg0, arg1);\n } else {\n FnArity *arity = findFnArity(f, 2);\n if(arity != (FnArity *)0 && !arity->variadic) {\n FnType2 *fn = (FnType2 *)arity->fn;\n rslt = fn(arity, arg0, arg1);\n } else if(arity != (FnArity *)0 && arity->variadic) {\n FnType1 *fn = (FnType1 *)arity->fn;\n List *dynArgs = empty_list;\n dynArgs = (List *)listCons(arg1, dynArgs);\n dynArgs = (List *)listCons(arg0, dynArgs);\n rslt = fn(arity, (Value *)dynArgs);\n } else {\n fprintf(stderr, \"\\n*** Invalid function for string reduction.\\n\");\n abort();\n }\n dec_and_free(f, 1);\n }\n return(rslt);\n}\n\nValue *strReduce(Value *s0, Value *x1, Value *f2) {\n int64_t len = ((String *)s0)->len;\n Value *result = x1;\n\n char *buffer;\n if (s0->type == StringBufferType)\n buffer = ((String *)s0)->buffer;\n else if (s0->type == SubStringType)\n buffer = ((SubString *)s0)->buffer;\n\n incRef(f2, len);\n incRef(s0, len);\n for (int64_t i = 0; i < len; i++) {\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n subStr->len = 1;\n subStr->source = s0;\n subStr->buffer = buffer + i;\n result = dynamicCall2Arg(f2, result, (Value *)subStr);\n }\n dec_and_free(f2, 1);\n dec_and_free(s0, 1);\n return((Value *)result);\n}\n\nValue *strVec(Value *arg0) {\n Vector *result = empty_vect;\n if (arg0->type == StringBufferType) {\n String *s = (String *)arg0;\n for (int64_t i = 0; i < s->len; i++) {\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n subStr->len = 1;\n subStr->source = arg0;\n subStr->buffer = s->buffer + i;\n result = mutateVectConj(result, (Value *)subStr);\n }\n incRef(arg0, s->len);\n } else if (arg0->type == SubStringType) {\n SubString *s = (SubString *)arg0;\n for (int64_t i = 0; i < s->len; i++) {\n SubString *subStr = malloc_substring();\n subStr->type = SubStringType;\n subStr->len = 1;\n subStr->source = arg0;\n subStr->buffer = s->buffer + i;\n result = mutateVectConj(result, (Value *)subStr);\n }\n incRef(arg0, s->len);\n }\n dec_and_free(arg0, 1);\n return((Value *)result);\n}\n\nValue *vectorGet(Value *arg0, Value *arg1) {\n Vector *vect = (Vector *)arg0;\n Integer *index = (Integer *)arg1;\n if (index->numVal < 0 || vect->count <= index->numVal) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n } else {\n Value *val = vectGet(vect, (unsigned)index->numVal);\n incRef(val, 1);\n Value *result = maybe((FnArity *)0, (Value *)0, val);\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(result);\n }\n}\n\nValue *symbol(Value *arg0) {\n int64_t len;\n char *buffer;\n if (arg0->type == StringBufferType) {\n String *s = (String *)arg0;\n buffer = s->buffer;\n len = s->len;\n } else if (arg0->type == SubStringType) {\n SubString *s = (SubString *)arg0;\n buffer = s->buffer;\n len = s->len;\n } else if (arg0->type == SymbolType) {\n return(arg0);\n }\n\n SubString *subStr = malloc_substring();\n subStr->type = SymbolType;\n subStr->len = len;\n subStr->source = arg0;\n subStr->hashVal = 0;\n subStr->buffer = buffer;\n return((Value *)subStr);\n}\n\nValue *symEQ(Value *arg0, Value *arg1) {\n if (arg0->type != arg1->type) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n } else {\n SubString *s1 = (SubString *)arg0;\n SubString *s2 = (SubString *)arg1;\n if (s1->len == s2->len &&\n\tstrncmp(s1->buffer, s2->buffer, s1->len) == 0) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n }\n}\n\nValue *symLT(Value *arg0, Value *arg1) {\n if (arg0->type != arg1->type) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n } else {\n SubString *s0 = (SubString *)arg0;\n SubString *s1 = (SubString *)arg1;\n int64_t len;\n if (s0->len < s1->len)\n len = s0->len;\n else\n len = s1->len;\n\n int cmp = strncmp(s0->buffer, s1->buffer, len);\n if (cmp < 0 || (cmp == 0 && s0->len < s1->len)) {\n dec_and_free(arg1, 1);\n return(maybe((FnArity *)0, (Value *)0, arg0));\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(nothing);\n }\n }\n}\n\nValue *listFilter(Value *arg0, Value *arg1) {\n List *l = (List *)arg0;\n if (l->len == 0) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return((Value *)empty_list);\n } else {\n List *head = empty_list;\n List *tail = empty_list;\n FnArity *arity2;\n if(arg1->type == FunctionType) {\n arity2 = findFnArity(arg1, 1);\n if(arity2 == (FnArity *)0) {\n\tfprintf(stderr, \"\\n*** no arity found for '%s'.\\n\", ((Function *)arg1)->name);\n\tabort();\n }\n }\n for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {\n Value *y;\n incRef(x, 1);\n if(arg1->type != FunctionType) {\n\tincRef(arg1, 1);\n\ty = invoke1Arg((FnArity *)0, arg1, x);\n } else if(arity2->variadic) {\n\tFnType1 *fn4 = (FnType1 *)arity2->fn;\n\tList *varArgs3 = empty_list;\n\tvarArgs3 = (List *)listCons(x, varArgs3);\n\ty = fn4(arity2, (Value *)varArgs3);\n } else {\n\tFnType1 *fn4 = (FnType1 *)arity2->fn;\n\ty = fn4(arity2, x);\n }\n\n // 'y' is the filter maybe/nothing value\n if (!isNothing(y, \"\", 0)) {\n\tincRef(x, 1);\n\tif (head == empty_list) {\n\t // if we haven't started the new list yet\n\t head = malloc_list();\n\t head->len = 1;\n\t head->head = x;\n\t head->tail = empty_list;\n\t tail = head;\n\t} else {\n\t // otherwise, append to tail of list\n\t List *new_tail = malloc_list();\n\t new_tail->len = 1;\n\t new_tail->head = x;\n\t new_tail->tail = empty_list;\n\t tail->tail = new_tail;\n\t tail = new_tail;\n\t head->len++;\n\t}\n }\n dec_and_free(y, 1);\n }\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return((Value *)head);\n }\n}\n\nBitmapIndexedNode *clone_BitmapIndexedNode(BitmapIndexedNode *node, int idx,\n Value *key, Value* val)\n{\n int itemCount = __builtin_popcount(node->bitmap);\n BitmapIndexedNode *newNode = malloc_bmiNode(itemCount);\n newNode->bitmap = node->bitmap;\n for (int i = 0; i < itemCount; i++) {\n if (i == idx) {\n newNode->array[i * 2] = key;\n newNode->array[i * 2 + 1] = val;\n } else {\n if (node->array[i * 2] != (Value *)0) {\n incRef(node->array[i * 2], 1);\n }\n if (node->array[i * 2 + 1] != (Value *)0) {\n incRef(node->array[i * 2 + 1], 1);\n }\n newNode->array[i * 2] = node->array[i * 2];\n newNode->array[i * 2 + 1] = node->array[i * 2 + 1];\n }\n }\n return(newNode);\n}\n\nValue *createNode(int shift,\n\t\t int64_t key1hash, Value *key1, Value *val1,\n\t\t int64_t key2hash, Value *key2, Value *val2)\n{\n if (shift > 60) {\n fprintf(stderr, \"Ran out of shift!!!!!!\");\n abort();\n }\n BitmapIndexedNode *newNode = malloc_bmiNode(2);\n int key1bit = bitpos(key1hash, shift);\n int key2bit = bitpos(key2hash, shift);\n newNode->bitmap = key1bit | key2bit;\n int key1idx = __builtin_popcount(newNode->bitmap & (key1bit - 1));\n int key2idx = __builtin_popcount(newNode->bitmap & (key2bit - 1));\n if (key1bit == key2bit) {\n newNode->array[0] = (Value *)0;\n newNode->array [1] = createNode(shift + 5, key1hash, key1, val1,\n\t\t\t\t key2hash, key2, val2);\n } else {\n newNode->array[key1idx * 2] = key1;\n newNode->array[key1idx * 2 + 1] = val1;\n newNode->array[key2idx * 2] = key2;\n newNode->array[key2idx * 2 + 1] = val2;\n }\n return((Value *)newNode);\n}\n\nValue *bmiHashSeq(Value *arg0, Value *arg1) {\n BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;\n int cnt = __builtin_popcount(node->bitmap);\n List *seq = (List *)arg1;\n for (int i = 0; i < cnt; i++) {\n if (node->array[2 * i] == (Value *)0) {\n seq = (List *)hashSeq((FnArity *)0, incRef(node->array[2 * i + 1], 1), (Value *)seq);\n } else {\n List *pair = listCons(node->array[2 * i], listCons(node->array[2 * i + 1], empty_list));\n incRef(node->array[2 * i], 1);\n incRef(node->array[2 * i + 1], 1);\n seq = listCons((Value *)pair, seq);\n }\n }\n dec_and_free(arg0, 1);\n return((Value *)seq);\n}\n\nValue *bmiHashVec(Value *arg0, Value *arg1) {\n BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;\n int cnt = __builtin_popcount(node->bitmap);\n Vector *vec = (Vector *)arg1;\n for (int i = 0; i < cnt; i++) {\n if (node->array[2 * i] == (Value *)0) {\n vec = (Vector *)hashVec(incRef(node->array[2 * i + 1], 1), (Value *)vec);\n } else {\n incRef(node->array[2 * i], 1);\n incRef(node->array[2 * i + 1], 1);\n Vector *pair = mutateVectConj(empty_vect, node->array[2 * i]);\n pair = mutateVectConj(pair, node->array[2 * i + 1]);\n vec = mutateVectConj(vec, (Value *)pair);\n }\n }\n dec_and_free(arg0, 1);\n return((Value *)vec);\n}\n\nValue *bmiCount(Value *arg0) {\n BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;\n int cnt = __builtin_popcount(((BitmapIndexedNode *)arg0)->bitmap);\n int accum = 0;\n for(int i = 0; i < cnt; i++) {\n if (node->array[i * 2] == (Value *)0 && node->array[i * 2 + 1] != (Value *)0) {\n Integer *subCnt = (Integer *)count((FnArity *)0,\n\t\t\t\t\t incRef(((BitmapIndexedNode *)arg0)->array[i * 2 + 1], 1));\n accum += subCnt->numVal;\n dec_and_free((Value *)subCnt, 1);\n } else {\n accum++;\n }\n }\n dec_and_free(arg0, 1);\n return(integerValue(accum));\n}\n\nValue *bmiCopyAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {\n BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;\n Value *key = arg1;\n Value *val = arg2;\n\n int bit = bitpos(hash, shift);\n int idx = __builtin_popcount(node->bitmap & (bit - 1));\n if (node->bitmap & bit) {\n // if the hash position is already filled\n Value *keyOrNull = node->array[2 * idx];\n Value *valOrNode = node->array[2 * idx + 1];\n if (keyOrNull == (Value *)0) {\n // There is no key in the position, so valOrNode is\n // pointer to a node.\n int newShift = shift + 5;\n Value *n = copyAssoc(incRef(valOrNode, 1), key, val, hash, newShift);\n if (n == valOrNode) {\n // the key was already associated with the value\n // so do nothing\n dec_and_free(n, 1);\n return(arg0);\n } else {\n // clone node and add n to it\n BitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, (Value *)0, n);\n\tdec_and_free(arg0, 1);\n return((Value *)newNode);\n }\n } else if (equal(incRef(key, 1), incRef(keyOrNull, 1))) {\n if (equal(incRef(val, 1), incRef(valOrNode, 1))) {\n dec_and_free(arg1, 1);\n dec_and_free(arg2, 1);\n return(arg0);\n } else {\n // if the keyOrNull points to a value that is equal to key\n // create new hash-map with valOrNode replaced by val\n // clone node and add val to it\n BitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, key, val);\n dec_and_free((Value *)node, 1);\n return((Value *)newNode);\n }\n } else {\n // there is already a key/val pair at the position where key\n // would be placed. Extend tree a level\n int64_t existingKeyHash = nakedSha1(incRef(keyOrNull, 1));\n if (existingKeyHash == hash) {\n // make & return HashCollisionNode\n HashCollisionNode *newLeaf = malloc_hashCollisionNode(2);\n newLeaf->array[0] = keyOrNull;\n newLeaf->array[1] = valOrNode;\n newLeaf->array[2] = key;\n newLeaf->array[3] = val;\n incRef((Value *)keyOrNull, 1);\n incRef((Value *)valOrNode, 1);\n\n BitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, (Value *)0,\n (Value *)newLeaf);\n dec_and_free((Value *)node, 1);\n return((Value *)newNode);\n } else {\n Value *newLeaf = createNode(shift + 5,\n existingKeyHash, incRef(keyOrNull, 1), incRef(valOrNode, 1),\n hash, key, val);\n BitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, (Value *)0, newLeaf);\n dec_and_free((Value *)node, 1);\n return((Value *)newNode);\n }\n }\n } else {\n // the position in the node is empty\n int n = __builtin_popcount(node->bitmap);\n if (n >= 16) {\n ArrayNode *newNode = (ArrayNode *)malloc_arrayNode();\n int jdx = mask(hash, shift);\n int newShift = shift + 5;\n newNode->array[jdx] = copyAssoc((Value *)&emptyBMI, key, val, hash, newShift);\n for (int i = 0, j = 0; i < ARRAY_NODE_LEN; i++) {\n if ((node->bitmap >> i) & 1) {\n if (node->array[j] == (Value *)0) {\n newNode->array[i] = node->array[j + 1];\n incRef(newNode->array[i], 1);\n } else {\n incRef(node->array[j], 2);\n\t newNode->array[i] = copyAssoc((Value *)&emptyBMI,\n\t\t\t\t\t node->array[j],\n\t\t\t\t\t incRef(node->array[j + 1], 1),\n\t\t\t\t\t nakedSha1(node->array[j]),\n\t\t\t\t\t newShift);\n\t }\n\t j += 2;\n\t}\n }\n dec_and_free((Value *)node, 1);\n return((Value *)newNode);\n } else {\n int itemCount = n + 1;\n BitmapIndexedNode *newNode = malloc_bmiNode(itemCount);\n newNode->bitmap = node->bitmap | bit;\n for (int i = 0; i < idx * 2; i++) {\n if (node->array[i] != (Value *)0) {\n incRef(node->array[i], 1);\n }\n newNode->array[i] = node->array[i];\n }\n newNode->array[2 * idx] = key;\n newNode->array[2 * idx + 1] = val;\n for (int i = idx * 2; i < n * 2; i++) {\n if (node->array[i] != (Value *)0) {\n incRef(node->array[i], 1);\n }\n newNode->array[i + 2] = node->array[i];\n }\n dec_and_free((Value *)node, 1);\n return((Value *)newNode);\n }\n }\n}\n\nValue *bmiMutateAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {\n if (arg0->refs != 1) {\n return(bmiCopyAssoc(arg0, arg1, arg2, hash, shift));\n } else {\n BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;\n Value *key = arg1;\n Value *val = arg2;\n\n int bit = bitpos(hash, shift);\n int idx = __builtin_popcount(node->bitmap & (bit - 1));\n if (node->bitmap & bit) {\n // if the hash position is already filled\n Value *keyOrNull = node->array[2 * idx];\n Value *valOrNode = node->array[2 * idx + 1];\n if (keyOrNull == (Value *)0) {\n\t// There is no key in the position, so valOrNode is\n\t// pointer to a node.\n\tValue *n;\n\tn = mutateAssoc(valOrNode, key, val, hash, shift + 5);\n\t// replace key/val at 'idx' with new stuff\n\tnode->array[idx * 2] = (Value *)0;;\n\tnode->array[idx * 2 + 1] = n;\n\treturn(arg0);\n } else if (equal(incRef(key, 1), incRef(keyOrNull, 1))) {\n\tif (equal(incRef(val, 1), incRef(valOrNode, 1))) {\n\t dec_and_free(arg1, 1);\n\t dec_and_free(arg2, 1);\n\t return(arg0);\n\t} else {\n\t // if the keyOrNull points to a value that is equal to key\n\t // replace key/val at 'idx' with new stuff\n\t node->array[idx * 2] = key;\n\t node->array[idx * 2 + 1] = val;\n\t dec_and_free(valOrNode, 1);\n\t dec_and_free(keyOrNull, 1);\n\t return(arg0);\n\t}\n } else {\n\t// there is already a key/val pair at the position where key\n\t// would be placed. Extend tree a level\n\tint64_t existingKeyHash = nakedSha1(incRef(keyOrNull, 1));\n\tif (existingKeyHash == hash) {\n\t // make & return HashCollisionNode\n\t HashCollisionNode *newLeaf = malloc_hashCollisionNode(2);\n\t newLeaf->array[0] = keyOrNull;\n\t newLeaf->array[1] = valOrNode;\n\t newLeaf->array[2] = key;\n\t newLeaf->array[3] = val;\n\n\t // replace key/val at 'idx' with new stuff\n\t node->array[idx * 2] = (Value *)0;\n\t node->array[idx * 2 + 1] = (Value *)newLeaf;\n\t return(arg0);\n\t} else {\n\t Value *newLeaf = createNode(shift + 5,\n\t\t\t\t existingKeyHash, keyOrNull, valOrNode,\n\t\t\t\t hash, key, val);\n\t // replace key/val at 'idx' with new stuff\n\t node->array[idx * 2] = (Value *)0;\n\t node->array[idx * 2 + 1] = (Value *)newLeaf;\n\t return(arg0);\n\t}\n }\n } else {\n // the position in the node is empty\n int n = __builtin_popcount(node->bitmap);\n if (n >= 16) {\n\tArrayNode *newNode = (ArrayNode *)malloc_arrayNode();\n\tint jdx = mask(hash, shift);\n\tint newShift = shift + 5;\n\tnewNode->array[jdx] = copyAssoc((Value *)&emptyBMI, key, val, hash, newShift);\n\tfor (int i = 0, j = 0; i < ARRAY_NODE_LEN; i++) {\n\t if ((node->bitmap >> i) & 1) {\n\t if (node->array[j] == (Value *)0) {\n\t newNode->array[i] = node->array[j + 1];\n\t node->array[j + 1] = (Value *)0;\n\t } else {\n\t incRef(node->array[j], 1);\n\t newNode->array[i] = copyAssoc((Value *)&emptyBMI,\n\t\t\t\t\t node->array[j],\n\t\t\t\t\t node->array[j + 1],\n\t\t\t\t\t nakedSha1(node->array[j]),\n\t\t\t\t\t newShift);\n\t node->array[j] = (Value *)0;\n\t node->array[j + 1] = (Value *)0;\n\t }\n\t j += 2;\n\t }\n\t}\n\tnode->bitmap = 0;\n\tdec_and_free((Value *)node, 1);\n\treturn((Value *)newNode);\n } else {\n\tint itemCount = n + 1;\n\tBitmapIndexedNode *newNode = malloc_bmiNode(itemCount);\n\tnewNode->bitmap = node->bitmap | bit;\n\tfor (int i = 0; i < idx * 2; i++) {\n\t if (node->array[i] != (Value *)0) {\n\t incRef(node->array[i], 1);\n\t }\n\t newNode->array[i] = node->array[i];\n\t}\n\tnewNode->array[2 * idx] = key;\n\tnewNode->array[2 * idx + 1] = val;\n\tfor (int i = idx * 2; i < n * 2; i++) {\n\t if (node->array[i] != (Value *)0) {\n\t incRef(node->array[i], 1);\n\t }\n\t newNode->array[i + 2] = node->array[i];\n\t}\n\tdec_and_free((Value *)node, 1);\n\treturn((Value *)newNode);\n }\n }\n }\n}\n\nValue *bmiGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {\n BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;\n Value *key = arg1;\n\n int bit = bitpos(hash, shift);\n int idx = __builtin_popcount(node->bitmap & (bit - 1));\n if (node->bitmap & bit) {\n // if the hash position is filled\n Value *keyOrNull = node->array[2 * idx];\n Value *valOrNode = node->array[2 * idx + 1];\n if (keyOrNull == (Value *)0) {\n // There is no key in the position, so valOrNode is\n // pointer to a node.\n Value *v = get((FnArity *)0, incRef(valOrNode, 1), key, arg2, hash, shift + 5);\n dec_and_free(arg0, 1);\n return(v);\n } else {\n incRef(keyOrNull, 1);\n if (equal(key, keyOrNull)) {\n\t// found 'key' at this position\n\tincRef(valOrNode, 1);\n\tdec_and_free(arg0, 1);\n\tdec_and_free(arg2, 1);\n\treturn(valOrNode);\n } else {\n\t// there's a key in this position, but doesn't equal 'key'\n\tdec_and_free(arg0, 1);\n\treturn(arg2);\n }\n }\n } else {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(arg2);\n }\n}\n\nValue *bmiDissoc(Value *arg0, Value* arg1, int64_t hash, int shift) {\n BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;\n Value *key = arg1;\n\n int bit = bitpos(hash, shift);\n int idx = __builtin_popcount(node->bitmap & (bit - 1));\n if (node->bitmap & bit) {\n // if the hash position is already filled\n Value *keyOrNull = node->array[2 * idx];\n Value *valOrNode = node->array[2 * idx + 1];\n if (keyOrNull == (Value *)0) {\n // There is no key in the position, so valOrNode is\n // pointer to a node.\n Value *n = baseDissoc(incRef(valOrNode, 1), key, hash, shift + 5);\n if (n == valOrNode) {\n\t// the key was not in the hash-map\n\t// so do nothing\n\tdec_and_free(n, 1);\n\treturn(arg0);\n } else if (n == (Value *)&emptyBMI && __builtin_popcount(node->bitmap) == 1) {\n\t// the subtree is now empty, and this node only points to it, so propagate\n\tdec_and_free(arg0, 1);\n\treturn(n);\n } else {\n\t// clone node and add n to it\n\tBitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, (Value *)0, n);\n\tdec_and_free(arg0, 1);\n\treturn((Value *)newNode);\n }\n } else if (equal(key, incRef(keyOrNull, 1))) {\n // if the keyOrNull points to a value that is equal to key\n if (__builtin_popcount(node->bitmap) == 1) {\n\t// and that is the only entry in this node\n\tdec_and_free(arg0, 1);\n\treturn((Value *)&emptyBMI);\n } else {\n\t// create new hash-map with keyOrNull and valOrNode replaced by (Value *)0\n\tint itemCount = __builtin_popcount(node->bitmap);\n\tBitmapIndexedNode *newNode = malloc_bmiNode(itemCount - 1);\n\tnewNode->bitmap = node->bitmap;\n int i, j;\n for (i = 0, j = 0; i < itemCount; i++) {\n if (i != idx) {\n if (node->array[i * 2] != (Value *)0) {\n incRef(node->array[i * 2], 1);\n }\n if (node->array[i * 2 + 1] != (Value *)0) {\n incRef(node->array[i * 2 + 1], 1);\n }\n newNode->array[j * 2] = node->array[i * 2];\n newNode->array[j * 2 + 1] = node->array[i * 2 + 1];\n j++;\n }\n }\n newNode->bitmap &= ~bit;\n dec_and_free(arg0, 1);\n return((Value *)newNode);\n }\n } else {\n // there is already a key/val pair at the position where key\n // would be. Do nothing\n return(arg0);\n }\n } else {\n // the position in the node is empty, do nothing\n dec_and_free(arg1, 1);\n return(arg0);\n }\n}\n\nValue *arrayNodeCopyAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {\n ArrayNode *node = (ArrayNode *)arg0;\n Value *key = arg1;\n Value *val = arg2;\n int idx = mask(hash, shift);\n int newShift = shift + 5;\n ArrayNode *newNode;\n\n Value *subNode = node->array[idx];\n int64_t keyHash = nakedSha1(incRef(key, 1));\n if (subNode == (Value *)0) {\n newNode = (ArrayNode *)malloc_arrayNode();\n for (int i = 0; i < ARRAY_NODE_LEN; i++) {\n if (node->array[i] != (Value *)0) {\n\tnewNode->array[i] = node->array[i];\n\tincRef(newNode->array[i], 1);\n }\n }\n newNode->array[idx] = copyAssoc((Value *)&emptyBMI, key, val, keyHash, newShift);\n } else {\n Value *n = copyAssoc(incRef(subNode, 1), key, val, keyHash, newShift);\n if (n == subNode) {\n dec_and_free(n, 1);\n return((Value *)node);\n } else {\n newNode = (ArrayNode *)malloc_arrayNode();\n for (int i = 0; i < ARRAY_NODE_LEN; i++) {\n\tif (i != idx && node->array[i] != (Value *)0) {\n\t newNode->array[i] = node->array[i];\n\t incRef(newNode->array[i], 1);\n\t}\n }\n newNode->array[idx] = n;\n }\n }\n dec_and_free((Value *)node, 1);\n return((Value *)newNode);\n}\n\nValue *arrayNodeMutateAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {\n if (arg0->refs != 1) {\n return(arrayNodeCopyAssoc(arg0, arg1, arg2, hash, shift));\n } else {\n ArrayNode *node = (ArrayNode *)arg0;\n Value *key = arg1;\n Value *val = arg2;\n int idx = mask(hash, shift);\n\n Value *subNode = node->array[idx];\n int64_t keyHash = nakedSha1(incRef(key, 1));\n if (subNode == (Value *)0) {\n node->array[idx] = copyAssoc((Value *)&emptyBMI, key, val, keyHash, shift + 5);\n } else {\n Value *n = mutateAssoc(subNode, key, val, keyHash, shift + 5);\n node->array[idx] = n;\n }\n return((Value *)node);\n }\n}\n\nValue *collisionAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {\n HashCollisionNode *node = (HashCollisionNode *)arg0;\n Value *key = arg1;\n Value *val = arg2;\n int itemCount = node->count / 2;\n\n if(nakedSha1(incRef(node->array[0], 1)) == hash) {\n HashCollisionNode *newNode = malloc_hashCollisionNode(itemCount + 1);\n for (int i = 0; i < itemCount; i++) {\n if (equal(incRef(key, 1), incRef(node->array[2 * i], 1))) {\n\tnewNode->array[2 * i] = key;\n\tnewNode->array[2 * i + 1] = val;\n\tnewNode->count -= 2;\n } else {\n\tnewNode->array[2 * i] = node->array[2 * i];\n\tnewNode->array[2 * i + 1] = node->array[2 * i + 1];\n\tincRef(node->array[2 * i], 1);\n\tincRef(node->array[2 * i + 1], 1);\n }\n }\n if (newNode->count / 2 != itemCount) {\n newNode->array[2 * itemCount] = key;\n newNode->array[2 * itemCount + 1] = val;\n }\n dec_and_free(arg0, 1);\n return((Value *)newNode);\n } else {\n BitmapIndexedNode * bmi = (BitmapIndexedNode *)copyAssoc((Value *)&emptyBMI,\n\t\t\t\t\t\t\t key, val, hash, 0);\n for (int i = 0; i < itemCount; i++) {\n bmi = (BitmapIndexedNode *)mutateAssoc((Value *)bmi,\n\t\t\t\t\t incRef(node->array[2 * i], 1),\n\t\t\t\t\t incRef(node->array[2 * i + 1], 1),\n\t\t\t\t\t nakedSha1(incRef(node->array[2 * i], 1)), 0);\n }\n dec_and_free(arg0, 1);\n return((Value *)bmi);\n }\n}\n\nValue notFound = {0, -2};\nValue *notFoundPtr = ¬Found;\n\nValue *arrayNodeGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {\n ArrayNode *node = (ArrayNode *)arg0;\n Value *key = arg1;\n Value *notFound = arg2;\n int idx = mask(hash, shift);\n\n Value *subNode = node->array[idx];\n if (subNode == (Value *)0) {\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(notFound);\n } else {\n incRef(subNode, 1);\n dec_and_free(arg0, 1);\n return(get((FnArity *)0, subNode, key, notFound, hash, shift + 5));\n }\n}\n\nValue *arrayNodeCount(Value *arg0) {\n int accum = 0;\n for(int i = 0; i < ARRAY_NODE_LEN; i++){\n if (((ArrayNode *)arg0)->array[i] != (Value *)0) {\n Integer *subCnt = (Integer *)count((FnArity *)0, incRef(((ArrayNode *)arg0)->array[i], 1));\n accum += subCnt->numVal;\n dec_and_free((Value *)subCnt, 1);\n }\n }\n dec_and_free(arg0, 1);\n return(integerValue(accum));\n}\n\nValue *collisionCount(Value *arg0) {\n Value *result = integerValue(((HashCollisionNode *) arg0)->count / 2);\n dec_and_free(arg0, 1);\n return(result);\n}\n\nValue *collisionSeq(Value *arg0, Value *arg1) {\n HashCollisionNode *node = (HashCollisionNode *)arg0;\n List *seq = (List *)arg1;\n for (int i = 0; i < node->count / 2; i++) {\n if (node->array[2 * i] != (Value *)0 && node->array[2 * i + 1] != (Value *)0) {\n List *pair = listCons(node->array[2 * i], listCons(node->array[2 * i + 1], empty_list));\n incRef(node->array[2 * i], 1);\n incRef(node->array[2 * i + 1], 1);\n seq = listCons((Value *)pair, seq);\n }\n }\n dec_and_free(arg0, 1);\n return((Value *)seq);\n}\n\nValue *collisionVec(Value *arg0, Value *arg1) {\n HashCollisionNode *node = (HashCollisionNode *)arg0;\n Vector *vec = (Vector *)arg1;\n // TODO: remove\nfprintf(stderr, \"collisionNodeVec\\n\");\n for (int i = 0; i < node->count / 2; i++) {\n if (node->array[2 * i] != (Value *)0 && node->array[2 * i + 1] != (Value *)0) {\n incRef(node->array[2 * i], 1);\n incRef(node->array[2 * i + 1], 1);\n Vector *pair = mutateVectConj(empty_vect, node->array[2 * i]);\n pair = mutateVectConj(pair, node->array[2 * i + 1]);\n vec = mutateVectConj(vec, (Value *)pair);\n }\n }\n dec_and_free(arg0, 1);\n return((Value *)vec);\n}\n\nValue *collisionDissoc(Value *arg0, Value *arg1, int64_t hash, int shift) {\n HashCollisionNode *node = (HashCollisionNode *)arg0;\n Value *key = arg1;\n HashCollisionNode *newNode;\n int itemCount = node->count / 2;\n\n if(itemCount == 1) {\n if(equal(key, incRef(node->array[0], 1))) {\n dec_and_free(arg0, 1);\n return((Value *)&emptyBMI);\n } else {\n return(arg0);\n }\n } else {\n int keyIdx = -1;\n int i = 0;\n do {\n keyIdx = i;\n i++;\n } while (i < itemCount && !equal(incRef(key, 1), incRef(node->array[2 * i], 1)));\n\n if(keyIdx >= 0) {\n newNode = malloc_hashCollisionNode(itemCount - 1);\n for (int i = 0, j = 0; i < itemCount; i++) {\n if (i != keyIdx) {\n newNode->array[j * 2] = node->array[i * 2];\n newNode->array[j * 2 + 1] = node->array[i * 2 + 1];\n incRef(newNode->array[j * 2], 1);\n incRef(newNode->array[j * 2 + 1], 1);\n j++;\n }\n }\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return((Value *)newNode);\n }\n }\n return(arg0);\n}\n\nValue *collisionGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {\n HashCollisionNode *node = (HashCollisionNode *)arg0;\n for (int i = 0; i < node->count / 2; i++) {\n if (node->array[2 * i] != (Value *)0 && equal(incRef(arg1, 1),\n\t\t\t\t\t\t incRef(node->array[2 * i], 1))) {\n if (node->array[2 * i + 1] != (Value *)0) {\n\tincRef(node->array[2 * i + 1], 1);\n\tdec_and_free(arg0, 1);\n\tdec_and_free(arg1, 1);\n\tdec_and_free(arg2, 1);\n\treturn(node->array[2 * i + 1]);\n } else {\nfprintf(stderr, \"Trying to get an invalid value from a CollisionNode of a hash-map. This should never happen!!!\");\nabort();\n\tdec_and_free(arg0, 1);\n\tdec_and_free(arg1, 1);\n\treturn(arg2);\n }\n }\n }\n dec_and_free(arg0, 1);\n dec_and_free(arg1, 1);\n return(arg2);\n}\n\nValue *arrayNodeSeq(Value *arg0, Value *arg1) {\n ArrayNode *node = (ArrayNode *)arg0;\n List *seq = (List *)arg1;\n for (int i = 0; i < ARRAY_NODE_LEN; i++) {\n if (node->array[i] != (Value *)0) {\n incRef(node->array[i], 1);\n seq = (List *)hashSeq((FnArity *)0, node->array[i], (Value *)seq);\n }\n }\n dec_and_free(arg0, 1);\n return((Value *)seq);\n}\n\nValue *arrayNodeVec(Value *arg0, Value *arg1) {\n ArrayNode *node = (ArrayNode *)arg0;\n Vector *vec = (Vector *)arg1;\n for (int i = 0; i < ARRAY_NODE_LEN; i++) {\n if (node->array[i] != (Value *)0) {\n incRef(node->array[i], 1);\n vec = (Vector *)hashVec(node->array[i], (Value *)vec);\n }\n }\n dec_and_free(arg0, 1);\n return((Value *)vec);\n}\n\nValue *arrayNodeDissoc(Value *arg0, Value *arg1, int64_t hash, int shift) {\n ArrayNode *node = (ArrayNode *)arg0;\n Value *key = arg1;\n int idx = mask(hash, shift);\n ArrayNode *newNode;\n\n Value *subNode = node->array[idx];\n if (subNode == (Value *)0) {\n // do nothing\n dec_and_free(arg1, 1);\n return(arg0);\n } else {\n int64_t hash = nakedSha1(incRef(key, 1));\n Value *n = baseDissoc(incRef(subNode, 1), key, hash, shift + 5);\n newNode = (ArrayNode *)malloc_arrayNode();\n for (int i = 0; i < ARRAY_NODE_LEN; i++) {\n if (i != idx && node->array[i] != (Value *)0) {\n newNode->array[i] = node->array[i];\n incRef(newNode->array[i], 1);\n }\n }\n newNode->array[idx] = n;\n dec_and_free(arg0, 1);\n }\n return((Value *)newNode);\n}\n\nValue *get(FnArity *arity, Value *node, Value *k, Value *v, int64_t hash, int shift) {\n switch(node->type) {\n case BitmapIndexedType:\n return(bmiGet(node, k, v, hash, shift));\n case ArrayNodeType:\n return(arrayNodeGet(node, k, v, hash, shift));\n case HashCollisionNodeType:\n return(collisionGet(node, k, v, hash, shift));\n default:\n fprintf(stderr, \"Can't get from that kind of node\\n\");\n abort();\n }\n}\n\nValue *baseDissoc(Value *node, Value *k, int64_t hash, int shift) {\n switch(node->type) {\n case BitmapIndexedType:\n return(bmiDissoc(node, k, hash, shift));\n case ArrayNodeType:\n return(arrayNodeDissoc(node, k, hash, shift));\n case HashCollisionNodeType:\n return(collisionDissoc(node, k, hash, shift));\n default:\n fprintf(stderr, \"Can't dissoc from that kind of node\\n\");\n abort();\n }\n}\n\nValue *hashVec(Value *node, Value *vec) {\n switch(node->type) {\n case BitmapIndexedType:\n return(bmiHashVec(node, vec));\n case ArrayNodeType:\n return(arrayNodeVec(node, vec));\n case HashCollisionNodeType:\n return(collisionVec(node, vec));\n default:\n fprintf(stderr, \"Can't assoc into that kind of node\\n\");\n abort();\n }\n}\n\nValue *copyAssoc(Value *node, Value *k, Value *v, int64_t hash, int shift) {\n switch(node->type) {\n case BitmapIndexedType:\n return(bmiCopyAssoc(node, k, v, hash, shift));\n case ArrayNodeType:\n return(arrayNodeCopyAssoc(node, k, v, hash, shift));\n case HashCollisionNodeType:\n return(collisionAssoc(node, k, v, hash, shift));\n default:\n fprintf(stderr, \"Can't assoc into that kind of node\\n\");\n abort();\n }\n}\n\nValue *mutateAssoc(Value *node, Value *k, Value *v, int64_t hash, int shift) {\n switch(node->type) {\n case BitmapIndexedType:\n return(bmiMutateAssoc(node, k, v, hash, shift));\n case ArrayNodeType:\n return(arrayNodeMutateAssoc(node, k, v, hash, shift));\n /*\n case HashCollisionNodeType:\n return(collisionAssoc(node, k, v, hash, shift));\n // */\n default:\n return(copyAssoc(node, k, v, hash, shift));\n }\n}\n\nValue *hashMapGet(Value *arg0, Value *arg1) {\n int64_t hash = nakedSha1(incRef(arg1, 1));\n Value *found = get((FnArity *)0, arg0, arg1, notFoundPtr, hash, 0);\n if (found == notFoundPtr) {\n return(nothing);\n } else {\n return(maybe((FnArity *)0, (Value *)0, found));\n }\n}\n\n// used for static encoding hash maps and other things\nValue *hashMapAssoc(Value *arg0, Value *arg1, Value *arg2) {\n int64_t hash = nakedSha1(incRef(arg1, 1));\n return(mutateAssoc(arg0, arg1, arg2, hash, 0));\n}\n\nValue *dynamicCall1Arg(Value *f, Value *arg) {\n Value *rslt;\n if(f->type != FunctionType) {\n rslt = invoke1Arg((FnArity *)0, f, arg);\n } else {\n FnArity *arity = findFnArity(f, 1);\n if(arity != (FnArity *)0 && !arity->variadic) {\n FnType1 *fn = (FnType1 *)arity->fn;\n rslt = fn(arity, arg);\n } else if(arity != (FnArity *)0 && arity->variadic) {\n FnType1 *fn = (FnType1 *)arity->fn;\n List *dynArgs = empty_list;\n dynArgs = (List *)listCons(arg, dynArgs);\n rslt = fn(arity, (Value *)dynArgs);\n } else {\n fprintf(stderr, \"\\n*** Invalid action for Promise.\\n\");\n abort();\n }\n dec_and_free(f, 1);\n }\n return(rslt);\n}\n\nValue *addPromiseAction(Promise *p, Value *action) {\n pthread_mutex_lock(&p->access);\n if (p->result == (Value *)0) {\n List *newList = malloc_list();\n newList->head = (Value *)action;\n List *actions;\n#ifdef SINGLE_THREADED\n actions = p->actions;\n newList->len = actions->len + 1;\n newList->tail = actions;\n p->actions = newList;\n#else\n __atomic_load(&p->actions, &actions, __ATOMIC_RELAXED);\n do {\n if (actions != (List *)0) {\n\tnewList->len = actions->len + 1;\n\tnewList->tail = actions;\n } else {\n\tnewList->len = 1;\n\tnewList->tail = empty_list;\n }\n } while (!__atomic_compare_exchange((List **)&p->actions, (List **)&actions, (List **)&newList,\n\t\t\t\t\t1, __ATOMIC_RELAXED, __ATOMIC_RELAXED));\n#endif\n pthread_mutex_unlock(&p->access);\n } else {\n pthread_mutex_unlock(&p->access);\n incRef(p->result, 1);\n Value *trash = dynamicCall1Arg(action, p->result);\n dec_and_free(trash, 1);\n }\n return((Value *)p);\n}\n\nValue *deliverPromise(Value *arg0, Value *arg1) {\n Promise *p = (Promise *)arg0;\n if (p->result == (Value *)0) {\n pthread_mutex_lock(&p->access);\n if (p->result == (Value *)0) {\n p->result = arg1;\n pthread_cond_broadcast(&p->delivered);\n }\n List *l = p->actions;\n List *head = l;\n p->actions = (List *)0;\n pthread_mutex_unlock(&p->access);\n\n // perform actions\n if (l != (List *)0 && l->len != 0) {\n for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {\n\tincRef(x, 1);\n\tincRef(arg1, 1);\n\tValue *trash = dynamicCall1Arg(x, arg1);\n\tdec_and_free(trash, 1);\n }\n }\n dec_and_free((Value *)head, 1);\n } else {\n dec_and_free(arg1, 1);\n }\n return(arg0);\n}\n\nValue *extractPromise(Value *arg0) {\n Promise *p = (Promise *)arg0;\n while (p->result == (Value *)0) {\n pthread_mutex_lock (&p->access);\n if (p->result == (Value *)0) {\n#ifdef SINGLE_THREADED\n runningWorkers--;\n int rw = runningWorkers;\n#else\n int rw = __atomic_fetch_sub(&runningWorkers, 1, __ATOMIC_ACQ_REL);\n#endif\n replaceWorker();\n pthread_cond_wait(&p->delivered, &p->access);\n#ifdef SINGLE_THREADED\n runningWorkers++;\n#else\n __atomic_fetch_add(&runningWorkers, 1, __ATOMIC_ACQ_REL);\n#endif\n }\n pthread_mutex_unlock (&p->access);\n }\n Value *result = p->result;\n incRef(result, 1);\n dec_and_free(arg0, 1);\n return(result);\n}\n\nValue *promiseDelivered(Value *arg0) {\n Promise *p = (Promise *)arg0;\n if(p->result == (Value *)0) {\n dec_and_free(arg0, 1);\n return(nothing);\n } else {\n Value *mv = maybe((FnArity *)0, (Value *)0, p->result);\n incRef(p->result, 1);\n dec_and_free(arg0, 1);\n return((Value *)mv);\n }\n}\n\nValue *extractFuture(Value *arg0) {\n Future *f = (Future *)arg0;\n while (f->result == (Value *)0) {\n pthread_mutex_lock (&f->access);\n if (f->result == (Value *)0) {\n#ifdef SINGLE_THREADED\n runningWorkers--;\n#else\n __atomic_fetch_sub(&runningWorkers, 1, __ATOMIC_ACQ_REL);\n#endif\n replaceWorker();\n pthread_cond_wait(&f->delivered, &f->access);\n#ifdef SINGLE_THREADED\n runningWorkers++;\n#else\n __atomic_fetch_add(&runningWorkers, 1, __ATOMIC_ACQ_REL);\n#endif\n }\n pthread_mutex_unlock (&f->access);\n }\n Value *result = f->result;\n incRef(result, 1);\n dec_and_free((Value *)f, 1);\n return(result);\n}\n\nValue *makeFuture(Value *arg0) {\n Future *f = malloc_future(__LINE__);\n f->action = arg0;\n if (arg0 != (Value *)0) {\n incRef((Value *)f, 1);\n scheduleFuture(f);\n }\n return((Value *)f);\n}\n\nValue *addFutureAction(Future *p, Value *action) {\n pthread_mutex_lock(&p->access);\n if (p->result == (Value *)0) {\n List *newList = malloc_list();\n newList->head = (Value *)action;\n List *actions;\n#ifdef SINGLE_THREADED\n actions = p->actions;\n if (actions != (List *)0) {\n newList->len = actions->len + 1;\n newList->tail = actions;\n } else {\n newList->len = 1;\n newList->tail = empty_list;\n }\n p->actions = newList;\n#else\n __atomic_load(&p->actions, &actions, __ATOMIC_RELAXED);\n do {\n if (actions != (List *)0) {\n\tnewList->len = actions->len + 1;\n\tnewList->tail = actions;\n } else {\n\tnewList->len = 1;\n\tnewList->tail = empty_list;\n }\n } while (!__atomic_compare_exchange((List **)&p->actions, (List **)&actions, (List **)&newList, 1,\n\t\t\t\t\t__ATOMIC_RELAXED, __ATOMIC_RELAXED));\n#endif\n pthread_mutex_unlock(&p->access);\n } else {\n pthread_mutex_unlock(&p->access);\n incRef(p->result, 1);\n Value *trash = dynamicCall1Arg(action, p->result);\n dec_and_free(trash, 1);\n }\n return((Value *)p);\n}\n\nValue *makeAgent(Value *arg0) {\n Agent *a = (Agent *)my_malloc(sizeof(Agent));\n // incTypeMalloc(AgentType, 1);\n a->type = AgentType;\n#ifdef SINGLE_THREADED\n a->refs = refsInit;\n#else\n __atomic_store(&a->refs, &refsInit, __ATOMIC_RELAXED);\n#endif\n a->input = empty_list;\n a->output = empty_list;\n pthread_mutex_init(&a->access, NULL);\n a->val = arg0;\n return((Value *)a);\n}\n\nValue *extractAgent(Value *arg0) {\n pthread_mutex_lock (&((Agent *)arg0)->access);\n Value *v = ((Agent *)arg0)->val;\n incRef(v, 1);\n pthread_mutex_unlock (&((Agent *)arg0)->access);\n dec_and_free(arg0, 1);\n return(v);\n}\n\nList *readAgentQueue(Agent *agent) {\n List *output = agent->output;\n if (output != (List *)0 && output->len != 0) {\n // if there was an item in the queue, return it\n Value *item = output->head;\n agent->output = output->tail;\n output->head = (Value *)0;\n output->tail = (List *)0;\n REFS_SIZE refs;\n#ifdef SINGLE_THREADED\n refs = output->refs;\n#else\n __atomic_load(&output->refs, &refs, __ATOMIC_RELAXED);\n#endif\n if (refs != 1) {\n fprintf(stderr, \"failure in readAgentQueue()\\n\");\n abort();\n }\n dec_and_free((Value *)output, 1);\n return((List *)item);\n } else {\n // move the input list to the output\n // atomically get the input list and reset it to empty_list\n List *input;\n#ifdef SINGLE_THREADED\n input = agent->input;\n agent->input = empty_list;\n#else\n __atomic_exchange((List **)&agent->input,\n\t\t (List **)&empty_list,\n\t\t (List **)&input,\n\t\t __ATOMIC_RELAXED);\n#endif\n\n if (input == (List *)0 || input->len == 0) {\n // if the input was empty, return 0\n agent->output = input;\n return((List *)0);\n } else {\n // otherwise, move the input list to the output\n agent->output = reverseList(input);\n return(readAgentQueue(agent));\n }\n }\n}\n\nValue *updateAgent_impl(FnArity *arity) {\n Agent *agent = (Agent *)(arity->closures)->tail[0];\n if (pthread_mutex_trylock (&agent->access) == 0) { // succeeded\n List *action = readAgentQueue(agent);\n while(action != (List *)0) {\n Value *f = (Value *)action->head;\n List *args = listCons(agent->val, action->tail);\n incRef((Value *)action->tail, 1);\n agent->val = fn_apply((FnArity *)0, incRef((Value *)f, 1), (Value *)args);\n dec_and_free((Value *)action, 1);\n action = readAgentQueue(agent);\n }\n pthread_mutex_unlock (&agent->access);\n }\n return(nothing);\n};\n\nvoid scheduleAgent(Agent *agent, List *action) {\n#ifdef SINGLE_THREADED\n Value *f = (Value *)action->head;\n incRef((Value *)agent->val, 1);\n List *args = listCons(agent->val, action->tail);\n incRef((Value *)action->tail, 1);\n agent->val = fn_apply((FnArity *)0, (Value *)f, (Value *)args);\n action->head = (Value *)0;\n dec_and_free((Value *)action, 1);\n#else\n List *newList = malloc_list();\n newList->head = (Value *)action;\n List *input;\n __atomic_load(&agent->input, &input, __ATOMIC_RELAXED);\n do {\n newList->len = input->len + 1;\n newList->tail = input;\n } while (!__atomic_compare_exchange(&agent->input, &input, &newList, 1, __ATOMIC_RELAXED, __ATOMIC_RELAXED));\n\n FnArity *updateAgentArity = malloc_fnArity();\n updateAgentArity->variadic = 0;\n updateAgentArity->fn = updateAgent_impl;\n updateAgentArity->count = 0;\n incRef((Value *)agent, 1);\n updateAgentArity->closures = mutateVectConj(empty_vect, (Value *)agent);\n Function *updateAgentFn = malloc_function(1);\n updateAgentFn->name = \"update-agent\";\n updateAgentFn->arityCount = 1;\n updateAgentFn->arities[0] = updateAgentArity;\n Future *f = malloc_future(__LINE__);\n f->action = (Value *)updateAgentFn;\n f->actions = empty_list;\n scheduleFuture(f);\n#endif\n}\n\nvoid freeExtractCache(void *cachePtr) {\n extractCache *cacheTail = (extractCache *)cachePtr;\n if (cacheTail != (extractCache *)0) {\n dec_and_free((Value *)cacheTail->tail, 1);\n if (!cleaningUp)\n free(cacheTail);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n // incTypeFree(14, 1);\n#endif\n }\n}\n\nvoid freeIntGenerator(void *ptr) {\n if (ptr != (void *)0) {\n if (!cleaningUp)\n free(ptr);\n#ifdef CHECK_MEM_LEAK\n __atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);\n // incTypeFree(14, 1);\n#endif\n }\n}\n\nString *nullTerm(Value *s) {\n String *arg0Str = malloc_string(((String *)s)->len);\n if (s->type == StringBufferType)\n snprintf(arg0Str->buffer, ((String *)s)->len + 1, \"%s\", ((String *)s)->buffer);\n else if (s->type == SubStringType)\n snprintf(arg0Str->buffer, ((String *)s)->len + 1, \"%s\", ((SubString *)s)->buffer);\n dec_and_free(s, 1);\n return(arg0Str);\n}\n\nvoid show(Value *v) {\n if (v == (Value *)0) {\n fprintf(stderr, \"Null\\n\");\n return;\n }\n if (v->refs == refsError) {\n fprintf(stderr, \"has been freed\\n\");\n return;\n }\n incRef(v, 1);\n List *strings = (List *)showFn((FnArity *)0, v);\n List *l = strings;\n for (Value *h = l->head; l != (List *)0 && h != (Value *)0; h = l->head) {\n incRef(h, 1);\n prErrSTAR(h);\n l = l->tail;\n }\n fprintf(stderr, \"\\n\");\n dec_and_free((Value *)strings, 1);\n return;\n}\n\nint64_t countSeq(Value *seq) {\n Integer *len = (Integer *)count((FnArity *)0, seq);\n int64_t result = len->numVal;\n dec_and_free((Value *)len, 1);\n return(result);\n}\n\nValue *reifiedTypeArgs(Value *x) {\n if (x->type < CoreTypeCount) {\n dec_and_free(x, 1);\n return((Value *)empty_vect);\n } else {\n Vector *typeArgs = empty_vect;\n ReifiedVal *rv = (ReifiedVal *)x;\n for (int i = 0; i < rv->implCount; i++) {\n if (rv->impls[i] != (Value *)0) {\n\ttypeArgs = mutateVectConj(typeArgs, incRef(rv->impls[i], 1));\n }\n }\n dec_and_free(x, 1);\n return((Value *)typeArgs);\n }\n}\n\nVector *listVec(Value *list) {\n List *l = (List *)list;\n Vector *newVect = empty_vect;\n for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {\n newVect = mutateVectConj(newVect, incRef(x, 1));\n }\n dec_and_free(list, 1);\n return(newVect);\n}\n\nValue *newTypeValue(int typeNum, Vector *fields) {\n Vector *vect ;\n if (fields->type == ListType) {\n incRef((Value *)fields, 1);\n vect = (Vector *)listVec((Value *)fields);\n }\n else {\n vect = fields;\n }\n ReifiedVal *rv = malloc_reified(vect->count);\n rv->type = typeNum;\n for (int i = 0; i < vect->count; i++) {\n rv->impls[i] = vect->tail[i];\n vect->tail[i] = (Value *)0;\n }\n#ifdef SINGLE_THREADED\n rv->refs = refsInit;\n#else\n __atomic_store(&rv->refs, &refsInit, __ATOMIC_RELAXED);\n#endif\n dec_and_free((Value *)fields, 1);\n return((Value *)rv);\n}\n" }, { "path": "core.h", "content": "\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n\n#define CLOSURE_INFO 1\n\nextern void abort();\n\n#define VECTOR_ARRAY_LEN 32\n#define ARRAY_NODE_LEN 32\n\n#ifdef TOCCATA_WASM\n#define SINGLE_THREADED 1\n#endif\n\n#ifndef TYPE_SIZE\n#define TYPE_SIZE int64_t\n#endif\n\n#ifndef REFS_SIZE\n#define REFS_SIZE int32_t\n#endif\n\ntypedef struct\n{\n uint32_t State[5];\n uint32_t Count[2];\n uint8_t Buffer[64];\n } Sha1Context;\n\ntypedef void (Destructor)(void *);\n// TODO: add hash cache and meta data. And update 'make-static-*' as well\ntypedef struct Value {TYPE_SIZE type; REFS_SIZE refs; struct Value* next;} Value;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t numVal;} Integer;\ntypedef struct HashedValue {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal;} HashedValue;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int64_t len; char buffer[0];} String;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int64_t len; Value *source; char *buffer;} SubString;\ntypedef struct List {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal;\n int64_t len; Value* head; struct List *tail;} List;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; Value *array[VECTOR_ARRAY_LEN];} VectorNode;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int32_t count; int8_t shift; int64_t tailOffset;\n VectorNode *root; Value *tail[VECTOR_ARRAY_LEN];} Vector;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int count; Vector *closures; Value *parent;\n int variadic; void *fn; Value *paramConstraints; Value *resultConstraint;} FnArity;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; char *name; int64_t arityCount; FnArity *arities[];} Function;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; Value* value;} Maybe;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int32_t bitmap; Value *array[];} BitmapIndexedNode;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; Value *array[ARRAY_NODE_LEN];} ArrayNode;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int16_t count; Value *array[];} HashCollisionNode;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; Value *result; List *actions;\n pthread_cond_t delivered; pthread_mutex_t access;} Promise;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; Value *action; Value* errorCallback; List *actions;\n Value *result; pthread_cond_t delivered; pthread_mutex_t access;} Future;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; Value *val; List* input; List *output;\n pthread_mutex_t access;} Agent;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int64_t implCount; Value* impls[];} ReifiedVal;\ntypedef struct {TYPE_SIZE type; REFS_SIZE refs; void *ptr; Destructor *destruct;} Opaque;\n\nInteger const0;\nValue *const0Ptr;\n\ntypedef struct {TYPE_SIZE type; Value *implFn;} ProtoImpl;\ntypedef struct {int64_t implCount; ProtoImpl impls[];} ProtoImpls;\n\ntypedef Value *(FnType0)(FnArity *);\ntypedef Value *(FnType1)(FnArity *, Value *);\ntypedef Value *(FnType2)(FnArity *, Value *, Value *);\ntypedef Value *(FnType3)(FnArity *, Value *, Value *, Value *);\ntypedef Value *(FnType4)(FnArity *, Value *, Value *, Value *, Value *);\ntypedef Value *(FnType5)(FnArity *, Value *, Value *, Value *, Value *, Value *);\ntypedef Value *(FnType6)(FnArity *, Value *, Value *, Value *, Value *, Value *, Value *);\ntypedef Value *(FnType7)(FnArity *, Value *, Value *, Value *, Value *, Value *, Value *, Value *);\ntypedef Value *(FnType8)(FnArity *, Value *, Value *, Value *, Value *, Value *, Value *, Value *, Value *);\ntypedef Value *(FnType9)(FnArity *, Value *, Value *, Value *, Value *, Value *, Value *, Value *, Value *, Value *);\n\ntypedef struct {\n List *tail;\n pthread_mutex_t access;} extractCache;\n\ntypedef struct {\n int64_t sym_counter;} intGenerator;\n\nValue *nothing;\nMaybe nothing_struct;\nValue *maybeNothing;\nREFS_SIZE refsInit;\nREFS_SIZE refsError;\nREFS_SIZE refsStatic;\n\n#define IgnoreType -1\n#define UnknownType 0\n#define IntegerType 1\n#define StringBufferType 2\n#define FnArityType 3\n#define FunctionType 4\n#define SubStringType 5\n#define ListType 6\n#define MaybeType 7\n#define VectorType 8\n#define VectorNodeType 9\n#define SymbolType 10\n#define BitmapIndexedType 11\n#define ArrayNodeType 12\n#define HashCollisionNodeType 13\n#define HashMapType 14\n#define PromiseType 15\n#define FutureType 16\n#define AgentType 17\n#define OpaqueType 18\n#define FloatType 19\n#define CoreTypeCount 20\n#define TypeConstraintType 21\n#define NoValuesType 22\n#define AllValuesType 23\n#define MultiConstraintType 24\n#define ResultConstraintType 25\n#define ItemsConstraintType 26\n#define FieldConstraintType 27\n#define StaticIntConstraintType 28\n#define MinValueType 29\n#define MaxValueType 30\n#define InferredInnerType 31\n#define StaticLengthConstraintType 32\n#define StaticStrConstraintType 33\n#define ContentsConstraintType 34\n#define HashSetType 35\n#define ProtoDispatcherType 36\n#define SumConstraintType 37\n#define KeysConstraintType 38\n#define TypeCount 39\n\nFILE *outstream;\nList *empty_list;\nList empty_list_struct;\nVector *empty_vect;\nVector empty_vect_struct;\nBitmapIndexedNode emptyBMI;\nValue *universalProtoFn;\nint typeCount;\n\nReifiedVal all_values_struct;\nValue *all_values;\n\nstruct {List* input; List* output;\n pthread_mutex_t mutex; pthread_cond_t notEmpty;} futuresQueue;\nFuture shutDown;\nint8_t mainThreadDone;\n\nint cleaningUp;\n\nint64_t malloc_count;\nint64_t free_count;\nvoid cleanupMemory(Value *the_final_answer, Value *maybeNothing, List *argList);\nvoid freeAll();\nvoid freeGlobal(Value *x);\n\n#ifndef FAST_INCS\nValue *incRef(Value *v, int deltaRefs);\n#else\nValue *simpleIncRef(Value *v, int n);\n#define incRef(V, N) ((V)->refs >= 0 ? simpleIncRef(V, N) : V)\n#endif\n\nvoid dec_and_free(Value *v, int deltaRefs);\n\nvoid prefs(char *tag, Value *v);\n\nValue *(*equalSTAR)(FnArity *, Value *, Value *);\nValue *(*dissoc)(FnArity *, Value *, Value *, Value *, Value *);\nValue *(*sha1)(FnArity *, Value *);\nValue *(*hashSeq)(FnArity *, Value*, Value *s);\nValue *(*count)(FnArity *, Value*);\nValue *(*vals)(FnArity *, Value*);\nValue *(*zero)(FnArity *, Value*);\nValue *(*invoke0Args)(FnArity *, Value *f);\nValue *(*invoke1Arg)(FnArity *, Value *f, Value* arg);\nValue *(*invoke2Args)(FnArity *, Value *f, Value* arg0, Value* arg1);\nValue *(*type_name)(FnArity *, Value *t);\nValue *(*seq)(FnArity *, Value *t);\nValue *(*newHashSet)(FnArity *, Value *t);\nValue *(*first)(FnArity *, Value *t);\nValue *(*rest)(FnArity *, Value *t);\nValue *(*showFn)(FnArity *, Value *t);\nValue *(*fn_apply)(FnArity *, Value *f, Value *args);\nValue *(*hasField)(FnArity *, Value *v, Value *field);\nValue *(*prErrSTAR)(Value *str);\nValue *(*prValue)(FnArity *, Value *v);\n\nValue *my_malloc(int64_t sz);\nList *malloc_list();\nValue *vectSeq(Vector *vect, int index);\nFnArity *malloc_fnArity();\nFunction *malloc_function(int arityCount);\nString *malloc_string(int len);\nMaybe *malloc_maybe();\nInteger *malloc_integer();\nVector *malloc_vector();\nFnArity *findFnArity(Value *fnVal, int64_t argCount);\nReifiedVal *malloc_reified(int64_t implCount);\nPromise *malloc_promise();\n\nvoid startWorkers();\nvoid replaceWorker();\nvoid waitForWorkers();\nchar *extractStr(Value *v);\nValue *isInstance(Value *arg0, Value *arg1);\nValue *prSTAR(Value *);\nValue *add_ints(Value *arg0, Value *arg1);\nValue *integer_str(Value *arg0);\nValue *integer_EQ(Value *arg0, Value *arg1);\nValue *integer_LT(Value *arg0, Value *arg1);\nValue *integerValue(int64_t n);\nVector *vectConj(Vector *vect, Value *val);\nVector *mutateVectConj(Vector *vect, Value *val);\nValue *vectStore(Vector *vect, unsigned index, Value *val);\nValue *updateField(Value *rval, Value *field, int64_t index);\nValue *vectorReverse(Value *arg0);\nList *listCons(Value *x, List *l);\nvoid destructValue(char *fileName, char *lineNum, Value *val, int numArgs, Value **args[]);\nValue *maybe(FnArity *, Value *arg0, Value *arg1);\nint8_t isNothing(Value *v, char *fileName, int lineNumber);\nValue *strCount(Value *arg0);\nValue *strEQ(Value *arg0, Value *arg1);\nValue *strList(Value *arg0);\nValue *strVect(Value *arg0);\nValue *checkInstance(TYPE_SIZE typeNum, Value *arg1);\nValue *listMap(Value *arg0, Value *arg1);\nValue *listConcat(Value *arg0);\nValue *car(Value *arg0);\nValue *cdr(Value *arg0);\nValue *integerLT(Value *arg0, Value *arg1);\nint64_t integerSha1(Value *arg0);\nValue *bitAnd(Value *arg0, Value *arg1);\nValue *bitOr(Value *arg0, Value *arg1);\nValue *bitXor(Value *arg0, Value *arg1);\nValue *bitShiftLeft(Value *arg0, Value *arg1);\nValue *bitShiftRight(Value *arg0, Value *arg1);\nValue *bitNot(Value *arg0);\nValue *addIntegers(Value *arg0, Value *arg1);\nValue *listEQ(Value *arg0, Value *arg1);\nint8_t equal(Value *v1, Value *v2);\nValue *maybeExtract(Value *arg0);\nValue *fnApply(Value *arg0, Value *arg1);\nValue *maybeApply(Value *arg0, Value *arg1);\nValue *maybeEQ(Value *arg0, Value *arg1);\nValue *maybeMap(Value *arg0, Value *arg1);\nint64_t strSha1(Value *arg0);\nValue *escapeChars(Value *arg0);\nValue *subs2(Value *arg0, Value *arg1);\nValue *subs3(Value *arg0, Value *arg1, Value *arg2);\nValue *strSeq(Value *arg0);\nValue *strReduce(Value *s0, Value *x1, Value *f2);\nValue *strVec(Value *arg0);\nValue *strLT(Value *arg0, Value *arg1);\nValue *vectorGet(Value *arg0, Value *arg1);\nValue *symbol(Value *arg0);\nValue *symbolSha1(Value *arg0);\nValue *symEQ(Value *arg0, Value *arg1);\nValue *symLT(Value *arg0, Value *arg1);\nValue *stringValue(char *s);\nValue *opaqueValue(void *ptr, Destructor *destruct);\nValue *listFilter(Value *arg0, Value *arg1);\nList *reverseList(List *input);\nValue *bmiHashSeq(Value *arg0, Value *arg1);\nValue *bmiCount(Value *arg0);\nValue *bmiCopyAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift);\nValue *bmiMutateAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift);\nValue *bmiGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift);\nValue *bmiDissoc(Value *arg0, Value* arg1, int64_t hash, int shift);\nValue *arrayNodeCopyAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift);\nValue *arrayNodeMutateAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift);\nValue *collisionAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift);\nValue *hashMapGet(Value *arg0, Value *arg1);\nValue *hashMapAssoc(Value *arg0, Value *arg1, Value *arg2);\nValue *arrayNodeGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift);\nValue *collisionCount(Value *arg0);\nValue *arrayNodeCount(Value *arg0);\nValue *collisionSeq(Value *arg0, Value *arg1);\nValue *collisionDissoc(Value *arg0, Value *arg1, int64_t hash, int shift);\nValue *collisionGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift);\nValue *arrayNodeSeq(Value *arg0, Value *arg1);\nValue *arrayNodeDissoc(Value *arg0, Value *arg1, int64_t hash, int shift);\nValue *deliverPromise(Value *arg0, Value *arg1);\nValue *extractPromise(Value *arg0);\nValue *promiseDelivered(Value *arg0);\nValue *extractFuture(Value *arg0);\nValue *makeFuture(Value *arg0);\nValue *makeAgent(Value *arg0);\nValue *extractAgent(Value *arg0);\nvoid scheduleAgent(Agent *agent, List *action);\nvoid freeExtractCache(void *cachePtr);\nvoid freeIntGenerator(void *ptr);\nValue *addPromiseAction(Promise *promise, Value *action);\nValue *dynamicCall1Arg(Value *f, Value *arg);\nValue *deliverFuture(Value *fut, Value *val);\nValue *addFutureAction(Future *p, Value *action);\nString *nullTerm(Value *s);\nvoid show(Value *v);\nint64_t countSeq(Value *seq);\nValue *malloc_sha1();\nValue *finalize_sha1(Value *ctxt);\nvoid Sha1Update (Sha1Context* Context, void* Buffer, int64_t BufferSize);\nvoid strSha1Update(Sha1Context *ctxt, Value *arg0);\nValue *reifiedTypeArgs(Value *x);\nValue *dispatchProto(Value *protocols, Value *protoSym, Value *fnSym, Value *dispValue, Value *args);\nValue *get(FnArity *, Value *, Value *, Value *, int64_t hash, int shift);\nValue *baseDissoc(Value *arg0, Value* arg1, int64_t hash, int shift);\nint64_t nakedSha1(Value *v1);\nValue *copyAssoc(Value *node, Value *k, Value *v, int64_t hash, int shift);\nValue *mutateAssoc(Value *node, Value *k, Value *v, int64_t hash, int shift);\nValue *newTypeValue(int typeNum, Vector *fields);\nValue *getField(Value *value, int fieldIndex);\nVector *listVec(Value *list);\nValue *defaultPrErrSTAR(Value *str);\nValue *vectGet(Vector *vect, unsigned index);\nValue *hashMapVec(Value *m);\nvoid incTypeMalloc(TYPE_SIZE type, int delta);\nvoid incTypeFree(TYPE_SIZE type, int delta);\nValue *hashVec(Value* n, Value *s);\n" }, { "path": "core.toc", "content": "\n;; 'core' is a virtual value. It is a hash map that all the symbols defined in this file will end up in.\n;; It maps symbol literals to values\n;; (def core {})\n\n(def empty-list (inline C List \"(Value *)&empty_list_struct\"))\n\n(def empty-vector (inline C Vector \"(Value *)&empty_vect_struct\"))\n\n(defn prefs [s v]\n ;; if you're using this function, you're so far off in the weeds, I can't help you\n (assert (instance? StringBuffer s))\n (inline C \" prefs(extractStr(s_0), v_1);\\nreturn(v_1);\\n\"))\n\n(defn maybe [v]\n ;; wrap `v` in a Maybe value\n (inline C Maybe \"return(maybe((FnArity *)0, (Value *)0, v_0));\"))\n\n(def nothing (inline C Maybe \"(Value *)&(Maybe){MaybeType, -2, 0}\"))\n\n;; protocol for implementing the hash map type\n(defprotocol HashMapNode\n (hash-seq [m s]\n (assert (instance? List s))\n (assert-result l (instance? List l)))\n\n (hash-vec [m v]\n (assert (instance? Vector v))\n (assert-result v (instance? Vector v)))\n\n (get* [m k v hash shift]\n (assert-result x (instance? Maybe x)))\n\n (assoc* [m k v hash shift]\n (assert (instance? Integer hash))\n (assert (instance? Integer shift)))\n\n (dissoc* [m k hash shift]))\n\n(defn default-type-name [value]\n ;; Return the string of the name of the type of `value`\n (inline C StringBuffer \"\n Value *numVal = integerValue(value_0->type);\n dec_and_free(value_0, 1);\n return(integer_str(numVal));\"))\n\n(defn default-type-args [x]\n (inline C Vector \"return(reifiedTypeArgs(x_0));\"))\n\n(defn get-refs [value]\n (inline C Integer \"\n Value *numVal = integerValue(value_0->refs);\n dec_and_free(value_0, 1);\n return(numVal);\"))\n\n(defn default-get-type [value]\n (inline C Integer \"\n Value *numVal = integerValue(value_0->type);\n dec_and_free(value_0, 1);\n return(numVal);\"))\n\n;; Internal protocol for types.\n(defprotocol Type\n (has-field [_ field]\n ;; TODO: in generated code, this constraint doesn't appear, so there's a runtime check\n (assert-result r (instance? Maybe r))\n ;; Does the type have `field` defined for it\n nothing)\n\n (get-type [value]\n (assert-result r (instance? Integer r))\n ;; Return the Integer representing the type of `value`\n (default-get-type value))\n\n (type-name [value]\n ;; Return the string of the name of the type of `value`\n ;; TODO: make work\n ;; (assert-result r (instance? (any-of StringBuffer\n ;; SubString)\n ;; r))\n (default-type-name value))\n\n (type-args [x]\n (assert-result r (instance? Vector r))\n ;; Return the values for all the fields of `x` in a vector\n (default-type-args x))\n\n (type-mapping [x])\n\n (instance? [t x]\n ;; test whether `x` is of type `t`\n (assert-result a (instance? Maybe a))))\n\n(defn list-count [l]\n (assert (instance? List l))\n (inline C Integer \"\n Value *numVal = integerValue(((List *)l_0)->len);\n dec_and_free(l_0, 1);\n return(numVal);\"))\n\n(defn mutate-vect-conj [v x]\n (assert (instance? Vector v))\n (inline C Vector \"return((Value *)mutateVectConj((Vector *)v_0, x_1));\"))\n\n(defn list-map [l f]\n (assert (instance? List l))\n (inline C List \"return(listMap(l_0, f_1));\"))\n\n(defn list-concat [l]\n (assert (instance? (list-of List) l))\n (assert-result r (instance? List r))\n (inline C List \"return(listConcat(l_0));\"))\n\n(defn add-numbers [x y]\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"\n Value *numVal = integerValue(((Integer *)x_0)->numVal + ((Integer *)y_1)->numVal);\n dec_and_free(x_0, 1);\n dec_and_free(y_1, 1);\n return(numVal);\"))\n\n(defn str-malloc [len]\n (assert (instance? Integer len))\n (inline C StringBuffer \"\n String *strVal = malloc_string(((Integer *)len_0)->numVal);\n strVal->len = 0;\n strVal->buffer[0] = 0;\n dec_and_free(len_0, 1);\n return((Value *)strVal);\\n\"))\n\n(defn abort []\n (inline C Maybe\n \"abort();\n return(nothing);\"))\n\n(defn subtract-numbers [x y]\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"\n Value *numVal = integerValue(((Integer *)x_0)->numVal - ((Integer *)y_1)->numVal);\n dec_and_free(x_0, 1);\n dec_and_free(y_1, 1);\n return(numVal);\"))\n\n(defn mult-numbers [x y]\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"\n Value *numVal = integerValue(((Integer *)x_0)->numVal * ((Integer *)y_1)->numVal);\n dec_and_free(x_0, 1);\n dec_and_free(y_1, 1);\n return(numVal);\"))\n\n(defn div [x y]\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"\n int denom = ((Integer *)y_1)->numVal;\n if (denom == 0) {\n fprintf(stderr, \\\"*** Can not divide by 0\\\\n\\\");\n abort();\n }\n Value *numVal = integerValue((int64_t)(((Integer *)x_0)->numVal / denom));\n dec_and_free(x_0, 1);\n dec_and_free(y_1, 1);\n return(numVal);\"))\n\n(defn mod [x y]\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"\n int denom = ((Integer *)y_1)->numVal;\n if (denom == 0) {\n fprintf(stderr, \\\"*** Can not divide by 0\\\\n\\\");\n abort();\n }\n Value *numVal = integerValue(((Integer *)x_0)->numVal % denom);\n dec_and_free(x_0, 1);\n dec_and_free(y_1, 1);\n return(numVal);\"))\n\n(defn vect-count [v]\n (assert (instance? Vector v))\n (inline C Integer \"\n Value *result = integerValue(((Vector *)v_0)->count);\n dec_and_free(v_0, 1);\n return(result);\"))\n\n(def emptyBMI\n (inline C BitmapIndexedNode \"(Value *)&emptyBMI\"))\n\n(defn identity [x] x)\n\n; For types that have some notion of equality between their values\n(defprotocol Eq\n (=* [x y]\n ;; Compare two values for equality\n (assert-result a (instance? Maybe a))))\n\n;; Definitions for the 'built-in' types\n(def Integer\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of Integer) \"return(checkInstance(IntegerType, x_1));\"))))\n\n(def List\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of List) \"return(checkInstance(ListType, x_1));\"))))\n\n(def Maybe\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of Maybe) \"return(checkInstance(MaybeType, x_1));\"))))\n\n(def Symbol\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of Symbol) \"return(checkInstance(SymbolType, x_1));\"))))\n\n(def Vector\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of Vector) \"return(checkInstance(VectorType, x_1));\"))))\n\n(def Fn\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of Fn) \"return(checkInstance(FunctionType, x_1));\"))))\n\n(def Promise\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of Promise) \"return(checkInstance(PromiseType, x_1));\"))))\n\n(def Future\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of Future) \"return(checkInstance(FutureType, x_1));\"))))\n\n(def Agent\n (reify\n Type\n (instance? [_ x]\n (inline C (maybe-of Agent) \"return(checkInstance(AgentType, x_1));\"))))\n\n(defn bit-and [x y]\n ;; Bitwise AND two integer values\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"return(bitAnd(x_0, y_1));\"))\n\n(defn bit-or [x y]\n ;; Bitwise OR two integer values\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"return(bitOr(x_0, y_1));\"))\n\n(defn bit-xor [x y]\n ;; Bitwise XOR two integer values\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"return(bitXor(x_0, y_1));\"))\n\n(defn bit-shift-left [x y]\n ;; Bitwise left shift of x by y bits\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"return(bitShiftLeft(x_0, y_1));\"))\n\n(defn bit-shift-right [x y]\n ;; Bitwise right shift of x by y bits\n (assert (instance? Integer x))\n (assert (instance? Integer y))\n (inline C Integer \"return(bitShiftRight(x_0, y_1));\"))\n\n(defn bit-not [x]\n ;; Bitwise NOT single integer value\n (assert (instance? Integer x))\n (inline C Integer \"return(bitNot(x_0));\"))\n\n(defn deliver [p v]\n ;; Deliver value `v` to any thread waiting on promise `p`. Any thread that\n ;; calls `extract` on `p` after this will return with `v` immediately without waiting\n (assert (instance? Promise p))\n (inline C Promise \"return(deliverPromise(p_0, v_1));\"))\n\n(defn delivered [p]\n ;; Test whether a value has been delivered for promise `p`\n (assert (instance? Promise p))\n (inline C Maybe \"return(promiseDelivered(p_0));\"))\n\n\n;; The core protocols of Toccata\n;; A type does not have to implement all the protocols or even all of the\n;; protocol functions of a given protocol. In fact, most won't\n\n;; For types whose values can be composed\n(defprotocol Composition\n (zero [x]\n ;; Produce a value with same type as `x` that can be `comp`d with any value\n ;;`y` of the same type to return `y`\n )\n (comp* [x xs]\n ;; Compose a number of values of the same type to produce a single value of\n ;; that type. `xs` is a list of values of same type as `x`.\n ;; `comp*` must be associative\n ))\n\n(defn comp\n ;; Compose values using the `comp*` protocol fn.\n ([x] x)\n ([x & xs]\n (comp* x xs)))\n\n;; For types that contain values. Focus is on container\n(defprotocol Container\n (flat-map [x f]\n ;; Apply `f` to the value(s) inside `x` and then flatten one level of nesting.\n ;; `f` must take one value and return a value of a type that's compatible with `x`\n )\n\n (flatten [x]\n ;; Given a value `x` that contains value(s) of the same type as `x`, remove\n ;; one layer of wrapping.\n\n ;; the default way of flattening. Requires `flat-map` to be implemented\n ;; for `x`\n )\n\n (extend [x f]\n ;; Create a new value of same type as `x` that will apply `f` to\n ;; values `extract`ed from `x`.\n ;; (map (duplicate x) f)\n )\n\n (duplicate [x]\n ;; Add a layer of wrapping to `x`\n (extend x (fn [x] x)))\n\n (extract [x]\n ;; Pull a value out of `x`\n )\n\n (wrap [x v]\n ;; Create a new value of same type as `x` that contains the value `y`\n )\n\n (apply [xf xs]\n ;; Apply a function(s) in `xf` to the value(s) in each of the `xs`,\n ;; wrapping the result in the same type as `xf`.\n )\n\n (map [x f]\n ;; Create a new value of same type as `x` that contains the results of\n ;; applying `f` to all the values contained in `x`\n )\n\n (map [x f embed]\n ;; Create a new value embedded in a context of same type as `x` that contains the results of\n ;; applying `f` to all the values contained in `x`. The context the new value is embedded in\n ;; must implement 'flat-map'. If there are no values contained in 'x', the 'embed' function\n ;; is used to create an empty value of type 'x' embedded in the context. \n )\n\n (send* [x f-and-ys]\n ;; Cause the value(s) in `x` to be updated with the results of applying the\n ;; the first item of `f-and-ys` to each of the value(s) in `x` and the rest\n ;; of `f-and-ys`. Should only be implemented for types that support in place\n ;; updating.\n )\n\n ;; (assert (== (flat-map (wrap a p) g)\n ;; (g p)))\n ;; (assert (== (flat-map (wrap a p) (fn [q]\n ;; (wrap a q)))\n ;; (wrap a p)))\n ;; (assert (== (flat-map (flat-map (wrap a p) g) h)\n ;; (flat-map (wrap a p) (fn [q]\n ;; (flat-map (g q) h)))))\n ;; (assert (== (apply (wrap p g) (list q))\n ;; (map q g)))\n ;; (assert (== p (flatten (wrap p p))))\n ;; (assert (== (extend p extract) p))\n ;; (assert (== (extract (extend p g)) (g p)))\n ;; (assert (== (extend (extend p g) h)\n ;; (extend p (fn [q]\n ;; (h (extend q g))))))\n ;; (assert (== (map (map p g) h)\n ;; (map p (comp h g))))\n ;; (assert (== p (extract (duplicate p))))\n )\n\n(defn cons [x l]\n ;; Add a value `x` to the head of list `l`\n (assert (instance? List l))\n (inline C List \"\n Value *listVal = (Value *)listCons(x_0, (List *)l_1);\n return(listVal);\\n\"))\n\n(defn send [v f & args]\n ;; send a function `f` to a value `v`. `f` will be applied to the contents of\n ;; `v` and the list of values in `args`\n (send* v (cons f args)))\n\n;; For types that contain values. Focus is on the contained values.\n;; No sense of ordering for contents\n(defprotocol Collection\n (empty? [coll]\n ;; Test whether `coll` contains any values\n (assert-result a (instance? Maybe a)))\n\n (count [coll]\n ;; Count the number of values in `coll`\n (assert-result y (instance? Integer y)))\n\n (empty [coll]\n ;; Create an empty collection of same type as `coll`\n )\n\n (conj [coll x]\n ;; Add `x` to `coll`\n )\n\n (filter [coll f]\n ;; Create a new collection of same type as `coll` with only the values\n ;; for which `f` does not return `nothing`.\n )\n\n (reduce [coll x f]\n ;; Produce a single value by calling `f` repeatedly on the contents of `coll`.\n ;; For example, if `coll` contains `p` and `q`, then: `(f (f x p) q)`\n ;; Will be done sequentially.\n ))\n\n;; Collection types that have some sense of ordering of their contents\n(defprotocol Seqable\n (seq [coll]\n ;; Create a list of the contents\n (assert-result a (instance? List a)))\n\n (vec [coll]\n ;; Create a vector of the contents\n (assert-result a (instance? Vector a)))\n\n (first [coll]\n ;; Return the first element in the `coll` (wrapped in a `Maybe`) if `coll`\n ;; is not empty. Returns 'nothing', if `coll` is empty.\n (assert-result a (instance? Maybe a)))\n\n (rest [coll]\n ;; Returns a new collection with all but the first value of `coll`\n )\n\n (last [coll]\n ;; Return the last element in the `coll` (wrapped in a `Maybe`) if `coll`\n ;; is not empty. Returns 'nothing', if `coll` is empty.\n (assert-result a (instance? Maybe a)))\n\n (butlast [coll]\n ;; Returns a new collection with all but the last value of `coll`\n )\n\n (split [coll n]\n ;; divides a sequence into to parts with at most 'n' elements being in the first part\n (assert (instance? Integer n)))\n\n (split [coll n prefix])\n\n (split-with [coll pred])\n\n (split-with [coll pred prefix])\n\n (take [coll n]\n (assert (instance? Integer n)))\n\n (drop [coll n]\n (assert (instance? Integer n)))\n\n (drop-while [coll pred])\n\n (take-while [coll pred])\n\n (reverse [coll]\n ;; Create a new collection of same type as `coll` with the contents\n ;; in reverse order\n )\n\n (to-str [coll]\n ;; Builds a string from the string representation of all the values in `coll`\n (assert-result a (instance? StringBuffer a))))\n\n(defn second [coll]\n ;; get the second element from the sequable `coll`\n (first (rest coll)))\n\n;; For collections whose contents can be indexed by integers\n(defprotocol Indexed\n (nth [coll n]\n ;; Retrieve the `n`th value from `coll`, wrapped in a Maybe, if there are\n ;; enough values in `coll`. Otherwise, returns `nothing`.\n (assert (instance? Integer n))\n (assert-result a (instance? Maybe a)))\n\n (store [coll n v]\n ;; Create a new copy of `coll` (wrapped in a Maybe) with `v` at index `n`\n ;; if `coll` is at least size of `n` - 1. Otherwise, return `nothing`.\n (assert (instance? Integer n))\n (assert-result a (instance? Maybe a))))\n\n;; For types whose values can be hashed to an integer\n(defprotocol Hashable\n (sha1-update [x context])\n (sha1 [x]\n ;; Compute the SHA1 hash of `x`\n (assert-result a (instance? Integer a))))\n\n;; For types that emulate a key/value store\n(defprotocol Associative\n (assoc [m k v])\n\n (get [m k]\n ;; Retrieve the value associated with `k` in `m`, wrapped in a `Maybe` if it exists.\n ;; Otherwise, return `nothing`\n (assert-result a (instance? Maybe a)))\n\n ;; TODO: Remove this arity. Should use 'either' instead\n (get [m k not-found]\n ;; Retrieve the value associated with `k` in `m` if it exists.\n ;; Otherwise, return `not-found`\n )\n\n (keys [m]\n ;; Get a list of the keys from `m`\n (assert-result a (instance? List a)))\n\n (vals [m]\n ;; Get a list of the vals from `m`\n (assert-result a (instance? List a))))\n\n;; For types whose values may be invoked like functions\n(defprotocol Function\n (invoke [_])\n (invoke [_ _])\n (invoke [_ _ _])\n (invoke [_ _ _ _])\n (invoke [_ _ _ _ _])\n (invoke [_ _ _ _ _ _])\n (invoke [_ _ _ _ _ _ _])\n (invoke [_ _ _ _ _ _ _ _])\n (invoke [_ _ _ _ _ _ _ _ _]))\n\n;; For types that have some notion of order of their values\n(defprotocol Ord\n (<* [x y]\n ;; Compare two values for order\n (assert-result a (instance? Maybe a))))\n\n(defn sha1-init []\n (inline C Opaque \"return(malloc_sha1());\"))\n\n(defn sha1-finalize [ctxt]\n (inline C Integer \"return(finalize_sha1(ctxt_0));\"))\n\n(defn address-of [x]\n (inline C Integer \"return(integerValue((long long)x_0));\"))\n\n(defn identical [x y]\n ;; Returns a `maybe` value if and only if the `x` and `y` reside at the same address in memory\n (inline C Maybe \"\n if (x_0 == y_1) {\n dec_and_free(y_1, 1);\n return(maybe((FnArity *)0, (Value *)0, x_0));\n } else {\n dec_and_free(x_0, 1);\n dec_and_free(y_1, 1);\n return(nothing);\n }\"))\n\n(defn fn-name [f]\n (assert (instance? Fn f))\n (inline C StringBuffer \"\n Value *strVal = stringValue(((Function *)f_0)->name);\n dec_and_free(f_0, 1);\n return(strVal);\"))\n\n;; TODO: implement Float as well.\n;; pay attention to https://blog.acolyer.org/2020/09/28/fpspy/\n(extend-type Integer\n Eq\n (=* [x y] (inline C (maybe-of Integer) \"return(integer_EQ(x_0, y_1));\")))\n\n(defn maybe-map [mv f]\n (assert (instance? Maybe mv))\n (inline C Maybe \"return(maybeMap(mv_0, f_1));\"))\n\n(defn maybe-apply [mv m-args args]\n (assert (instance? Maybe mv))\n (assert (instance? List m-args))\n (assert (instance? Vector args))\n\n (either (for [m-arg (first m-args)]\n (either (map m-arg (fn [arg]\n (maybe-apply mv (rest m-args) (conj args arg))))\n nothing))\n (map mv (fn [f]\n (apply f args)))))\n\n;; This is the declaration of the 'vector' function. Calls to 'vector' are inlined by the compiler\n(defn vector [& l]\n ;; construct a vector of values from the arguments\n (vec l))\n\n(extend-type Maybe\n Container\n (map [mv f]\n (maybe-map mv f))\n\n (map [mv f embed]\n ;; TODO: is this right?\n (embed (maybe-map mv f)))\n\n (extract [mv]\n (inline C \"return(maybeExtract(mv_0));\"))\n\n (wrap [_ mv]\n (maybe mv))\n\n (apply [mv args]\n (maybe-apply mv (seq args) []))\n\n (flat-map [mv f]\n (and mv (f (extract mv))))\n\n Composition\n (zero [mv]\n nothing)\n\n Eq\n (=* [x y] (inline C (maybe-of Maybe) \"return(maybeEQ(x_0, y_1));\"))\n\n Associative\n (get [m _]\n m)\n\n (get [m _ not-found]\n (either m not-found))\n\n (assoc [x y v]\n (maybe v)))\n\n;; This is the declaration of the 'list' function. Calls to 'list' are inlined by the compiler\n(defn list [& l]\n ;; construct a list of values from the arguments\n l)\n\n;; TODO: remove\n(def print-err)\n\n(extend-type List\n Collection\n (count [l] (list-count l))\n\n (empty? [l]\n (and (=* 0 (count l))\n (maybe empty-list)))\n\n (empty [_] empty-list)\n\n (conj [l v] (cons v l))\n\n (filter [coll f]\n (inline C List \"return(listFilter(coll_0, f_1));\"))\n\n Container\n (map [l f]\n (list-map l f))\n\n (map [l f embed]\n (-> l\n reverse\n (reduce (embed empty-list)\n (fn [v x]\n (flat-map (f x)\n (fn [y]\n (map v (fn [v]\n (conj v y)))))))\n (map reverse)))\n\n (wrap [x v]\n (list v))\n\n (flatten [ls]\n (list-concat ls))\n\n (flat-map [l mf]\n (list-concat (list-map l mf)))\n\n Composition\n (zero [_] empty-list)\n\n (comp* [l ls]\n (list-concat (cons l (map (seq ls) seq))))\n\n Eq\n (=* [x y] (inline C (maybe-of List) \"return(listEQ(x_0, y_1));\"))\n\n Seqable\n (seq [l] l)\n\n (vec [l]\n (inline C Vector \"return((Value *)listVec(l_0));\"))\n\n (reverse [l]\n (inline C List \"return((Value *)reverseList((List *)l_0));\"))\n\n (first [l]\n (inline C Maybe \"return(car(l_0));\"))\n\n (rest [l]\n (inline C List \"return(cdr(l_0));\")))\n\n(defn list-reduce [l result f]\n (assert (instance? List l))\n (cond\n (empty? l) result\n (list-reduce (rest l) (f result (extract (first l))) f)))\n\n(extend-type List\n Collection\n (reduce [l result f]\n (list-reduce l result f)))\n\n(defn +\n ([] 0)\n ([x y]\n (add-numbers x y))\n ([& xs]\n (reduce xs 0 add-numbers)))\n\n(defn <\n ;; Test whether a number of values are in order from least to greatest\n ;; (Uses `<*` protocol function)\n ([x y]\n (<* x y))\n ([v & vs]\n (let [maybe-v (maybe v)]\n (and (reduce vs maybe-v\n ;; TODO: there's a runtime check if '<' is a fn here that shouldn't be\n (fn [prev v]\n (flat-map prev (fn [prev]\n (and (< prev v)\n (maybe v))))))\n maybe-v))))\n\n(defn >\n ;; Test whether a number of values are in order from greatest to least\n ;; (Uses `<*` protocol function)\n ([x y] (map (<* y x) (fn [_] x)))\n ([v & vs]\n (let [maybe-v (maybe v)]\n (and (reduce vs maybe-v\n (fn [prev v]\n (flat-map prev (fn [prev]\n (and (> prev v)\n (maybe v))))))\n maybe-v))))\n\n(defn some [coll f]\n (and (< 0 (count coll))\n (or (flat-map (first coll) f)\n (some (rest coll) f))))\n\n(defn partial [f & args]\n ;; paritally apply `f` to `args` creating a new function that expects more arguments\n (fn [& more-args]\n (apply f (comp args more-args))))\n\n;; For types whose values can be converted to human-readable strings\n(defprotocol Stringable\n (string-list [x]\n ;; Create a list of strings of that comprise the representation of `x`\n (assert-result r (instance? (list-of (any-of StringBuffer\n SubString))\n r)))\n\n (show* [x indent]\n (assert (instance? (any-of StringBuffer\n SubString)\n indent))\n\n ;; Create a string list to show the value `x`\n (assert-result a (instance? List a))))\n\n(defn show [x]\n (show* x \"\"))\n\n(defn list*\n ([] empty-list)\n ([arg]\n (assert (instance? (any-of List\n Vector)\n arg))\n (seq arg))\n ([arg & args]\n (let [[arg-list & args] (reverse (cons arg args))]\n (assert (instance? (any-of List\n Vector)\n arg-list))\n\n (reduce args (seq arg-list) conj))))\n\n(def String (any-of StringBuffer\n SubString))\n\n(def Sequence (any-of List\n Vector))\n\n(defn <=\n ;; Test whether each value is greater than or equal to the preceding one.\n ;; (Uses `<*` and `=*` protocol functions)\n ([x] (maybe x))\n ([x y] (or (<* x y) (=* x y)))\n ([x & ys]\n (flat-map (first ys)\n (fn [y]\n (and (<= x y)\n (apply <= ys)\n (maybe x))))))\n\n(defn =\n ;; Test that a number of values are all equals\n ;; (Uses `=*` protcol funcion)\n ([v]\n (assert-result r (instance? Maybe r))\n (maybe v))\n ([x y]\n (assert-result r (instance? Maybe r))\n (=* x y))\n ([x y & ys]\n (assert-result r (instance? Maybe r))\n (and (=* x y)\n (apply = (list* y ys)))))\n\n(defn str-append [dest src]\n (assert (instance? StringBuffer dest))\n (assert (instance? String src))\n (inline C StringBuffer \"\n String *s_1 = (String *)dest_0;\n if (src_1->type == StringBufferType) {\n String *s2 = (String *)src_1;\n strncat(s_1->buffer, s2->buffer, s2->len);\n s_1->len += s2->len;\n } else if (src_1->type == SubStringType) {\n SubString *s2 = (SubString *)src_1;\n strncat(s_1->buffer, s2->buffer, s2->len);\n s_1->len += s2->len;\n }\n dec_and_free(src_1, 1);\n return(dest_0);\"))\n\n(defn pr* [str]\n (assert (instance? String str))\n (inline C Integer \"return(prSTAR(str_0));\"))\n\n(defn pr-err* [str]\n (assert (instance? String str))\n (inline C Integer \"return((*prErrSTAR)(str_0));\"))\n\n(defn escape-chars [s]\n (assert (instance? String s))\n (inline C StringBuffer \"return(escapeChars(s_0));\"))\n\n(defn char [n]\n ;; Convert an integer to a one-character string\n (assert (instance? Integer n))\n (inline C StringBuffer \"\n String *strVal = malloc_string(2);\n strVal->len = 1;\n strVal->buffer[0] = ((Integer *)n_0)->numVal;\n strVal->buffer[1] = 0;\n dec_and_free(n_0, 1);\n return((Value *)strVal);\\n\"))\n\n(defn char-code [c]\n ;; Convert the first character of a string to an integer\n (assert (instance? String c))\n (inline C Integer \"\n if (c_0->type == StringBufferType) {\n String *s = (String *)c_0;\n Value *numVal = integerValue((unsigned char)s->buffer[0]);\n dec_and_free(c_0, 1);\n return(numVal);\n } else if (c_0->type == SubStringType) {\n SubString *s = (SubString *)c_0;\n Value *numVal = integerValue((unsigned char)s->buffer[0]);\n dec_and_free(c_0, 1);\n return(numVal);\n }\\n\"))\n\n(defn subs\n ;; Take a substring of a larger string\n ([src index]\n (assert (instance? String src))\n (assert (instance? Integer index))\n (inline C SubString \"return(subs2(src_0, index_1));\"))\n ([src index length]\n (assert (instance? String src))\n (assert (instance? Integer index))\n (assert (instance? Integer length))\n (inline C SubString \"return(subs3(src_0, index_1, length_2));\")))\n\n(defn symbol [sym-str]\n ;; Convert a string to a symbol\n (assert (instance? String sym-str))\n (inline C Symbol \"return(symbol(sym_str_0));\"))\n\n(extend-type String\n Collection\n (count [s]\n (inline C Integer \"return(strCount(s_0));\")))\n\n(extend-type List\n Seqable\n (to-str [coll]\n (let [ss-list (flat-map coll string-list)\n new-len (reduce ss-list 0 (fn [len s]\n (+ len (count s))))]\n (reduce ss-list (str-malloc new-len) str-append))))\n\n(extend-type FnArity\n Type\n (type-name [_] \"FnArity\")\n\n Eq\n (=* [x y]\n (identical x y))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(def FnOrArity (any-of Fn FnArity))\n\n(defn fn-apply [x args]\n (assert (instance? FnOrArity x))\n (assert (instance? List args))\n (inline C \"return(fnApply(x_0, args_1));\"))\n\n(extend-type Fn\n Type\n (type-name [_] \"Fn\")\n\n Eq\n (=* [x y] nothing)\n\n Stringable\n (string-list [_] (list \"\"))\n\n (show* [x _]\n (string-list x))\n\n Hashable\n (sha1 [f] 0)\n\n Composition\n (comp* [f fs]\n (let [[f & fs] (reverse (cons f fs))]\n (fn [& xs]\n (reduce fs (apply f xs)\n (fn [x f]\n (f x))))))\n\n Container\n (apply [f args]\n (fn-apply f (seq args))))\n\n(defn interpose [coll sep]\n ;; build list by inserting `sep` between each of the elements of `coll`\n (rest (flat-map (seq coll) (partial list sep))))\n\n(defn print [& vs]\n (-> vs\n (interpose \" \")\n (flat-map string-list)\n (map pr*)))\n\n(defn println [& vs]\n ;; deprecated, will be removed. Use at your own risk\n (map (flat-map (interpose vs \" \") string-list) pr*)\n (pr* \"\\n\"))\n\n(defn print-err [& vs]\n ;; For temporary debugging only, subject to removal at any time\n (pr-err* \"\\n*** \")\n (map (flat-map (interpose vs \" \") string-list) pr-err*)\n (pr-err* \"\\n\"))\n\n(defn str [& vs]\n ;; Converts the list of arguments into a single string of characters. Every argument\n ;; must implment the `string-list` protocol function.\n (assert-result s (instance? String s))\n (to-str vs))\n\n(defn inc [x]\n ;; Add 1 to an integer\n (+ 1 x))\n\n(defn -\n ;; Numerical subtraction\n ([] 0)\n ([x] x)\n ([x & xs]\n (assert-result y (instance? Integer y))\n (reduce xs x subtract-numbers)))\n\n(defn dec [x]\n ;; Subtract 1 from an integer\n (assert (instance? Integer x))\n\n (subtract-numbers x 1))\n\n(defn *\n ;; Multiply numbers\n ([] 1)\n ([x y] (mult-numbers x y))\n ([& xs]\n (assert-result y (instance? Integer y))\n\n (reduce xs 1 mult-numbers)))\n\n(extend-type Opaque\n Type\n (type-name [_] \"Opaque\")\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(extend-type Integer\n Type\n (type-args [n] [n])\n (type-name [_] \"Integer\")\n\n Stringable\n (string-list [n]\n (inline C \"return((Value *)listCons(integer_str(n_0), empty_list));\\n\"))\n\n (show* [x indent]\n (string-list x))\n\n Ord\n (<* [x y] (inline C (maybe-of Integer) \"return(integerLT(x_0, y_1));\"))\n\n Hashable\n (sha1-update [x ctxt]\n (inline C Integer \"\n Sha1Update(((Opaque *)ctxt_1)->ptr, (void *)&((Integer *)x_0)->type, 8);\n Sha1Update(((Opaque *)ctxt_1)->ptr, (void *)&((Integer *)x_0)->numVal, 8);\n dec_and_free(x_0, 1);\n return(ctxt_1);\n\"))\n\n (sha1 [x]\n (inline C Integer \"return(integerValue(integerSha1(x_0)));\")))\n\n(extend-type Vector\n Associative\n (get [v n]\n (assert (instance? Integer n))\n ;; TODO\n ;; (assert (<= 0 n))\n (inline C Maybe \"return(vectorGet(v_0, n_1));\"))\n\n Collection\n (empty? [v]\n (and (= 0 (count v))\n (maybe empty-vector)))\n\n (empty [coll] empty-vector)\n\n (count [l]\n (vect-count l))\n\n (conj [vect v]\n (inline C Vector \"\n Value *result = (Value *)vectConj((Vector *)vect_0, v_1);\n dec_and_free(vect_0, 1);\n return(result);\"))\n\n Seqable\n (seq [v]\n (inline C List \"return(vectSeq((Vector *)v_0, 0));\\n\"))\n\n (to-str [coll]\n (let [ss-list (cons \"\" (flat-map (seq coll) string-list))\n new-len (reduce ss-list 0 (fn [len s]\n (+ len (count s))))]\n (reduce ss-list (str-malloc new-len) str-append))))\n\n(extend-type String\n Type\n (type-name [_] \"String\")\n (type-args [s] [s])\n\n Stringable\n (string-list [s] (list s))\n\n (show* [s indent]\n (list* \"\\\"\" s (list \"\\\"\")))\n\n Composition\n (zero [_] \"\")\n\n (comp* [s ss]\n (to-str (cons s ss)))\n\n Collection\n (empty? [coll]\n (and (= 0 (count coll))\n (maybe \"\")))\n\n (empty [coll]\n \"\")\n\n (reduce [s x f]\n (inline C \"return(strReduce(s_0, x_1, f_2));\"))\n\n Seqable\n (to-str [s]\n (str s))\n\n (seq [coll]\n (inline C (list-of String) \"return(strSeq(coll_0));\"))\n\n (vec [coll]\n (inline C (vector-of String) \"return(strVec(coll_0));\"))\n\n (first [s]\n (map (< 0 (count s))\n (fn [_]\n (subs s 0 1))))\n\n (rest [s]\n (subs s 1))\n\n (last [s]\n (let [n (count s)]\n (map (< 0 n)\n (fn [_]\n (subs s (dec n))))))\n\n (butlast [s]\n (subs s 0 (dec (count s))))\n\n (reverse [s]\n (to-str (reverse (seq s))))\n\n (split-with [s pred prefix]\n (assert (instance? Vector prefix))\n (or (flat-map (first s) (fn [head]\n (and (pred head)\n (split-with (rest s) pred (conj prefix head)))))\n (maybe [(to-str prefix) s])))\n\n (split-with [s pred]\n (either (split-with s pred [])\n [\"\" s]))\n\n Eq\n (=* [x y] (inline C (maybe-of String) \"return(strEQ(x_0, y_1));\"))\n\n Indexed\n (nth [s n]\n (map (< n (count s))\n (fn [_]\n (subs s n 1))))\n\n Ord\n (<* [x y] (inline C (maybe-of String) \"return(strLT(x_0, y_1));\"))\n\n Hashable\n (sha1-update [x ctxt]\n (inline C Integer \"\n strSha1Update(((Opaque *)ctxt_1)->ptr, x_0);\n dec_and_free(x_0, 1);\n return(ctxt_1);\n\"))\n\n (sha1 [s]\n (inline C Integer \"\n// fprintf(stderr, \\\"wtf\\\\n\\\");\n// abort();\nreturn(integerValue(strSha1(s_0)));\")))\n\n(defn split-string\n ([s pred] (split-string s\n (fn [x]\n (cond (pred x)\n nothing\n (maybe x)))\n []))\n ([s pred splits]\n (let [[prefix tail] (-> s\n (take-while pred)\n count\n inc\n ((partial subs s))\n (split-with pred))]\n (either (or (and (= \"\" tail prefix)\n (maybe []))\n (and (= \"\" tail)\n (maybe (conj splits prefix)))\n (and (= \"\" prefix)\n (maybe (conj splits tail))))\n (split-string tail pred (conj splits prefix))))))\n\n(extend-type Symbol\n Type\n (type-name [_] \"Symbol\")\n (type-args [s] [s])\n\n Stringable\n (string-list [v]\n (inline C \"\n Value *strVal = stringValue(((SubString *)v_0)->buffer);\n dec_and_free(v_0, 1);\n return((Value *)listCons(strVal, empty_list));\"))\n\n (show* [x indent]\n (cons \"'\" (string-list x)))\n\n Eq\n (=* [x y]\n (inline C (maybe-of Symbol) \"return(symEQ(x_0, y_1));\"))\n\n Ord\n (<* [x y]\n (inline C (maybe-of Symbol) \"return(symLT(x_0, y_1));\"))\n\n Hashable\n (sha1-update [x ctxt]\n (inline C Integer \"\n SubString *subStrVal = (SubString *)x_0;\n Sha1Update(((Opaque *)ctxt_1)->ptr, (void *)&((Integer *)x_0)->type, 8);\n Sha1Update(((Opaque *)ctxt_1)->ptr, (void *)subStrVal->buffer, subStrVal->len);\n dec_and_free(x_0, 1);\n return(ctxt_1);\n\"))\n\n (sha1 [s]\n (inline C Integer \"\n// fprintf(stderr, \\\"wtf symbol\\\\n\\\");\n// abort();\nreturn(integerValue(strSha1(s_0)));\")))\n\n(defn sha1-update-type [x ctxt]\n (inline C Integer \"\n Sha1Update(((Opaque *)ctxt_1)->ptr, (void *)&((Integer *)x_0)->type, 8);\n dec_and_free(x_0, 1);\n return(ctxt_1);\n\"))\n\n;; recursion schemes\n(deftype Left [x]\n Stringable\n (string-list [_]\n (list \"(Left \" (str x) \")\"))\n\n Container\n (map [_ f]\n (Left (f x)))\n\n (map [_ f embed]\n (map (f x) Left)))\n\n(deftype Right [x]\n Stringable\n (string-list [_]\n (list \"(Right \" (str x) \")\"))\n\n Container\n (map [_ f]\n (Right (f x)))\n\n (map [_ f embed]\n (map (f x) Right)))\n\n(def Either (any-of Left\n Right))\n\n(deftype Attr [attribute hole]\n Stringable\n (string-list [_]\n (list \"(Attr \" (str attribute) \"\\n\" (str hole) \")\"))\n\n Container\n (map [_ f]\n (map hole f)))\n\n(defprotocol FromCoFree\n (from-cofree [x cv-coalg]))\n\n(deftype Pure [a]\n Stringable\n (string-list [_]\n (list \"(Pure \" (str a) \")\")))\n\n(deftype Impure [g]\n Stringable\n (string-list [_]\n (list \"(Impure \" (str g) \")\"))\n\n FromCoFree\n (from-cofree [_ cv-coalg]\n (map g (fn [x]\n (from-cofree x cv-coalg)))))\n\n(def Free (any-of Pure\n Impure))\n\n(defn cata\n ([algebra x]\n (algebra (map x (partial cata algebra))))\n ([algebra v embed]\n (flat-map (map v (fn [v]\n (cata algebra v embed))\n embed)\n algebra)))\n\n(defn ana\n ([co-algebra x]\n (map (co-algebra x) (partial ana co-algebra)))\n ([co-algebra v embed]\n (flat-map (co-algebra v)\n (fn [new-v]\n (map new-v (fn [v]\n (ana co-algebra v embed))\n embed)))))\n\n(defn para\n ([r-alg x]\n (-> x\n (map (partial para r-alg))\n (r-alg x)))\n ([r-alg x embed]\n (flat-map (map x (fn [mapped-x]\n (para r-alg mapped-x embed))\n embed)\n (fn [new-x]\n (r-alg new-x x)))))\n\n(defn apo\n ([r-co-alg v]\n (let [x (r-co-alg v)]\n (assert (instance? Either x))\n\n (either (map (instance? Left x) .x)\n (map (.x x) (partial apo r-co-alg)))))\n ([r-co-alg v embed]\n (flat-map (r-co-alg v) (fn [x]\n (either (map (instance? Left x)\n (fn [left-x]\n (embed (.x left-x))))\n (map (.x x)\n (fn [inner-x]\n (apo r-co-alg inner-x embed))\n embed))))))\n\n(defn to-cofree [t cv-alg]\n (assert-result r (instance? Attr r))\n\n (let [y (map t (fn [x]\n (to-cofree x cv-alg)))]\n (Attr (cv-alg y) y)))\n\n;; TODO: add embed and test\n(defn histo [cv-alg x]\n (-> x\n (to-cofree cv-alg)\n .attribute))\n\n(defn futu [cv-coalg x]\n (-> x\n cv-coalg\n (map (fn [y]\n (assert (instance? Free y))\n (from-cofree y cv-coalg)))))\n\n(defn hylo\n ([co-algebra algebra x]\n (-> x\n co-algebra\n (map (partial hylo co-algebra algebra))\n algebra))\n ([co-algebra algebra x embed]\n ;; TODO: using contextual hylo as the first expression in a 'for' doesn't work\n (flat-map (co-algebra x)\n (fn [new-x]\n (flat-map (map new-x (fn [y]\n (hylo co-algebra algebra y embed))\n embed)\n algebra)))))\n\n(defn elgot\n ([co-algebra algebra x]\n (let [new-x (co-algebra x)]\n (cond (instance? Left new-x)\n (.x new-x)\n\n (-> (.x new-x)\n (map (partial elgot co-algebra algebra))\n algebra))))\n ([co-algebra algebra x embed]\n (flat-map (co-algebra x)\n (fn [new-x]\n (cond (instance? Left new-x)\n (embed (.x new-x))\n\n (map (.x new-x) (fn [y]\n (elgot co-algebra algebra y embed))\n embed))))))\n\n(extend-type Pure\n FromCoFree\n (from-cofree [pure-v cv-coalg]\n (futu cv-coalg (.a pure-v))))\n\n(extend-type Maybe\n Type\n (type-args [v]\n (either (map v vector)\n empty-vector))\n\n (type-name [_] \"Maybe\")\n\n Hashable\n (sha1-update [x ctxt]\n (sha1-update-type x ctxt)\n (either (map x (fn [v]\n (sha1-update v ctxt)))\n ctxt))\n\n (sha1 [x]\n (let [ctxt (sha1-init)]\n (sha1-update x ctxt)\n (sha1-finalize ctxt)))\n\n Stringable\n (string-list [mv]\n (either (map mv (fn [v]\n (comp (list \"\"))))\n (list \"\")))\n\n (show* [x indent]\n (either (map x (fn [v]\n (comp (list \"\"))))\n (list \"\"))))\n\n(defn range* [n l]\n (assert (instance? Integer n))\n (assert (instance? List l))\n (assert-result new-l (instance? (list-of Integer) new-l))\n (cond (= n 0) (cons 0 l)\n (< n 0) l\n (range* (dec n) (cons n l))))\n\n(defn range [n]\n (range* (dec n) empty-list))\n\n(defn apply-to-vectors [f vects arg-vects]\n (either (for [vect (first vects)]\n (apply-to-vectors f (rest vects)\n (reduce vect [] (fn [new-args v]\n (reduce arg-vects new-args\n (fn [new-args arg-vect]\n (conj new-args (conj arg-vect v))))))))\n (map arg-vects (fn [args]\n (apply f (seq args))))))\n\n(extend-type List\n Type\n (type-name [_] \"List\")\n (type-args [l] (vec l))\n\n Stringable\n (string-list [l]\n (list-concat (list (list \"(\")\n (flat-map (interpose l \", \") string-list)\n (list \")\"))))\n\n (show* [x indent]\n (either (map (empty? x) string-list)\n (let [[h & tail] x]\n ;; (assert (instance? List tail))\n (comp (cons \"(\" (show* h (comp indent \" \")))\n (flat-map tail (fn [x]\n (list* \",\\n\" indent \" \"\n (show* x (comp indent \" \")))))\n (list \")\")))))\n\n Hashable\n (sha1-update [l ctxt]\n (sha1-update-type l ctxt)\n (reduce l ctxt (fn [ctxt x]\n (sha1-update x ctxt))))\n\n (sha1 [l]\n (let [ctxt (sha1-init)]\n (sha1-update l ctxt)\n (sha1-finalize ctxt)))\n\n Container\n (apply [mf vects]\n (either (for [f (first mf)\n vect (first vects)]\n (seq (apply-to-vectors f\n (rest vects)\n (map vect vector))))\n empty-list))\n\n Seqable\n (last [coll]\n (nth coll (dec (count coll))))\n\n (butlast [coll]\n (let [[r _] (split coll (dec (count coll)))]\n r))\n\n (split [l n prefix]\n (assert (instance? List prefix))\n (either (for [head (and (< 0 n)\n (first l))]\n (split (rest l) (dec n) (cons head prefix)))\n [(reverse prefix) l]))\n\n (split [l n]\n (split l n empty-list))\n\n (split-with [l pred prefix]\n (assert (instance? List prefix))\n (or (flat-map (first l) (fn [head]\n (and (pred head)\n (split-with (rest l) pred (cons head prefix)))))\n (maybe [(reverse prefix) l])))\n\n (split-with [l pred]\n (either (split-with l pred empty-list)\n [empty-list l]))\n\n (take [coll n]\n (assert-result l (instance? List l))\n (let [[prefix _] (split coll n)]\n prefix))\n\n (drop [coll n]\n (assert-result l (instance? List l))\n (let [[_ tail] (split coll n)]\n tail))\n\n (drop-while [coll pred]\n (assert-result l (instance? List l))\n (let [[_ tail] (split-with coll pred)]\n tail))\n\n (take-while [coll pred]\n (assert-result l (instance? List l))\n (let [[prefix _] (split-with coll pred)]\n prefix))\n\n Indexed\n (nth [coll n]\n (or (and (= n 0) (first coll))\n (and (< 0 n) (nth (rest coll) (dec n)))))\n\n Associative\n (get [l k]\n (nth l k)))\n\n(defn vec= [x y n]\n (assert (instance? Vector x))\n (assert (instance? Integer n))\n (or (= 0 n)\n (let [n (dec n)]\n (and (= (get x n) (get y n))\n (vec= x y n)))))\n\n(defn subvec* [v curr-index max-index result]\n (assert (instance? Vector v))\n (assert (instance? Integer curr-index))\n (assert (instance? Integer max-index))\n (assert (instance? Vector result))\n (either (and (<= curr-index max-index)\n (map (get v curr-index)\n (fn [x]\n (subvec* v (inc curr-index) max-index (mutate-vect-conj result x)))))\n result))\n\n(defn subvec\n ;; Extract a smaller vector from a larger one\n ([v start]\n (subvec* v start (count v) empty-vector))\n ([v start len]\n (subvec* v start (dec (+ start len)) empty-vector)))\n\n(defn vect-reduce [v n result f]\n (assert (instance? Vector v))\n (either (map (get v n)\n (fn [x]\n (vect-reduce v (inc n) (f result x) f)))\n result))\n\n(defn comp-vect [v vs]\n (assert (instance? Vector v))\n (assert (instance? (list-of Sequence) vs))\n (assert-result r (instance? Vector r))\n\n ;; TODO: I wonder if this could be streamlined\n ;; or even an inline fn\n (reduce (cons v vs) empty-vector\n (fn [v next-v]\n (reduce next-v v mutate-vect-conj))))\n\n(extend-type Vector\n Type\n (type-name [_] \"Vector\")\n (type-args [v] v)\n\n Stringable\n (string-list [v]\n (comp (list \"[\")\n (interpose (map (seq v) str) \", \")\n (list \"]\")))\n\n (show* [x indent]\n (either (map (empty? x) string-list)\n (let [[h & tail] (seq x)]\n (comp (cons \"[\" (show* h (comp indent \" \")))\n (flat-map tail (fn [x]\n (list* \",\\n\" indent \" \"\n (show* x (comp indent \" \")))))\n (list \"]\")))))\n\n Hashable\n (sha1-update [x ctxt]\n (sha1-update-type x ctxt)\n (reduce x ctxt (fn [ctxt x]\n (sha1-update x ctxt))))\n\n (sha1 [v]\n (let [ctxt (sha1-init)]\n (sha1-update v ctxt)\n (sha1-finalize ctxt)))\n\n Composition\n (zero [_] empty-vector)\n (comp* [v vs]\n (assert-result v (instance? Vector v))\n\n (comp-vect v vs))\n\n Container\n (map [v f]\n ;; TODO: should use 'doAssoc' or whatever it gets renamed to\n (assert-result v (instance? Vector v))\n (reduce v empty-vector (fn [v x]\n (mutate-vect-conj v (f x)))))\n\n (map [v f embed]\n (-> v\n reverse\n (reduce (embed empty-vector)\n (fn [v x]\n (flat-map (f x)\n (fn [y]\n (map v (fn [v]\n (conj v y)))))))\n (map reverse)))\n\n (wrap [v x] [x])\n\n (apply [mf vects]\n (either (for [f (first mf)\n vect (first vects)]\n (apply-to-vectors f\n (rest vects)\n (map vect vector)))\n []))\n\n (flat-map [v mf]\n (assert-result v (instance? Vector v))\n (reduce v empty-vector\n (fn [result x]\n (reduce (mf x) result mutate-vect-conj))))\n\n (flatten [v]\n (either (empty? v)\n (vec (apply comp v))))\n\n Collection\n (filter [v f]\n (assert-result v (instance? Vector v))\n (reduce v empty-vector\n (fn [result x]\n (cond (f x)\n (mutate-vect-conj result x)\n\n result))))\n\n (reduce [v result f]\n (vect-reduce v 0 result f))\n\n Seqable\n (vec [v] v)\n\n (first [v]\n (get v 0))\n\n (rest [v]\n (subvec v 1))\n\n (last [v]\n (and (< 0 (count v))\n (get v (dec (count v)))))\n\n (butlast [v]\n (subvec v 0 (dec (count v))))\n\n (reverse [v]\n (inline C Vector \"return(vectorReverse(v_0));\"))\n\n (split [l n prefix]\n (assert (instance? Vector prefix))\n (either (for [head (and (< 0 n)\n (first l))]\n (split (rest l) (dec n) (conj prefix head)))\n [prefix l]))\n\n (split [l n]\n (split l n []))\n\n (split-with [v pred prefix]\n (assert (instance? Vector prefix))\n (or (flat-map (first v) (fn [head]\n (and (pred head)\n (split-with (rest v) pred (conj prefix head)))))\n (maybe [prefix v])))\n\n (split-with [v pred]\n (either (split-with v pred [])\n [[] v]))\n\n (take [coll n]\n (assert-result v (instance? Vector v))\n (let [[prefix _] (split coll n)]\n prefix))\n\n (drop [coll n]\n (assert-result v (instance? Vector v))\n (let [[_ tail] (split coll n)]\n tail))\n\n (drop-while [coll pred]\n (assert-result v (instance? Vector v))\n (let [[_ tail] (split-with coll pred)]\n tail))\n\n (take-while [coll pred]\n (assert-result v (instance? Vector v))\n (let [[prefix _] (split-with coll pred)]\n prefix))\n\n Indexed\n (nth [v n]\n (get v n))\n\n (store [v n x]\n (inline C (maybe-of Vector) \"\n Value *result = vectStore((Vector *)v_0, ((Integer *)n_1)->numVal, (Value *)x_2);\n dec_and_free(v_0, 1);\n dec_and_free(n_1, 1);\n return(result);\"))\n\n Eq\n (=* [x y]\n (and (instance? Vector y)\n (= (count x) (count y))\n (vec= x y (count x))\n (maybe x))))\n\n(defn partitioner [coll n]\n (assert (instance? Integer n))\n (reduce coll [empty-list empty-list]\n (fn [[result part] x]\n (let [part (cons x part)]\n (cond (= n (count part))\n [(cons (reverse part) result) empty-list]\n\n [result part])))))\n\n(defn partition [coll n]\n (let [[partitioned] (partitioner coll n)]\n (reverse partitioned)))\n\n(defn partition-all [coll n]\n (let [[partitioned remainder] (partitioner coll n)]\n (reverse (cons remainder partitioned))))\n\n(defn every [coll f]\n (or (empty? coll)\n (for [head (flat-map (first coll) f)\n tail (every (rest coll) f)]\n (conj tail head))))\n\n\n(defn find-lo [v pivot lo]\n (let [lo (inc lo)]\n (either (for [lo-v (get v lo)\n _ (< lo-v pivot)]\n (find-lo v pivot lo))\n lo)))\n\n(defn find-hi [v pivot hi]\n (let [hi (dec hi)]\n (either (for [hi-v (get v hi)\n _ (< pivot hi-v)]\n (find-hi v pivot hi))\n hi)))\n\n(deftype Sorting [k v]\n Eq\n (=* [x y]\n (=* k (.k y)))\n\n Ord\n (<* [x y]\n (<* k (.k y))))\n\n;; TODO: not effecient. But will be when implemented as C code\n(defn sort* [v p r]\n (either (and (< p r)\n (map (get v r)\n (fn [pivot]\n (let [[v q] (reduce (range (- r p))\n [v p]\n (fn [curr-state j]\n (let [[v q] curr-state\n j (+ p j)]\n (either (for [x (get v j)\n :when (<= x pivot)\n y (get v q)\n v1 (store v j y)\n v2 (store v1 q x)]\n [v2 (inc q)])\n curr-state))))]\n (extract (for [q-val (get v q)\n v1 (store v q pivot)\n v2 (store v1 r q-val)]\n (let [[v3] (sort* v2 p (dec q))]\n (sort* v3 (inc q) r))))))))\n [v r]))\n\n(defn sort\n ([vs]\n (let [[vs] (sort* vs 0 (dec (count vs)))]\n vs))\n ([vs f]\n (-> vs\n (map (fn [v]\n (Sorting (f v) v)))\n sort\n (reduce [] (fn [vs v]\n (conj vs (.v v)))))))\n\n(extend-type BitmapIndexedNode\n Type\n (type-name [_] \"BitmapIndexedNode\")\n\n HashMapNode\n (hash-seq [m s]\n (inline C (list-of List) \"return(bmiHashSeq(m_0, s_1));\"))\n\n (assoc* [m k v hash shift]\n ;; TODO: find all calls to 'numVal' and dec_and_free the Values\n (inline C BitmapIndexedNode \"\n int64_t hash = ((Integer *)hash_3)->numVal;\n dec_and_free(hash_3, 1);\n int64_t shift = ((Integer *)shift_4)->numVal;\n dec_and_free(shift_4, 1);\n return(bmiMutateAssoc(m_0, k_1, v_2, hash, shift));\n\"))\n\n (dissoc* [node k hash shift]\n (inline C BitmapIndexedNode \"\n int64_t hash = ((Integer *)hash_2)->numVal;\n dec_and_free(hash_2, 1);\n int64_t shift = ((Integer *)shift_3)->numVal;\n dec_and_free(shift_3, 1);\n return(bmiDissoc(node_0, k_1, hash, shift));\"))\n\n (get* [node k v hash shift]\n (inline C \"\n int64_t hash = ((Integer *)hash_3)->numVal;\n dec_and_free(hash_3, 1);\n int64_t shift = ((Integer *)shift_4)->numVal;\n dec_and_free(shift_4, 1);\n return(bmiGet(node_0, k_1, v_2, hash, shift));\"))\n\n Collection\n (count [x]\n (inline C Integer \"return(bmiCount(x_0));\")))\n\n(extend-type ArrayNode\n Type\n (type-name [_] \"ArrayNode\")\n\n Collection\n (count [x]\n (inline C Integer \"return(arrayNodeCount(x_0));\"))\n\n HashMapNode\n (hash-seq [m s]\n (inline C (list-of List) \"return(arrayNodeSeq(m_0, s_1));\"))\n\n (assoc* [m k v hash shift]\n (inline C ArrayNode \"\n int64_t hash = ((Integer *)hash_3)->numVal;\n dec_and_free(hash_3, 1);\n int64_t shift = ((Integer *)shift_4)->numVal;\n dec_and_free(shift_4, 1);\n return(arrayNodeMutateAssoc(m_0, k_1, v_2, hash, shift));\"))\n\n (get* [m k v hash shift]\n (inline C \"\n int64_t hash = ((Integer *)hash_3)->numVal;\n dec_and_free(hash_3, 1);\n int64_t shift = ((Integer *)shift_4)->numVal;\n dec_and_free(shift_4, 1);\n return(arrayNodeGet(m_0, k_1, v_2, hash, shift));\"))\n\n (dissoc* [m k hash shift]\n (inline C ArrayNode \"\n int64_t hash = ((Integer *)hash_2)->numVal;\n dec_and_free(hash_2, 1);\n int64_t shift = ((Integer *)shift_3)->numVal;\n dec_and_free(shift_3, 1);\n return(arrayNodeDissoc(m_0, k_1, hash, shift));\")))\n\n(extend-type HashCollisionNode\n Type\n (type-name [_] \"HashCollisionNode\")\n\n Collection\n (count [x]\n (inline C Integer \"return(collisionCount(x_0));\"))\n\n HashMapNode\n (hash-seq [m s]\n (inline C (list-of List) \"return(collisionSeq(m_0, s_1));\"))\n\n (assoc* [node k v hash shift]\n (inline C HashCollisionNode \"\n int64_t hash = ((Integer *)hash_3)->numVal;\n dec_and_free(hash_3, 1);\n int64_t shift = ((Integer *)shift_4)->numVal;\n dec_and_free(shift_4, 1);\n return(collisionAssoc(node_0, k_1, v_2, hash, shift));\"))\n\n (dissoc* [node k hash shift]\n (inline C HashCollisionNode \"\n int64_t hash = ((Integer *)hash_2)->numVal;\n dec_and_free(hash_2, 1);\n int64_t shift = ((Integer *)shift_3)->numVal;\n dec_and_free(shift_3, 1);\n return(collisionDissoc(node_0, k_1, hash, shift));\"))\n\n (get* [node k v hash shift]\n (inline C \"\n int64_t hash = ((Integer *)hash_3)->numVal;\n dec_and_free(hash_3, 1);\n int64_t shift = ((Integer *)shift_4)->numVal;\n dec_and_free(shift_4, 1);\n return(collisionGet(node_0, k_1, v_2, hash, shift));\")))\n\n(defn dissoc [m & ks]\n ;; Create a new copy of `m` without the associations of `ks`\n (reduce ks m (fn [m k]\n ;; TODO: make inline fn that uses nakedSha1\n (dissoc* m k (sha1 k) 0))))\n\n(defn assoc-all [m & kv-pairs]\n ;; Create a new copy of `m` that adds an association for all the key/value pairs\n ;; ex. (assoc {'a 1} 'b 2 'c 3 'd 4)\n (reduce (partition kv-pairs 2) m (fn [m [k v]]\n (assoc m k v))))\n\n(defn spaces [n]\n (assert (instance? Integer n))\n (to-str (map (range n) (fn [_] \" \"))))\n\n(defn show-kv [[k v] indent]\n (let [k-str (apply str (show* k indent))]\n (comp (list k-str \" \")\n (show* v (comp indent (spaces (+ 2 (count k-str))))))))\n\n(def HashMap (any-of HashCollisionNode\n ArrayNode\n BitmapIndexedNode))\n\n(extend-type HashMap\n Type\n (type-name [_] \"HashMap\")\n\n Composition\n (zero [_] emptyBMI)\n (comp* [mval mvals]\n (reduce mvals mval\n (fn [acc mval]\n (reduce (vec mval) acc\n (fn [acc [k v]]\n (assoc acc k v))))))\n\n Collection\n (empty? [x]\n (and (= 0 (count x))\n (maybe emptyBMI)))\n\n Stringable\n (string-list [n]\n (let [kv-strs (map (seq n) (fn [[k v]]\n (comp (string-list k) (list \" \") (string-list v))))]\n (comp (list \"{\")\n (flatten (interpose kv-strs (list \", \")))\n (list \"}\"))))\n\n (show* [m indent]\n (either (map (empty? m) string-list)\n (let [[h & tail] (seq m)]\n (comp (cons \"{\" (show-kv h indent))\n (flat-map tail (fn [kv]\n (list* \",\\n\" indent \" \"\n (show-kv kv indent))))\n (list \"}\")))))\n\n Hashable\n (sha1-update [x ctxt]\n (sha1-update-type x ctxt)\n (-> (vec x)\n (sort (fn [[k v]] k))\n (reduce ctxt (fn [ctxt x]\n (sha1-update x ctxt)))))\n\n (sha1 [v]\n (let [ctxt (sha1-init)]\n (sha1-update v ctxt)\n (sha1-finalize ctxt)))\n\n Seqable\n (seq [n]\n ;; TODO: remove this impl\n (hash-seq n empty-list))\n\n (vec [m]\n (hash-vec m []))\n\n Eq\n (=* [x y]\n (and (instance? HashMap y)\n (= (count x) (count y))\n (every (seq x) (fn [[k v]]\n (flat-map (get y k)\n (partial = v))))\n (maybe x)))\n\n HashMapNode\n (hash-vec [m s]\n (inline C (vector-of Vector) \"return(hashVec(m_0, s_1));\"))\n\n Associative\n (assoc [m k v]\n (inline C \"return(mutateAssoc(m_0, k_1, v_2, nakedSha1(incRef(k_1, 1)), 0));\"))\n\n (keys [m]\n (map (seq m) (fn [[k v]] k)))\n (vals [m]\n (map (seq m) (fn [[k v]] v)))\n (get [m k]\n (inline C Maybe \"return(hashMapGet(m_0, k_1));\"))\n (get [m k not-found]\n (either (get m k)\n not-found)))\n\n(defn hash-map [& kv-pairs]\n ;; create a hash-map from a number of key/value pairs\n (assert-result x (instance? HashMap x))\n (reduce (partition kv-pairs 2)\n emptyBMI\n (fn [m [k v]]\n (assoc m k v))))\n\n(defn filter-keys [m f]\n ;; create a new hash-map from `m` that only contains key/value pairs\n ;; where applying `f` to the key does not return `nothing`\n (assert-result x (instance? HashMap x))\n (reduce (seq m) {}\n (fn [m [k v]]\n (either (map (f k) (fn [_] (assoc m k v)))\n m))))\n\n(defn remove-keys [m f]\n ;; create a new hash-map from `m` that only contains key/value pairs\n ;; where applying `f` to the key returns `nothing`\n (assert-result x (instance? HashMap x))\n (reduce (seq m) {}\n (fn [m [k v]]\n (either (map (f k) (fn [_] m))\n (assoc m k v)))))\n\n(defn map-vals [m f]\n ;; create a new hash-map from `m` with `f` applied to each value\n (assert-result x (instance? HashMap x))\n (reduce (seq m) {}\n (fn [m [k v]]\n (assoc m k (f v)))))\n\n(defn contextual-map-vals [m f embed]\n (-> m\n vec\n (map (fn [[k v]]\n (map (map v f embed)\n (partial vector k)))\n embed)\n (map (fn [kv-pairs]\n (reduce kv-pairs {}\n (fn [m [k v]]\n (assoc m k v)))))))\n\n(defn get-in* [m path]\n (assert (instance? List path))\n ;; TODO: try alternate formulation\n ;; probably works but not any faster\n ;; (or (flat-map (first path)\n ;; (fn [k]\n ;; (flat-map (get m k)\n ;; (fn [sub-m] \n ;; (get-in* sub-m (rest path))))))\n ;; (and (empty? path)\n ;; (maybe m)))\n\n ;; this seems to work, I think can be optimized more\n ;; probably hard to gain perf, though\n (or (and (empty? path)\n (maybe m))\n (let [[k & tail] path]\n (flat-map (get m k)\n (fn [sub-m]\n (get-in* sub-m tail)))))\n\n ;; (or (and (empty? path)\n ;; (maybe m))\n ;; (for [k (first path)\n ;; sub-m (get m k)\n ;; v (get-in* sub-m (rest path))]\n ;; v))\n )\n\n(defn get-in [m path]\n (and (< 0 (count path))\n (get-in* m (seq path))))\n\n(defn update-in [m path f]\n (or (and (empty? path)\n (maybe m))\n (and (= 1 (count path))\n (for [k (first path)\n v (get m k)]\n (assoc m k (f v))))\n (for [k (first path)\n sub-m (get m k)\n new-m (update-in sub-m (rest path) f)]\n (assoc m k new-m))))\n\n;; TODO: make this a protocol fn and implement for getters automatically\n(defn update [m key f]\n (map (get m key)\n (fn [v]\n (assoc m key (f v)))))\n\n(defn assoc-in* [m path v]\n (assert (instance? List path))\n (or (and (empty? path)\n (maybe m))\n (for [_ (= 1 (count path))\n k (first path)]\n (assoc m k v))\n (for [k (first path)\n sub-m (or (get m k)\n (maybe {}))\n new-m (assoc-in* sub-m (rest path) v)]\n (assoc m k new-m))))\n\n(defn assoc-in [m path v]\n (extract (assoc-in* m (seq path) v)))\n\n(defn merge-with [merge-fn hm & ms]\n (reduce ms hm\n (fn [hm m]\n (reduce (seq m) hm\n (fn [hm [k v]]\n (either (map (get hm k)\n (fn [old-v]\n (let [new-v (merge-fn old-v v)]\n (-> hm\n (dissoc k)\n (assoc k new-v)))))\n (assoc hm k v)))))))\n\n(defn merge-maps [merge-fn ms]\n (reduce ms {}\n (fn [hm m]\n (reduce (seq m) hm\n (fn [hm [k v]]\n (either (map (get hm k)\n (fn [old-v]\n (let [new-v (merge-fn old-v v)]\n (-> hm\n (dissoc k)\n (assoc k new-v)))))\n (assoc hm k v)))))))\n\n\n(defn add-promise-action [p f]\n (assert (instance? Promise p))\n (inline C Promise \"return(addPromiseAction((Promise *)p_0, f_1));\"))\n\n(defn promise\n ([] (inline C Promise \"return((Value *)malloc_promise());\\n\"))\n ([v] (deliver (promise) v)))\n\n(extend-type Promise\n Type\n (type-name [_] \"Promise\")\n\n Stringable\n (string-list [p]\n (either (map (delivered p) (fn [x]\n (list \"\")))\n (list \"\")))\n\n (show* [p indent]\n (either (for [x (delivered p)]\n (comp (list* \"\")))\n (list \"\")))\n\n Composition\n (comp* [p ps]\n (let [new-p (promise)\n f (fn [x] (deliver new-p x))]\n (map (cons p ps) (fn [p]\n (add-promise-action p f)))\n new-p))\n\n Container\n (extract [prom]\n (inline C \"return(extractPromise(prom_0));\"))\n\n (map [p f]\n (let [new-p (promise)]\n (add-promise-action p (fn [x]\n (deliver new-p (f x))))\n new-p))\n\n (wrap [_ v] (promise v))\n\n (apply [p-f p-vs]\n (let [new-p (promise)\n p-vlist (reduce (reverse p-vs) (promise empty-list)\n (fn [p-list p-v]\n (flat-map p-list (fn [l]\n (map p-v (fn [v]\n (cons v l)))))))]\n (add-promise-action p-vlist (fn [vs]\n (deliver new-p (apply (extract p-f) vs))))\n new-p))\n\n (flat-map [p f]\n (let [new-p (promise)]\n (add-promise-action p (fn [x]\n (add-promise-action (f x) (fn [y]\n (deliver new-p y)))))\n new-p)))\n\n\n(defn future\n ([] (inline C Future \"return(makeFuture((Value *)0));\"))\n ([f] (inline C Future \"return(makeFuture(f_0));\")))\n\n(defn thread-id []\n (inline C Integer \"return(integerValue((int64_t)pthread_self()));\"))\n\n(defn deliver-future [fut val]\n (assert (instance? Future fut))\n (inline C Future \"return(deliverFuture(fut_0, val_1));\"))\n\n(defn add-future-action [fut f]\n (assert (instance? Future fut))\n (inline C Future \"return(addFutureAction((Future *)fut_0, f_1));\"))\n\n(extend-type Future\n Type\n (type-name [_] \"Future\")\n\n Stringable\n (string-list [_] (list \"\"))\n\n (show* [p indent]\n (string-list p))\n\n Eq\n (=* [x y]\n (identical x y))\n\n Composition\n (comp* [p ps]\n (let [new-p (future)\n f (fn [x] (deliver-future new-p x))]\n (map (cons p ps) (fn [p]\n (add-future-action p f)))\n new-p))\n\n Container\n (map [fut f]\n (let [new-fut (future)]\n (add-future-action fut (fn [x]\n (deliver-future new-fut (f x))))\n new-fut))\n\n (wrap [_ v]\n (deliver-future (future) v))\n\n (apply [fut-f fut-vs]\n (let [new-fut (future)\n fut-vlist (reduce (reverse fut-vs) (deliver-future (future) empty-list)\n (fn [fut-list fut-v]\n (flat-map fut-list (fn [l]\n (map fut-v (fn [v]\n (cons v l)))))))]\n (add-future-action fut-vlist (fn [vs]\n (deliver-future new-fut (apply (extract fut-f) vs))))\n new-fut))\n\n (flat-map [fut f]\n (let [new-fut (future)]\n (add-future-action fut (fn [x]\n (add-future-action (f x) (fn [y]\n (deliver-future new-fut y)))))\n new-fut))\n\n (extract [fut]\n (inline C \"return(extractFuture(fut_0));\"))\n\n (extend [fut f]\n (future (fn []\n (f fut)))))\n\n\n(extend-type Agent\n Type\n (type-name [_] \"Agent\")\n\n Eq\n (=* [x y]\n nothing)\n\n Stringable\n (string-list [a]\n (list \"\"))\n\n (show* [a indent]\n (comp (cons \" int-str\n (take-while (fn [c]\n (<= code-0 (char-code c) code-9)))\n (reduce 0 (fn [n c]\n (+ (* n 10) (- (char-code c) code-0))))))))\n\n(deftype HashSet [set-map]\n (assert (instance? HashMap set-map))\n\n Stringable\n (string-list [_]\n (comp (list \"#{\")\n (interpose (flat-map (vals set-map) string-list)\n \" \")\n (list \"}\")))\n\n Function\n (invoke [_ v]\n (get set-map v))\n\n Hashable\n (sha1-update [x ctxt]\n (sha1-update-type x ctxt)\n (-> (vec set-map)\n (sort (fn [[k v]] k))\n (reduce ctxt (fn [ctxt x]\n (sha1-update x ctxt)))))\n\n (sha1 [s]\n (let [ctxt (sha1-init)]\n (sha1-update s ctxt)\n (sha1-finalize ctxt)))\n\n Associative\n (get [m k]\n (get set-map k))\n\n Collection\n (empty? [coll]\n (and (empty? set-map)\n (maybe coll)))\n (empty [coll]\n (HashSet {}))\n (count [coll]\n (count set-map))\n (conj [coll value]\n (HashSet (assoc set-map value value)))\n (reduce [coll result f]\n (reduce (vals set-map) result f))\n\n Composition\n (zero [_]\n (HashSet {}))\n (comp* [mval mvals]\n (HashSet (comp* set-map (map mvals .set-map))))\n\n Container\n (flat-map [mval func]\n (HashSet (comp* {} (map (vals set-map)\n (fn [v]\n (.set-map (func v)))))))\n (wrap [x v]\n (HashSet {v v}))\n\n (map [v f]\n (HashSet (reduce (vals set-map)\n {}\n (fn [m v]\n (let [new-v (f v)]\n (assoc m new-v new-v))))))\n\n Seqable\n (vec [coll]\n (vec (vals set-map)))\n\n (seq [coll]\n (vals set-map)))\n\n(defn set [val-list]\n (HashSet (reduce val-list {} (fn [m v] (assoc m v v)))))\n\n(defn hash-set [& values]\n (set values))\n\n(defn new-hash-set [hash-map]\n (assert (instance? HashMap hash-map))\n\n (HashSet hash-map))\n\n(defn disj [set val]\n (assert (instance? HashSet set))\n (HashSet (dissoc (.set-map set) val)))\n\n(defn subset [super sub]\n (assert (instance? HashSet super))\n (assert (instance? HashSet sub))\n (map (every (keys (.set-map sub))\n (partial get super))\n (fn [_] sub)))\n\n(defn union [set1 set2]\n (assert (instance? HashSet set1))\n (assert (instance? HashSet set2))\n (reduce (keys (.set-map set2)) set1 conj))\n\n(defn intersection [set1 & sets]\n (assert (instance? HashSet set1))\n (assert (instance? (list-of HashSet) sets))\n\n (reduce sets set1 (fn [set1 set2]\n (reduce (keys (.set-map set2)) #{}\n (fn [inter x]\n (either (map (set1 x) (partial conj inter))\n inter))))))\n\n(defn difference [set1 set2]\n (assert (instance? HashSet set1))\n (assert (instance? HashSet set2))\n (reduce (keys (.set-map set1)) #{}\n (fn [diff x]\n (cond (get (.set-map set2) x)\n diff\n\n (conj diff x)))))\n\n(defn select-keys [m ks]\n (filter-keys m (set ks)))\n\n\n(defn integer-gen [x]\n (inline C \"\n if (x_0->type != IntegerType) {\n fprintf(stderr, \\\"Invalid argument passed to 'integer-gen'\\\\n\\\");\n abort();\n }\n intGenerator *intGen = (intGenerator *)my_malloc(sizeof(intGenerator));\n#ifdef CHECK_MEM_LEAK\n incTypeMalloc(14, 1);\n#endif\n intGen->sym_counter = ((Integer *)x_0)->numVal;\n dec_and_free(x_0, 1);\n return((Value *)opaqueValue((void *)intGen, freeIntGenerator));\n\"))\n\n(defn new-int [gen]\n (inline C Integer \"\n intGenerator *gen = (intGenerator *)((Opaque *)gen_0)->ptr;\n dec_and_free(gen_0, 1);\n return(integerValue(gen->sym_counter++));\n\"))\n\n(deftype IntGenerator [gen]\n Seqable\n (rest [x]\n x)\n\n Container\n (extract [_]\n (new-int gen)))\n\n(defn int-generator\n ([] (int-generator 0))\n ([x] (IntGenerator (integer-gen x))))\n\n(def sym-counter (int-generator))\n\n(defn gensym [prefix]\n (assert (instance? String prefix))\n ;; TODO: make sure the call to 'extract' is type-known\n (symbol (str prefix (extract sym-counter))))\n\n\n(defn create-lazy []\n ;; private function used for implementing LazyList\n (inline C \"\n extractCache *newCache = (extractCache *)my_malloc(sizeof(extractCache));\n#ifdef CHECK_MEM_LEAK\n incTypeMalloc(14, 1);\n#endif\n newCache->tail = malloc_list();\n pthread_mutex_init(&newCache->access, NULL);\n return((Value *)opaqueValue((void *)newCache, freeExtractCache));\n\"))\n\n(defn get-lazy [lazy-struct]\n ;; private function used for implementing LazyList\n (inline C List \"\n extractCache *cache = (extractCache *)((Opaque *)lazy_struct_0)->ptr;\n incRef((Value *)cache->tail, 1);\n dec_and_free(lazy_struct_0, 1);\n return((Value *)cache->tail);\n\"))\n\n(defn first-lazy [lazy tail]\n (assert (instance? List lazy))\n ;; private function used for implementing LazyList\n (inline C Maybe \"\n List *cache = (List *)lazy_0;\n extractCache *tail = (extractCache *)((Opaque *)tail_1)->ptr;\n if (cache->head == (Value *)0) {\n pthread_mutex_lock(&tail->access);\n if (cache->head == (Value *)0) {\n // leave the mutex locked and return nothing\n dec_and_free(lazy_0, 1);\n dec_and_free(tail_1, 1);\n return(nothing);\n } else {\n// TODO: untested code path\nfprintf(stderr, \\\"first-lazy 4\\\\n\\\");\nabort();\n pthread_mutex_unlock(&tail->access);\n incRef(cache->head, 1);\n dec_and_free(lazy_0, 1);\n dec_and_free(tail_1, 1);\n return(maybe((FnArity *)0, (Value *)0, cache->head));\n }\n } else {\n Value *head = cache->head;\n incRef(head, 1);\n dec_and_free(lazy_0, 1);\n dec_and_free(tail_1, 1);\n return(maybe((FnArity *)0, (Value *)0, head));\n }\n\"))\n\n(defn append-to-lazy-tail [tail value]\n ;; private function used for implementing LazyList\n (inline C Maybe \"\n extractCache *cacheTail = (extractCache *)((Opaque *)tail_0)->ptr;\n cacheTail->tail->head = value_1;\n cacheTail->tail->tail = malloc_list();\n List *original = cacheTail->tail;\n cacheTail->tail = cacheTail->tail->tail;\n incRef((Value *)cacheTail->tail, 1);\n dec_and_free(tail_0, 1);\n dec_and_free((Value *)original, 1);\n pthread_mutex_unlock(&cacheTail->access);\n return(nothing);\n\"))\n\n(defn rest-of-lazy [lazy]\n (assert (instance? List lazy))\n ;; private function used for implementing LazyList\n (inline C List \"\n List *cache = (List *)lazy_0;\n Value *result;\n result = (Value *)cache->tail;\n incRef(result, 1);\n dec_and_free(lazy_0, 1);\n return(result);\n\"))\n\n(deftype LazyList [container lazy tail]\n (assert (instance? List lazy))\n\n Stringable\n (string-list [_] (list \"\"))\n\n Collection\n (empty? [_]\n (empty? container))\n\n Seqable\n (first [c]\n ;; 'first-lazy' leaves the mutex locked if the lazy list remains empty\n ;; after acquiring it. 'append-to-lazy' then frees it\n (or (first-lazy lazy tail)\n (maybe (let [v (extract container)]\n (append-to-lazy-tail tail v)\n v))))\n\n (rest [c]\n ;; make sure that there's at least one item in the lazy list\n (first c)\n (LazyList container (rest-of-lazy lazy) tail)))\n\n(defn lazy-list [container]\n (let [lazy-struct (create-lazy)]\n (LazyList container (get-lazy lazy-struct) lazy-struct)))\n\n(defn null-term [s]\n (assert (instance? String s))\n (inline C StringBuffer \"return((Value *)nullTerm(s_0));\\n\"))\n\n(defn list-zipper [lists zipped]\n (assert (instance? List zipped))\n\n (either (or (and (empty? lists)\n (maybe zipped))\n (map (every lists first)\n (fn [firsts]\n (list-zipper (map lists rest) (cons firsts zipped)))))\n (reverse zipped)))\n\n(defn zip-lists [l & lists]\n (list-zipper (cons l lists) empty-list))\n\n(extend-type String\n Seqable\n (take [coll n]\n (let [[prefix _] (split coll n)]\n prefix))\n\n (drop [coll n]\n (let [[_ tail] (split coll n)]\n tail))\n\n (drop-while [coll pred]\n (let [[_ tail] (split-with coll pred)]\n tail))\n\n (take-while [coll pred]\n (let [[prefix _] (split-with coll pred)]\n prefix)))\n\n(def CoreTypes (any-of Integer\n String\n Symbol\n Maybe\n List\n Vector\n HashMap\n Fn\n Promise\n Agent\n Future))\n\n(defn pr-value [x]\n (print-err x))\n\n;; (defprotocol CoreTestProto\n;; (test-proto [x y]\n;; (assert (instance? Integer x))\n;; (assert (instance? String y))\n\n;; (str (inc x) (subs y 1))))\n\n;; (extend-type HashMap\n;; CoreTestProto\n;; (test-proto [m y]\n;; (assert (instance? Integer y))\n;; (print-err 'y y)))\n" }, { "path": "ebnf.md", "content": "\nlinear-whitespace = ',' | ' ' | '\\t';\n\nnewline = '\\n';\n\nwhitespace = linear-whitespace | '\\r' | newline;\n\nopen-paren = { whitespace }, '(', { whitespace };\n\nlower-alpha = 'a' - 'z';\n\nupper-alpha = 'A' - 'Z';\n\nalpha = lower-alpha | upper-alpha;\n\ndigit = '0' - '9';\n\nnamespace-punct = '.' | '_' | '<' | '>' | '=' | '*' | '+' | '!' | '-' | '?';\n\nrest-of-namespace = { alpha | digit | namespace-punct };\n\nnamespace = alpha, rest-of-namespace, '/';\n\nsymbol-start = alpha | '.' | '_' | '<' | '>' | '=' | '+' | '-' | '*' | '/';\n\nsymbol-punct = '.' | '_' | '<' | '>' | '=' | '+' | '-' | '*' | '/' | '!' | '?';\n\nsymbol-char = alpha | digit | symbol-punct;\n\nrest-of-symbol = { symbol-char };\n\ntagged-symbol = [namespace], symbol-start, rest-of-symbol;\n\narg = { whitespace }, tagged-symbol, { whitespace };\n\nvar-arg = { whitespace }, '&', arg;\n\nlist-destructure = { whitespace }, '[', { destructure }, var-arg | , ']';\n\nclose-paren = { whitespace }, ')';\n\ntype-assertion = open-paren, { whitespace }, 'instance?', whitespace, { whitespace }, tagged-symbol, whitespace, { whitespace }, tagged-symbol, close-paren;\n\nnumber = digit, { digit } | '-', digit, { digit };\n\nassert = open-paren, 'assert', whitespace, { whitespace }, type-assertion | type-assertion, close-paren;\n\nassert-result = open-paren, 'assert-result', whitespace, { whitespace }, tagged-symbol, whitespace, { whitespace }, type-assertion, close-paren;\n\nnot-eol = not '\\n';\n\nblock-comment = { whitespace }, ';', { ';' }, { not-eol }, newline, { { whitespace }, ';', { ';' }, { not-eol }, newline };\n\nread-string-fragment = (* not '\"' or '\\' *)\n\nbackslash = '\\\\', '\\\\';\n\ndoublequote = '\\\\', '\\\"';\n\ntab = '\\\\', 't';\n\nbackspace = '\\\\', 'b';\n\nreturn = '\\\\', 'r';\n\nformfeed = '\\\\', 'f';\n\nstring = '\\\"', { read-string-fragment | backslash | doublequote | tab | backspace | return | formfeed | newline }, '\\\"';\n\nread-inline = open-paren, 'inline', whitespace, { whitespace }, tagged-symbol, whitespace, { whitespace }, [tagged-symbol, whitespace, { whitespace }], string, close-paren;\n\nread-inline-body = { assert | assert-result | block-comment }, { whitespace }, read-inline, { block-comment };\n\n\\_FILE\\_ = { whitespace }, '\\_FILE\\_';\n\n\\_LINE\\_ = { whitespace }, '\\_LINE\\_';\n\nquoted-value = { whitespace }, open-paren, { quoted-value }, close-paren | '[', quoted-value, { quoted-value }, ']' | number | string | tagged-symbol, { whitespace };\n\nquoted = ''', quoted-value;\n\nor = open-paren, 'or', whitespace, { whitespace }, expr, { expr }, close-paren;\n\nand = open-paren, 'and', whitespace, { whitespace }, expr, { expr }, close-paren;\n\neither = open-paren, 'either', whitespace, { whitespace }, expr, expr, close-paren;\n\nfn-doc = block-comment | ;\n\nsingle-arity = list-destructure, fn-doc, read-inline-body | expr, { expr } | , { whitespace };\n\narities = single-arity | fn-doc, open-paren, single-arity, close-paren, { open-paren, single-arity, close-paren };\n\nfn = open-paren, 'fn', whitespace, { whitespace }, [tagged-symbol], { whitespace }, arities, close-paren | ;\n\ndestructure = list-destructure | arg;\n\nlet-binding = { whitespace }, [block-comment], { whitespace }, destructure, expr;\n\nlet = open-paren, 'let', { whitespace }, '[', let-binding, { let-binding }, ']', expr, { expr }, close-paren | ;\n\ndo = open-paren, 'do', whitespace, { whitespace }, expr, { expr }, close-paren;\n\ncomp = '(', { whitespace }, 'comp', whitespace, { whitespace }, expr, { expr }, { whitespace }, ')' | ;\n\napply = '(', { whitespace }, 'apply', whitespace, { whitespace }, expr, { expr }, { whitespace }, ')' | ;\n\napply-to = '(', { whitespace }, 'apply-to', whitespace, { whitespace }, expr, expr, { expr }, { whitespace }, ')' | ;\n\nprotocol-implementation = open-paren, tagged-symbol, single-arity, close-paren;\n\nprotocol-implementations = { whitespace }, tagged-symbol, protocol-implementation, { protocol-implementation } | assert | block-comment;\n\nreify = open-paren, 'reify', whitespace, { whitespace }, protocol-implementations, { protocol-implementations }, close-paren;\n\nvector = '[', { expr }, ']' | ;\n\nhash-map = '{', { expr, expr }, '}' | ;\n\nhash-set = '#{', { expr }, '}' | ;\n\nfor-let = { whitespace } | block-comment, ':let', whitespace, { whitespace }, '[', let-binding, { let-binding }, ']', { whitespace };\n\nfor-when = { whitespace } | block-comment, ':when', whitespace, { whitespace }, expr;\n\nfor-when-not = { whitespace } | block-comment, ':when-not', whitespace, { whitespace }, expr;\n\nfor-binding = for-let | for-when | for-when-not | let-binding | block-comment, { whitespace };\n\nfor = open-paren, 'for', whitespace, { whitespace }, '[', let-binding | , { for-binding } | , ']', expr | | , close-paren;\n\ncall = open-paren, expr, { expr }, close-paren;\n\n->exp = tagged-symbol | call, { whitespace };\n\n-> = open-paren, '->', expr, ->exp, { ->exp } | , close-paren;\n\nexpr = { whitespace }, number | string | _FILE_ | _LINE_ | tagged-symbol | quoted | or | and | either | fn | let | do | comp | apply | apply-to | reify | vector | hash-map | hash-set | for | -> | assert | assert-result | read-inline | call | block-comment, { whitespace };\n\nmain = open-paren, 'main', list-destructure, read-inline-body | expr, { expr } | , close-paren | ;\n\ndef = open-paren, 'def', whitespace, { whitespace }, tagged-symbol, whitespace, { whitespace }, { block-comment }, read-inline | expr, { whitespace }, { block-comment }, close-paren | tagged-symbol, close-paren | ;\n\nprototype = assert | open-paren, tagged-symbol, list-destructure, fn-doc, read-inline-body | { expr }, close-paren | ;\n\ndefprotocol = open-paren, 'defprotocol', whitespace, { whitespace }, tagged-symbol, block-comment | prototype, { block-comment | prototype }, close-paren | ;\n\ndefn = open-paren, 'defn', whitespace, { whitespace }, tagged-symbol, whitespace, { whitespace }, arities, close-paren | ;\n\nextend-type = open-paren, 'extend-type', whitespace, { whitespace }, tagged-symbol, protocol-implementations, { protocol-implementations }, close-paren | ;\n\ndeftype = open-paren, 'deftype', whitespace, { whitespace }, tagged-symbol, list-destructure, { protocol-implementations }, close-paren | ;\n\nmodule = open-paren, 'module', whitespace, { whitespace }, string, close-paren | ;\n\ngit-kwargs = { whitespace, { whitespace }, ':', 'tag', whitespace, { whitespace }, string | whitespace, { whitespace }, ':', 'sha', whitespace, { whitespace }, string | whitespace, { whitespace }, ':', 'branch', whitespace, { whitespace }, string };\n\ngit-dep = open-paren, 'git-dependency', whitespace, { whitespace }, string, whitespace, { whitespace }, string, git-kwargs, close-paren | ;\n\nadd-ns = open-paren, 'add-ns', whitespace, { whitespace }, tagged-symbol, module | git-dep, close-paren | ;\n\nbad-expr = { whitespace }, '(';\n\ntop-level = main | read-inline | def | defprotocol | defn | extend-type | deftype | block-comment | add-ns | bad-expr;" }, { "path": "em-run", "content": "#!/bin/bash\n\nrm $1.out $1.tmp\n$TOCCATA_DIR/new-toc $1 > $1.tmp &&\nawk '/^#$/ { printf \"#line %d \\\"%s\\\"\\n\", NR+1, \"m.c\"; next; } { print; }' $1.tmp > m.c &&\n$EMSCRIPTEN/emcc -I$TOCCATA_DIR\\\n $TOCCATA_DIR/core.c\\\n -O1\\\n -DTOCCATA_WASM=1\\\n m.c\\\n -s ALLOW_MEMORY_GROWTH=1\\\n -s ASSERTIONS=1\\\n -s WASM=1\\\n -o $1.js &&\nnode $1.js\n\n# ./$1.out \"${@:2}\"\n\n# $CC -g -fno-objc-arc -o m -I$TOCCATA_DIR -std=c99 -DCHECK_MEM_LEAK=1 $TOCCATA_DIR/core.c m.c -lpthread && ./m\n# $CC -g -fno-objc-arc -o new-toc -I$TOCCATA_DIR -std=c99 -DCHECK_MEM_LEAK=1 $TOCCATA_DIR/core.c new-toc.c -lpthread\n\n" }, { "path": "examples/apply-maybe.toc", "content": "\n(main [_]\n (println \"apply '+':\" (apply (maybe +) (maybe 3) (maybe 4)))\n (let [x 3]\n (println \"apply-to '+':\" (apply-to + (= 3 x) (maybe 4)))\n (println \"apply-to nothing:\" (apply-to + (= 0 x) (maybe 4)))))\n" }, { "path": "examples/apply-vector.toc", "content": "\n(main [_]\n (println \"apply-to []:\" (apply-to inc []))\n (println \"map [1 2 3]:\" (map [1 2 3] inc))\n (println \"apply-to [1 2 3]:\" (apply-to inc [1 2 3]))\n (println \"apply-to 2 vectors:\" (apply-to + [1 2 3] [10 30]))\n (println \"apply-to an empty vector:\" (apply-to + [1 2 3] [] [10 20 30])))\n" }, { "path": "examples/config-file.toc", "content": "\n(add-ns rd (git-dependency \"https://github.com/Toccata-Lang/recursive-descent.git\"\n \"recursive-descent.toc\"\n :sha \"c89ab00\"))\n(add-ns grmr (git-dependency \"https://github.com/Toccata-Lang/grammar.git\"\n \"grammar.toc\"\n :sha \"7690cd3\"))\n(add-ns fio (git-dependency \"https://github.com/Toccata-Lang/file-io.git\"\n \"file-io.toc\"\n :sha \"e7a489b\"))\n\n(def whitespace (grmr/one-or-more (grmr/any \" \"\n \"\\t\")))\n\n(def newline \"\\n\")\n\n(def empty-line (grmr/all (grmr/optional whitespace)\n newline))\n\n(def not-newline (grmr/not-char \"\\n\"))\n\n(def comment (grmr/all (grmr/optional whitespace)\n \"#\"\n (grmr/none-or-more not-newline)\n newline))\n\n(def name (map (grmr/one-or-more (grmr/any grmr/alpha\n \"-\"))\n to-str))\n\n(def integer-value (map (grmr/one-or-more grmr/digit)\n (fn [digits]\n (str-to-int (to-str digits)))))\n\n(def string-value (grmr/apply-fn to-str\n (grmr/ignore \"\\\"\")\n (grmr/none-or-more (grmr/not-char \"\\\"\"))\n (grmr/ignore \"\\\"\")))\n\n(def config-line (grmr/apply-fn hash-map\n (grmr/ignore (grmr/optional whitespace))\n name\n (grmr/ignore whitespace)\n (grmr/any integer-value\n string-value)\n (grmr/ignore (grmr/optional whitespace))\n (grmr/ignore newline)))\n\n(defn ignore [g]\n (map g (fn [_] {})))\n\n(def config-file (map (grmr/none-or-more (grmr/any (ignore comment)\n config-line\n (ignore empty-line)))\n (fn [config-lines]\n (comp* {} config-lines))))\n\n(def parser (rd/parser config-file))\n\n(main [_]\n (for [config-map (parser (fio/slurp \"config.txt\"))]\n (map (seq config-map) (fn [[name value]]\n (println (str name \":\") value)))))\n" }, { "path": "examples/debugging.toc", "content": "\n(defn foo [x y z]\n (+ 3\n (+ y x)))\n\n(main [args]\n (println 'args args)\n (foo 1 2 3)\n (println 'done 'again))\n" }, { "path": "examples/flat-map-list.toc", "content": "\n(main [_]\n (println (map (list 15 99 24)\n (fn [x]\n (list (inc x)))))\n (println \"flat-map list\" (flat-map (list 15 99 24)\n (fn [x]\n (list (inc x)))))\n (println \"flat-map empty list\" (flat-map (list)\n (fn [x]\n (list (inc x)))))\n (println \"flat-map empty lists\" (flat-map (list 1 2 3)\n (fn [x]\n (list))))\n (println \"for\" (for [x (list 15 99 24)]\n (inc x))))\n" }, { "path": "examples/flat-map-maybe.toc", "content": "\n(main [_]\n (println (first (list 15 99 24)))\n (println (map (first (list 15 99 24))\n (fn [x]\n (= 15 x))))\n (println \"first = 15\" (flat-map (first (list 15 99 24))\n (fn [x]\n (= 15 x))))\n (println \"flat-map nothing\" (flat-map (first (list))\n (fn [x]\n (= 15 x))))\n (println \"first not = 15\" (flat-map (first (list 1 2 3))\n (fn [x]\n (= 15 x))))\n (println \"for\" (for [head (first (list 15 99 24))]\n (inc head))))\n" }, { "path": "examples/greeting.toc", "content": "\n(def greetings {\"Jim\" \"Howdy\"\n \"Frank\" \"Hello\"\n \"Maria\" \"Bonjour\"\n \"Tina\" \"Beautiful\"\n \"Human\" \"Greetings\"})\n\n(main [args]\n (let [maybe-name (second args)]\n (println (either (or (for [name maybe-name\n salutation (get greetings name)]\n (str salutation \", \" name))\n (map maybe-name\n (fn [name]\n (str \"Howdy, \" name))))\n \"Howdy, Folks\"))))\n" }, { "path": "examples/howdy.toc", "content": "\n(main [args]\n (println \"Howdy,\" (either (second args)\n \"Folks\")))\n" }, { "path": "examples/json-ebnf.toc", "content": "\n;; A simple (and not quite complete) JSON parser\n\n(add-ns ebnf (git-dependency \"https://github.com/Toccata-Lang/ebnf.git\"\n \"ebnf.toc\"\n :sha \"359e84b\"))\n(add-ns json (module \"json.toc\"))\n\n(main [_]\n (println (ebnf/produce-ebnf json/value)))\n\n" }, { "path": "examples/json-graph.toc", "content": "\n(add-ns gg (git-dependency \"https://github.com/Toccata-Lang/grammar-graph.git\"\n \"grammar-graph.toc\"\n :sha \"ebd437c\"))\n(add-ns json (module \"json.toc\"))\n\n(main [_]\n (gg/produce-graph json/value))\n\n" }, { "path": "examples/json-parser.toc", "content": "\n(add-ns rd (git-dependency \"https://github.com/Toccata-Lang/recursive-descent.git\"\n \"recursive-descent.toc\"\n :sha \"c89ab00\"))\n(add-ns json (module \"json.toc\"))\n\n(def parser (rd/parser json/value))\n\n(main [_]\n (println (parser \"\n[1,2 , 3]\n\"))\n (println (parser \" [2 , 3] \"))\n (println (parser \" [ 3 ] \"))\n (println (parser \" [ ] \"))\n (println (parser \" [ [-2 , 3] ] \"))\n (println (parser \" [ [ -3 ] [ 1, 2] ] \"))\n (println (parser \" [ [] {} [] ] \"))\n (println (parser \" { } \"))\n (println (parser \" { \\\"k1\\\" : [ 1, 2 ] }\"))\n (println (parser \" { \\\"k1\\\" : [ 1, 2 ] , \\\"k2\\\": {\\\"a\\\": 8} }\"))\n (println (parser \" { \\\"k1\\\" : \\\"bo\\n\\tgus\\\" , \\\"k2\\\": [\\\"toxic\\\"], \\\"k3\\\": 15 }\"))\n (println (parser \" true \"))\n (println (parser \"false \"))\n (println (parser \" null\")))\n\n" }, { "path": "examples/json.toc", "content": "\n;; A simple (and not quite complete) JSON parser\n\n(add-ns grmr (git-dependency \"https://github.com/Toccata-Lang/grammar.git\"\n \"grammar.toc\"\n :sha \"7690cd3\"))\n\n(def whitespace\n (grmr/recursive-rule \"whitespace\"\n (grmr/none-or-more (grmr/any \" \" \"\\t\" \"\\r\" \"\\n\" \"\\f\"))))\n\n(def integer-value\n (grmr/rule \"integer\"\n (grmr/apply-fn (fn [negate digits]\n (let [magnitude (str-to-int (to-str digits))]\n (either (and negate\n (maybe (* -1 magnitude)))\n magnitude)))\n (grmr/ignore whitespace)\n (grmr/optional \"-\")\n (grmr/one-or-more grmr/digit))))\n\n(defn escaped-char [char result]\n (grmr/apply-fn (fn [& _] result) char))\n\n(def escaped-chars\n (grmr/rule \"escaped chars\"\n (grmr/all \"\\\\\" (grmr/any (escaped-char \"\\\"\" \"\\\"\")\n (escaped-char \"\\\\\" \"\\\\\")\n (escaped-char \"/\" \"/\")\n (escaped-char \"b\" \"\\b\")\n (escaped-char \"f\" \"\\f\")\n (escaped-char \"n\" \"\\n\")\n (escaped-char \"r\" \"\\r\")\n (escaped-char \"t\" \"\\t\")))))\n\n(def string-value\n (grmr/recursive-rule \"string\"\n (grmr/apply-fn identity\n (grmr/ignore whitespace)\n (grmr/apply-fn to-str\n (grmr/ignore \"\\\"\")\n (grmr/none-or-more\n (grmr/any escaped-chars\n (grmr/not-char \"\\\"\")))\n (grmr/ignore \"\\\"\")))))\n\n\n(def value (grmr/recurse \"value\"))\n\n(def comma (grmr/all whitespace \",\" whitespace))\n\n(def array\n (grmr/rule \"array\"\n (grmr/apply-fn (fn [items]\n (either items\n []))\n (grmr/ignore whitespace)\n (grmr/ignore \"[\")\n (grmr/optional\n (grmr/apply-fn (fn [items last-item]\n (conj (flatten items) last-item))\n (grmr/none-or-more (grmr/all value\n (grmr/ignore comma)))\n value))\n (grmr/ignore whitespace)\n (grmr/ignore \"]\"))))\n\n(def colon (grmr/all whitespace \":\" whitespace))\n\n(def key-value-pair (grmr/all string-value\n (grmr/ignore colon)\n value))\n\n(def object\n (grmr/rule \"object\"\n (grmr/apply-fn (fn [kv-pairs]\n (reduce (either kv-pairs [])\n {} (fn [m [k v]]\n (assoc m k v))))\n (grmr/ignore whitespace)\n (grmr/ignore \"{\")\n (grmr/optional\n (grmr/apply-fn (fn [items last-item]\n (conj (flatten items) last-item))\n (grmr/none-or-more (grmr/all key-value-pair\n (grmr/ignore comma)))\n key-value-pair))\n (grmr/ignore whitespace)\n (grmr/ignore \"}\"))))\n\n(def value\n (grmr/recursive-rule \"value\"\n (grmr/any string-value\n integer-value\n object\n array\n (grmr/apply-fn (fn [_ _] (maybe 'true))\n whitespace\n \"true\")\n (grmr/apply-fn (fn [_ _] nothing)\n whitespace\n \"false\")\n (grmr/apply-fn (fn [_ _] 'null)\n whitespace\n \"null\"))))\n\n" }, { "path": "examples/map-maybe.toc", "content": "\n(main [_]\n (println \"map nothing:\" (map nothing inc))\n\n (println \"map (maybe 8) with inc:\" (map (maybe 8) inc)))\n" }, { "path": "examples/map-vector.toc", "content": "\n(main [_]\n (println \"map vector:\" (map [1 2 3] inc)))\n" }, { "path": "examples/number-option.toc", "content": "(add-ns rd (git-dependency \"https://github.com/Toccata-Lang/recursive-descent.git\"\n \"recursive-descent.toc\"\n :sha \"c89ab00\"))\n(add-ns grmr (git-dependency \"https://github.com/Toccata-Lang/grammar.git\"\n \"grammar.toc\"\n :sha \"7690cd3\"))\n\n(defn print-msg [n msg]\n (either (= 0 n)\n (do\n (println msg)\n (print-msg (dec n) msg))))\n\n(def integer (map (grmr/one-or-more grmr/digit)\n (fn [digits]\n (str-to-int (to-str digits)))))\n\n(def name (map (grmr/one-or-more grmr/alpha)\n to-str))\n\n(def parse-and-print (grmr/apply-fn (fn [n name]\n (print-msg n (str \"Hello, \" name)))\n integer\n (grmr/ignore \" \")\n name))\n\n(def parser (rd/parser parse-and-print))\n\n(main [cmd-args]\n (either (-> cmd-args\n rest\n (interpose \" \")\n parser)\n (print-err \"Invalid arguments.\")))\n" }, { "path": "examples/tictactoe.toc", "content": "\n(add-ns w (module \"../wasm-toc/wasm.toc\"))\n(add-ns d (module \"../wasm-toc/dom.toc\"))\n\n(add-ns h (git-dependency \"https://github.com/Toccata-Lang/html-css.git\"\n \"html-css.toc\"\n :sha \"280e508\"))\n\n;; game HTML UI\n\n(def square\n (-> (h/class \"square\")\n (h/background-color (h/hex-color \"fff\"))\n (h/border-width (h/px 1))\n (h/border-style h/solid)\n (h/border-color (h/hex-color \"999\"))\n (h/float h/left)\n (h/font-size (h/px 24))\n (h/font-weight h/bold)\n (h/line-height (h/px 34))\n (h/height (h/px 34))\n (h/margin-right (h/px -1))\n (h/margin-top (h/px -1))\n (h/padding (h/px 0))\n (h/text-align h/center)\n (h/width (h/px 34))))\n\n(def board-row (h/class \"board-row\"))\n\n(defn row [start]\n (h/div (-> (h/button \"X\")\n square\n (h/attr \"onclick\" (str \"move(\" start \")\"))\n (h/attr \"id\" (str \"button\" start)))\n (-> (h/button \"X\")\n square\n (h/attr \"onclick\" (str \"move(\" (+ 1 start) \")\"))\n (h/attr \"id\" (str \"button\" (+ 1 start))))\n (-> (h/button \"X\")\n square\n (h/attr \"onclick\" (str \"move(\" (+ 2 start) \")\"))\n (h/attr \"id\" (str \"button\" (+ 2 start))))))\n\n(def board\n (-> (h/div (row 0)\n (row 3)\n (row 6))\n (h/flex-column)))\n\n(def history-button\n (-> (h/class \"history-button\")\n (h/color h/black)\n (h/background-color h/buttonface)))\n\n(def ol\n (-> (h/class \"ol\")\n (h/padding-left (h/px 10))))\n\n(def body\n (-> (h/class \"body\")\n (h/flex-row)\n (h/justify-content h/center)\n (h/height (h/percent 100))\n (h/font-size (h/px 14))\n (h/font-face \"Century Gothic, Futura, sans-serif\")\n (h/padding-top (h/percent 10))\n (h/margin (h/px 20))))\n\n(def game-info\n (-> (h/div (-> (h/div \"Winner\")\n (h/attr \"id\" \"status\")\n (h/margin-bottom (h/px 10)))\n (-> (apply h/ol (map (range 10) (fn [idx]\n (-> (h/button (either (and (= 0 idx)\n (maybe (str \"Go to game start\")))\n (str \"Go to position #\" idx)))\n (h/attr \"id\" (str \"position\" idx))\n history-button\n (h/attr \"onclick\" (str \"position(\" idx \")\"))))))\n (h/flex-column)))\n (h/margin-left (h/px 20))))\n\n(def game\n (-> (h/div board game-info)\n (h/flex-row)))\n\n;; create the UI\n\n(def create-css-styles\n (map (first (d/get-elements-by-tag-name \"head\"))\n (fn [node]\n (d/append-child node\n (d/inner-html (d/create-node (-> (h/style)\n (h/attr \"type\" \"text/css\")))\n (str \".\" (h/html-str square) \"\\n\"\n \".\" (h/html-str history-button) \"\\n\"\n (h/html-str body) \"\\n\"\n (h/html-str ol)))))))\n\n(def create-board\n (map (first (d/get-elements-by-tag-name \"body\"))\n (fn [node]\n (d/append-child node (d/create-node game)))))\n\n(def create-game-status\n (map (d/get-element-by-id \"status\")\n (fn [node]\n (d/inner-html node \"Next player: X\"))))\n\n\n;; game mechanics\n\n(def empty-board [\"\" \"\" \"\"\n \"\" \"\" \"\"\n \"\" \"\" \"\"])\n\n(deftype GameState [curr-move history winner]\n Stringable\n (string-list [_]\n (let [curr-board (either (get history curr-move)\n [\"-\" \"-\" \"-\"\n \"-\" \"-\" \"-\"\n \"-\" \"-\" \"-\"])]\n (list \"curr-move: \" (str curr-move) \" winner: \" (str winner) \"\\n\"\n \".\" (to-str (take curr-board 3)) \"\\n\"\n \".\" (to-str (take (drop curr-board 3) 3)) \"\\n\"\n \".\" (to-str (drop curr-board 6))))))\n\n(def game-state (agent (GameState 0 [empty-board] \"\")))\n\n(defn check-possible-winner [board a b c]\n (for [a (get board a)\n b (get board b)\n c (get board c)\n result (= a b c)]\n result))\n\n(defn check-winner [board]\n (either (flat-map (or (check-possible-winner board 0 1 2)\n (check-possible-winner board 3 4 5)\n (check-possible-winner board 6 7 8)\n (check-possible-winner board 0 3 6)\n (check-possible-winner board 1 4 7)\n (check-possible-winner board 2 5 8)\n (check-possible-winner board 0 4 8)\n (check-possible-winner board 2 4 6))\n first)\n \"\"))\n\n(defn reset-history [x]\n (map (drop (range 10) (inc x))\n (fn [idx]\n (map (d/get-element-by-id (str \"position\" idx))\n (fn [node]\n (d/set-style-attribute node \"display\" \"none\"))))))\n\n(defn make-move [game-state y]\n (let [curr-move (.curr-move game-state)\n player (either (and (= 0 (rem curr-move 2))\n (maybe \"X\"))\n \"O\")\n next-player (either (and (= \"X\" player)\n (maybe \"O\"))\n \"X\")]\n (either (for [_ (= \"\" (.winner game-state))\n curr-board (get-in game-state [.history curr-move])\n curr-square-value (get curr-board y)\n _ (= \"\" curr-square-value)\n new-board (store curr-board y player)]\n (let [new-history (-> (.history game-state)\n (take (inc curr-move))\n (conj new-board))\n game-state (-> game-state\n (.curr-move (inc curr-move))\n (.history new-history))\n winner (check-winner new-board)]\n (map (d/get-element-by-id \"status\")\n (fn [node]\n (d/inner-html node\n (either (and (= \"\" winner)\n (maybe (str \"Next player: \" next-player)))\n (str \"Winner: \" winner)))))\n (reset-history (inc curr-move))\n (map (range (count new-board)) (fn [idx]\n (map (d/get-element-by-id (str \"button\" idx))\n (fn [node]\n (d/inner-html node (either (get new-board idx)\n \"\"))))))\n (map (d/get-element-by-id (str \"position\" (inc curr-move)))\n (fn [node]\n (d/set-style-attribute node \"display\" \"block\")))\n (GameState (inc curr-move) new-history winner)))\n game-state)))\n\n(defn go-to-position [game-state curr-move]\n (either (map (get-in game-state [.history curr-move])\n (fn [board]\n (let [winner (check-winner board)\n next-player (either (and (= 0 (rem curr-move 2))\n (maybe \"X\"))\n \"O\")]\n (map (d/get-element-by-id \"status\")\n (fn [node]\n (d/inner-html node (either (and (= \"\" winner)\n (maybe (str \"Next player: \" next-player)))\n (str \"Winner: \" winner)))))\n (map (range (count board)) (fn [idx]\n (map (d/get-element-by-id (str \"button\" idx))\n (fn [node]\n (d/inner-html node (either (get board idx)\n \"\"))))))\n (-> game-state\n (.winner winner)\n (.curr-move curr-move)))))\n game-state))\n\n;; possible actions from JavaScript\n\n(defn move [x]\n (send game-state make-move x))\n\n(JS-callable move 1)\n\n(defn position [x]\n (send game-state go-to-position x))\n\n(JS-callable position 1)\n\n(def initialze-game\n (do\n (position 0)\n (reset-history 0)))\n\n(main [_]\n '_)\n" }, { "path": "foundry/docker/Development.docker", "content": "FROM debian:stretch\n\nRUN apt-get update \\\n && apt-get install -y --no-install-recommends \\\n ca-certificates \\\n sudo \\\n curl \\\n git \\\n make \\\n clang-3.9 \\\n llvm-3.9-dev \\\n zlib1g \\\n zlib1g-dev \\\n linux-base \\\n linux-perf-4.9 \\\n procps \\\n lldb-3.9 \\\n gdb \\\n && rm -rf /var/lib/apt/lists*\n\n# Uncomment this when you have a good net connection\nRUN curl -sSL https://cmake.org/files/v3.9/cmake-3.9.4-Linux-x86_64.tar.gz | sudo tar -xzC /opt\n\n# When you don't, use a local copy of the installer.\n# COPY foundry/docker/cmake-3.9.4-Linux-x86_64.tar.gz /tmp/cmake.tgz\n# RUN sudo tar -xz -f /tmp/cmake.tgz -C /opt && \\\n# rm -f /tmp/cmake.tgz\n\nARG USER=toccata-dev\n\n# Create userspace\nRUN \\\n groupadd $USER && \\\n useradd $USER -m -g $USER -s /bin/zsh && \\\n passwd -d -u $USER && \\\n mkdir -p /etc/sudoers.d && \\\n echo \"#includedir /etc/sudoers.d\" >>/etc/sudoers && \\\n touch /etc/sudoers.d/$USER && \\\n echo \"$USER ALL=(ALL) NOPASSWD:ALL\" > /etc/sudoers.d/$USER && \\\n chmod 0440 /etc/sudoers.d/$USER\n\nWORKDIR /home/$USER\n\nCOPY foundry/docker/bashrc .bashrc\n\nADD . toccata\n\nRUN \\\n chown -R $USER:$USER toccata && \\\n chmod -R u=rw,go=r,a+X toccata && \\\n chmod u+x toccata/run\nRUN git clone https://github.com/brendangregg/FlameGraph.git\n\nUSER $USER\n\nENV SHELL /bin/bash\n\nENTRYPOINT /bin/bash" }, { "path": "foundry/docker/README.md", "content": "# Docker Build\n\nThis folder allows you to build Toccata in a container. The Dockerfile contains instructions to set up all build dependencies needed.\n\n# Build Dev Environment\n\nBuilding the development environment creates a container that has Toccata's prerequisites in place. Using this container, you can then compile and run the compiler.\n\nTo build the dev environment, use:\n\n`docker build -t toccata-devenv -f Development.docker ../..`\n\nThe `../..` is very important. That's what allows the Docker container to use the sources in this tree.\n\nThis builds a local docker image and tags it as `toccata-devenv`.\n\nThe short form of this is spelled as:\n\n`build-devenv`\n\n## Using the Dev Environment\n\nHaving the image built is just the first step. Next, you'll want to log in and use it. For that, use:\n\n`docker run -it --rm --name toccata-dev toccata-devenv`\n\nThis says to run interactively and attach to the terminal (\"-it\"), remove the container instance when you exit (\"--rm\"), name the container `toccata-dev` (\"--name toccata-dev\") and use the tagged container image we just built.\n\nThis also has a short form:\n\n`enter-dev`\n\n# Build Toccata Container\n\nBuilding a Toccata container creates a container image with Toccata in binary form, ready to run. This is the image you might want to push to a Docker repository, or use as a base for Toccata applications.\n\n`docker build -f Distribution.docker .`\n" }, { "path": "foundry/docker/bashrc", "content": "PATH=$PATH:/opt/cmake-3.9.4-Linux-x86_64/bin\n\nexport CC=/usr/bin/clang-3.9\nexport CXX=/usr/bin/clang-3.9\n" }, { "path": "foundry/docker/build-devenv", "content": "#! /bin/bash\ndocker build -t toccata-devenv -f Development.docker ../.." }, { "path": "foundry/docker/build-devenv.cmd", "content": "docker build -t toccata-devenv -f Development.docker ../.." }, { "path": "foundry/docker/enter-dev", "content": "#! /bin/bash\ndocker run -it --rm --name toccata-dev toccata-devenv\n" }, { "path": "foundry/docker/enter-dev.cmd", "content": "docker run -it --rm --name toccata-dev toccata-devenv\n" }, { "path": "interpreter-tests/abort-memory-leak.toc", "content": "\n(defn f []\n (abort))\n" }, { "path": "interpreter-tests/bad-and-clause-type-1.toc", "content": "\n(and (maybe 3)\n 3)\n" }, { "path": "interpreter-tests/bad-apply-arg-1.toc", "content": "\n(main [_]\n (ev/test-apply 'x))" }, { "path": "interpreter-tests/bad-apply-arg-2.toc", "content": "\n(defn f [_]\n (ev/test-apply 'x))" }, { "path": "interpreter-tests/bad-constructor-arg-1.toc", "content": "\n(defn f2 []\n (HashSet 'bogus))\n" }, { "path": "interpreter-tests/bad-constructor-arg-2.toc", "content": "\n(main []\n (HashSet 'bogus))\n" }, { "path": "interpreter-tests/bad-default-proto-param.toc", "content": "\n\n(ev/test-proto 9 10)\n" }, { "path": "interpreter-tests/bad-field-1.toc", "content": "\n(main [_]\n (print-err (.k (HashSet {}))))\n" }, { "path": "interpreter-tests/bad-field-2.toc", "content": "\n(defn f [_]\n (print-err (.k (HashSet {}))))\n" }, { "path": "interpreter-tests/bad-proto-impl-param-const.toc", "content": "\n\n(deftype Bogus [x]\n Seqable\n (take [_ n]\n (subs n 1)))\n\n(main [_]\n (take (Bogus 'a) 4)\n (print-err \"FAIL!!!!!\"))\n" }, { "path": "interpreter-tests/bad-proto-param.toc", "content": "\n(test-proto {'a 1} \"8\")\n" }, { "path": "interpreter-tests/bad-proto-return-type.toc", "content": "\n\n(deftype Bogus [x]\n Stringable\n (string-list [_]\n (subs x 1)))\n\n(main [_]\n (print-err 'bo (string-list (Bogus \"boop\")))\n (print-err \"FAIL!!!!!\"))\n" }, { "path": "interpreter-tests/bad-reify-arg-1.toc", "content": "\n(main [_]\n (ev/test-invoke 'x))" }, { "path": "interpreter-tests/bad-reify-arg-2.toc", "content": "\n(defn f [_]\n (ev/test-invoke 'x))" }, { "path": "interpreter-tests/bad-reify-arg-3.toc", "content": "\n(defn f []\n ((reify\n Function\n (invoke [_ x]\n (subs x 1)))\n 99))\n" }, { "path": "interpreter-tests/constrain-let-expr.toc", "content": "\n(main [_]\n (print-err (or nothing\n (let [x (maybe 'something)]\n (inc 9))))\n (print-err 'FAIL!!!!))\n" }, { "path": "interpreter-tests/constrain-tagged.toc", "content": "\n(defn f [ast]\n (.fn-sym ast))\n\n(f (reader/tag \"bogus\"))\n" }, { "path": "interpreter-tests/insufficient-apply-args-1.toc", "content": "\n(defn f3 []\n (ev/test-apply))\n" }, { "path": "interpreter-tests/insufficient-apply-args-2.toc", "content": "\n(main [_]\n (ev/test-apply))\n" }, { "path": "interpreter-tests/insufficient-invoke-args-1.toc", "content": "\n(main [_]\n (ev/test-invoke))\n" }, { "path": "par-test", "content": "#!/bin/bash\n\nset -e\n\n$CC -O3 -g -fno-objc-arc -std=c99 -c core.c &&\n\ngit checkout toccata.c &&\n$CC -O3 -g -fno-objc-arc -o toccata -std=c99 core.o toccata.c -lpthread &&\ntime `./toccata toccata.toc > toccata.c` &&\n\nrm toccata\n$CC -O3 -g -fno-objc-arc -o toccata -std=c99 core.o toccata.c -lpthread &&\n\npids=( )\nfor file in regression-tests/test*.toc\ndo\n ./test-regression $file & pids+=( $! )\ndone\n\nfor file in assertion-tests/*.toc\ndo\n ./test-assertion $file 2> /dev/null & pids+=( $! )\ndone\n\nfor file in runtime-tests/*.toc\ndo\n ./test-runtime-check $file 2> /dev/null & pids+=( $! )\ndone\n\nfor pid in \"${pids[@]}\";\ndo\n wait \"$pid\"\ndone\n\ntime `./toccata toccata.toc > toccata.c` &&\n$CC -O3 -g -fno-objc-arc -o toccata -std=c99 core.o toccata.c -lpthread &&\n\ntime `./toccata toccata.toc > toccata.c`&&\n$CC -O3 -g -fno-objc-arc -o toccata -std=c99 core.o toccata.c -lpthread &&\n\necho\necho \"Regressions pass\"\n" }, { "path": "regression-tests/Boomer.toc", "content": "\n(add-ns b (module \"boom.toc\"))\n\n(deftype Boomer [z]\n Stringable\n (string-list [_]\n (list \"\"))\n\n Container\n (wrap [a q]\n [(b/boom q)]))\n" }, { "path": "regression-tests/agent-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(def agt (agent {}))\n\n(def global-x {(inc 0) (symbol \"abc\")})\n\n(defn inc-agent [agt n]\n (or (= n 0)\n (let [_ (send agt inc)]\n (inc-agent agt (dec n)))))\n\n(defn test []\n (println \"Check agent regressions\")\n (send agt (fn [m]\n (assoc m (inc 0) (symbol \"bogus\"))))\n (send agt (fn [m]\n (maybe global-x)))\n (let [agt (agent (inc 0))\n done (promise)\n well-done (promise)\n inc-val (inc 0)]\n (send agt + (inc 0))\n (send agt (fn [x]\n (+ x inc-val)))\n (send agt (fn [x]\n (deliver done x)\n x))\n (rt/test (= (extract done) (extract agt))\n _FILE_ _LINE_)\n\n (inc-agent agt 6)\n (send agt (fn [x]\n (deliver well-done x)\n x))\n (rt/test (= (extract well-done) (extract agt))\n _FILE_ _LINE_))\n (println \"Agents are good\"))\n" }, { "path": "regression-tests/and-prop.toc", "content": "\n(defn f [x y]\n (and (instance? Integer x)\n (maybe (inc x))\n (maybe (subs y 1))))\n\n(main [_]\n (println \"1)\" (f 1 \"1234\"))\n (println \"2)\" (f \"2\" \"1234\"))\n (println \"3)\" (f \"3\" 1234)))\n" }, { "path": "regression-tests/boom.toc", "content": "\n(defn boom [x]\n (print-err 'booming x)\n (str \"boomed \" x))\n" }, { "path": "regression-tests/comment-in-deftype.toc", "content": "\n(deftype Commentary [x]\n Stringable\n ;; Stringable\n (string-list [_]\n (list \"xxx\"))\n\n )\n\n(main [_]\n (print-err (Commentary 'x)))\n" }, { "path": "regression-tests/cond-expr-1.toc", "content": "\n(main [_]\n (print-err (cond (= 0 0) (str 'yeppers \" \" (inc 0))\n (= 0 0) (str 'yeppers \" \" (inc 1))\n (= 0 0) (str 'yeppers \" \" (inc 2))\n (= 0 0) (str 'yeppers \" \" (inc 3))\n (str 'nopenopenope \" \" (inc 4))))\n\n (print-err 'done))\n" }, { "path": "regression-tests/cond-expr-2.toc", "content": "\n(main [_]\n (print-err (cond (= 0 1) (str 'yeppers \" \" (inc 0))\n (= 0 0) (str 'yeppers \" \" (inc 1))\n (= 0 0) (str 'yeppers \" \" (inc 2))\n (= 0 0) (str 'yeppers \" \" (inc 3))\n (str 'nopenopenope \" \" (inc 4))))\n\n (print-err 'done))\n" }, { "path": "regression-tests/cond-expr-3.toc", "content": "\n(main [_]\n (print-err (cond (= 0 1) (str 'yeppers \" \" (inc 0))\n (= 0 1) (str 'yeppers \" \" (inc 1))\n (= 0 0) (str 'yeppers \" \" (inc 2))\n (= 0 0) (str 'yeppers \" \" (inc 3))\n (str 'nopenopenope \" \" (inc 4))))\n\n (print-err 'done))\n" }, { "path": "regression-tests/cond-expr-4.toc", "content": "\n(main [_]\n (print-err (cond (= 0 1) (str 'yeppers \" \" (inc 0))\n (= 0 1) (str 'yeppers \" \" (inc 1))\n (= 0 1) (str 'yeppers \" \" (inc 2))\n (= 0 0) (str 'yeppers \" \" (inc 3))\n (str 'nopenopenope \" \" (inc 4))))\n\n (print-err 'done))\n" }, { "path": "regression-tests/cond-expr-5.toc", "content": "\n(defn new-nothing []\n (inline C \"return((Value *)malloc_maybe());\\n\"))\n\n(main [_]\n (print-err (cond (= 0 1) (str 'yeppers \" \" (inc 0))\n (new-nothing) (str 'yeppers \" \" (inc 1))\n (= 0 1) (str 'yeppers \" \" (inc 2))\n (new-nothing) (str 'yeppers \" \" (inc 3))\n (str 'nopenopenope \" \" (inc 4))))\n\n (print-err 'done))\n" }, { "path": "regression-tests/destruct-test.toc", "content": "\n(defn f [x]\n (and x (let [[result new-s] (extract x)\n [[a b] & c] [[1 2] 3 4]]\n (println 'a a 'b b 'c c)\n nothing)))\n\n(main [_]\n (f (maybe [1 2]))\n (println 'done))\n" }, { "path": "regression-tests/free-static-value.toc", "content": "\n(def init-str (str \"wt\" \"f\"))\n\n(deftype Bogus [x y])\n\n(def x (Bogus {init-str 8} init-str))\n\n(main [_]\n (print-err 'done))\n" }, { "path": "regression-tests/function-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n;; TODO: this causes the compiler to blow the stack\n;; infinite recursion while inlining\n;; (extend-type Integer\n;; Container\n;; (map [n f]\n;; (either (= 0 n)\n;; (map (dec n) f))))\n\n(def one (add-numbers (inc -2) (inc 1)))\n\n(defn add-1-variadic [& x]\n (let [[x] x]\n (add-numbers 1 x)))\n\n(defn no-op-fixed [_ _ _]\n nothing)\n\n(defn no-op-variadic [& _]\n nothing)\n\n(defn z [arg]\n (no-op-variadic arg))\n\n(defn z* [arg]\n [(no-op-variadic arg)])\n\n(defn z** [arg]\n (no-op-variadic arg)\n [(no-op-variadic arg)])\n\n(defn y [& args]\n (let [[arg] args\n [_] args]\n (no-op-variadic arg)))\n\n(defn y* [& args]\n (let [[arg] args]\n [(no-op-variadic arg)]))\n\n(defn y** [& args]\n (let [[arg] args]\n (no-op-variadic arg)\n [(no-op-variadic arg)]))\n\n(defn y*** [& args]\n (let [[arg] args]\n (map args no-op-variadic)))\n\n(def add-1-invoke\n (reify\n Function\n (invoke [_ x]\n (inc x))))\n\n(defn f2 []\n (let [x (inc 0)\n y x\n f (fn [] (+ x y))]\n (f)))\n\n(defn f3 [y]\n (inc (let [_ (inc 99)]\n y)))\n\n(defn triggers-bus-error [[arg & boom] s]\n 'triggered)\n\n(defn test []\n (println \"Checking function regressions\")\n (identity one)\n (rt/test (instance? Fn (fn [] one))\n _FILE_ _LINE_)\n (let [[a b & c] [(inc 0) 2 3 (inc 3)]]\n (identity one))\n (let [[a y & c] (list (inc 0) 2 3 (inc 3))]\n (identity one))\n (no-op-variadic one)\n (no-op-fixed one (inc 2) (inc 3))\n (z one)\n (z* one)\n (z** one)\n (y one (inc 2))\n (y* one)\n (y** one)\n (y*** one)\n (let [x (inc 9)]\n (map (list x) no-op-variadic))\n (let [new-str (str-malloc (inc 11))]\n (str-append new-str (str \"file\" \"\\n\"))\n (y new-str))\n (let [new-str (str-malloc 12)\n _ (str-append new-str \"bogus\")\n _ (str-append new-str \".\")]\n (str-append new-str \"file\\n\")\n (no-op-variadic new-str))\n (let [new-str (str-malloc 12)\n l (list [\"1\"] 2 (list 'three) 'four)\n _ (str-append new-str \"bogus\")\n _ (str-append new-str \".\")]\n (str-append new-str \"file\\n\")\n (no-op-variadic new-str)\n (map (list new-str) no-op-variadic))\n (let [new-str (str-malloc 12)]\n (str-append new-str \"file\\n\")\n (y* new-str))\n (let [new-str (str-malloc 12)]\n (str-append new-str \"file\\n\")\n (y** new-str))\n (let [new-str (str-malloc 12)]\n (str-append new-str \"file\\n\")\n (y*** new-str))\n (let [new-str (str-malloc 12)]\n (str-append new-str \"file\\n\")\n (z* new-str))\n (let [new-str (str-malloc 12)]\n (str-append new-str \"file\\n\")\n (z** new-str))\n (let [v [1]]\n (no-op-variadic v v v)\n (no-op-fixed v v v))\n (let [bogus (list \"bogus\")\n some-str \"popper\\n\"\n v-fn (fn variadic-fn [& x] bogus)\n this-fn (fn this-fn\n ([] bogus)\n ([_] bogus)\n ([_ _] bogus)\n ([_ _ _] bogus)\n ([_ _ _ _] bogus)\n ([_ _ _ _ _] bogus)\n ([_ _ _ _ _ _] bogus)\n ([_ _ _ _ _ _ _] bogus)\n ([_ _ _ _ _ _ _ _] bogus)\n ([_ _ _ _ _ _ _ _ _] bogus))]\n (rt/test (= bogus (apply this-fn empty-list))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0)\n (inc 1))))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0)\n (inc 1)\n (inc 2))))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0)\n (inc 1)\n (inc 2)\n (inc 3))))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0)\n (inc 1)\n (inc 2)\n (inc 3)\n (inc 4))))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0)\n (inc 1)\n (inc 2)\n (inc 3)\n (inc 4)\n (inc 5))))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0)\n (inc 1)\n (inc 2)\n (inc 3)\n (inc 4)\n (inc 5)\n (inc 6))))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0)\n (inc 1)\n (inc 2)\n (inc 3)\n (inc 4)\n (inc 5)\n (inc 6)\n (inc 7))))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply this-fn (list (inc 0)\n (inc 1)\n (inc 2)\n (inc 3)\n (inc 4)\n (inc 5)\n (inc 6)\n (inc 7)\n (inc 8))))\n _FILE_ _LINE_)\n (rt/test (= bogus (v-fn (inc 0) (inc 1)))\n _FILE_ _LINE_)\n (rt/test (= bogus (apply v-fn (list (inc 0) (inc 1) (inc 2))))\n _FILE_ _LINE_)\n (rt/test (= 3 (add-1-invoke (inc 1)))\n _FILE_ _LINE_)\n (apply add-1-variadic (list (inc 0))))\n (let [inc-val (inc 0)\n f1 (reify\n Function\n (invoke [_ x]\n (+ inc-val x)))\n f2 (fn [x]\n (+ inc-val x))\n f3 (fn [x]\n (inc x))\n f4 (fn [& xs]\n (let [[x] xs]\n (+ inc-val x)))]\n (rt/test (= (f1 9) (f2 9) (f3 9) (f4 9))\n _FILE_ _LINE_))\n\n (let [x (inc 0)\n fx (fn [_]\n (inc x))]\n (fx (inc 1)))\n\n (f2)\n\n (let [x (inc 0)\n fx (fn fx []\n (inc (let [_ (inc 99)]\n x)))\n fy (fn fy []\n (list x)\n (list x))]\n (fy))\n\n (f3 (inc 0))\n\n (let [l (list 22)\n f (fn [h]\n l\n h\n (maybe l))]\n (f one))\n (let [l (seq \"xy\")]\n ((fn [x] (maybe l)) 0))\n\n ;; TODO: this generates bad code\n ;; (rt/test ((fn [x]\n ;; (= 'y x))\n ;; 'y)\n ;; _FILE_ _LINE_)\n\n (println \"Functions are good\"))\n" }, { "path": "regression-tests/future-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(deftype Thunk [f x]\n Function\n (invoke [v]\n (f)))\n\n(defn test []\n (println \"Checking future regressions\")\n\n (let [p (future (fn []\n (inc 9)))]\n (rt/test (= 10 (extract p))\n _FILE_ _LINE_)\n (rt/test (= 10 (extract p))\n _FILE_ _LINE_))\n\n (let [f1 (future (fn [] 3))\n _ (map (range 800) inc)\n f2 (map f1 inc)\n fut (future (fn []\n (rt/test (= 4 (extract f2))\n _FILE_ _LINE_)))]\n (rt/test (= 3 (extract f1))\n _FILE_ _LINE_)\n (extract fut))\n\n (let [p (promise)]\n (extract (future (Thunk (fn [] (deliver p (inc 0))) (inc 9)))))\n\n (let [f1 (future (fn []\n (map (range 800) inc)\n 2))\n f2 (map f1 inc)\n fut (future (fn []\n (rt/test (= 3 (extract f2))\n _FILE_ _LINE_)))]\n (rt/test (= 2 (extract f1))\n _FILE_ _LINE_)\n (extract fut))\n\n (let [double (fn [x]\n (+ x x))]\n (let [f1 (future (fn []\n (map (range 800) inc)\n 3))\n f2 (map (map f1 inc) double)\n f3 (map f1 (fn [x]\n (double (inc x))))]\n (rt/test (= (extract f2) (extract f3))\n _FILE_ _LINE_))\n\n (let [p1 (future (fn []\n (map (range 800) inc)\n 5))\n p2 (map p1 inc)\n p3 (apply-to inc p1)]\n (rt/test (= (extract p2) (extract p3))\n _FILE_ _LINE_))\n\n (let [p1 (future (fn []\n (map (range 800) inc)\n 5))\n p2 (future (fn []\n (map (range 200) inc)\n 10))\n p3 (apply (future (fn [] +)) [p1 p2])]\n (rt/test (= 15 (extract p3))\n _FILE_ _LINE_))\n\n (let [p1 (future (fn []\n (map (range 800) inc)\n 5))\n p2 (map p1 double)\n p4 (apply-to + p2 p1)]\n (rt/test (= 15 (extract p4))\n _FILE_ _LINE_))\n\n (let [p1 (future (fn []\n (map (range 800) inc)\n \"one\"))\n p2 (future (fn []\n (map (range 800) inc)\n \"two\"))\n p3 (future (fn []\n (map (range 800) inc)\n \"three\"))\n p4 (apply-to vector p1 p2 p3)]\n (rt/test (= [\"one\" \"two\" \"three\"]\n (extract p4))\n _FILE_ _LINE_)))\n\n (let [f (fn [x]\n (future (fn [] (inc x))))\n double (fn [x]\n (+ x x))\n g (fn [x]\n (future (fn [] (double x))))]\n (let [p1 (future (fn []\n (map (range 800) inc)\n 7))\n p2 (flat-map p1 (fn [x] (future (fn [] x))))]\n (rt/test (= (extract p2) 7)\n _FILE_ _LINE_))\n\n (let [p1 (future (fn []\n (map (range 800) inc)\n 4))\n p2 (flat-map p1 f)]\n (rt/test (= (extract p2)\n (extract (f 4)))\n _FILE_ _LINE_))\n\n (let [p1 (future (fn []\n (map (range 800) inc)\n 4))\n p2 (flat-map p1 f)\n p3 (flat-map p2 g)\n p4 (flat-map p1 (fn [x] (flat-map (f x) g)))]\n (rt/test (= 10 (extract p3) (extract p4))\n _FILE_ _LINE_)))\n\n (rt/test (= 93 (extract (future (reify\n Function\n (invoke [_]\n (inc 92))))))\n _FILE_ _LINE_)\n\n (rt/test (= 93 (extract (future (reify\n Function\n (invoke [_]\n (inc 92))))))\n _FILE_ _LINE_)\n\n (rt/test (= 93 (extract (future (fn [& _]\n (inc 92)))))\n _FILE_ _LINE_)\n\n (println \"Futures are good\"))\n" }, { "path": "regression-tests/hash-map-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(deftype ControlledHash [y eq]\n Stringable\n (string-list [_] (string-list y))\n\n Eq\n (=* [_ v]\n (and eq\n (= y (.y v))\n (maybe _)))\n\n Hashable\n (sha1 [_] y))\n\n(defn bar [x]\n (assert (instance? ArrayNode x))\n (dissoc x '_))\n\n(defn foo [x]\n (assert (instance? HashMap x))\n (assert-result y (instance? HashMap y))\n (bar x))\n\n(defn test []\n (println \"Checking hash-map regressions\")\n (rt/test (= {} {})\n _FILE_ _LINE_)\n (rt/test (empty? {})\n _FILE_ _LINE_)\n\n (let [one-hash-map {(inc 0) (symbol \"a\")}]\n (rt/test (= nothing (empty? one-hash-map))\n _FILE_ _LINE_)\n (rt/test (= 1 (count one-hash-map))\n _FILE_ _LINE_)\n (rt/test (= 1 (count (assoc one-hash-map (inc 0) (symbol \"b\"))))\n _FILE_ _LINE_)\n (rt/test (= 2 (count (assoc one-hash-map (inc 1) (symbol \"b\"))))\n _FILE_ _LINE_))\n\n (let [one-hash-map {(ControlledHash (inc -1) (maybe (inc -1))) (symbol \"a\")}\n full-bmi (reduce (range 16) {} (fn [m n]\n (assoc m (ControlledHash n (maybe n)) (inc n))))\n array-node (assoc full-bmi (ControlledHash (inc 20) (maybe (inc 20))) (symbol \"c\"))\n collided (assoc-all {}\n (ControlledHash (inc -1) nothing) (inc 0)\n (ControlledHash (inc -1) (maybe (inc -1))) (symbol \"a\")\n (ControlledHash (inc -1) nothing) (inc 0))]\n (rt/test (= nothing (empty? one-hash-map))\n _FILE_ _LINE_)\n (rt/test (= 1 (count one-hash-map))\n _FILE_ _LINE_)\n (rt/test (= 2 (count (hash-seq one-hash-map (list \"\"))))\n _FILE_ _LINE_)\n (rt/test (= (maybe (symbol \"a\")) (get one-hash-map (ControlledHash (inc -1) (maybe (inc -1)))))\n _FILE_ _LINE_)\n (rt/test (= 100 (get* full-bmi (ControlledHash 2 nothing) (inc 99)\n (sha1 (ControlledHash 2 (maybe 1))) (inc -1)))\n _FILE_ _LINE_)\n (rt/test (= 1 (get* one-hash-map (inc 9) (inc 0) (sha1 (inc 9)) (inc -1)))\n _FILE_ _LINE_)\n (rt/test (= (symbol \"a\") (get* one-hash-map (ControlledHash (inc -1) (maybe (inc -1)))\n (inc 0) (sha1 (ControlledHash (inc -1) (maybe (inc -1))))\n (inc -1)))\n _FILE_ _LINE_)\n (rt/test (= (range 16)\n (let [ints-map (reduce (range 16) {} (fn [m n] (assoc m n n)))]\n (map (range 16) (fn [n]\n (-> n\n (= (get* ints-map n (inc 0) (sha1 n) (inc -1)))\n (rt/test _FILE_ _LINE_)\n extract)))))\n _FILE_ _LINE_)\n (rt/test (= 1 (count (dissoc* one-hash-map (inc 0) (sha1 1) (inc -1))))\n _FILE_ _LINE_)\n (rt/test (= 0 (count (dissoc* one-hash-map (ControlledHash (inc -1) (maybe (inc -1)))\n (sha1 (ControlledHash (inc -1) (maybe (inc -1)))) (inc -1))))\n _FILE_ _LINE_)\n (rt/test (= 15 (count (dissoc* full-bmi (ControlledHash 5 (maybe 5))\n (sha1 (ControlledHash 5 (maybe 5))) 0)))\n _FILE_ _LINE_)\n (rt/test (= 1 (get* array-node (inc 3) (inc 0) (sha1 (inc 3)) (inc -1)))\n _FILE_ _LINE_)\n (rt/test (= 2 (count (assoc {(ControlledHash (inc -1) nothing) (symbol \"a\")}\n (ControlledHash (inc -1) nothing) (symbol \"a\"))))\n _FILE_ _LINE_)\n (rt/test (= 1 (count (assoc one-hash-map (ControlledHash (inc -1) (maybe (inc -1)))\n (symbol \"b\"))))\n _FILE_ _LINE_)\n (rt/test (= 2 (count (assoc one-hash-map (ControlledHash (inc 0) (maybe (inc 0)))\n (symbol \"b\"))))\n _FILE_ _LINE_)\n (rt/test (= 17 (count (hash-seq full-bmi (list \"\"))))\n _FILE_ _LINE_)\n (rt/test (= 27 (count (reduce (range 27) {}\n (fn [m n] (assoc m (- n 1) (inc n))))))\n _FILE_ _LINE_)\n (rt/test (= 28 (count (hash-seq (reduce (range 27) {}\n (fn [m n] (assoc m (- n 1) (inc n))))\n (list \"\"))))\n _FILE_ _LINE_)\n (rt/test (= 2001 (count (hash-seq (reduce (range 2000) {}\n (fn [m n] (assoc m (ControlledHash n (maybe n)) (inc n))))\n (list \"\"))))\n _FILE_ _LINE_)\n (rt/test (= 16 (count (assoc full-bmi (ControlledHash (inc 0) (maybe (inc 0))) (symbol \"b\"))))\n _FILE_ _LINE_)\n (rt/test (= 17 (count (assoc full-bmi (ControlledHash (inc 98) (maybe (inc 98))) (symbol \"b\"))))\n _FILE_ _LINE_)\n (rt/test (= 17 (count array-node))\n _FILE_ _LINE_)\n (rt/test (= 18 (count (assoc array-node (symbol \"a\") (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= 18 (count (assoc-all full-bmi\n (symbol \"b\") (inc 0)\n (symbol \"d\") (inc 1))))\n _FILE_ _LINE_)\n (rt/test (= 2 (count collided))\n _FILE_ _LINE_)\n (rt/test (= 3 (count (hash-seq collided (list \"\"))))\n _FILE_ _LINE_)\n (rt/test (= 1 (count (dissoc collided (ControlledHash (inc -1) (maybe (inc -1))))))\n _FILE_ _LINE_)\n (rt/test (= 100 (get* collided (ControlledHash 256 nothing) (inc 99)\n (sha1 (ControlledHash 256 nothing)) (inc -1)))\n _FILE_ _LINE_)\n (rt/test (= (symbol \"a\") (get* collided (ControlledHash (inc -1) (maybe (inc -1))) (inc 99)\n (sha1 (ControlledHash (inc -1) (maybe (inc -1)))) (inc -1)))\n _FILE_ _LINE_)\n (rt/test (instance? HashMap one-hash-map)\n _FILE_ _LINE_)\n (rt/test (instance? HashMap array-node)\n _FILE_ _LINE_)\n (rt/test (= array-node (dissoc array-node (ControlledHash (inc 17) (maybe (inc 2)))))\n _FILE_ _LINE_))\n (rt/test (= 3 (count (reduce (range 3) {}\n (fn [m n]\n (assoc m (ControlledHash (inc -1) nothing) (inc n))))))\n _FILE_ _LINE_)\n (rt/test (= 3 (count (assoc-all {}\n (symbol \"a\") (inc 0)\n (symbol \"b\") (inc 1)\n (symbol \"c\") (inc 2))))\n _FILE_ _LINE_)\n (rt/test (= 0 (count (reduce (range 16) (reduce (range 16) {} (fn [m n] (assoc m n n)))\n (fn [m n]\n (dissoc* m n (sha1 n) (inc -1))))))\n _FILE_ _LINE_)\n (let [size 25\n ints-map (reduce (range size) {} (fn [m n] (assoc m n n)))]\n (rt/test (empty? (reduce (range size) ints-map\n (fn [m n]\n (dissoc* m n (sha1 n) (inc -1)))))\n _FILE_ _LINE_)\n\n (rt/test (= ints-map (foo ints-map))\n _FILE_ _LINE_))\n\n (let [bmi {(ControlledHash 3 (maybe 3)) 4, (ControlledHash 35 (maybe 3)) 99}]\n (rt/test (= bmi (dissoc bmi (ControlledHash 3 nothing)))\n _FILE_ _LINE_)\n (rt/test (empty? (dissoc bmi (ControlledHash 3 (maybe 3))\n (ControlledHash 35 (maybe 3))))\n _FILE_ _LINE_))\n\n (let [collided (assoc-all {}\n (ControlledHash (inc 0) nothing) (inc 2)\n (ControlledHash (inc 0) (maybe (inc -1))) (inc 1)\n (ControlledHash (inc 0) nothing) (inc 9))]\n (dissoc collided (ControlledHash (inc 0) (maybe (inc -1))))) \n\n (let [collided (assoc-all {}\n (ControlledHash (inc 0) (maybe (inc -1))) (inc 1)\n (ControlledHash (inc 0) nothing) (inc 2)\n (ControlledHash (inc 0) nothing) (inc 9))]\n (dissoc collided (ControlledHash (inc 0) (maybe (inc -1))))) \n\n (let [collided (assoc-all {}\n (ControlledHash (inc 0) (maybe (inc -1))) (inc 1)\n (ControlledHash (inc 0) (maybe (inc 0))) (inc 2)\n (ControlledHash (inc 0) nothing) (inc 9))]\n (-> collided\n (dissoc (ControlledHash (inc 0) (maybe (inc -1))))\n (dissoc (ControlledHash (inc 0) (maybe (inc 0)))))) \n\n (let [collided (assoc-all {}\n (ControlledHash (inc 0) (maybe (inc -1))) (inc 1)\n (ControlledHash (inc 0) nothing) (inc 2)\n (ControlledHash (inc 0) nothing) (inc 2)\n (ControlledHash (inc 0) nothing) (inc 9))]\n (-> collided\n (dissoc (ControlledHash (inc 0) (maybe (inc -1))))\n (dissoc (ControlledHash (inc 0) (maybe (inc -1))))\n (dissoc (ControlledHash (inc 0) (maybe (inc 0)))))) \n\n (let [collided (assoc-all {}\n (ControlledHash (inc 0) (maybe (inc -1))) (inc 1)\n (ControlledHash (inc 0) nothing) (inc 2)\n (ControlledHash (inc 256) nothing) (inc 9))]\n (dissoc collided (ControlledHash (inc 0) (maybe (inc -1)))))\n\n (println \"hash-maps are good\"))\n\n" }, { "path": "regression-tests/integer-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(defn test []\n (println \"Checking for integer regressions\")\n (rt/test (= (inc 2) (+ (inc 0) (inc 0) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= (inc 2) (inc 2))\n _FILE_ _LINE_)\n (rt/test (= \"Integer\" (type-name (+ 2 1)))\n _FILE_ _LINE_)\n (rt/test (= [3] (type-args (+ 2 1)))\n _FILE_ _LINE_)\n (rt/test (instance? Integer (+ 2 1))\n _FILE_ _LINE_)\n (rt/test (= (list \"3\") (string-list (+ 2 1)))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (inc 2) (list (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (inc 2) (inc 3)))\n _FILE_ _LINE_)\n (rt/test (= 3 (+ 1 (+ 1 1)))\n _FILE_ _LINE_)\n (rt/test (= (+ (+ (inc 0) (inc 0)) (inc 0)) (inc 2))\n _FILE_ _LINE_)\n (rt/test (= (+ (inc 0) (inc 0) (inc 0)) (inc 2))\n _FILE_ _LINE_)\n (rt/test (= -1 (- (- (inc 0) (inc 0)) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= (- (- (inc 0) (inc 0)) (inc 0)) -1)\n _FILE_ _LINE_)\n (rt/test (= -1 (- (inc 0) (inc 0) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= (* (inc 1) (* (inc 1) (inc 1))) 8)\n _FILE_ _LINE_)\n (rt/test (= 8 (* (inc 1) (* (inc 1) (inc 1))))\n _FILE_ _LINE_)\n (rt/test (= 8 (* (inc 1) (inc 1) (inc 1)))\n _FILE_ _LINE_)\n (rt/test (= (mod 8 (* 2 2)) 0)\n _FILE_ _LINE_)\n (rt/test (= 1 (mod (* 3 3) 2))\n _FILE_ _LINE_)\n (let [x (inc 49)]\n (sha1 x)\n (sha1 x))\n (rt/test (= (maybe 1) (< (inc 0) (inc 1) (inc 2) (inc 3) (inc 4)))\n _FILE_ _LINE_)\n (rt/test (= nothing (<* (inc 1) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= 255 (bit-and (dec 512) (inc 254)))\n _FILE_ _LINE_)\n (rt/test (= 511 (bit-or (dec 512) (inc 254)))\n _FILE_ _LINE_)\n (rt/test (= 256 (bit-xor (dec 512) (inc 254)))\n _FILE_ _LINE_)\n (rt/test (= 4088 (bit-shift-left (dec 512) (inc 2)))\n _FILE_ _LINE_)\n (rt/test (= 63 (bit-shift-right (dec 512) (inc 2)))\n _FILE_ _LINE_)\n (rt/test (= -512 (bit-not (dec 512)))\n _FILE_ _LINE_)\n (println \"Integers are good\"))\n" }, { "path": "regression-tests/interpreter-test.toc", "content": "#! /home/jim/toccata/new-toc --script\n;; You'll need to replace $TOCCATA_DIR with the path to your 'toccata' executable\n\n(add-ns int (module \"integer-regressions.toc\"))\n(add-ns fns (module \"function-regressions.toc\"))\n(add-ns strs (module \"string-regressions.toc\"))\n(add-ns myb (module \"maybe-regressions.toc\"))\n(add-ns sym (module \"symbol-regressions.toc\"))\n(add-ns lst (module \"list-regressions.toc\"))\n(add-ns vec (module \"vector-regressions.toc\"))\n(add-ns hm (module \"hash-map-regressions.toc\"))\n(add-ns typ (module \"types-regressions.toc\"))\n(add-ns prom (module \"promise-regressions.toc\"))\n(add-ns agt (module \"agent-regressions.toc\"))\n(add-ns ll (module \"lazy-list-regressions.toc\"))\n(add-ns git (git-dependency \"https://github.com/jduey/test-git.git\" \"repo-root.toc\"\n :branch \"non-master-test\"))\n(add-ns fut (module \"future-regressions.toc\"))\n\n(main [args]\n (assert (instance? List args))\n (int/test)\n (fns/test)\n (strs/test)\n (myb/test)\n (sym/test)\n (lst/test)\n (vec/test)\n (hm/test)\n (typ/test)\n (prom/test)\n (agt/test)\n (ll/test)\n (git/test)\n (fut/test)\n (println 'all-done))\n" }, { "path": "regression-tests/lazy-list-regressions.toc", "content": "\n(defn test []\n (lazy-list sym-counter)\n (first (lazy-list sym-counter))\n (rest (lazy-list sym-counter))\n (first (rest (lazy-list sym-counter)))\n (first (rest (rest (rest (lazy-list sym-counter)))))\n (let [lc (lazy-list sym-counter)]\n (first lc)\n lc)\n (let [lc (lazy-list sym-counter)]\n (first lc))\n (let [lc (lazy-list sym-counter)]\n (first lc)\n (first lc)\n lc)\n (let [lc (lazy-list sym-counter)]\n (first lc)\n (first lc)\n (first lc)\n (first lc))\n (let [lc (lazy-list sym-counter)]\n (rest lc))\n (let [lc (lazy-list sym-counter)]\n (first (rest lc)))\n (let [lc (lazy-list sym-counter)]\n (first (rest (rest lc))))\n (println \"LazyList good\"))\n" }, { "path": "regression-tests/list-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(def is-1-invoke\n (reify\n Function\n (invoke [_ x]\n (= (inc 0) x))))\n\n(def two-list (list (inc 0) (inc 1)))\n(def three-list (list (inc 0) (inc 1) (inc 2)))\n\n(defn is-1-static [x]\n (= (inc 0) x))\n\n(defn is-1-variadic [& x]\n (let [[x] x]\n (= (inc 0) x)))\n\n(defn f [x]\n (list (inc x)))\n\n(defn double [x]\n (* 2 x))\n\n(defn g [x]\n (list (double x)))\n\n(defn test []\n (println \"Checking List regressions\")\n (rt/test (instance? List three-list)\n _FILE_ _LINE_)\n (rt/test (= nothing (instance? List (inc 55)))\n _FILE_ _LINE_)\n (rt/test (= \"List\" (type-name three-list))\n _FILE_ _LINE_)\n (rt/test (= (vec three-list) (type-args three-list))\n _FILE_ _LINE_)\n (rt/test (= 3 (count (cons (inc 0) (cons (inc 2) (cons (inc 3) empty-list)))))\n _FILE_ _LINE_)\n (rt/test (= 3 (count (conj (conj (conj (list) 3) 2) 1)))\n _FILE_ _LINE_)\n (rt/test (= three-list (conj (conj (conj (list) 3) 2) 1))\n _FILE_ _LINE_)\n (rt/test (empty? empty-list)\n _FILE_ _LINE_)\n (rt/test (empty? (list))\n _FILE_ _LINE_)\n (rt/test (= nothing (first empty-list))\n _FILE_ _LINE_)\n (rt/test (= nothing (empty? (cons 3 empty-list)))\n _FILE_ _LINE_)\n (rt/test (= (maybe \"1\") (first (list (subs \"01\" 1) (inc 1) (inc 2))))\n _FILE_ _LINE_)\n (rt/test (empty? (rest empty-list))\n _FILE_ _LINE_)\n (rt/test (empty? (rest (list (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= (maybe \"1\") (first (rest (list 2 (subs \"01\" 1) 3))))\n _FILE_ _LINE_)\n (rt/test (empty? (rest (list)))\n _FILE_ _LINE_)\n (rt/test (= nothing (= three-list (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= three-list three-list)\n _FILE_ _LINE_)\n (rt/test (empty? (list-concat (rest (list (inc 0)))))\n _FILE_ _LINE_)\n (rt/test (= 2 (count (list-concat (list two-list))))\n _FILE_ _LINE_)\n (rt/test (= 4 (count (list-concat (list two-list (list 3 4)))))\n _FILE_ _LINE_)\n (rt/test (= 6 (count (list-concat (list two-list (list 3 4) (list (inc 4) (inc 5))))))\n _FILE_ _LINE_)\n (rt/test (= 6 (count (comp two-list (list 3 4) [(inc 4) (inc 5)])))\n _FILE_ _LINE_)\n (rt/test (= 2 (count (comp (list (inc 0) (inc 1)))))\n _FILE_ _LINE_)\n (rt/test (= 4 (count (comp (list (inc 0) (inc 1)) (list (inc 2) (inc 3)))))\n _FILE_ _LINE_)\n (rt/test (= 6 (count (comp two-list (list 3 4) (list 5 6))))\n _FILE_ _LINE_)\n (rt/test (= 6 (count (comp two-list empty-list (list 3 4) (empty (list)) (list 5 6))))\n _FILE_ _LINE_)\n (rt/test (empty? (empty two-list))\n _FILE_ _LINE_)\n (rt/test (empty? (filter (rest (list 1)) is-1-static))\n _FILE_ _LINE_)\n (rt/test (= 1 (count (filter (list (inc 0)) is-1-static)))\n _FILE_ _LINE_)\n (rt/test (= 4 (count (filter (list (inc 0) (inc 1) 3 1 (inc 0) 5 1 (inc 5) 7)\n (fn [x] (= (inc 0) x)))))\n _FILE_ _LINE_)\n (rt/test (= 4 (count (filter (list (inc 0) (inc 1) 3 1 (inc 0) 5 1 (inc 5) 7)\n (fn [& x]\n (let [[x] x]\n (= (inc 0) x))))))\n _FILE_ _LINE_)\n (let [inc-val (inc 0)]\n (rt/test (= 4 (count (filter (list (inc 0) (inc 1) 3 1 (inc 0) 5 1 (inc 5) 7)\n (reify\n Function\n (invoke [_ x]\n (= 1 x))))))\n _FILE_ _LINE_)\n (rt/test (= 4 (count (filter (list (inc 0) (inc 1) 3 1 (inc 0) 5 1 (inc 5) 7)\n (reify\n Function\n (invoke [_ x]\n (= inc-val x))))))\n _FILE_ _LINE_))\n (rt/test (= (list 2 3 4) (map three-list inc))\n _FILE_ _LINE_)\n (let [inc-val (inc 0)]\n (rt/test (= (list 2 3 4) (map three-list (fn [x] (+ inc-val x))))\n _FILE_ _LINE_))\n (let [inc-val (inc 0)]\n (rt/test (= (list 2 3 4) (map three-list (fn [& xs] (let [[x] xs] (+ inc-val x)))))\n _FILE_ _LINE_))\n (let [inc-val (inc 0)]\n (rt/test (= (map three-list (reify\n Function\n (invoke [_ x]\n (+ inc-val x))))\n (list 2 3 4))\n _FILE_ _LINE_))\n (rt/test (= three-list (reverse (reverse three-list)))\n _FILE_ _LINE_)\n (rt/test (= 6 (reduce (list (inc 2) 2 1) (inc -1) +))\n _FILE_ _LINE_)\n (rt/test (= '(2) (wrap three-list (inc 1)))\n _FILE_ _LINE_)\n (rt/test (= (list 1 2 4) (flat-map '(0 1 3) (fn [x] (list (inc x)))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (nth '((inc 0) 2 3) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= nothing (nth '(1 2 (inc 2)) (inc 2)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 3) (last (list (inc 0) 2 (inc 2))))\n _FILE_ _LINE_)\n (rt/test (= nothing (last empty-list))\n _FILE_ _LINE_)\n (rt/test (= [1 2 3] (vec three-list))\n _FILE_ _LINE_)\n (rt/test (= (list 1 2 3 4) (comp (list (inc 0) 2) [(inc 2) (inc 3)]))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (list 1 2 3) (list 0 1 2)))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (list 1 2 3) (list 1 2 2)))\n _FILE_ _LINE_)\n (rt/test (= empty-list (let [x (inc 0)]\n (filter empty-list (fn [y] (= x y)))))\n _FILE_ _LINE_)\n (rt/test (= empty-list (list* empty-list))\n _FILE_ _LINE_)\n (rt/test (= empty-list (apply list* empty-list))\n _FILE_ _LINE_)\n (rt/test (= '(1 2 3) (list* (inc 0) (inc 1) (inc 2) empty-list))\n _FILE_ _LINE_)\n (rt/test (= '(1 2 3 4 5) (list* (inc 0) (inc 1) (inc 2) (list (inc 3) (inc 4))))\n _FILE_ _LINE_)\n (rt/test (= '(1 2 3) (apply list* (list (inc 0) (inc 1) (inc 2) empty-list)))\n _FILE_ _LINE_)\n (rt/test (= '(1 2 3 4 5) (apply list* (list (inc 0) (inc 1) (inc 2) (list (inc 3) (inc 4)))))\n _FILE_ _LINE_)\n (rt/test (= '(3 4 5) (drop (list (inc 0) 2 (inc 2) (inc 3) 5) 2))\n _FILE_ _LINE_)\n (rt/test (= '() (drop (list (inc 0) 2 (inc 2) (inc 3) 5) 10))\n _FILE_ _LINE_)\n (rt/test (= '(1 2 3 4 5) (drop (list (inc 0) 2 (inc 2) (inc 3) 5) 0))\n _FILE_ _LINE_)\n\n (rt/test (= (map (list (inc 11)) (fn [x] x)) (list (inc 11)))\n _FILE_ _LINE_)\n (let [inc-val (inc 0)]\n (rt/test (= (map (map (list (inc 1)) (fn [x] (+ inc-val x))) double)\n (map (list (inc 1)) (fn [x] (double (+ inc-val x)))))\n _FILE_ _LINE_))\n\n (rt/test (= (map (list (inc 11)) list) (list (list (inc 11))))\n _FILE_ _LINE_)\n (rt/test (= (flat-map (list (inc 7)) list) (list (inc 7)))\n _FILE_ _LINE_)\n (rt/test (= (flat-map (list 4) f) (f 4))\n _FILE_ _LINE_)\n (rt/test (= (list 10)\n (flat-map (flat-map (list 4) f) g)\n (flat-map (list 4) (fn [x] (flat-map (f x) g))))\n _FILE_ _LINE_)\n (rt/test (empty? (butlast '()))\n _FILE_ _LINE_)\n (rt/test (= '(1) (butlast (list (inc 0) (inc 2))))\n _FILE_ _LINE_)\n\n (rt/test (= empty-list (apply (list list) empty-list))\n _FILE_ _LINE_)\n (rt/test (= empty-list (apply-to inc empty-list))\n _FILE_ _LINE_)\n (rt/test (= (list 2 3 4) (apply-to inc (list 1 2 3)))\n _FILE_ _LINE_)\n (rt/test (= (list 11 12 13 31 32 33) (apply-to + (list 1 2 (inc 2)) [10 30]))\n _FILE_ _LINE_)\n (rt/test (= empty-list (apply-to + '(1 2 (inc 2)) empty-list [10 20 30]))\n _FILE_ _LINE_)\n (rt/test (= '(2) (flat-map (list (inc 1)) vector))\n _FILE_ _LINE_)\n (let [m (list (subs \"string\" 2) (inc 4))]\n (sha1 m)\n (sha1 m))\n (println \"Lists are good\"))\n\n" }, { "path": "regression-tests/maybe-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(defn add-1-variadic [& x]\n (let [[x] x]\n (+ 1 x)))\n\n(def m-val (maybe \"poke\"))\n\n(defn test []\n (println \"Check Maybe regressions\")\n (rt/test (= \"Maybe\" (type-name nothing))\n _FILE_ _LINE_)\n (rt/test (instance? Maybe nothing)\n _FILE_ _LINE_)\n (rt/test (= \"Maybe\" (type-name (maybe (inc 1))))\n _FILE_ _LINE_)\n (rt/test (instance? Maybe (maybe (inc 8)))\n _FILE_ _LINE_)\n (rt/test (= 2 (extract (maybe (inc 1))))\n _FILE_ _LINE_)\n (rt/test (= [2] (type-args (maybe (inc 1))))\n _FILE_ _LINE_)\n (rt/test (= [] (type-args nothing))\n _FILE_ _LINE_)\n (rt/test m-val\n _FILE_ _LINE_)\n (rt/test (= (maybe 'yep) (and m-val (maybe 'yep)))\n _FILE_ _LINE_)\n (rt/test (= nothing (and nothing m-val))\n _FILE_ _LINE_)\n (rt/test (= nothing (and m-val nothing))\n _FILE_ _LINE_)\n (rt/test (or nothing m-val)\n _FILE_ _LINE_)\n (rt/test (or m-val nothing)\n _FILE_ _LINE_)\n (rt/test (= (maybe (inc 2)) (maybe (inc 2)))\n _FILE_ _LINE_)\n (let [x (inc 2)]\n (rt/test (= (maybe x) (maybe x))\n _FILE_ _LINE_))\n (rt/test (= nothing nothing)\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (map (maybe (inc 0)) inc))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (apply (maybe add-1-variadic) (list (maybe (inc 0)))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (apply (maybe add-1-variadic) (list (maybe (inc 0)))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 8) (apply (maybe +) (list (maybe (inc 0))\n (maybe (inc 2))\n (maybe (inc 3)))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 8) (apply (maybe (reify\n Container\n (apply [_ args]\n (apply + args))))\n (list (maybe (inc 0))\n (maybe (inc 2))\n (maybe (inc 3)))))\n _FILE_ _LINE_)\n (rt/test (= nothing (apply nothing (list (maybe (inc 0)))))\n _FILE_ _LINE_)\n (rt/test (= nothing (apply nothing (list (maybe (inc 0)) (maybe (inc 1)))))\n _FILE_ _LINE_)\n (rt/test (= nothing (apply-to inc nothing))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (maybe 2) (apply-to inc (maybe (inc 0)) nothing)))\n _FILE_ _LINE_)\n (rt/test (= nothing (apply nothing (list (maybe (inc 0)))))\n _FILE_ _LINE_)\n (rt/test (= nothing (apply-to + (maybe 8) nothing (maybe 13)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (apply (maybe inc) (list (maybe (inc 0)))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (apply-to add-1-variadic (maybe (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (apply (maybe (fn [] 2)) empty-list))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (apply (maybe (fn [& _] 2)) empty-list))\n _FILE_ _LINE_)\n (rt/test (= (maybe 3) (apply (maybe +) (list (maybe (inc 1)) (maybe (inc 0)))))\n _FILE_ _LINE_)\n (let [inc-val (inc 0)]\n (rt/test (= nothing (flat-map nothing (fn [x]\n (maybe (+ inc-val x)))))\n _FILE_ _LINE_))\n (let [inc-val (inc 0)]\n (rt/test (= (maybe 2) (flat-map (maybe (inc 0)) (fn [x]\n (maybe (+ inc-val x)))))\n _FILE_ _LINE_))\n (let [l (list 33)]\n (flat-map nothing\n (fn [h]\n (list l)\n (println \"fail in!!\" _FILE_ _LINE_)\n (abort))))\n\n (let [l (list 22)]\n (flat-map (maybe (inc 0))\n (fn [h]\n l\n h\n (maybe 8))))\n\n (let [double (fn [x]\n (+ x x))\n check-int (fn [x]\n (and (= 0 (mod x 2))\n (maybe x)))]\n ;; check the functor and applicative laws for maybe\n (rt/test (= (map (maybe 5) (fn [x] x)) (maybe 5))\n _FILE_ _LINE_)\n (rt/test (= (map (map (maybe 2) inc) double)\n (map (maybe 2) (fn [x]\n (double (inc x)))))\n _FILE_ _LINE_)\n (rt/test (= (map (maybe 5) inc)\n (apply-to inc (maybe 5)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 5) (apply-to (fn [x] x) (maybe 5)))\n _FILE_ _LINE_)\n (let [v1 (maybe \"first \")\n v2 (maybe \"second \")\n v3 (maybe \"third\")]\n (rt/test (= (apply-to comp (apply-to comp v1 v2) v3)\n (apply-to comp v1 (apply-to comp v2 v3))\n (apply-to comp v1 v2 v3))\n _FILE_ _LINE_))\n ;; check the functor and applicative laws for nothing\n (rt/test (= (map nothing (fn [x] x)) nothing)\n _FILE_ _LINE_)\n (rt/test (= (map (map nothing inc) double)\n (map nothing (fn [x]\n (double (inc x)))))\n _FILE_ _LINE_)\n (rt/test (= (map nothing inc)\n (apply-to inc nothing))\n _FILE_ _LINE_)\n (rt/test (= (apply-to comp (apply-to comp nothing nothing) nothing)\n (apply-to comp nothing (apply-to comp nothing nothing))\n (apply-to comp nothing nothing nothing))\n _FILE_ _LINE_)\n\n ;; nothing in action\n (let [good-ints (map (list 8 10 2 4 14) check-int)\n nothing-ints (map (list 8 3 2 5 14) check-int)]\n (rt/test (apply (maybe +) good-ints)\n _FILE_ _LINE_)\n (rt/test (= nothing (apply (maybe +) nothing-ints))\n _FILE_ _LINE_)))\n\n (let [inc-val (inc 0)\n f (reify\n Function\n (invoke [_ x]\n (+ inc-val x 2)))]\n (rt/test (= nothing (map nothing (fn [x]\n (+ inc-val x))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 4) (map (maybe (inc 0)) f))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (map (maybe (inc 0)) (reify\n Function\n (invoke [_ x]\n (+ inc-val x)))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 3) (flat-map (maybe 1) (reify\n Function\n (invoke [_ x]\n (maybe (+ inc-val x inc-val))))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (map (maybe (inc 0)) (fn [& xs]\n (let [[x] xs]\n (+ x inc-val)))))\n _FILE_ _LINE_))\n (rt/test (= (maybe 2) (flat-map (maybe (inc 0)) (reify\n Function\n (invoke [_ x]\n (maybe (inc x))))))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (flat-map (maybe (inc 0)) (fn [& xs]\n (let [[x] xs]\n (maybe (inc x))))))\n _FILE_ _LINE_)\n\n ;; check the monad laws for maybe\n (let [f (fn [x]\n (maybe (inc x)))\n double (fn [x]\n (+ x x))\n g (fn [x]\n (maybe (double x)))]\n (rt/test (= (flat-map (maybe (inc 7)) maybe) (maybe (inc 7)))\n _FILE_ _LINE_)\n (rt/test (= (flat-map (maybe 4) f) (f 4))\n _FILE_ _LINE_)\n (rt/test (= (maybe 10)\n (flat-map (flat-map (maybe 4) f) g)\n (flat-map (maybe 4) (fn [x] (flat-map (f x) g))))\n _FILE_ _LINE_))\n (let [m (maybe (subs \"string\" 2))]\n (sha1 m)\n (sha1 m))\n (println \"Maybe is good\"))\n" }, { "path": "regression-tests/or-and-constraints.toc", "content": "\n(defn inter [c]\n (or (and nothing\n (maybe (inc c)))\n (maybe c)))\n\n(main [_]\n (inter \" \"))\n" }, { "path": "regression-tests/promise-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(defn test []\n (println \"Checking promise regressions\")\n (let [p (promise)]\n (rt/test (= nothing (delivered p))\n _FILE_ _LINE_)\n (deliver p (inc 9))\n (rt/test (= 10 (extract p))\n _FILE_ _LINE_)\n (rt/test (delivered p)\n _FILE_ _LINE_))\n (let [p (promise (inc 9))]\n (rt/test (= (maybe 10) (delivered p))\n _FILE_ _LINE_)\n (rt/test (delivered p)\n _FILE_ _LINE_))\n (let [p (promise)\n f1 (future (fn []\n (let [x (extract p)]\n (+ x 10))))\n f2 (future (fn []\n (let [x (extract p)]\n (+ x 20))))]\n (future (fn [] (deliver p (inc 0))))\n (rt/test (= 11 (extract f1))\n _FILE_ _LINE_)\n (rt/test (= 21 (extract f2))\n _FILE_ _LINE_))\n (let [p (future (fn []\n (inc 9)))]\n (rt/test (= 10 (extract p))\n _FILE_ _LINE_)\n (rt/test (= 10 (extract p))\n _FILE_ _LINE_))\n (let [p1 (promise)\n p2 (map p1 inc)\n fut (future (fn []\n (rt/test (= 4 (extract p2))\n _FILE_ _LINE_)))]\n (deliver p1 3)\n (rt/test (= 3 (extract p1))\n _FILE_ _LINE_)\n (extract fut))\n (let [p1 (promise 2)\n p2 (map p1 inc)\n fut (future (fn []\n (rt/test (= 3 (extract p2))\n _FILE_ _LINE_)))]\n (rt/test (= 2 (extract p1))\n _FILE_ _LINE_)\n (extract fut))\n\n (let [double (fn [x]\n (+ x x))]\n (let [p1 (promise)\n p2 (map (map p1 inc) double)\n p3 (map p1 (fn [x]\n (double (inc x))))]\n (deliver p1 5)\n (rt/test (= (extract p2) (extract p3))\n _FILE_ _LINE_))\n\n (let [p1 (apply (promise (fn [] 5)) empty-list)]\n (rt/test (= (extract p1) 5)\n _FILE_ _LINE_))\n\n (let [p1 (promise)\n p2 (map p1 inc)\n p3 (apply-to inc p1)]\n (deliver p1 5)\n (rt/test (= (extract p2) (extract p3))\n _FILE_ _LINE_))\n\n (let [p1 (promise)\n p2 (promise)\n p3 (apply (promise +) [p1 p2])]\n (deliver p1 5)\n (deliver p2 10)\n (rt/test (= 15 (extract p3))\n _FILE_ _LINE_))\n\n (let [p1 (promise)\n p2 (promise)\n p3 (apply (promise +) [p1 p2])]\n (deliver p2 10)\n (deliver p1 5)\n (rt/test (= 15 (extract p3))\n _FILE_ _LINE_))\n\n (let [p1 (promise)\n p2 (map p1 double)\n p4 (apply-to + p2 p1)]\n (deliver p1 5)\n (rt/test (= 15 (extract p4))\n _FILE_ _LINE_))\n\n (let [p1 (promise)\n p2 (promise)\n p3 (promise)\n p4 (apply-to vector p1 p2 p3)]\n (deliver p2 \"two\")\n (deliver p1 \"one\")\n (deliver p3 \"three\")\n (rt/test (= [\"one\" \"two\" \"three\"]\n (extract p4))\n _FILE_ _LINE_)))\n\n (let [p1 (promise)\n p2 (promise)\n p3 (promise)\n p4 (comp p1 p2 p3)]\n (deliver p1 (inc 3))\n (deliver p2 (inc 7))\n (rt/test (= 4 (extract p4))\n _FILE_ _LINE_))\n\n (let [p1 (promise)\n p2 (promise)\n p3 (promise)\n p4 (comp p1 p2 p3)]\n (deliver p2 4)\n (deliver p1 8)\n (rt/test (= 4 (extract p4))\n _FILE_ _LINE_))\n\n (let [p1 (promise)\n p2 (promise)\n p3 (promise)\n p4 (comp p1 p2 p3)]\n (deliver p3 4)\n (deliver p2 8)\n (rt/test (= 4 (extract p4))\n _FILE_ _LINE_))\n\n (let [inc-val (inc 0)\n f (reify\n Function\n (invoke [_ x]\n (+ inc-val x 2)))]\n (let [p1 (promise)\n p2 (map p1 f)]\n (deliver p1 (inc 0))\n (rt/test (= 4 (extract p2))\n _FILE_ _LINE_))\n (let [p1 (promise)\n p2 (map p1 (reify\n Function\n (invoke [_ x]\n (+ inc-val x))))]\n (deliver p1 (inc 0))\n (rt/test (= 2 (extract p2))\n _FILE_ _LINE_))\n (let [p1 (promise)\n p2 (flat-map p1 (reify\n Function\n (invoke [_ x]\n (promise (+ inc-val x inc-val)))))]\n (deliver p1 (inc 0))\n (rt/test (= 3 (extract p2))\n _FILE_ _LINE_))\n (let [p1 (promise)\n p2 (map p1 (fn [& xs]\n (let [[x] xs]\n (+ x inc-val))))]\n (deliver p1 (inc 0))\n (rt/test (= 2 (extract p2))\n _FILE_ _LINE_)))\n\n ;; check the monad laws for Promise\n (let [f (fn [x]\n (promise (inc x)))\n double (fn [x]\n (+ x x))\n g (fn [x]\n (promise (double x)))]\n (let [p1 (promise)\n p2 (flat-map p1 promise)]\n (deliver p1 7)\n (rt/test (= (extract p2) 7)\n _FILE_ _LINE_))\n (let [p1 (promise)\n p2 (flat-map p1 f)]\n (deliver p1 4)\n (rt/test (= (extract p2)\n (extract (f 4)))\n _FILE_ _LINE_))\n (let [p1 (promise)\n p2 (flat-map p1 f)\n p3 (flat-map p2 g)\n p4 (flat-map p1 (fn [x] (flat-map (f x) g)))]\n (deliver p1 4)\n (rt/test (= 10 (extract p3) (extract p4))\n _FILE_ _LINE_)))\n ;; a special test\n (let [p1 (promise)\n p2 (promise)\n p3 (promise)\n p4 (flat-map p1 (fn [x]\n (deliver p2 x)\n p3))\n fut (future (fn []\n (let [x (extract p4)]\n (rt/test (= 99 x)\n _FILE_ _LINE_))))]\n (future (fn []\n (let [x (extract p2)]\n (deliver p3 x))))\n (deliver p1 99)\n (extract fut))\n (println \"Promises are good\"))\n" }, { "path": "regression-tests/regression-tester.toc", "content": "\n(defn test [v file line]\n (or v\n (let [_ (println \"fail in!!\" file line)]\n (abort))))\n" }, { "path": "regression-tests/string-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(def sample-str (str \"Str\" \"ing\"))\n\n(defn test []\n (println \"Checking string regressions\")\n (rt/test (instance? String (char (inc 65)))\n _FILE_ _LINE_)\n (rt/test (= nothing (instance? Maybe (char 66)))\n _FILE_ _LINE_)\n (rt/test (instance? String (subs \"bogus\" (inc 1)))\n _FILE_ _LINE_)\n (rt/test (= (list \"string\") (string-list \"string\"))\n _FILE_ _LINE_)\n (rt/test (= (list \"tring\") (string-list (subs \"string\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= \"tring\" (escape-chars (subs \"string\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= \"String\" (type-name \"string\"))\n _FILE_ _LINE_)\n (rt/test (= \"str\" \"str\")\n _FILE_ _LINE_)\n (rt/test (= sample-str sample-str)\n _FILE_ _LINE_)\n (rt/test (= \"string\" (escape-chars \"string\"))\n _FILE_ _LINE_)\n (rt/test (= \"String\" (type-name (subs \"string\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= \"\" (subs (str 'a) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= [\"string\"] (type-args \"string\"))\n _FILE_ _LINE_)\n (rt/test (= [\"tring\"] (type-args (subs \"string\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= (char-code \"B\") 66)\n _FILE_ _LINE_)\n (rt/test (= (subs sample-str (inc 0)) \"tring\")\n _FILE_ _LINE_)\n (rt/test (= \"ring \" (subs (subs (str sample-str \" \") (inc 0)) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= \"tr\" (subs sample-str (inc 0) (inc 1)))\n _FILE_ _LINE_)\n (rt/test (= \"ri\" (subs (subs sample-str (inc 0)) (inc 0) (inc 1)))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (subs (str sample-str \" \") (inc 3) (inc 6)) \"tring\"))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (subs (subs (str sample-str \" \") 1) (inc 3) (inc 6)) \"tring\"))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (subs (str sample-str \" \") 2) (subs (str sample-str \" \") 1)))\n _FILE_ _LINE_)\n (rt/test (= (char-code (subs \"Bro\" (inc -1) (inc 0))) 66)\n _FILE_ _LINE_)\n (rt/test (= \"\" (subs (str sample-str \" \") (inc 2) (inc -5)))\n _FILE_ _LINE_)\n (rt/test (= (count (subs \"Bro\" (inc -1) (inc 0))) (inc 0))\n _FILE_ _LINE_)\n (rt/test (= \"abcd\" (comp \"a\" \"\" \"bc\" \"d\"))\n _FILE_ _LINE_)\n (rt/test (= (comp* (str \"b\" \"o\") (list \"gus\")) (comp* \"bo\" (list \"gu\" \"s\")))\n _FILE_ _LINE_)\n (rt/test (= (subs \"bogus\" (inc 1)) (comp* \"g\" (list \"u\" \"s\")))\n _FILE_ _LINE_)\n (rt/test (= (subs \"bogus\" (inc 1)) (subs \"bogus\" (inc 1)))\n _FILE_ _LINE_)\n (rt/test (= \"B\" (char 66))\n _FILE_ _LINE_)\n (rt/test (= (char 66) (str \"B\" \"\"))\n _FILE_ _LINE_)\n (rt/test (= \"\" (empty \"xy\"))\n _FILE_ _LINE_)\n (rt/test (= \"\" (empty (subs \"abc\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= nothing (empty? \"abc\"))\n _FILE_ _LINE_)\n (rt/test (= nothing (empty? (subs \"abc\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= nothing (first \"\"))\n _FILE_ _LINE_)\n (rt/test (= (maybe \"a\") (first \"abc\"))\n _FILE_ _LINE_)\n (rt/test (= nothing (last \"\"))\n _FILE_ _LINE_)\n (rt/test (= (maybe \"c\") (last \"abc\"))\n _FILE_ _LINE_)\n (rt/test (= \"\" (butlast \"\"))\n _FILE_ _LINE_)\n (rt/test (= \"ab\" (butlast \"abc\"))\n _FILE_ _LINE_)\n (rt/test (= \"\" (rest \"\"))\n _FILE_ _LINE_)\n (rt/test (= \"\" (rest (subs \"aa\" 1)))\n _FILE_ _LINE_)\n (rt/test (= \"bc\" (rest \"abc\"))\n _FILE_ _LINE_)\n (let [s \"string\"]\n (sha1 s)\n (sha1 s))\n (let [s (subs (subs sample-str (inc 0)) (inc 0) (inc 1))]\n (sha1 s)\n (sha1 s))\n (rt/test (= (inc -1) (count \"\"))\n _FILE_ _LINE_)\n (rt/test (= (inc 1) (count \"ab\"))\n _FILE_ _LINE_)\n (rt/test (= (inc -1) (count (subs \"a\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= (inc 1) (count (subs \"abc\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= empty-list (seq (str \"\" \"\")))\n _FILE_ _LINE_)\n (rt/test (= (list \"x\" \"y\" \"z\") (seq (str \"xy\" \"z\")))\n _FILE_ _LINE_)\n (rt/test (= (list \"y\" \"z\") (seq (subs (str \"xy\" \"z\") 1)))\n _FILE_ _LINE_)\n (rt/test (= empty-vector (vec (str \"\" \"\")))\n _FILE_ _LINE_)\n (rt/test (= [\"x\" \"y\" \"z\"] (vec (str \"xy\" \"z\")))\n _FILE_ _LINE_)\n (rt/test (= (vector \"y\" \"z\") (vec (subs (str \"xy\" \"z\") 1)))\n _FILE_ _LINE_)\n (rt/test (= \"\" (empty (subs \"abc\" (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= (list \"z\" \"y\" \"x\") (reduce \"xyz\" empty-list conj))\n _FILE_ _LINE_)\n (rt/test (= (list \"z\" \"y\" \"x\") (reduce \"xyz\" empty-list (reify\n Function\n (invoke [_ l x]\n (conj l x)))))\n _FILE_ _LINE_)\n (let [prefix \"-\"]\n (rt/test (= (list \"-z\" \"-y\" \"-x\") (reduce \"xyz\" empty-list (reify\n Function\n (invoke [_ l x]\n (conj l (str prefix x))))))\n _FILE_ _LINE_))\n (rt/test (= (maybe \"c\") (nth \"abc\" 2))\n _FILE_ _LINE_)\n (rt/test (= nothing (= \"b\" (nth \"abc\" 4)))\n _FILE_ _LINE_)\n (let [abc (str \"abc\" \"\")\n abcd (str \"abcd\" \"\")\n xyz (subs \"wxyz\" 1)\n wxyz (subs \"vwxyz\" 1)]\n (rt/test (< abc abcd)\n _FILE_ _LINE_)\n (rt/test (< abc xyz)\n _FILE_ _LINE_)\n (rt/test (< wxyz xyz)\n _FILE_ _LINE_)\n (rt/test (= nothing (< xyz abc))\n _FILE_ _LINE_))\n (println \"Strings are good\"))\n" }, { "path": "regression-tests/symbol-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(def sym 'symbol)\n\n(defn test []\n (println \"Check symbol regressions\")\n (rt/test (= \"Symbol\" (type-name (symbol (str \"bo\" \"gus\"))))\n _FILE_ _LINE_)\n (rt/test (= ['bogus] (type-args (symbol (subs \" bogus\" 1))))\n _FILE_ _LINE_)\n (rt/test (= nothing (instance? Integer (symbol \"bogus\")))\n _FILE_ _LINE_)\n (let [sym-str (str \"symbol\" \"\")]\n (rt/test (= sym (symbol sym-str))\n _FILE_ _LINE_)\n\n (rt/test (= (symbol sym-str) sym)\n _FILE_ _LINE_)\n\n (rt/test (= (symbol (subs sym-str 1)) 'ymbol)\n _FILE_ _LINE_)\n\n (let [sym (symbol sym-str)]\n (sha1 sym)\n (sha1 sym)))\n (println \"Symbols are good\"))\n" }, { "path": "regression-tests/tail-cond-1.toc", "content": "\n(defn g []\n (cond (= 0 0) (str 'yeppers \" \" (inc 0))\n (= 0 0) (str 'yeppers \" \" (inc 1))\n (= 0 0) (str 'yeppers \" \" (inc 2))\n (= 0 0) (str 'yeppers \" \" (inc 3))\n (str 'nopenopenope \" \" (inc 4))))\n\n(main [_]\n (print-err (g))\n\n (print-err 'done))\n" }, { "path": "regression-tests/test-apply-constructor.toc", "content": "\n(deftype Bogus [a b c]\n Stringable\n (string-list [_]\n (list \"\")))\n\n(main [_]\n (print-err (apply (maybe Bogus) (list (maybe (inc 3)) (maybe (inc 4)) (maybe (inc 5))))))\n" }, { "path": "regression-tests/test-comment-in-let.toc", "content": "\n(defprotocol Boom\n (boomaliscious [vect]\n (let [vect (subvec vect 3)]\n (print-err 'prices vect)\n ;; Boom\n )))\n\n(main [_]\n (boomaliscious [4 8 1 2 4 6]))\n" }, { "path": "regression-tests/test-def-empty.test", "content": "\n;; this causes a phantom memory leak\n(def grammars [])\n\n(main [_]\n (println 'done))\n" }, { "path": "regression-tests/test-either.toc", "content": "\n(defn lr1 [l result f]\n (either (maybe l)\n (lr1 (rest l) (f empty-list 1) f))\n l)\n\n(defn lr2 [l result f]\n (either (maybe l)\n (lr2 (rest l) (f empty-list 1) f)))\n\n(defn p1 [coll n]\n (lr1 coll (list \"a\" \"b\")\n (fn inner-p [q x]\n n\n (to-str q)))\n (lr2 coll (list \"a\" \"b\")\n (fn inner-p [q x]\n n\n (to-str q))))\n\n(defn p2 [coll n]\n (reduce coll (list \"a\" \"b\")\n (fn [q x]\n (to-str q))))\n\n(defn lr3 [l result f]\n (either (empty? l)\n (lr3 (rest l) (f result (extract (first l))) f)))\n\n(defn p3 [coll n]\n (lr3 coll (list \"a\" \"b\")\n (fn inner-p [q x]\n n\n (to-str q)))\n (lr3 coll (list \"a\" \"b\")\n (fn other-inner-p [q x]\n (either (= n 2 2)\n 5))))\n\n(defn p4 [coll n]\n (reduce coll (list \"a\" \"b\")\n (fn [q x]\n n)))\n\n(main [_]\n (p1 (list 'c 3) 2)\n (p2 (list 'c 3) 2)\n (p3 (list 'c 3) 2)\n (p4 (list 'c 3) 2))\n" }, { "path": "regression-tests/test-for.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(main [_]\n (rt/test (= (maybe 9) (for [x (maybe 8)]\n (+ x 1)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 17) (for [x (maybe 8)\n y (maybe 9)]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 27) (for [x (maybe 8)\n :let [z (+ 10 x)]\n y (maybe 9)]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 27) (for [x (maybe 8)\n y (maybe 9)\n :let [z (+ 10 x)]]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 17) (for [x (maybe 8)\n :when (maybe 1)\n y (maybe 9)]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 17) (for [x (maybe 8)\n y (maybe 9)\n :when (maybe 1)]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= nothing (for [x (maybe 8)\n :when nothing\n y (maybe 9)]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= nothing (for [x (maybe 8)\n y (maybe 9)\n :when nothing]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 27) (for [x (maybe 8)\n y (maybe 9)\n :when (maybe 1)\n :let [z (+ x 10)]]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 27) (for [x (maybe 8)\n y (maybe 9)\n :let [z (+ x 10)]\n :when (maybe 1)]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= nothing (for [x (maybe 8)\n y (maybe 9)\n :when nothing\n :let [z (+ x 10)]]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= nothing (for [x (maybe 8)\n y (maybe 9)\n :let [z (+ x 10)]\n :when nothing]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 17) (for [x (maybe 8)\n :when-not nothing\n y (maybe 9)]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 17) (for [x (maybe 8)\n y (maybe 9)\n :when-not nothing]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= nothing (for [x (maybe 8)\n :when-not (maybe 1)\n y (maybe 9)]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= nothing (for [x (maybe 8)\n y (maybe 9)\n :when-not (maybe 1)]\n (+ x y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 27) (for [x (maybe 8)\n y (maybe 9)\n :when-not nothing\n :let [z (+ x 10)]]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 27) (for [x (maybe 8)\n y (maybe 9)\n :let [z (+ x 10)]\n :when-not nothing]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= nothing (for [x (maybe 8)\n y (maybe 9)\n :when-not (maybe 1)\n :let [z (+ x 10)]]\n (+ z y)))\n _FILE_ _LINE_)\n (rt/test (= nothing (for [x (maybe 8)\n y (maybe 9)\n :let [z (+ x 10)]\n :when-not (maybe 1)]\n (+ z y)))\n _FILE_ _LINE_)\n (println \"'for' is good\"))\n" }, { "path": "regression-tests/test-gensym.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(main [_]\n (rt/test (= 'sym0 (gensym \"sym\"))\n _FILE_ _LINE_)\n (rt/test (= 'sym1 (gensym \"sym\"))\n _FILE_ _LINE_)\n (rt/test (= 'sym2 (gensym \"sym\"))\n _FILE_ _LINE_)\n (extract (future (fn []\n (rt/test (= 'fut3 (gensym \"fut\"))\n _FILE_ _LINE_)\n (rt/test (= 'fut4 (gensym \"fut\"))\n _FILE_ _LINE_)\n (rt/test (= 'fut5 (gensym \"fut\"))\n _FILE_ _LINE_))))\n (println \"gensym is good\"))\n" }, { "path": "regression-tests/test-global-empty-list.toc", "content": "\n;; TODO: bad error message\n(def el ())\n\n(main [_]\n (print-err 'woo-hoo))\n" }, { "path": "regression-tests/test-hlist-cons.toc", "content": "\n(deftype Bogus [x])\n\n(main [_]\n (cons 44\n (cons \"\"\n (-> [1 2 3]\n seq\n (map (fn bogus-fn [x]\n (Bogus x)))))))\n" }, { "path": "regression-tests/test-ignore-inferred.toc", "content": "\n(deftype SomeType [field])\n\n(defprotocol SomeProto\n (f [x]\n (.field x (inc (.field x)))))\n\n(extend-type String\n SomeProto\n (f [s]\n s))\n\n(main [_]\n (f \"howdy\"))\n" }, { "path": "regression-tests/test-inline-invoke.toc", "content": "\n(deftype Error [val state]\n Stringable\n (string-list [_] \n (list \"(Error \" (str val) \")\")))\n\n(deftype new-se [invoke-fn]\n (assert (instance? Fn invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s))\n\n Container\n (map [ev f]\n (new-se (fn [st]\n (let [x (invoke-fn st)]\n (either (instance? Error x)\n (let [[v new-s] x]\n [(f v) new-s]))))))\n\n (wrap [_ v]\n (new-se (fn [s]\n [v s])))\n\n (flat-map [ev f]\n (new-se (fn [s]\n (let [x (invoke-fn s)]\n (either (instance? Error x)\n (let [[v new-s] x]\n ((f v) new-s))))))))\n\n(defn state-error [v]\n (new-se (fn [s]\n [v s])))\n\n(defn tc [sym]\n (let [s 'sumptin]\n (flat-map (state-error 'checking)\n (fn [_]\n (print-err 'test 2 s)\n (map (state-error 'again)\n (fn [c]\n (or (instance? Symbol s)\n (abort))\n c))))))\n\n(main [_]\n (print-err ((tc 'some-sym)\n {'module (list {'some-sym 'blewie})})))\n" }, { "path": "regression-tests/test-inline-namespaced-sym.toc", "content": "\n(add-ns b (module \"Boomer.toc\"))\n\n(main [_]\n (print-err (wrap (b/Boomer 18) 48))\n\n (print-err 'done))\n" }, { "path": "regression-tests/test-inline-sym-literal.toc", "content": "\n(deftype Error [val state]\n Stringable\n (string-list [_] \n (list \"(Error \" (str val) \")\")))\n\n(deftype new-se [invoke-fn]\n (assert (instance? Fn invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"\")))\n\n Function\n (invoke [ev s]\n (invoke-fn s))\n\n Container\n (map [ev f]\n (new-se (fn [s]\n (let [x (invoke-fn s)]\n (either (instance? Error x)\n (let [[v new-s] x]\n (print-err 'v)\n (either (= (symbol \"v\") 'v)\n (abort))\n [(f v) new-s])))))))\n\n(main [_]\n (print-err ((map (new-se (fn [s]\n [99 s]))\n (fn [y]\n 'x\n ))\n 'state)))\n" }, { "path": "regression-tests/test-inlined-result-constraint.toc", "content": "\n(defn test-h [nums]\n (assert (instance? (vector-of Integer) nums))\n\n (map nums (fn [n]\n (assert (instance? Integer n))\n (assert-result r (instance? (maybe-of Integer) r))\n (maybe n))))\n\n(main [_]\n (print-err (test-h [1 2 3])))\n" }, { "path": "regression-tests/test-or-comment.toc", "content": "\n(defn f1 [d]\n (or (map (get d 'x)\n (fn [x]\n (list (str (inc 9)))))\n ;; this comment used to cause an incRef error\n )\n (or (map (get d 'x)\n (fn [x]\n (list (str (inc 9)))))\n ;; this comment used to cause an incRef error\n ))\n\n(defn f2 [x]\n (and (and\n ;; just a comment\n nothing)\n\n ;; try a comment here\n (maybe 99)))\n\n(main [_]\n (f1 {})\n (f2 'flyer))\n" }, { "path": "regression-tests/test-parser-efficience.toc", "content": "\n(add-ns rdr (git-dependency \"https://github.com/Toccata-Lang/reader.git\"\n \"reader.toc\"\n :sha \"783bbe8\"))\n(add-ns rd (git-dependency \"https://github.com/Toccata-Lang/recursive-descent.git\"\n \"recursive-descent.toc\"\n :sha \"6378d02\"))\n\n;; Replace rdr/read-sum-type with this\n\n;; (def read-sum-type\n;; (grmr/rule \"sum-type\"\n;; (grmr/apply-fn ast/any-of\n;; read-open-paren\n;; ignore-whitespace\n;; (debug 'any-of)\n;; (grmr/ignore \"any-of\")\n;; (debug 'sub-types)\n;; (grmr/one-or-more (grmr/all (grmr/ignore (grmr/one-or-more whitespace))\n;; read-sub-type-expr))\n;; (debug 'done)\n;; read-close-paren)))\n\n;; then parse this string and the debug info gets printed twice. Why?\n\n\n(def input \"\n(defn boomity [x]\n (assert (instance? (any-of StringBuffer\n SubString)\n x))\n ;; (assert-result r (instance? (list-of (any-of StringBuffer\n ;; SubString))\n ;; r))\n (list x x))\n\")\n\n(main [_]\n ;; (print-err ((rd/parser rdr/top-level)\n ;; {'file-name \"boomer.toc\"\n ;; 'line-number 1\n ;; 'project-directory \"\"\n ;; 'root-directory \"\"}\n ;; input))\n (abort)\n )\n" }, { "path": "regression-tests/test-proto-def-constraints.toc", "content": "\n\n(deftype Dummy [field])\n\n(defprotocol Proto\n (proto-fn [x]\n (.field x)))\n\n(extend-type String\n Proto\n (proto-fn [s]\n s))\n\n(deftype OneType [y]\n Stringable\n (string-list [_]\n (list (str y)))\n\n Proto\n (proto-fn [_]\n (proto-fn y)))\n\n(main [_]\n (OneType 'bogus))\n" }, { "path": "regression-tests/test-proto-impl-destruct.toc", "content": "\n(defprotocol Proto\n (f [x]))\n\n(extend-type Vector\n Proto\n (f [[a b]]\n (print-err 'a a)\n (print-err 'b b)))\n\n(main [_]\n (f [1 3]))\n" }, { "path": "regression-tests/test-recursive-map-fn.toc", "content": "\n(main [_]\n (map [] (fn some-fn [x]\n (map [] some-fn))))\n" }, { "path": "regression-tests/test-regressions.toc", "content": "#! $TOCCATA_DIR/toccata --script\n;; You'll need to replace $TOCCATA_DIR with the path to your 'toccata' executable\n\n(add-ns int (module \"integer-regressions.toc\"))\n(add-ns fns (module \"function-regressions.toc\"))\n(add-ns strs (module \"string-regressions.toc\"))\n(add-ns myb (module \"maybe-regressions.toc\"))\n(add-ns sym (module \"symbol-regressions.toc\"))\n(add-ns lst (module \"list-regressions.toc\"))\n(add-ns vec (module \"vector-regressions.toc\"))\n(add-ns hm (module \"hash-map-regressions.toc\"))\n(add-ns typ (module \"types-regressions.toc\"))\n(add-ns agt (module \"agent-regressions.toc\"))\n(add-ns ll (module \"lazy-list-regressions.toc\"))\n(add-ns git (git-dependency \"https://github.com/jduey/test-git.git\" \"repo-root.toc\"\n :branch \"non-master-test\"))\n(add-ns prom (module \"promise-regressions.toc\"))\n(add-ns fut (module \"future-regressions.toc\"))\n\n(deftype Bogus [x m])\n\n(def ns (Bogus (get typ/symbols 'test)\n typ/symbols))\n\n(main [args]\n (assert (instance? List args))\n (.x ns)\n (.m ns)\n (int/test)\n (fns/test)\n (strs/test)\n (myb/test)\n (sym/test)\n (lst/test)\n (vec/test)\n (hm/test)\n (typ/test)\n (agt/test)\n (ll/test)\n (git/test)\n (prom/test)\n (fut/test)\n (println 'all-done))\n" }, { "path": "regression-tests/test-tail-recur-1.toc", "content": "\n(defn loop [tmp n]\n (or (and (< n 0) (maybe tmp))\n (loop (add-numbers 1 tmp) (dec n))))\n\n\n(main [_]\n (print-err 'tmp (loop 0 30000)))\n" }, { "path": "regression-tests/test-tail-recur-2.toc", "content": "\n(defn loop [tmp n]\n (and (< n 0)\n (loop (add-numbers 1 tmp) (dec n))))\n\n\n(main [_]\n (print-err 'tmp (loop 0 30000)))\n" }, { "path": "regression-tests/test-tail-recur-3.toc", "content": "\n(defn loop [tmp n]\n (either (and (< n 0) (maybe tmp))\n (loop (add-numbers 1 tmp) (dec n))))\n\n\n(main [_]\n (print-err 'tmp (loop 0 30000)))\n" }, { "path": "regression-tests/test-threading.toc", "content": "\n;; NOT testing process threading\n;; rather, testing the '->' special form\n\n(add-ns rt (module \"regression-tester.toc\"))\n\n(main [_]\n (rt/test (= {'a 1 'b 2 'c 3}\n (-> {}\n (assoc 'b 2)\n (assoc 'a 1)\n (assoc 'c 3)))\n _FILE_ _LINE_)\n (rt/test (= 6 (-> {'c 3}\n (assoc 'b 2)\n (assoc 'a 1)\n vals\n (reduce 0 +)))\n _FILE_ _LINE_)\n (println \"'->' is good\"))\n" }, { "path": "regression-tests/test-trailing-comment.toc", "content": "\n(defn f [x y]\n ;; some comment\n nothing\n ;; another comment\n )\n\n(main [_]\n (f (str 1) (str 3)))\n" }, { "path": "regression-tests/test-type-of-tail.toc", "content": "\n(defn f [y]\n (let [[& x] [(inc 0) (inc 3)]]\n (cons (inc 4) x)))\n\n(main [_]\n (println (f ['a 9])))\n" }, { "path": "regression-tests/test-underscore-inline.toc", "content": "\n(deftype Boomer [z]\n Stringable\n (string-list [_]\n (list \"\"))\n\n Container\n (wrap [_ q]\n [q]))\n\n(main [_]\n (print-err (wrap (Boomer 8) 99)))\n" }, { "path": "regression-tests/test-uni.toc", "content": "\n(defn init [f]\n (inline C \"\nuniversalProtoFn = (Value *)f_0;\nreturn(nothing);\n\"))\n\n(defprotocol TestProto\n (no-default [x y z])\n (with-default [x y]\n 'the-default-result))\n\n\n(defn f [path fn-sym disp-arg & args]\n (print-err 'uni path fn-sym disp-arg args)\n nothing)\n\n(main [_]\n (init f)\n (let [rv (reify\n Stringable\n (string-list [_]\n (list \"Howdy\"))\n\n TestProto\n (no-default [x y z]\n (inc 91))\n (with-default [x y]\n (str 'bippity)))]\n \n (or (and (= \"bippity\" (with-default rv (inc 8)))\n (= 92 (no-default rv (inc 1) (str \"a\" \"b\"))))\n (maybe (abort)))\n\n (print-err 'done)))\n" }, { "path": "regression-tests/test1.toc", "content": "\n(main [_]\n (inline C \"\ndec_and_free(arg0, 1);\nprintf(\\\"Howdy, folks\\\\n\\\");\nreturn(nothing);\"))\n" }, { "path": "regression-tests/test10.toc", "content": "\n(defn add-ints [x y]\n (inline C Integer \"\n return(add_ints(x_0, y_1));\n\"))\n\n(defn integer-str [n]\n (inline C String \"\n return(integer_str(n_0));\n\"))\n\n(defn int= [x y]\n (inline C String \"\n return(integer_EQ(x_0, y_1));\n\"))\n\n(def msg1 \"Howdy Folks\\n\")\n(def msg2 msg1)\n(def int1 (let [x (add-ints 1 7)\n y (add-ints 4 5)]\n (add-ints x y)))\n\n(main [_]\n (let [x (add-ints 6 3)\n y (add-ints 8 2)]\n (pr* (integer-str (add-ints x y)))\n (pr* \"\\n\"))\n (pr* (integer-str int1))\n (pr* \"\\n\")\n (pr* msg2))\n" }, { "path": "regression-tests/test11.toc", "content": "\n(def vect1 (vector 1 2 3))\n(def list1 (list 4 5 6))\n\n(defn integer-str [n]\n (inline C String \"\n return(integer_str(n_0));\n\"))\n\n(defn f1 [[x y z]]\n (pr* (integer-str x))\n (pr* \" \")\n (pr* (integer-str y))\n (pr* \" \")\n (pr* (integer-str z))\n (pr* \"\\n\"))\n\n(main [_]\n (let [[x y] vect1]\n (pr* (integer-str x))\n (pr* \" \")\n (pr* (integer-str y))\n (pr* \" \"))\n (let [[a b c] list1]\n (pr* (integer-str a))\n (pr* \" \")\n (pr* (integer-str b))\n (pr* \" \")\n (pr* (integer-str c))\n (pr* \"\\n\"))\n (pr* \"Now for the local call sites\\n\")\n (let [[x y z] (vector 1 2 3)]\n (pr* (integer-str x))\n (pr* \" \")\n (pr* (integer-str y))\n (pr* \" \")\n (pr* (integer-str z))\n (pr* \" \"))\n (let [[a b c] (list 4 5 6)]\n (pr* (integer-str a))\n (pr* \" \")\n (pr* (integer-str b))\n (pr* \" \")\n (pr* (integer-str c))\n (pr* \"\\n\"))\n (pr* \"Function destructuring\\n\")\n (f1 vect1)\n (f1 list1)\n (pr* \"Vectors and Lists! Oh my!\\n\"))\n" }, { "path": "regression-tests/test12.toc", "content": "\n(main [_]\n (pr* (do\n (pr* \"one\\n\")\n (pr* \"two\\n\")\n \"three\\n\")))\n" }, { "path": "regression-tests/test13.toc", "content": "\n(main [_]\n (and (=* 0 0)\n ;; a comment\n (=* (inc 0) (inc 0))\n (maybe (pr* \"'and' works\\n\")))\n (or (=* 0 1)\n ;; a comment\n (maybe (pr* \"'or' works\\n\")))\n (or (and (=* 0 0)\n (maybe (pr* \"'and' in 'or' works\\n\")))\n (maybe (pr* \"'and' in 'or' works\\n\")))\n (or (and (=* 1 0)\n (maybe (pr* \"'and' in 'or' works\\n\")))\n (and (=* 0 0)\n (maybe (pr* \"2 'and' in 'or' works\\n\"))))\n (and (or (=* 0 0)\n (maybe (pr* \"'or' in 'and' wandks\\n\")))\n (maybe (pr* \"'or' in 'and' wandks\\n\")))\n (and (or (=* 0 0)\n (maybe (pr* \"2 'or' in 'and' works\\n\")))\n (or (=* 1 0)\n (maybe (pr* \"2 'or' in 'and' works\\n\"))))\n (let [x (maybe 8)]\n (and x (let [y (extract x)]\n (maybe (+ y 1)))))\n (let [w (maybe 99)]\n (or (let [_ w\n mv (+ 7 1)]\n (maybe mv))\n nothing))\n (and nothing\n (do\n (print-err \"FAIL!!!\")\n (abort))))\n" }, { "path": "regression-tests/test14.toc", "content": "\n(defn integer-str [n]\n (inline C String \"\n return(integer_str(n_0));\n\"))\n\n(def vect1 (vector (integer-str 1) (integer-str 2) 3))\n(def list1 (list (integer-str 4) (integer-str 5) 6))\n\n(defn f0 [x y]\n (pr* (integer-str x))\n (pr* \" \")\n (pr* (integer-str y))\n (pr* \"\\n\"))\n\n(defn f1 [x y & z]\n (pr* x)\n (pr* \" \")\n (pr* y)\n (pr* \"\\n\")\n (let [[a b] z]\n (pr* (integer-str a))\n (pr* \" \")\n (pr* (integer-str b))\n (pr* \"\\n\")))\n\n(defn f2 [[x y z] & tail]\n (pr* x)\n (pr* \" \")\n (pr* \"\\n\"))\n\n(defn f3 [[x y z] & tail]\n (pr* x)\n (pr* \" \")\n (pr* y)\n (pr* \" \")\n (pr* (integer-str z))\n (pr* \" \")\n (let [[a b] tail]\n (pr* (integer-str a))\n (pr* \" \")\n (pr* (integer-str b)))\n (pr* \"\\n\"))\n\n(def global-x 99)\n\n(main [_]\n (pr* \"Function destructuring\\n\")\n (f0 1 2)\n (f1 (integer-str 1) (integer-str 2) 3 4)\n (f2 vect1 10 11)\n (f3 list1 10 11)\n (f3 vect1 10 11)\n (pr* (integer-str global-x))\n (pr* \"\\n\")\n (pr* \"Vectors and Lists! Oh my!\\n\"))\n" }, { "path": "regression-tests/test15.toc", "content": "\n\n(defn integer-str [n]\n (inline C String \"\n return(integer_str(n_0));\n\"))\n\n(main [_]\n (let [xx 10\n xs (list (integer-str xx))\n f1 (fn f1 [y]\n (pr* y)\n (let [[x] xs]\n (pr* x)\n (pr* \" \")\n (pr* x)\n (pr* \"\\n\")))]\n (f1 \"Howdy\\n\")))\n\n\n" }, { "path": "regression-tests/test16.toc", "content": "\n(defn integer-str [n]\n (inline C String \"\n return(integer_str(n_0));\n\"))\n\n(defn f\n ([x]\n (pr* (integer-str x))\n (pr* \"\\n\"))\n ([x & xs]\n (map (cons x xs) (fn [x]\n (pr* (integer-str x))\n (pr* \" \")))\n (pr* \"\\n\")))\n\n(main [_]\n (f 1)\n (f 4 5 6 7))\n" }, { "path": "regression-tests/test17.toc", "content": "\n(main [_]\n (println \"Howdy,\" \"Boyz!\" 99))\n" }, { "path": "regression-tests/test18.toc", "content": "\n(defn f [q]\n (q))\n\n(main [_]\n (f (fn boom1 []\n (let [max (maybe 0)]\n (and (and max\n (maybe 9))\n max))))\n (print-err 'boom1)\n (f (fn boom2 []\n (let [max (maybe 0)]\n (and (or max\n (maybe 9))\n max))))\n (print-err 'boom2)\n (f (fn boom3 []\n (let [max (maybe 0)]\n (or (and max\n (maybe 9))\n max))))\n (print-err 'boom3)\n (f (fn boom4 []\n (let [max (maybe 0)]\n (or (or max\n (maybe 9))\n max))))\n (print-err 'boom4))\n" }, { "path": "regression-tests/test19.toc", "content": "\n(inline C \"\n#include \n#include \\n\")\n\n(defn sleep [seconds]\n (inline C Integer \"\n replaceWorker();\n int secs = ((Integer *)seconds_0)->numVal;\n dec_and_free(seconds_0, 1);\n Value *result = integerValue(sleep(secs));\n return(result);\\n\"))\n\n(add-ns rt (module \"regression-tester.toc\"))\n\n(def agt (agent {}))\n\n(main [_]\n (let [p1 (future (fn []\n (sleep 3)\n 2))\n p2 (future (fn []\n (sleep 2)\n 8))\n p3 (future (fn []\n (sleep 1)\n 4))\n p4 (comp p1 p2 p3)]\n (rt/test (= 4 (extract p4))\n _FILE_ _LINE_)\n (extract p1)\n (extract p2)\n (extract p3))\n\n (let [p (promise)]\n (send agt (fn [n]\n (let [r (assoc n 'p (extract p))]\n (sleep 3)\n r)))\n (deliver p 8))\n (sleep 1)\n (print-err 'success))\n" }, { "path": "regression-tests/test20.toc", "content": "\n(def en (enum r3 r1 r2))\n\n(defn r-str [r]\n (assert (instance? en r))\n (print-err 'r r))\n\n(main [_]\n (r-str r2))\n" }, { "path": "regression-tests/test3.toc", "content": "\n;; this is a block comment\n ;; it consists of multiple lines of comments\n\n;; But this is a new block comment\n\n(main [_]\n ;; this is a block comment inside a 'main' fn\n ;; with two lines, even\n (inline C \"\ndec_and_free(arg0, 1);\nprintf(\\\"Howdy, folks\\\\n\\\");\nreturn(nothing);\")\n ;; and after the inline expr\n )\n" }, { "path": "regression-tests/test4.toc", "content": "\n;; define a const integer literal using an inline expr\n(def int1\n ;; the pre-def comment block\n (inline C String \"(Value *)&(Integer){IntegerType, -1, 29}\")\n ;; the post-def comment block\n )\n\n;; define a const integer literal value\n(def int2 35)\n\n;; redefine 'int2'\n(def int2 45)\n\n;; this should not emit any C code because '35' is already compiled\n(def int3 35)\n\n(main [_]\n (inline C \"\ndec_and_free(arg0, 1);\nprintf(\\\"Howdy, folks\\\\n\\\");\nreturn(nothing);\")\n )\n" }, { "path": "regression-tests/test5.toc", "content": "\n;; define a const string literal value\n(def str1 \"some string\")\n\n;; redefine 'str1'\n(def str1 \"another string\")\n\n;; this should not emit any C code because '35' is already compiled\n(def str2 \"some string\")\n\n(main [_]\n (inline C \"\ndec_and_free(arg0, 1);\nprintf(\\\"Howdy, folks\\\\n\\\");\nreturn(nothing);\"))\n" }, { "path": "regression-tests/test6.toc", "content": "\n(defn pr* [str]\n ;; If a block comment appears first in the body, it serves\n ;; as the documentation for the function\n (inline C Integer\n \"if (str_0->type == StringBufferType) {\n fprintf(stdout, \\\"%-.*s\\\", (int)((String *)str_0)->len, ((String *)str_0)->buffer);\n } else if (str_0->type == SubStringType) {\n fprintf(stdout, \\\"%-.*s\\\", (int)((SubString *)str_0)->len, ((SubString *)str_0)->buffer);\n } else {\n fprintf(stdout, \\\"\\\\ninvalid type for 'pr*'\\\\n\\\");\n abort();\n }\n dec_and_free(str_0, 1);\n return(integerValue(1));\\n\")\n ;; But block comments that appear after are ignored\n )\n\n(main [_]\n (pr* \"Howdy, folks\\n\"))\n\n" }, { "path": "regression-tests/test7.toc", "content": "\n(main [_]\n (pr* \"Howdy Folks\\n\"))\n" }, { "path": "regression-tests/test8.toc", "content": "\n(defn add-ints [x y]\n (inline C Integer \"\n return(add_ints(x_0, y_1));\n\"))\n\n(defn integer-str [n]\n (inline C String \"\n return(integer_str(n_0));\n\"))\n\n(def msg1 \"Howdy Folks\\n\")\n(def msg2 msg1)\n(def int1 (add-ints 7 8))\n(def int2 (add-ints 9 2))\n\n\n(main [_]\n (pr* (integer-str int1))\n (pr* \"\\n\")\n (pr* msg2))\n" }, { "path": "regression-tests/test9.toc", "content": "\n(defn add-ints [x y]\n (inline C Integer \"\n return(add_ints(x_0, y_1));\n\"))\n\n(defn integer-str [n]\n (inline C String \"\n return(integer_str(n_0));\n\"))\n\n(defn int= [x y]\n (inline C String \"\n return(integer_EQ(x_0, y_1));\n\"))\n\n(def msg1 \"Howdy Folks\\n\")\n(def msg2 msg1)\n(def int1 (add-ints 7 8))\n(def int2 (add-ints 9 2))\n\n(main [_]\n (int= int1 int2)\n (pr* (integer-str int1))\n (pr* \"\\n\")\n (pr* msg1))\n" }, { "path": "regression-tests/types-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(deftype EmptyType []\n Stringable\n (string-list [_] '(\"\")))\n\n(deftype BogusType [z]\n ;; blow it up\n\n ;; TODO: fix this\n ;; Container\n ;; (apply* [_ [arg & args]]\n ;; (print-err 'arg arg 'args args))\n )\n\n(defprotocol BogusProtocol\n (bogus [x y]\n (str x)))\n\n;; (def new-bogus bogus)\n\n(deftype OneType [x]\n (assert (instance? Integer x))\n\n Stringable\n (string-list [_] (list \"\")))\n\n(deftype AnotherType [x z]\n (assert (instance? Integer x))\n (assert (instance? Symbol z))\n\n Stringable\n (string-list [_] (list \"\")))\n\n(def BothTypes (any-of OneType\n AnotherType))\n\n(def ReifiedType\n (reify\n Stringable\n (string-list [_] (list \"\"))))\n\n(defn foo [x]\n (assert (instance? BothTypes x))\n (str x))\n\n(defn f-instance [n]\n (assert-result x (instance? BothTypes x))\n (either (and (= 1 n)\n (maybe (OneType n)))\n (AnotherType n (symbol (str n)))))\n\n(extend-type BogusType\n Stringable\n (string-list [x] (list \"\"))\n\n BogusProtocol\n (bogus [x y]\n (+ y 10)))\n\n(deftype AssocType [m]\n (assert (instance? HashMap m))\n\n Associative\n (assoc [at k v]\n (either (and (< 0 k 4)\n (maybe (AssocType (assoc m k v))))\n at))\n\n (get [_ k]\n (and (< 0 k 4)\n (get m k))))\n\n(def f1)\n\n(defn f2 [x]\n (f1 x))\n\n(def f1\n (reify\n Function\n (invoke [_ x]\n (+ x 10))))\n\n(defn make-reified-value [z]\n (reify\n Eq\n (=* [x y]\n (and (= (get-type x) (get-type y))\n (maybe x)))\n\n Stringable\n (string-list [_]\n (list \"\"))))\n\n(defprotocol Impls\n ;; For AST nodes that can be embedded in other AST nodes\n (call-this [_]\n (assert-result x (instance? Integer x)))\n\n ;; Mark this AST node as the final (or tail) expression in a function body\n (dont-call [x y z]))\n\n(defn test []\n (println \"Check deftypes regressions\")\n (rt/test (= 15 (f2 5))\n _FILE_ _LINE_)\n\n (rt/test (instance? BothTypes (OneType (inc 12)))\n _FILE_ _LINE_)\n\n (rt/test (= (AnotherType (inc 4) 'z) (apply AnotherType [(inc 4) 'z]))\n _FILE_ _LINE_)\n (rt/test (instance? BothTypes (AnotherType (inc 4) 'z))\n _FILE_ _LINE_)\n\n (rt/test (instance? String (foo (OneType (inc 4))))\n _FILE_ _LINE_)\n\n (rt/test (instance? String (foo (AnotherType (inc 9) 'z)))\n _FILE_ _LINE_)\n\n (rt/test (instance? OneType (f-instance 1))\n _FILE_ _LINE_)\n\n (rt/test (instance? AnotherType (f-instance 3))\n _FILE_ _LINE_)\n\n (rt/test (= \"\" (str ReifiedType))\n _FILE_ _LINE_)\n (rt/test (= \"\" (str (make-reified-value 9)))\n _FILE_ _LINE_)\n (rt/test (= \"\" (str (make-reified-value 8)))\n _FILE_ _LINE_)\n (rt/test (= (make-reified-value 9) (make-reified-value 8))\n _FILE_ _LINE_)\n\n (rt/test (= \"\" (str (AnotherType 10 'bogus)))\n _FILE_ _LINE_)\n\n (rt/test (= nothing (= (get-type [1]) (get-type (list 1 2))))\n _FILE_ _LINE_)\n (rt/test (= (get-type (list 1)) (get-type (list 2)))\n _FILE_ _LINE_)\n (rt/test (= nothing (= (get-type (list 1)) (get-type [1])))\n _FILE_ _LINE_)\n\n (let [one (inc 0)\n bt (BogusType one)\n [x] (type-args bt)]\n\n (rt/test (= \"* BogusType constructor at /home/jim/toccata/regression-tests/types-regressions.toc: 8 *\"\n (type-name BogusType))\n _FILE_ _LINE_)\n (rt/test (= \"\" (str BogusType))\n _FILE_ _LINE_)\n (rt/test (= \"BogusType\" (type-name bt))\n _FILE_ _LINE_)\n (rt/test (instance? BogusType bt)\n _FILE_ _LINE_)\n (rt/test (= 1 x)\n _FILE_ _LINE_)\n (rt/test (= 1 (.z bt))\n _FILE_ _LINE_)\n (rt/test (= (maybe 1) (get bt .z))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (get (.z bt (inc 1)) .z))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (get (assoc bt .z (inc 1)) .z))\n _FILE_ _LINE_)\n (rt/test (= nothing (get bt .x))\n _FILE_ _LINE_)\n (rt/test (= bt (assoc bt .x 2))\n _FILE_ _LINE_)\n\n (rt/test (= (BogusType (inc 0)) bt)\n _FILE_ _LINE_)\n (rt/test (= (maybe (inc 4)) (get (assoc bt .z (inc 4)) .z))\n _FILE_ _LINE_))\n \n (rt/test (instance? BogusType (extract (= (BogusType 9) (BogusType 9))))\n _FILE_ _LINE_)\n (rt/test (instance? Integer (inc 7))\n _FILE_ _LINE_)\n\n (let [at (AssocType {5 'a 3 'b})]\n (rt/test (= {5 'a 3 'b} (.m (assoc at 5 'c)))\n _FILE_ _LINE_)\n (rt/test (= {5 'a 3 'c} (.m (assoc at 3 'c)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 'b) (get at 3))\n _FILE_ _LINE_)\n (rt/test (= nothing (get at 5))\n _FILE_ _LINE_))\n\n (let [closure 9\n x (reify\n Impls\n (dont-call [x y z]\n (print-err 'FAIL)\n (abort))\n (call-this [_]\n (inc closure)))]\n (call-this x))\n\n (rt/test (= \"8\" (bogus 8 'howdy))\n _FILE_ _LINE_)\n\n ;; TODO: this needs to be fixed\n ;; (rt/test (= \"8\" (new-bogus 8 'howdy))\n ;; _FILE_ _LINE_)\n\n (println \"Types are good\"))\n\n" }, { "path": "regression-tests/vector-regressions.toc", "content": "\n(add-ns rt (module \"regression-tester.toc\"))\n\n(def three-vect (vector (inc 0) (inc 1) (inc 2)))\n\n(defn f [x]\n (vector (inc x)))\n\n(defn double [x]\n (* 2 x))\n\n(defn g [x]\n (vector (double x)))\n\n(defn int-vect [n]\n (vec (range n)))\n\n(defn test []\n (println \"Check vector regressions\")\n (rt/test (instance? Vector [(inc 0) (inc 1) (inc 2)])\n _FILE_ _LINE_)\n (rt/test (= nothing (instance? Vector (char 66)))\n _FILE_ _LINE_)\n (rt/test (= \"Vector\" (type-name [1 2 3]))\n _FILE_ _LINE_)\n (rt/test (= [1 2 3] (type-args [1 2 3]))\n _FILE_ _LINE_)\n (rt/test (= 3 (count three-vect))\n _FILE_ _LINE_)\n (rt/test (= (maybe 3) (get [(inc 2)] (dec 1)))\n _FILE_ _LINE_)\n (rt/test (= nothing (get [(inc 1)] (dec 2)))\n _FILE_ _LINE_)\n (rt/test (= (maybe 2) (nth [1 (inc 1) 3] (dec 2)))\n _FILE_ _LINE_)\n (rt/test (= nothing (nth [1 2 3] (inc 2)))\n _FILE_ _LINE_)\n (rt/test (= [3] (vector 3))\n _FILE_ _LINE_)\n (rt/test (= [[3]] (vector [(inc 2)]))\n _FILE_ _LINE_)\n (rt/test (= [3] (conj [] (inc 2)))\n _FILE_ _LINE_)\n (rt/test (= 3 (count (conj (conj (conj [] (inc 2)) (inc 1)) (inc 0))))\n _FILE_ _LINE_)\n (rt/test (= [3 2 1] (conj (conj (conj [] 3) 2) 1))\n _FILE_ _LINE_)\n (rt/test (empty? [])\n _FILE_ _LINE_)\n (rt/test (= nothing (empty? [3]))\n _FILE_ _LINE_)\n (rt/test (= [] (subvec [(inc 1) (subs \"01\" 1) (inc 2)] (inc 90)))\n _FILE_ _LINE_)\n (rt/test (= [] (subvec [(inc 1) (subs \"01\" 1) (inc 2)] (inc 90) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= [\"1\" 3] (subvec [2 (subs \"01\" 1) 3] 1))\n _FILE_ _LINE_)\n (rt/test (= [\"1\"] (subvec [(inc 1) (subs \"01\" 1) (inc 2)] (inc 0) (inc 0)))\n _FILE_ _LINE_)\n (rt/test (= [\"1\" 3] (subvec [(inc 1) (subs \"01\" 1) (inc 2)] (inc 0) (inc 6)))\n _FILE_ _LINE_)\n (rt/test (empty? (rest []))\n _FILE_ _LINE_)\n (rt/test (= nothing (= [1 2 3] 1))\n _FILE_ _LINE_)\n (rt/test (= 2 (count (comp [1 2])))\n _FILE_ _LINE_)\n (rt/test (= 4 (count (comp [1 2] [3 4])))\n _FILE_ _LINE_)\n (rt/test (= 6 (count (comp [1 2] [3 (inc 3)] [(inc 4) 6])))\n _FILE_ _LINE_)\n (rt/test (= 6 (count (comp [1 (inc 1)] [] [3 4] (empty []) [(inc 4) 6])))\n _FILE_ _LINE_)\n (rt/test (empty? (empty [1 2]))\n _FILE_ _LINE_)\n (let [inc-val (inc 0)]\n (rt/test (= 4 (count (filter [(inc 0) 2 3 1 (inc 0) (inc 4) 1 6 (inc 6)]\n (fn [x] (= x inc-val)))))\n _FILE_ _LINE_))\n (let [inc-val (inc 0)]\n (rt/test (= 4 (count (filter [(inc 0) 2 3 1 (inc 0) (inc 4) 1 6 (inc 6)]\n (fn [& xs] (let [[x] xs] (= x inc-val))))))\n _FILE_ _LINE_))\n (let [inc-val (inc 0)]\n (rt/test (= [2 3 4] (map [1 2 3] (fn [x] (+ inc-val x))))\n _FILE_ _LINE_)\n (rt/test (= [2 3 4] (map [1 (inc 1) 3] (reify\n Function\n (invoke [_ x]\n (+ inc-val x)))))\n _FILE_ _LINE_))\n (let [inc-val (inc 0)]\n (rt/test (= [2 3 4] (map [1 2 3] (fn [& xs] (let [[x] xs] (+ inc-val x)))))\n _FILE_ _LINE_))\n (rt/test (= 6 (reduce [(inc 2) (inc 1) 1] 0 +))\n _FILE_ _LINE_)\n (rt/test (= [2] (wrap [1 2 3] (inc 1)))\n _FILE_ _LINE_)\n (let [inc-val (inc 0)]\n (rt/test (= [1 2 4] (flat-map [0 (inc 0) 3]\n (fn [x]\n [(+ inc-val x)])))\n _FILE_ _LINE_))\n (rt/test (= (maybe 3) (last [1 2 (inc 2)]))\n _FILE_ _LINE_)\n (rt/test (= nothing (last []))\n _FILE_ _LINE_)\n (rt/test (= (maybe [55]) (store [] (dec 1) (inc 54)))\n _FILE_ _LINE_)\n (rt/test (= (maybe [55 2 3 4]) (store [(inc 0) 2 3 4] (dec 1) (inc 54)))\n _FILE_ _LINE_)\n (rt/test (= (maybe [1 2 55 4]) (store [(inc 0) 2 (inc 2) 4] (inc 1) (inc 54)))\n _FILE_ _LINE_)\n (rt/test (= (maybe [1 2 3 4 55]) (store [1 2 3 (inc 3)] (inc 3) (inc 54)))\n _FILE_ _LINE_)\n (rt/test (= nothing (store [(inc 0) 2 3 4] (inc 8) (inc 54)))\n _FILE_ _LINE_)\n (rt/test (= [3 4 1 2] (comp [(inc 2) 4] (list (inc 0) 2)))\n _FILE_ _LINE_)\n (rt/test (= \"[]\" (str []))\n _FILE_ _LINE_)\n (rt/test (= \"[8, 1]\" (str [8 1]))\n _FILE_ _LINE_)\n (rt/test (= (list 1 2 3) (seq three-vect))\n _FILE_ _LINE_)\n (rt/test (= [95 96 97 98 99] (subvec (int-vect 100) (inc 94)))\n _FILE_ _LINE_)\n (rt/test (= (maybe [24 55 26])\n (map (store (int-vect 40) 25 55) (fn [v]\n (subvec v 24 3))))\n _FILE_ _LINE_)\n (rt/test (= 6000 (count (int-vect 6000)))\n _FILE_ _LINE_)\n (rt/test (= 2000 (count (reduce (seq (int-vect 2000)) [] conj)))\n _FILE_ _LINE_)\n (rt/test (= [30 31 2] (subvec (conj (int-vect (inc 31)) (inc 1)) 30))\n _FILE_ _LINE_)\n (rt/test (= [31 32 2] (subvec (conj (int-vect 33) (inc 1)) 31))\n _FILE_ _LINE_)\n (let [big-v (int-vect 65)]\n (rt/test (= 2080 (count (flat-map big-v (fn [x] (int-vect x)))))\n _FILE_ _LINE_))\n (let [[c] [(vector 1 2 3 4 5)]]\n (let [[a & b] c]\n (rt/test (and (= '(2 3 4 5) b)\n (= [1 2 3 4 5] c))\n _FILE_ _LINE_)))\n (rt/test (= ['one 'two 'three] '[one two three])\n _FILE_ _LINE_)\n (rt/test (= ['one 2 'three] '[one 2 three])\n _FILE_ _LINE_)\n (rt/test (= ['one '(2 three) 'four] '[one (2 three) four])\n _FILE_ _LINE_)\n (let [[a b & c] (vector 1 2 3 4 5)]\n (rt/test (and (= 1 a)\n (= 2 b)\n (= '(3 4 5) c))\n _FILE_ _LINE_))\n (let [[a b & c] [1 2 3 4]]\n ((fn [x] x) (inc 1)))\n\n (rt/test (= (map (vector 12) (fn [x] x)) (vector 12))\n _FILE_ _LINE_)\n (rt/test (= (map (map (vector 2) inc) double)\n (map (vector 2) (fn [x]\n (double (inc x)))))\n _FILE_ _LINE_)\n\n (rt/test (= (flat-map (vector 8) vector) (vector 8))\n _FILE_ _LINE_)\n (rt/test (= (flat-map (vector 4) f) (f 4))\n _FILE_ _LINE_)\n (rt/test (= (flat-map (vector 4) vector) (vector 4))\n _FILE_ _LINE_)\n (rt/test (= (vector 10)\n (flat-map (flat-map (vector 4) f) g)\n (flat-map (vector 4) (fn [x] (flat-map (f x) g))))\n _FILE_ _LINE_)\n\n (rt/test (= [1 2 3] (reverse [3 (inc 1) 1]))\n _FILE_ _LINE_)\n\n (rt/test (= 6 (reduce [(inc 2) (inc 1) (inc 0)] 0 +))\n _FILE_ _LINE_)\n\n (rt/test (= empty-vector (reverse empty-vector))\n _FILE_ _LINE_)\n\n (rt/test (= [1 2 3] (reverse [(inc 2) (inc 1) (inc 0)]))\n _FILE_ _LINE_)\n (let [[a [b c]] [1 [2 3] 4 5]]\n (rt/test (and (= a 1)\n (= b 2)\n (= c 3))\n _FILE_ _LINE_))\n\n (rt/test (= [] (apply [list] empty-list))\n _FILE_ _LINE_)\n (rt/test (= [] (apply-to inc []))\n _FILE_ _LINE_)\n (rt/test (= [2 3 4] (apply-to inc [1 2 3]))\n _FILE_ _LINE_)\n (rt/test (= [11 12 13 31 32 33] (apply-to + [1 2 3] [10 30]))\n _FILE_ _LINE_)\n (rt/test (= [] (apply-to + [1 2 3] [] [10 20 30]))\n _FILE_ _LINE_)\n (let [m (vector (subs \"string\" 2) (inc 4))]\n (sha1 m)\n (sha1 m))\n\n (println \"Vectors are good\"))\n" }, { "path": "run", "content": "#!/bin/bash\n\nrm $1.out $1.tmp\n# echo \"using toccata, not new-toc\"\n$TOCCATA_DIR/new-toc $1 > $1.tmp &&\nawk '/^#$/ { printf \"#line %d \\\"%s\\\"\\n\", NR+1, \"m.c\"; next; } { print; }' $1.tmp > m.c &&\n$CC -g -fno-objc-arc -o $1.out -I$TOCCATA_DIR -std=c99 -DCHECK_MEM_LEAK=1 $TOCCATA_DIR/core.c m.c \\\n -lpthread -latomic &&\n./$1.out \"${@:2}\"\n\n# $CC -g -fno-objc-arc -o m -I$TOCCATA_DIR -std=c99 -DCHECK_MEM_LEAK=1 $TOCCATA_DIR/core.c m.c -lpthread -latomic && ./m\n# $CC -g -fno-objc-arc -o new-toc -I$TOCCATA_DIR -std=c99 -DCHECK_MEM_LEAK=1 $TOCCATA_DIR/core.c new-toc.c -lpthread\n# $CC -g -fno-objc-arc -o scripter -I$TOCCATA_DIR -std=c99 -DCHECK_MEM_LEAK=1 $TOCCATA_DIR/core.c scripter.c -lpthread && ./scripter test.toc\n\n" }, { "path": "runtime-tests/agent-loop.toc", "content": "\n(main [_]\n (let [pm (maybe (agent nothing))]\n (map pm (fn [p]\n (send p (fn [_] pm)))))\n (print-err 'done))\n" }, { "path": "runtime-tests/apply-constructor.toc", "content": "\n\n(deftype Popper [x y]\n (assert (instance? Symbol x))\n (assert (instance? Integer y)))\n\n(defn g [& vs]\n (apply Popper vs))\n\n(main [_]\n (print-err (g 's (either nothing \"8\"))))\n" }, { "path": "runtime-tests/bad-arity-1.toc", "content": "\n;; TODO: error message doesn't point to line number\n\n(defn bad [a b]\n a)\n\n(main [_]\n ((either (maybe bad) 'boom) \"Bogus\"))\n" }, { "path": "runtime-tests/bad-arity-2.toc", "content": "\n;; TODO: error doesn't specify position\n\n(deftype BogusType [var struct])\n\n(main [_]\n ((either (maybe BogusType)\n 'bogus)\n \"Bogus\"))\n" }, { "path": "runtime-tests/bad-enum-1.toc", "content": "\n(def en (enum r3 r1))\n\n(defn r-str [r]\n (assert (instance? en r))\n (print-err 'r r))\n\n(main [_]\n (r-str (either (maybe 'r2) r1)))\n" }, { "path": "runtime-tests/bad-field-1.toc", "content": "\n(deftype Ooops [not-there])\n\n(deftype Bogus [x-field])\n\n;; TODO: remove 'required from' part of error message\n\n(main [_]\n (.not-there (either (maybe (Bogus 99))\n (Ooops 99))))\n" }, { "path": "runtime-tests/bad-field-2.toc", "content": "\n(deftype Ooops [not-there])\n\n(deftype Bogus [x-field])\n\n;; TODO: pass the field constraint throught the call to setter .x-field\n\n(defn f [x]\n (-> x\n (.x-field 3)\n (.not-there)))\n\n(main [_]\n (println (f (Bogus 99))))\n" }, { "path": "runtime-tests/bad-maybe-flat-map.toc", "content": "\n(defprotocol C\n (eic [_]\n []))\n\n(deftype IC [items]\n Stringable\n (string-list [_]\n (list \"\")))\n\n(defn maybe-mapper [x f]\n (flat-map x f))\n\n(deftype MC [cs]\n C\n (eic [mc]\n (-> (.cs mc)\n (some (partial instance? IC))\n (maybe-mapper .items))))\n\n(main [_]\n (print-err (eic (MC [1 (IC 2) 3])))\n (print-err 'FAIL!!!))\n" }, { "path": "runtime-tests/bad-param.toc", "content": "\n(main [_]\n (inc (either (maybe \"p\")\n 88)))\n" }, { "path": "runtime-tests/bad-proto-param-1.toc", "content": "\n(defprotocol BogusProto\n (update [x]\n x))\n\n(deftype BogusType [field]\n (assert (instance? Vector field)))\n\n(defn dorf [x]\n (-> (BogusType [])\n (update)\n (.field x)))\n\n;; TODO: error message has '#' in it.\n\n(main [_]\n (map [empty-list] dorf))\n" }, { "path": "runtime-tests/bad-proto-param-2.toc", "content": "\n(defprotocol BogusProto\n (update [x]\n x)\n\n (some-fn [x y]))\n\n(deftype BogusType [field]\n (assert (instance? Vector field))\n\n BogusProto\n (some-fn [_ [y]]\n y))\n\n(defn dorf [x]\n (-> (BogusType [])\n (update)\n (some-fn x)))\n\n;; TODO: improve error message\n\n(main [_]\n (map [empty-list] dorf))\n" }, { "path": "runtime-tests/bad-proto-param-3.toc", "content": "\n(defprotocol BogusProto\n (update [x]\n x)\n\n (some-fn [x y]))\n\n(deftype Bogosity [x])\n\n(deftype BogusType [field]\n (assert (instance? Vector field))\n\n BogusProto\n (some-fn [_ y]\n (.x y)))\n\n(defn dorf [x]\n (-> (BogusType [])\n (update)\n (some-fn x)))\n\n(main [_]\n (map [empty-list] dorf))\n" }, { "path": "runtime-tests/bad-proto-param-4.toc", "content": "\n(defprotocol BogusProto\n (brop [x]\n x))\n\n(deftype BogusType [field]\n (assert (instance? Vector field))\n\n Stringable\n (string-list [_]\n (list \"(BogusType \" (str field) \")\"))\n\n BogusProto\n (brop [x]\n x))\n\n(defn dorf [x]\n (-> (BogusType [])\n ;; (brop)\n (.field (either (maybe x)\n []))))\n\n(main [_]\n (print-err (map [empty-list] dorf)))\n" }, { "path": "runtime-tests/bad-variadic-param.toc", "content": "\n(defn f [x & y]\n (assert (instance? Integer x))\n (str x))\n\n(main [_]\n (print-err 'wut (f (either nothing \"99\")))\n (print-err 'done))\n" }, { "path": "runtime-tests/check-and-1.toc", "content": "\n(defn f [g x]\n (let [y (either nothing x)]\n (and (maybe 'h)\n y)))\n\n\n(main [_]\n (print-err (f inc 1)))\n" }, { "path": "runtime-tests/check-and-2.toc", "content": "\n(defn f [g x]\n (let [y (either nothing x)]\n (and (maybe 'h)\n y)\n 'done))\n\n\n(main [_]\n (print-err (f inc 1)))\n" }, { "path": "runtime-tests/check-and-3.toc", "content": "\n(defn f [g x]\n (and (maybe 'h)\n (g x)))\n\n\n(main [_]\n (print-err (f inc 1)))\n" }, { "path": "runtime-tests/check-and-4.toc", "content": "\n(defn f [g x]\n (and (maybe 'h)\n (g x))\n 'done)\n\n\n(main [_]\n (print-err (f inc 1)))\n" }, { "path": "runtime-tests/check-every-time.toc", "content": "\n(defn f [x]\n (or (and nothing\n (maybe (subs (either nothing x)\n 1)))\n (and (maybe 9)\n (maybe (inc (either nothing x))))))\n\n(main [_]\n (print-err 'wut (f \"99\"))\n (print-err 'done))\n" }, { "path": "runtime-tests/check-or-1.toc", "content": "\n(defn f [g x]\n (or nothing\n (g x)))\n\n\n(main [_]\n (print-err (f inc 1)))\n" }, { "path": "runtime-tests/check-or-2.toc", "content": "\n(defn f [g x]\n (let [y (either nothing x)]\n (or nothing\n (g x)))\n 'done)\n\n\n(main [_]\n (print-err (f inc 1)))\n" }, { "path": "runtime-tests/check-or-3.toc", "content": "\n(defn f [g x]\n (let [y (either nothing x)]\n (or nothing\n y)))\n\n\n(main [_]\n (print-err (f inc 1)))\n" }, { "path": "runtime-tests/check-or-4.toc", "content": "\n(defn f [g x]\n (let [y (either nothing x)]\n (or nothing\n y)\n 'done))\n\n\n(main [_]\n (print-err (f inc 1)))\n" }, { "path": "runtime-tests/check-params-1.toc", "content": "\n(main [_]\n (inc (either (maybe (str 'bogus))\n 8)))\n" }, { "path": "runtime-tests/check-params-2.toc", "content": "\n(defn g [z]\n (inc z))\n\n(defn f [g h]\n (println 'h (inc h))\n (g \"bogus\"))\n\n(main [_]\n (println (f g 99))\n (println 'done))\n" }, { "path": "runtime-tests/check-return-sum-type.toc", "content": "\n(defprotocol Proto\n (proto-fn [_]\n (assert-result r (instance? (any-of String Integer) r))))\n\n(deftype IC [x]\n Proto\n (proto-fn [c]\n (either (maybe 'bog)\n 88)))\n\n(main [_]\n (print-err 'done (str \"'\" (proto-fn (IC 8)) \"'\" )))\n" }, { "path": "runtime-tests/check-tail-either.toc", "content": "\n(defprotocol Proto\n (proto-fn [_]\n (assert-result r (instance? Vector r))))\n\n(deftype IC [x]\n Proto\n (proto-fn [c]\n (either (and (or nothing\n (maybe []))\n (maybe \"\"))\n [\"\"])))\n\n(main [_]\n (print-err 'done (str \"'\" (proto-fn (IC 8)) \"'\" )))\n" }, { "path": "runtime-tests/closure-param.toc", "content": "\n(main [_]\n (let [x 8\n f (fn [z]\n (+ x z))]\n (println (f (either nothing \"100\"))))\n (println 'done))\n" }, { "path": "runtime-tests/constructor-param.toc", "content": "\n(deftype Biggie [x]\n (assert (instance? HashSet x)))\n\n(main [_]\n (print-err \"Line number should be\" (inc _LINE_))\n (Biggie (either nothing \"99\"))\n (print-err 'FAIL))\n" }, { "path": "runtime-tests/default-impl-parameter.toc", "content": "\n(defprotocol Bogus\n (bogus [x y z]\n (assert (instance? Symbol z))\n\n (inc y)))\n\n(main [_]\n (print-err 'bad (bogus 8 'a 'b)))\n" }, { "path": "runtime-tests/default-proto.toc", "content": "\n(defn g [z]\n (inc z))\n\n(defprotocol SomeProto\n (f [g h]\n (print-err 'h (inc h))\n (print-err \"Line in error should be\" (inc _LINE_))\n (g \"bogus\")))\n\n(main [_]\n (f g (either (maybe \"99\") 0))\n (print-err 'done))\n" }, { "path": "runtime-tests/destruct-variadic-tail-1.toc", "content": "\n(defn f [x]\n (assert (instance? Integer x))\n (str x))\n\n(defn g [& y]\n (let [[x] y]\n (f x)))\n\n(main [_]\n (print-err \"Line number should be 12\")\n (print-err 'wut (g (either nothing \"99\")))\n (print-err 'done))\n" }, { "path": "runtime-tests/flat-map-param.toc", "content": "\n(deftype and-ast [clauses]\n (assert (instance? Vector clauses))\n\n Stringable\n (string-list [_]\n (comp (list \"\"))))\n\n(defn traverse [asts f]\n (reduce (reverse asts) (maybe empty-list)\n (fn [l ast]\n (flat-map (f ast)\n (fn [emitted]\n (map l (fn [x]\n (cons emitted x))))))))\n\n;; TODO: error message has '#field' in it\n\n(main [_]\n (let [aa (and-ast ['a 'b])]\n (println (map (traverse (either (maybe ['a 'b])\n '(a b)) maybe)\n (fn [nc]\n (.clauses aa (either (maybe nc)\n []))))))\n (println 'done))\n" }, { "path": "runtime-tests/higher-order-fn.toc", "content": "\n(main [_]\n (println (map [1 2 (either (maybe 'three)\n 3) 4]\n inc)))\n" }, { "path": "runtime-tests/higher-order-variadic.toc", "content": "\n(defn g [z & x]\n (inc z))\n\n(defn f [g h]\n (println 'h (inc h))\n (g \"bogus\" 10))\n\n(main [_]\n (println (f g 99))\n (println 'done))\n" }, { "path": "runtime-tests/insufficient-elements.toc", "content": "\n(defn f [y]\n (let [[[a x] & b] (either nothing [[(inc 1) (inc 7)] (inc 0)])\n [y z] b]\n (println 'a (inc a))))\n\n(main [_]\n (println (f ['a 9])))\n" }, { "path": "runtime-tests/int-too-large-1.toc", "content": "\n(defn f [n]\n (assert (instance? (max 4) n))\n (inc n))\n\n(main [_]\n (print-err \"Line in error should be\" (inc _LINE_))\n (f (+ 4 4))\n (print-err 'howdy))\n" }, { "path": "runtime-tests/int-too-large-2.toc", "content": "\n(main [_]\n (let [x 1\n f (fn f [n]\n (assert (instance? (max 4) n))\n (inc n))]\n (print-err (f (+ 4 4)))\n (print-err 'howdy)))\n" }, { "path": "runtime-tests/int-too-large.toc", "content": "\n(defn f [n]\n (assert (instance? (max 4) n))\n (inc n))\n\n(main [_]\n (f (either nothing 5))\n (print-err 'howdy))\n" }, { "path": "runtime-tests/int-too-small.toc", "content": "\n(defn f [n]\n (assert (instance? (min 4) n))\n (inc n))\n\n(main [_]\n (f (either nothing 3))\n (print-err 'howdy))\n" }, { "path": "runtime-tests/invalid-type.toc", "content": "\n(defprotocol Proto\n (proto-fn [x]\n \"string\"))\n\n(defn f [x]\n (let [x (inc x)\n x (str x)]\n (subs x 1)))\n\n(main [_]\n (println (f (proto-fn 81)))\n (println 'done))\n" }, { "path": "runtime-tests/invoke-param.toc", "content": "\n\n(deftype Biggie [x]\n Function\n (invoke [_ y]\n (assert (instance? HashSet y))\n (str y)))\n\n(main [_]\n (print-err \"Line number should be\" (inc _LINE_))\n ((Biggie #{}) (either nothing \"99\"))\n (print-err 'FAIL))\n" }, { "path": "runtime-tests/list-len-1.toc", "content": "\n(main [_]\n (let [[x y] (cons 1 empty-list)]\n (println 'x x)))\n" }, { "path": "runtime-tests/list-len-2.toc", "content": "\n(defn f [x y & t]\n (println 'x x))\n\n(main [_]\n (apply f (cons 1 empty-list)))\n\n" }, { "path": "runtime-tests/list-len-3.toc", "content": "\n(defn f [x]\n (let [[a b & c] x]\n (println 'hoo-boy)))\n\n(main [_]\n (print-err \"FAIL error doesn't have full path\")\n (f (either (maybe [1])\n [1 2 3])))\n\n" }, { "path": "runtime-tests/nested-destruct-1.toc", "content": "\n(defn f [[a b]]\n (println 'a (inc a) 'b b)\n nothing)\n\n(main [_]\n ;; TODO: it is possible to detect this at runtime\n (f (either nothing\n [[\"19\" 3] 4 6]))\n (println 'done))\n" }, { "path": "runtime-tests/nested-destruct-2.toc", "content": "\n(defn f [[[a b] c & d]]\n (println 'a (inc a) 'b b 'c c)\n nothing)\n\n(main [_]\n (f (either nothing\n [[\"19\" 3] 4 6]))\n (println 'done))\n" }, { "path": "runtime-tests/nested-destruct.toc", "content": "\n(defn f [y]\n (let [;; [result new-s] (extract x)\n [[a b] c & d] y]\n (inc a)\n (println 'a a 'b b 'c c)\n nothing))\n\n(main [_]\n (f (either (maybe [[\"2\" 3] 4 6])\n [[2 3] 4 6]))\n (println 'done))\n" }, { "path": "runtime-tests/param-in-cond-2.toc", "content": "\n(defprotocol VarOps\n (update-var [vh newer]\n (assert (instance? String newer))))\n\n(deftype VarHolder [var]\n (assert (instance? String var))\n\n Stringable\n (string-list [_]\n (list \"\"))\n\n VarOps\n (update-var [vh newer]\n (.var vh newer)))\n\n\n(deftype c-code [c-var]\n (assert (instance? String c-var)))\n\n(defn get-constraint [var]\n (fn [s]\n (-> (either nothing (VarHolder \"\"))\n (update-var var)\n (vector s)\n maybe)))\n\n(defn append-constraint [var constraint]\n (cond (= constraint 'top-type)\n (fn [x] (maybe ['_ x]))\n (get-constraint var)))\n\n(defn add-contents-constraint [v]\n (append-constraint v 'bogus))\n\n(main [_]\n (print-err ((add-contents-constraint (c-code \"var\")) {}))\n (print-err 'done))\n" }, { "path": "runtime-tests/param-in-cond.toc", "content": "\n(defn f [x]\n (cond nothing\n 'never-mind\n\n x\n 'yeppers\n\n 'nada))\n\n\n(main [_]\n (print-err (f 1)))\n" }, { "path": "runtime-tests/preserve-asserts.toc", "content": "\n(deftype Checked [m]\n (assert (instance? HashMap m))\n\n Associative\n (assoc [_ k v]\n (assert (instance? HashSet v))\n\n (or (instance? HashSet v)\n (maybe 'fail))\n (Checked (assoc m k v))))\n\n(main [_]\n (assoc (Checked {}) \"bogus\" (either (maybe 'bogus)\n #{})))\n" }, { "path": "runtime-tests/promise-loop.toc", "content": "\n(main [_]\n (let [pm (maybe (promise))]\n (map pm (fn [p]\n (print-err 'p p)\n (deliver p pm))))\n (print-err 'done))\n" }, { "path": "runtime-tests/proto-fn-arg.toc", "content": "\n(defprotocol SomeProto\n (id [x] x)\n (f [g h]\n (print-err 'h (inc h))\n (g \"bogus\")))\n\n(deftype SomeType [x y]\n (assert (instance? String x))\n (assert (instance? Integer y))\n \n SomeProto\n (f [g h]\n (print-err 'h (subs h 1)))\n \n Stringable\n (string-list [_]\n (list \"\")))\n\n(main [_]\n (print-err (f (id (SomeType \"string\" 7))\n 14))\n (print-err 'done))\n" }, { "path": "runtime-tests/test-tail-and.toc", "content": "\n(defprotocol Proto\n (proto-fn [_]\n (assert-result r (instance? (maybe-of Integer) r))))\n\n(deftype IC [x]\n Proto\n (proto-fn [c]\n (or (and (maybe 88)\n (maybe 'bog))\n nothing)))\n\n(main [_]\n (print-err 'done (str \"'\" (proto-fn (IC 8)) \"'\" )))\n" }, { "path": "runtime-tests/test-tail-or.toc", "content": "\n(defprotocol Proto\n (proto-fn [_]\n (assert-result r (instance? (maybe-of Integer) r))))\n\n(deftype IC [x]\n Proto\n (proto-fn [c]\n (or (maybe 'bog)\n (maybe 88))))\n\n(main [_]\n (print-err 'done (str \"'\" (proto-fn (IC 8)) \"'\" )))\n" }, { "path": "runtime-tests/update-field-2.toc", "content": "\n(deftype SomeType [x y]\n (assert (instance? String x))\n (assert (instance? Integer y))\n \n Stringable\n (string-list [_]\n (list \"\")))\n\n(main [_]\n (println (update (SomeType \"string\" 7) .x (fn [_] 3)))\n (println 'done))\n" }, { "path": "runtime-tests/variadic-count-2.toc", "content": "\n(main [_]\n (let [a 'bogus\n f (fn [x y & t]\n (println a x))]\n (print-err \"Line number should be\" (inc _LINE_))\n ((either nothing f) 1)))\n\n" }, { "path": "test", "content": "#!/bin/bash\n\nset -e\n\n# $CC -O3 -g -fno-objc-arc -std=c99 -c core.c &&\n# time `$CC -DCHECK_MEM_LEAK=1 -g -fno-objc-arc -std=c99 core.c -lpthread -latomic` &&\n\n# git checkout toccata.c &&\n# $CC -O3 -g -fno-objc-arc -o toccata -std=c99 core.c toccata.c -lpthread &&\n\n# echo &&\n# echo \"restored\" &&\n# echo &&\n\n# unfortunately this doesn't completely solve the problem\n# sed -i 's/^\\/\\/ #line/#line/' new-toc.c &&\n\ntime `./toccata toccata.toc > new-toc.tmp` &&\n# sed -i 's/^\\/\\/ #line/#line/' new-toc.c &&\nawk '/^#$/ { printf \"#line %d \\\"%s\\\"\\n\", NR+1, \"new-toc.c\"; next; } { print; }' new-toc.tmp > new-toc.c &&\ntime `$CC -DCHECK_MEM_LEAK=1 -g -fno-objc-arc -o new-toc -std=c99 core.c new-toc.c -lpthread -latomic` &&\n\necho &&\necho \"compiled\" &&\necho &&\n\n# run test.toc &&\n# new-toc test.toc > /dev/null &&\n# run regression-tests/test-regressions.toc &&\n# run testr.toc &&\n# test-assertion assertion-tests/dynamic-field-type-1.toc &&\n# test-assertion assertion-tests/bad-state-maybe-value-1.toc &&\n# test-assertion assertion-tests/bad-state-maybe-value-2.toc &&\n# test-assertion assertion-tests/bad-function-returns-1.toc &&\n# test-assertion assertion-tests/bad-function-returns-2.toc &&\n# time new-toc toccata.toc > /dev/null &&\n# time `./new-toc new-toc.toc > bad.c` &&\n# exit 1 &&\n\ntime `./new-toc toccata.toc > new-toc.tmp` &&\n# sed -i 's/^\\/\\/ #line/#line/' new-toc.c &&\nawk '/^#$/ { printf \"#line %d \\\"%s\\\"\\n\", NR+1, \"new-toc.c\"; next; } { print; }' new-toc.tmp > new-toc.c &&\ntime `$CC -O3 -DRECURSE_CLOSURES=1 -DCHECK_MEM_LEAK=1 -g -fno-objc-arc -o new-toc -std=c99 core.c new-toc.c -lpthread -latomic` &&\n\necho &&\necho \"re-compiled\" &&\necho &&\n\n# time new-toc toccata.toc > /dev/null &&\n# time new-toc test.toc > /dev/null &&\n# run test.toc &&\n# exit 1 &&\n\n# time `./new-toc scripter.toc > m.tmp` &&\n# awk '/^#$/ { printf \"#line %d \\\"%s\\\"\\n\", NR+1, \"scripter.c\"; next; } { print; }' m.tmp > scripter.c &&\n# $CC -g -fno-objc-arc -o scripter -std=c99 core.c scripter.c -lpthread &&\n# ./scripter test.toc &&\n# exit 1 &&\n\n# for git bisect\n# status=0\n# ./new-toc toccata.toc > new-toc.tmp || status=$?\n\n# if [ \"$status\" -eq 125 ] || [ \"$status\" -gt 127 ]; then\n# status=1\n# fi\n# exit \"$status\"\n\nfor file in regression-tests/test*.toc\ndo\n echo\n echo \"testing\" $file\n ./test-regression $file\ndone &&\n\nfor file in assertion-tests/*.toc\ndo\n echo\n ./test-assertion $file\ndone &&\n\nfor file in runtime-tests/*.toc\ndo\n echo\n echo \"testing\" $file\n ./test-runtime-check $file\ndone &&\n\ntime new-toc toccata.toc > /dev/null &&\n\necho \"Regressions pass\"\n" }, { "path": "test-assertion", "content": "#!/bin/bash\n\necho \"testing $1\"\n$TOCCATA_DIR/new-toc $1 > /dev/null\nif [ $? -eq 0 ]\nthen\n echo\n echo \"FAIL!!\" $1\n echo\n exit 1\nelse\n exit 0\nfi\n" }, { "path": "test-regression", "content": "#!/bin/bash\n\n$TOCCATA_DIR/new-toc $1 > $1.tmp &&\nawk '/^#$/ { printf \"#line %d \\\"%s\\\"\\n\", NR+1, \"m.c\"; next; } { print; }' $1.tmp > $1.c &&\n$CC -g -fno-objc-arc -o $1.out -I$TOCCATA_DIR -std=c99 -DCHECK_MEM_LEAK=1 $TOCCATA_DIR/core.c $1.c\\\n -latomic -lpthread &&\n./$1.out > /dev/null\nif [ $? -ne 0 ]\nthen\n echo\n echo \"FAIL!!\" $1\n echo\n rm $1.out $1.tmp\n exit 1\nfi\nrm $1.out $1.tmp $1.c\n" }, { "path": "test-runtime-check", "content": "#!/bin/bash\n\n$TOCCATA_DIR/new-toc $1 > $1.c\nif [ $? -ne 0 ]\nthen\n echo \"FAIL!!\" $1\n rm $1.c\n exit\nelse\n $CC -g -fno-objc-arc -o $1.out -I$TOCCATA_DIR -std=c99 -DCHECK_MEM_LEAK=1 $TOCCATA_DIR/core.c $1.c\\\n\t-latomic -lpthread &&\n rm $1.c &&\n ./$1.out > /dev/null &&\t\n if [ $? -ne 1 ]\n then\n\techo \"FAIL!!\" $1\n\trm $1.out\n\texit\n fi\n rm $1.out\nfi\n" }, { "path": "toccata.toc", "content": "\n;; TODO: benchmarks to implement\n;; https://github.com/christianscott/levenshtein-distance-benchmarks\n;; https://github.com/darklang/fizzboom/\n\n;; libs to implement\n;; ZIO and associated\n;; shpadoinkle https://gitlab.com/fresheyeball/Shpadoinkle/-/tree/master\n\n;; things to remember and aspire to\n;; https://stackoverflow.blog/2020/06/05/why-the-developers-who-use-rust-love-it-so-much/\n;; https://github.com/hasura/eff\n\n;; TODO:\n;; As soon as possible, implement\n;; https://github.com/smarr/are-we-fast-yet/\n\n(add-ns c (git-dependency \"https://github.com/Toccata-Lang/constraints.git\"\n \"constraints.toc\"\n :sha \"dd8f917\"))\n(add-ns ast (git-dependency \"https://github.com/Toccata-Lang/ast.git\"\n \"ast.toc\"\n :sha \"4f9242f\"))\n(add-ns fio (git-dependency \"https://github.com/Toccata-Lang/file-io.git\"\n \"file-io.toc\"\n :sha \"36fa952\"))\n(add-ns sm (git-dependency \"https://github.com/Toccata-Lang/state-maybe.git\"\n \"state-maybe.toc\"\n :sha \"4f87b5e\"))\n(add-ns sys (git-dependency \"https://github.com/Toccata-Lang/system.git\"\n \"system.toc\"\n :sha \"13097ff\"))\n(add-ns grmr (git-dependency \"https://github.com/Toccata-Lang/grammar.git\"\n \"grammar.toc\"\n :sha \"4846add\"))\n;; (add-ns ev (git-dependency \"https://github.com/Toccata-Lang/eval.git\"\n;; \"eval.toc\"\n;; :sha \"29cf820\"))\n;; (add-ns interp (git-dependency \"https://github.com/Toccata-Lang/eval.git\"\n;; \"interpreter.toc\"\n;; :sha \"29cf820\"))\n(add-ns rdr (git-dependency \"https://github.com/Toccata-Lang/reader.git\"\n \"reader.toc\"\n :sha \"d82d67d\"))\n(add-ns rd (git-dependency \"https://github.com/Toccata-Lang/recursive-descent.git\"\n \"recursive-descent.toc\"\n :sha \"eccb64f\"))\n(add-ns strm (git-dependency \"https://github.com/Toccata-Lang/stream.git\"\n \"stream.toc\"\n :sha \"4aa15f9\"))\n(add-ns sh (git-dependency \"https://github.com/Toccata-Lang/shell-proc.git\"\n \"shell-proc.toc\"\n :sha \"1e413ea\"))\n(add-ns se (git-dependency \"https://github.com/Toccata-Lang/state-error.git\"\n \"state-error.toc\"\n :sha \"a1bad99\"))\n\n(def symbols-sym (ast/tag \"#symbols\"))\n(def protocols-sym (ast/tag \"#protocols\"))\n(def invoke-sym (ast/tag 'invoke 'core 0))\n(def Type-sym (ast/tag 'Type 'core 0))\n(def Function-sym (ast/tag 'Function 'core 0))\n(def Container-sym (ast/tag 'Container 'core 0))\n(def Stringable-sym (ast/tag 'Stringable 'core 0))\n(def type-name-sym (ast/tag 'type-name 'core 0))\n(def type-mapping-sym (ast/tag 'type-mapping 'core 0))\n(def =*-sym (ast/tag '=* 'core 0))\n(def apply-sym (ast/tag 'apply 'core 0))\n(def get-type-sym (ast/tag 'default-get-type 'core 0))\n(def extract-sym (ast/tag 'extract 'core 0))\n(def instance?-sym (ast/tag 'instance? 'core 0))\n(def string-list-sym (ast/tag 'string-list 'core 0))\n(def list-sym (ast/tag 'list 'core 0))\n(def has-field-sym (ast/tag 'has-field 'core 0))\n(def identical-sym (ast/tag 'identical 'core 0))\n(def Eq-sym (ast/tag 'Eq 'core 0))\n(def Associative-sym (ast/tag 'Associative 'core 0))\n(def get-symb (ast/tag 'get 'core 0))\n(def maybe-sym (ast/tag 'maybe 'core 0))\n(def HashMapNode-sym (ast/tag 'HashMapNode 'core 0))\n(def Hashable-sym (ast/tag 'Hashable 'core 0))\n(def sha1-sym (ast/tag 'sha1 'core 0))\n(def sha1-update-sym (ast/tag 'sha1-update 'core 0))\n(def sha1-init-sym (ast/tag 'sha1-init 'core 0))\n(def sha1-finalize-sym (ast/tag 'sha1-finalize 'core 0))\n(def sha1-update-type-sym (ast/tag 'sha1-update-type 'core 0))\n(def assoc-sym (ast/tag 'assoc 'core 0))\n(def update-field-sym (ast/tag 'update-field 'core 0))\n(def store-sym (ast/tag 'store 'core 0))\n(def default-type-args-sym (ast/tag 'default-type-args 'core 0))\n(def nth-sym (ast/tag 'nth 'core 0))\n(def partial-sym (ast/tag 'partial 'core 0))\n(def some-sym (ast/tag 'some 'core 0))\n(def nothing-sym (ast/tag 'nothing 'core 0))\n\n(def type-counter (int-generator c/TypeCount))\n\n(def rt-exprs (agent []))\n\n;; TODO: replace this with (cata print x)\n(defprotocol StringWriter\n (write-str [x]\n (print x)))\n\n(def sm-nop (sm/state-maybe '_))\n(def se-nop (se/state-error '_))\n\n(def string-writer (agent \"\"))\n(defn write-strings [strs]\n (send string-writer (fn [_]\n (write-str strs))))\n\n(defn safe-pr [& args]\n (send string-writer\n (fn [_]\n (apply print-err args))))\n\n(defn flush-pr []\n (let [p (promise)]\n (send string-writer\n (fn [x]\n (deliver p 'done)\n x))\n (extract p)))\n\n;; useful for debugging the compiler\n(defn debug [& args]\n (map sm-nop (fn [_]\n (send string-writer\n (fn [_]\n (apply print-err args)))\n (flush-pr))))\n\n(defn se-debug [& args]\n (map se-nop\n (fn [_]\n (send string-writer\n (fn [_]\n (apply print-err args)))\n (flush-pr))))\n\n(def Tagged (any-of Symbol\n ast/tagged-symbol))\n\n;; TODO: use 'either' here\n(def path-to-core (extract (or (map (sys/get-environment \"TOCCATA_DIR\")\n (fn [toc-dir]\n (str toc-dir \"/core.toc\")))\n (do\n (print-err \"Could not read environnment variable\"\n \"TOCCATA_DIR\")\n (abort)))))\n\n(def line-sep \"\")\n\n(defn line-marker [file-name line-number marker]\n (cond (or (= \"\" file-name)\n (and (= 'core file-name)\n (= 0 line-number)))\n \"\\n#\\n\"\n [\"\\n\" marker \"\\n#line \"\n (str line-number) \" \" \"\\\"\"\n (cond (= 'core file-name)\n path-to-core\n file-name)\n \"\\\"\\n\"]))\n\n(defn line-macro [ast marker]\n (wrap sm/zero-sm (line-marker (ast/file-name ast) (ast/line-number ast) marker)))\n\n(def type-names {c/IntegerType \"Integer\"\n c/StringBufferType \"String\"\n c/SubStringType \"String\"\n c/FnArityType \"FnArity\"\n c/FunctionType \"Fn\"\n c/ListType \"List\"\n c/MaybeType \"Maybe\"\n c/VectorType \"Vector\"\n c/VectorNodeType \"VectorNode\"\n c/SymbolType \"Symbol\"\n c/BitmapIndexedType \"BitmapIndexNode\"\n c/ArrayNodeType \"ArrayNode\"\n c/HashCollisionNodeType \"HashCollisionNode\"\n c/HashSetType \"Set\"\n c/PromiseType \"Promise\"\n c/FutureType \"Future\"\n c/AgentType \"Agent\"\n c/OpaqueType \"Opaque\"\n c/UnknownType \"UnknownType\"})\n\n(defn target-type-name [n]\n (either (get type-names n)\n (str n)))\n\n(def fn-constraint (c/TypeConstraint {c/FunctionType #{}} empty-list 'Fn nothing \"\"))\n(def sym-constraint (c/TypeConstraint {c/SymbolType #{}} empty-list 'Symbol nothing \"\"))\n(def vect-constraint (c/TypeConstraint {c/VectorType #{}} empty-list 'Vector nothing \"\"))\n(def list-constraint (c/TypeConstraint {c/ListType #{}} empty-list 'List nothing \"\"))\n(def seq-constraint (c/TypeConstraint {c/ListType #{}\n c/VectorType #{}} empty-list 'Sequence nothing \"\"))\n(def string-constraint (c/TypeConstraint {c/StringBufferType #{} c/SubStringType #{}}\n empty-list 'String nothing \"\"))\n(def hashmap-constraint (c/TypeConstraint {c/BitmapIndexedType #{}\n c/ArrayNodeType #{}\n c/HashCollisionNodeType #{}}\n empty-list 'HashMap nothing \"\"))\n(def int-constraint (c/TypeConstraint {c/IntegerType #{}} empty-list 'Integer nothing \"\"))\n(def maybe-constraint (c/TypeConstraint {c/MaybeType #{}} empty-list 'Maybe nothing \"\"))\n\n;; for when a fatal error occurs\n(defn compilation-error [& msg]\n (sm/new-sm (fn [s]\n (send string-writer\n (fn [_]\n (apply print-err msg)\n (abort)))\n nothing)))\n\n(defprotocol Emitter\n (reify-c [c param-exprs file-name line-number]\n (assert-result r (instance? sm/new-sm r))\n (sm/state-maybe c))\n\n ;; Unwrap the tail call\n (remove-tail [ast]\n ast)\n\n (all-symbols [ast]\n (assert-result l (instance? (vector-of ast/ParamType) l))\n ;; ast\n\n;; how to use\n;; (cata all-symbols (.fields ast))\n )\n\n (dissoc-sym [ast]\n (assert-result x (instance? sm/new-sm x)))\n\n (new-bound-var [ast]\n (assert-result x (instance? sm/new-sm x)))\n\n ;; replace all occurances of the keys in 'subs' with their associated values\n (update-syms [ast update-bindings]\n (assert-result x (instance? sm/new-sm x))\n\n (sm/state-maybe (Right ast)))\n\n (pop-subs [x]\n (sm/state-maybe x))\n\n ;; get the constraints for a symbol or params-ast\n (get-param-cs [_]\n (assert-result x (instance? sm/new-sm x)))\n\n ;; Mark this AST node as the final (or tail) expression in a function body\n (wrap-tail [ast params]\n (assert-result r (instance? Either r))\n\n (Right ast))\n\n (to-constraint [c]\n (sm/state-maybe c))\n\n ;; prepare an ast node for binding an expression to it\n (pre-bind [ast]\n (assert-result x (instance? sm/new-sm x)))\n\n ;; generate a new local C var for a symbol\n (bind-expr [binding]\n (assert-result x (instance? sm/new-sm x)))\n\n ;; bind fn parameters\n (bind-param-expr [binding]\n ;; (assert (instance? BindingValue expr))\n (assert-result x (instance? sm/new-sm x)))\n\n ;; ----- need recursion scheming\n\n ;; bind the symbol 'binding' to the results of 'evalled'\n (bind-expr [binding evalled]\n ;; TODO: re-arrange code to make this possible\n ;; (assert (instance? BindingValue evalled))\n (assert-result x (instance? sm/new-sm x)))\n\n (update-call-site-count [_]\n (assert-result x (instance? sm/new-sm x)))\n\n (call-site-meta-data [c-var file-name line-number]\n (assert-result x (instance? sm/new-sm x)))\n\n ;; encode a static representation of a core data structure\n (encode [m]\n (emit m))\n\n ;; Change any InferredInner constraint to a CollectionOf\n (promote-inferred [c]\n c)\n\n (encode [m var-prefix])\n\n (validate-field [c m fields file-name line-number]\n (assert (instance? c/ValueConstraint c))\n (assert (instance? (map-of Symbol c/ValueConstraint) m))\n (assert (instance? (vector-of Symbol) fields))\n (assert (instance? ast/SymbolOrString file-name))\n (assert (instance? Integer line-number))\n\n m)\n\n ;; encode a statically initialized representation of a core data structure\n ;; TODO: make sure every impl is needed and constrains the var properly\n (encode-static [m]\n (do\n (print-err 'could-not-encode (type-name m) m)\n sm/zero-sm))\n\n (runtime-check [constraint value-info file-name line-number checked-var]\n (assert (instance? ast/SymbolOrString file-name))\n (assert (instance? Integer line-number))\n (assert-result r (instance? Vector r))\n\n ;; generated code must preserve ref counts\n (cond (c/satisfied-by constraint value-info)\n []\n\n ;; TODO: at some point, check for more instances of 'satisfied-by' that should pass\n ;; (do\n ;; (or (= c/top-type init-c)\n ;; (map (= final-c init-c)\n ;; (fn [x]\n ;; (safe-pr 'same file-name line-number x)\n ;; (safe-pr var)))\n ;; (maybe (do\n ;; (safe-pr 'not-same file-name line-number)\n ;; (safe-pr 'final final-c \"\\n\" 'init init-c)))))\n (runtime-check constraint value-info\n (cond (= \"\" file-name)\n [\"\\\"\\\"\"]\n [\"\\\"at \" file-name \": \" line-number \"\\\"\"])\n checked-var)))\n\n (runtime-check [constraint value-info sym-location checked-var]\n (assert (instance? (any-of c/NoValues\n c/ResultConstraint\n c/ValueConstraint)\n constraint))\n (assert (instance? c/ValueConstraint value-info))\n (assert (instance? String checked-var))\n (assert-result r (instance? Vector r)))\n\n (runtime-check [constraint value-info checked-var]\n (assert (instance? (any-of c/NoValues\n c/ResultConstraint\n c/ValueConstraint)\n constraint))\n (assert (instance? c/ValueConstraint value-info))\n (assert (instance? String checked-var))\n (assert-result r (instance? Vector r)))\n\n (old-reify-c [c param-exprs file-name line-number]\n (sm/state-maybe c))\n\n (get-result-constraint [_ num-args]\n (assert-result r (instance? sm/new-sm r)))\n\n (cache-static-constant [v expr]\n '_)\n\n ;; For AST nodes that can be embedded in other AST nodes\n (emit [_]\n (assert-result x (instance? sm/new-sm x)))\n\n ;; For AST nodes that can be assigned to a symbol at the top level\n (emit-defined-value [ast defined-sym]\n (assert-result x (instance? sm/new-sm x)))\n\n ;; For AST nodes that can appear at the top level of a file\n (emit-definition [_]\n (assert-result x (instance? sm/new-sm x)))\n\n (emit-recursive-call [ast params]\n sm/zero-sm)\n\n ;; expand 'target-ast' so that it's component asts are inlined\n (inline-expr [target-ast arg-asts]\n (assert-result x (instance? sm/new-sm x))\n sm/zero-sm)\n\n (clear-init [expr]\n ;; TODO: re-arrange code to make this possible\n ;; (assert (instance? BindingValue expr))\n ))\n\n;; (defn extract-collection-of [ast]\n;; (let [x (old-extract-collection-of ast)\n;; y (cata collection-of ast)]\n;; (or (= x y)\n;; (maybe (print-err 'diff-coll-of (ast/file-name ast) (ast/line-number ast) \"\\n\\n\" x \"\\n\\n\" y))))\n;; y))\n\n(defn all-syms [params]\n (assert (instance? ast/BindingTarget params))\n\n (cata all-symbols params))\n\n(defn bind-param [params]\n (assert (instance? ast/params-ast params))\n (cond (.variadic params)\n (map (hylo pre-bind bind-param-expr params sm/state-maybe)\n vector)\n\n (map (.fixed params)\n (fn [ast]\n (hylo pre-bind bind-param-expr ast sm/state-maybe))\n sm/state-maybe)))\n\n(defn lookup-constraint [c]\n (hylo to-constraint (comp sm/state-maybe c/trim)\n c sm/state-maybe))\n\n(defn tail-call [ast params]\n (apo (fn [ast]\n (wrap-tail ast params))\n ast))\n\n(defn get-param-constraints [ast]\n (for [y (cata get-param-cs ast sm/state-maybe)]\n (c/update-path y (ast/file-name ast) (ast/line-number ast))))\n\n(defn replace-syms [ast subs]\n (assert (instance? HashMap subs))\n\n (cond (empty? subs)\n ast\n\n (either (flat-map (or ((elgot (fn [ast]\n (update-syms ast dissoc-sym))\n pop-subs\n ast sm/state-maybe)\n (list subs))\n nothing)\n first)\n ast)))\n\n(defn replace-bound-vars [ast]\n (either (flat-map (or ((elgot (fn [ast]\n (update-syms ast new-bound-var))\n pop-subs\n ast sm/state-maybe)\n (list {}))\n (do\n (print-err 'boom (ast/file-name ast) (ast/line-number ast)\n ast)\n nothing))\n first)\n ast))\n\n(defn unwrap-tail [ast]\n (cata remove-tail ast))\n\n(defn reify-constraint [c param-exprs file-name line-number]\n (for [x (old-reify-c c param-exprs file-name line-number)\n ;; new-c (ana (fn [c]\n ;; (reify-c c param-exprs file-name line-number))\n ;; c sm/state-maybe)\n ]\n (let [;; x (cata c/trim x)\n new-c (cata c/trim x)]\n ;; (or (= x new-c)\n ;; (do\n ;; (print-err 'diff-reify-c 'c c \"\\n\\n\" 'params param-exprs \"\\n\\n\" x \"\\n\\n\" new-c)\n ;; ;; (abort)\n ;; nothing\n ;; ))\n new-c)))\n\n(defn destruct-seq [seq-c-var elem-c-vars dest-args file-name line-num]\n (assert (instance? String seq-c-var))\n (assert (instance? String dest-args))\n\n ;; TODO: inline destructuring of sequences if type is known\n (let [elem-count (count elem-c-vars)]\n (cond (= 1 elem-count)\n (let [[tail-var] elem-c-vars]\n [\"Value *\" tail-var \" = seq((FnArity *)0, \" seq-c-var \");\" line-sep])\n\n [(map elem-c-vars (fn [var]\n [\"Value *\" var \";\" line-sep]))\n \"Value **\" dest-args \"[\" elem-count \"] = {\"\n (interpose (map elem-c-vars (partial vector \"&\")) \", \")\n \"};\" line-sep \"destructValue(\\\"\" file-name \"\\\", \\\"\" line-num\n \"\\\", (Value *)\" seq-c-var \", \" elem-count \", \"\n dest-args \");\" line-sep])))\n\n(deftype FnValPtr [var]\n ;; pointer to a Fn struct\n (assert (instance? ast/SymbolOrString var)))\n\n(deftype ArityValPtr [var struct]\n ;; pointer to a FnArity struct\n (assert (instance? ast/SymbolOrString var)))\n\n(deftype StaticFnPtr [var]\n ;; pointer to a FnArity struct\n (assert (instance? ast/SymbolOrString var)))\n\n(deftype ProtoDispFnPtr [var]\n ;; pointer to a FnArity struct\n (assert (instance? ast/SymbolOrString var)))\n\n(deftype ProtoDispatcher [prototype-name path p-impls]\n (assert (instance? Symbol prototype-name))\n (assert (instance? String path))\n (assert (instance? HashMap p-impls))\n\n Type\n (type-name [_]\n (str \"ProtoDispatcher: \" prototype-name))\n\n Stringable\n (string-list [_]\n (list (str prototype-name))))\n\n(def CFnPtr (any-of StaticFnPtr\n ProtoDispFnPtr))\n\n(def PointerVar (any-of FnValPtr\n ArityValPtr\n CFnPtr))\n\n(extend-type PointerVar\n Emitter\n (encode-static [x]\n (emit (.var x)))\n\n Stringable\n (string-list [x]\n (list (str (.var x))))\n\n Eq\n (=* [x y]\n (and (=* y (str (.var x)))\n (maybe x)))\n\n Hashable\n (sha1 [x]\n (sha1 (.var x)))\n\n (sha1-update [x context]\n (sha1-update (.var x) context)))\n\n(defprotocol C-Code\n (expr-constraints [expr]\n (assert-result x (instance? c/Constraints x)))\n\n (expr-constraints [expr new-const]\n (assert (instance? c/Constraints new-const))\n\n expr)\n\n (collapse-expressions* [x y]\n (assert-result r (instance? sm/new-sm r))))\n\n;; information about a compiled expression(s)\n;; c-var: C variable that holds the value produced by the code\n;; init: C code that produces the value at run time\n;; decl: C code to declare anything needed\n;; refs-map: map of C variables that are used in 'init' and how many times\n\n(deftype empty-code [c-var init refs-map]\n (assert (instance? String c-var))\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n Stringable\n (string-list [_]\n (list \"\"))\n\n Collection\n (empty? [c]\n (maybe c))\n\n Emitter\n (emit [x]\n (wrap sm/zero-sm x)))\n\n(def empty-c-code (empty-code \"\" [] {}))\n\n(deftype c-code [c-var init refs-map constraints]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n (assert (instance? c/Constraints constraints))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-static-reified [type-num c-var init refs-map constraints c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n (assert (instance? c/Constraints constraints))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-constructor [c-var init refs-map constraints c-struct type-num fields]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n (assert (instance? c/Constraints constraints))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-static-str [c-var init refs-map constraints c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n (assert (instance? c/Constraints constraints))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-static-int [c-var init refs-map constraints c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n (assert (instance? c/Constraints constraints))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-static-sym [c-var init refs-map constraints c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n (assert (instance? c/Constraints constraints))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-vector-fn [c-var init refs-map c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n C-Code\n (expr-constraints [_]\n fn-constraint)\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-maybe-fn [c-var init refs-map c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n C-Code\n (expr-constraints [_]\n fn-constraint)\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-list-fn [c-var init refs-map c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n C-Code\n (expr-constraints [_]\n fn-constraint)\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-protocol-fn [c-var init refs-map c-struct proto-sym arities]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n (assert (instance? HashMap arities))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(deftype c-static-arity [c-var init refs-map c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n Stringable\n (string-list [_]\n (list \"(c-static-arity \" (str c-var) \", \"\n (str (count init)) \", \" (str refs-map) \")\")))\n\n(deftype c-static-fn [c-var init refs-map c-struct arities]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n Stringable\n (string-list [_]\n (list \"(c-static-fn \" (str c-var) \", \" (str (count init)) \", \"\n (str refs-map) \", \" (str arities) \")\")))\n\n(deftype c-static-val [c-var init refs-map c-struct]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(extend-type c-code\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type)))\n\n(def C-Static-Value (any-of c-static-int\n c-static-str\n c-static-sym\n c-static-reified\n c-constructor\n c-list-fn\n c-maybe-fn\n c-vector-fn\n c-static-fn\n c-static-arity\n c-protocol-fn\n c-static-val))\n\n(extend-type C-Static-Value\n Emitter\n (encode-static [x]\n (wrap sm/zero-sm x)))\n\n;; same as 'c-code', but defines a function parameter\n(deftype c-param [c-var init refs-map constraints file-name line-number]\n (assert (instance? String c-var))\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n Stringable\n (string-list [_]\n (list \"\"))\n\n Collection\n (empty? [c] nothing))\n\n(deftype c-field [c-var init refs-map constraints parent]\n (assert (instance? String c-var))\n (assert (instance? Sequence init))\n (assert (instance? HashMap refs-map))\n (assert (instance? c/Constraints constraints))\n (assert (instance? String parent))\n\n Stringable\n (string-list [_]\n (list \"\"))\n\n Emitter\n (emit [x]\n (sm/state-maybe x))\n\n Collection\n (empty? [c] nothing))\n\n;; same as 'c-code', but is the first appearance of 'c-var' in the generated code\n;; TODO: should add a constraint field\n(deftype c-init [c-var init refs-map file-name line-number]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n\n Stringable\n (string-list [_]\n (list \"\"))\n\n Collection\n (empty? [c] nothing))\n\n;; same as 'c-init', but specifically for anon closure functions\n(deftype c-closure-fn [c-var init refs-map arities file-name line-number]\n (assert (instance? Sequence init))\n (assert (instance? (map-of String Integer) refs-map))\n (assert (instance? HashMap arities))\n\n Stringable\n (string-list [_]\n (list \"\"))\n\n Collection\n (empty? [c] nothing))\n\n\n(def C-Value (any-of c-code\n c-closure-fn\n c-param\n C-Static-Value))\n\n(extend-type C-Value\n Collection\n (empty? [c]\n (empty? (.init c)))\n\n Emitter\n (emit [x]\n (wrap sm/zero-sm x)))\n\n(def C-expr (any-of empty-code\n C-Value\n c-param\n c-init))\n\n(def BindingValue (any-of C-expr\n c-field))\n\n\n(extend-type BindingValue\n Container\n (map [x _]\n x)\n\n (map [x _ embed]\n (embed x)))\n\n(defn bind\n ([ast]\n (hylo pre-bind bind-expr ast sm/state-maybe))\n ([ast expr]\n (bind-expr ast expr)))\n\n(defn collapse-expressions [cs]\n (assert (instance? (sequence-of BindingValue) cs))\n (assert-result r (instance? sm/new-sm r))\n\n (either (or (and (empty? cs)\n (maybe (sm/state-maybe empty-c-code)))\n (and (empty? (rest cs))\n (map (first cs) sm/state-maybe)))\n (let [[c & cs] cs]\n (flat-map (collapse-expressions cs)\n (partial collapse-expressions* c)))))\n\n(extend-type empty-code\n Composition\n (comp* [x xs]\n (either (map (first xs)\n (fn [y]\n (comp* y (rest xs))))\n x))\n\n C-Code\n (collapse-expressions* [x y]\n (assert (instance? C-expr y))\n (sm/state-maybe y)))\n\n(extend-type c-init\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n Composition\n (comp* [x xs]\n (either (map (first xs)\n (fn [y]\n (let [y (comp* y (rest xs))\n y (.refs-map y (merge-with + (.refs-map y) {(.c-var x) 1}))\n c-var (.c-var x)\n file-name (.file-name x)\n line-number (.line-number x)\n init [(.init x)\n (either (or (for [refs (get-in y [.refs-map c-var])]\n [(cond (< refs 2)\n \"\"\n [\"incRef(\" c-var \", \" (dec refs) \");\" line-sep])])\n (= \"\" c-var))\n [line-sep \"dec_and_free(\" c-var \", 1);\" line-sep])\n (.init y)]\n refs-map (dissoc (merge-with + (.refs-map x) (.refs-map y))\n c-var)]\n (-> y\n (.init init)\n (.refs-map refs-map)))))\n x))\n\n C-Code\n (collapse-expressions* [x y]\n (assert (instance? C-expr y))\n\n (let [c-var (.c-var x)\n file-name (.file-name x)\n line-number (.line-number x)\n\n refs-map (dissoc (merge-with + (.refs-map x) (.refs-map y))\n c-var)\n init [(.init x)\n (either (or (for [refs (get-in y [.refs-map c-var])]\n [(cond (< refs 2)\n \"\"\n [\"incRef(\" c-var \", \" (dec refs) \");\" line-sep])])\n (= \"\" c-var))\n [line-sep \"dec_and_free(\" c-var \", 1);\" line-sep])\n (.init y)]]\n (-> (cond (instance? empty-code y)\n (c-code \"\" [] {} c/top-type)\n y)\n (.init init)\n (.refs-map refs-map)\n sm/state-maybe))))\n\n(extend-type C-Value\n Composition\n (comp* [x xs]\n (assert-result z (instance? C-expr z))\n\n (either (map (first xs)\n (fn [y]\n (let [y (comp* y (rest xs))]\n (-> (cond (instance? empty-code y)\n x\n y)\n (.init [(.init x) (.init y)])\n (.refs-map (merge-with + (.refs-map x) (.refs-map y)))))))\n x))\n\n C-Code\n (collapse-expressions* [x y]\n (assert (instance? C-expr y))\n\n (let [x (cond (empty? (.init x))\n (.refs-map x {})\n x)]\n (-> (cond (instance? empty-code y)\n (c-code \"\" [] {} c/top-type)\n y)\n (.init [(.init x) (.init y)])\n (.refs-map (merge-with + (.refs-map x) (.refs-map y)))\n sm/state-maybe))))\n\n(deftype Closures [closures refs-map]\n (assert (instance? (vector-of Vector) closures))\n (assert (instance? (map-of String Integer) refs-map)))\n\n(def empty-closures (Closures [] {}))\n\n(deftype ConstantValues [numbers strings symbols type-names encoded other]\n ;; numbers static numbers\n (assert (instance? (map-of Integer String) numbers))\n ;; strings static strings\n (assert (instance? (map-of String String) strings))\n ;; symbols static symbols\n (assert (instance? (map-of Symbol String) symbols))\n ;; type-names map of type numbers to type names\n (assert (instance? (map-of Integer String) type-names))\n ;; encoded cache of values that have been statically encoded\n (assert (instance? HashMap encoded)))\n\n(def constants (agent (ConstantValues {} {} {} type-names {} {})))\n\n(deftype FnSpec [arity-info param-vars]\n (assert (instance? HashMap arity-info))\n (assert (instance? (map-of String c-param) param-vars)))\n\n;; Every function arity has some information that's local to it\n(deftype FunctionArityContext [fn-spec sym-count syms context-syms closed-over decl subs field-constrs]\n ;; fn-spec info about the function arity being emitted\n (assert (instance? FnSpec fn-spec))\n ;; sym-count number of local symbols that have been defined\n (assert (instance? Integer sym-count))\n ;; syms the symbols local to the function that are currently interned\n (assert (instance? HashMap syms))\n ;; context-syms the symbols in the context of the function being emitted\n (assert (instance? HashMap context-syms))\n ;; closed-over symbols that this function closes over\n (assert (instance? Closures closed-over))\n ;; C code to declare stuff needed for fn arity\n (assert (instance? Vector decl))\n ;; Substitutions for checking types\n (assert (instance? (map-of String c/ValueConstraint) subs))\n ;; constraints for fields in type-ast implementations\n (assert (instance? (maybe-of c/ItemsConstraint) field-constrs))\n\n Stringable\n (string-list [_]\n (comp (list \"\"))))\n\n(deftype ConstrainedAST [ast constraint]\n Stringable\n (string-list [_]\n (list \"(ConstrainedAST \" (either (and (instance? ast/tagged-symbol ast)\n (maybe (str \"'\" ast \" \")))\n (str ast \"\\n\"))\n (str constraint) \")\"))\n\n Container\n (map [x f]\n (ConstrainedAST (f ast) constraint))\n\n (map [x f embed]\n (map (f ast)\n (fn [new-ast]\n (ConstrainedAST new-ast constraint)))))\n\n;; information that must be tracked for each module\n(deftype Module [path index values protocols declarations namespaces types value-types]\n ;; path path to file containing the modules source code (Symbol or String)\n ;; index this module's index\n (assert (instance? Integer index))\n ;; values map of value symbols to defined values\n (assert (instance? HashMap values))\n ;; protocols set of protocol symbols\n (assert (instance? HashMap protocols))\n ;; declarations map of symbols to C vars that have not been defined\n (assert (instance? HashMap declarations))\n ;; namespaces imported namespaces\n (assert (instance? (map-of Symbol Module) namespaces))\n ;; types map of symbols (type names) to type constraints\n (assert (instance? (map-of Symbol c/ValueConstraint) types))\n ;; value-types map of symbols (values) to type constraints\n (assert (instance? (list-of (map-of Symbol c/ValueConstraint)) value-types))\n\n Stringable\n (string-list [_] (list \"\")))\n\n(def core-agent (agent (Module 'core 0 {} {} {} {} {} empty-list)))\n\n(deftype ModuleSetup [init cleanup]\n ;; init strings to initialize the module\n (assert (instance? Vector init))\n ;; cleanup strings to initialize the module\n (assert (instance? Vector cleanup)))\n\n;; There's a bunch of information to keep track of while compiling\n(deftype GlobalContext [fn-context rt-init module constants reify-fn-index loaded setup mod-files]\n ;; fn-context context for the fn currently being compiled\n (assert (instance? FunctionArityContext fn-context))\n ;; init context for the runtime initialization\n (assert (instance? FunctionArityContext rt-init))\n ;; module info for each module compiled\n (assert (instance? Module module))\n ;; constants the various constants encountered\n (assert (instance? ConstantValues constants))\n ;; reify-fn-index index of reified fn being compiled\n (assert (instance? Integer reify-fn-index))\n ;; loaded promise to hold finished module\n (assert (instance? Promise loaded))\n ;; setup strings to initialize the module\n (assert (instance? ModuleSetup setup))\n ;; mod-files map from filename to module\n (assert (instance? (map-of String Module) mod-files))\n\n Stringable\n (string-list [_] (list \"\")))\n\n;; TODO: use later\n;; (def protocols (agent {}))\n;; (defn get-in-protos [path]\n;; (let [result (promise)]\n;; (send protocols (fn [protos]\n;; (deliver result (get-in protos path))\n;; protos))\n;; (extract result)))\n\n(def modules (agent {}))\n;; TODO: to be added later\n;; (assert (instance? (agent-of (map-of String (agent-of GlobalContext)))))\n\n(defn get-subs []\n (sm/get-in-val [.fn-context .subs] {}))\n\n(defn get-constraint [var]\n ;; TODO: this doesn't get promoted up through append-constraint it seems\n (assert (instance? String var))\n\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n ;; TODO: this doesn't get promoted up through append-constraint it seems\n ;; assuming the one above is not there\n ;; and it should come from update-var anyway\n (assert (instance? String var))\n\n (-> (either (-> s\n .fn-context\n .subs\n (get var))\n c/top-type)\n (c/update-var var)\n (vector s)\n maybe))))\n\n(defn set-constraint [var constraint]\n (cond (= c/top-type constraint)\n sm-nop\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (let [constraint (c/update-var constraint var)]\n (maybe [constraint (assoc-in s [.fn-context .subs var] constraint)]))))))\n\n(defn append-constraint [var constraint file-name line-number]\n (let [constraint (c/update-path constraint file-name line-number)]\n (cond (= constraint c/top-type)\n sm-nop\n (flat-map (get-constraint var)\n (fn [curr-const]\n (set-constraint var (either (c/compose-constraints file-name line-number\n constraint curr-const)\n (abort))))))))\n\n(defn propogate-constraint [src-var dest-var f file-name line-number]\n (flat-map (get-constraint src-var)\n (fn [arg-c]\n (append-constraint dest-var (f arg-c) file-name line-number))))\n\n(defn constraint-type-num [c]\n (let [type-nums (either (map (c/extract-type-map c) keys)\n [])]\n (either (and (= 1 (count type-nums))\n (first type-nums))\n c/UnknownType)))\n\n(defn var-type-num [var]\n (map (get-constraint var)\n constraint-type-num))\n\n(defn declare [new-decl]\n (sm/update-in-val [.fn-context .decl] (fn [decl]\n (conj decl new-decl))))\n\n(defn reset-fn-context\n ([]\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (let [curr-fn-context (.fn-context s)\n subs (either (get curr-fn-context .subs)\n {})\n new-context (reduce (vec (.syms curr-fn-context))\n (.context-syms curr-fn-context)\n (fn [syms [sym expr]]\n (assoc syms sym\n (expr-constraints expr (either (get subs (.c-var expr))\n c/top-type)))))]\n (maybe [(.decl curr-fn-context [])\n (.fn-context s (FunctionArityContext (FnSpec {} {})\n 0 {} new-context empty-closures\n (.decl curr-fn-context) {}\n (.field-constrs curr-fn-context)))])))))\n ([new-fn-context]\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (maybe [(.decl (.fn-context s) [])\n (.fn-context s (-> new-fn-context\n (.field-constrs (-> s .fn-context .field-constrs))\n (.decl (comp (.decl (.fn-context s))\n (.decl new-fn-context)))))])))))\n\n(defn namespace-index [sym]\n (either (map (ast/namespace sym)\n (fn [ns-sym]\n (sm/get-in-val [.module .namespaces ns-sym .index])))\n (sm/get-in-val [.module .index])))\n\n(defn redef-proto-fn-error [sym]\n (for [ns-index (namespace-index sym)\n path (comp (for [protos (sm/get-in-val [.module .protocols])\n :when (some (vals protos) (fn [proto] (get proto (ast/untag sym))))\n path (sm/get-in-val [.module .path])]\n path)\n (sm/when (-> (extract core-agent)\n .protocols\n vals\n (some (fn [proto]\n (and (get proto (ast/untag sym))\n (maybe 'core)))))))\n _ (compilation-error \"Redefining\" (str \"'\" sym \"'\") \"at\"\n (str (ast/file-name sym) \":\") (ast/line-number sym)\n \"which is a protocol function in\" path)]\n \"\"))\n\n(def C-var-punct (grmr/any (map (grmr/ignore \"*\") (constantly \"_STAR_\"))\n (map (grmr/ignore \".\") (constantly \"\"))\n (map (grmr/ignore \"#\") (constantly \"_HASH_\"))\n (map (grmr/ignore \"+\") (constantly \"_PLUS_\"))\n (map (grmr/ignore \"?\") (constantly \"_QM_\"))\n (map (grmr/ignore \"!\") (constantly \"_BANG_\"))\n (map (grmr/ignore \"=\") (constantly \"_EQ_\"))\n (map (grmr/ignore \"<\") (constantly \"_LT_\"))\n (map (grmr/ignore \">\") (constantly \"_GT_\"))))\n\n(def C-var-remaining\n (grmr/none-or-more (grmr/any \"_\"\n (map (grmr/ignore \"-\") (constantly \"_\"))\n grmr/alpha\n grmr/digit\n C-var-punct)))\n\n(def C-var (apply-to (fn [start remaining]\n (to-str (comp [start] remaining)))\n (grmr/any grmr/alpha\n (map (grmr/ignore \"#\") (fn [] \"\"))\n (map (grmr/ignore \"-\") (fn [] \"_MINUS_\"))\n C-var-punct)\n C-var-remaining))\n\n(def C-var (rd/parser C-var))\n\n(defn check-C-var [var-name alt-var]\n (let [parse-result (C-var var-name)]\n\n ;; TODO: this form doesn't work. 'instance?' fails\n ;; (either (and (instance? se/Failure parse-result)\n ;; (maybe alt-var))\n\n ;; (let [[c-var] parse-result]\n ;; c-var))\n\n (cond (instance? Vector parse-result)\n (let [[c-var] parse-result]\n c-var)\n\n alt-var)))\n\n(defn genlocal\n ([pre]\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (let [ctxt (.fn-context s)\n sym-count (.sym-count ctxt)\n new-ctxt (.fn-context s (.sym-count ctxt (inc sym-count)))]\n (maybe [(str pre sym-count) new-ctxt])))))\n ([sym arg-name]\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (let [ctxt (.fn-context s)\n sym-count (.sym-count ctxt)\n new-ctxt (.fn-context s (.sym-count ctxt (inc sym-count)))]\n (maybe [(str (check-C-var (str sym \"_\") arg-name)\n sym-count)\n new-ctxt]))))))\n\n(defprotocol ConstrainParams\n (constrain-params [pb]))\n\n(deftype ParamBinding [bound vars tail-var destruct]\n (assert (instance? (vector-of C-expr) destruct))\n\n ConstrainParams\n (constrain-params [pb]\n (cond (and (empty? vars)\n (= tail-var \"\"))\n (get-constraint bound)\n\n (for [tail-const (get-constraint tail-var)\n items-const (sm/traverse vars constrain-params)\n :let [constraint (c/ItemsConstraint items-const tail-const empty-list nothing tail-var)]\n _ (append-constraint bound constraint \"\" 0)\n ;; TODO: Probably should get the new constraint\n ]\n constraint)))\n\n Container\n (map [x f]\n (print-err 'ParamBinding-map)\n (abort)\n x)\n\n (map [x f embed]\n (print-err 'ParamBinding-map-contextual)\n (abort)\n (embed x))\n\n Stringable\n (string-list [_]\n (cond\n (and (empty? vars)\n (= tail-var \"\"))\n (list bound)\n\n (empty? vars)\n (list \"[|\" tail-var \"]\")\n\n (list (str (comp vars [(str \"| \" tail-var)]))))))\n\n\n;; generate symbols that are available globally inside the 'state-maybe' container\n(defn make-global-var\n ([module-index arg-name]\n (str (gensym (str \"m\" module-index \"_\" arg-name))))\n ([module-index sym arg-name]\n (str (gensym (str \"m\" module-index \"_\" (check-C-var (str sym \"_\") arg-name))))))\n\n(defn global-var\n ([arg-name]\n (for [module-index (sm/get-in-val [.module .index])]\n (make-global-var module-index arg-name)))\n ([sym arg-name]\n (for [module-index (sm/get-in-val [.module .index])]\n (make-global-var module-index sym arg-name))))\n\n(deftype ProtoImpl [dispatch-type c-var ast param-constraints result-constraint c-fn]\n (assert (instance? ArityValPtr c-var))\n (assert (instance? Integer dispatch-type))\n (assert (instance? CFnPtr c-fn))\n (assert (instance? ast/fn-arity-ast ast))\n\n ;; TODO: remove these eventually\n (assert (instance? c/ItemsConstraint param-constraints))\n (assert (instance? c/ValueConstraint result-constraint))\n\n Stringable\n (string-list [_] (list \"\"))\n\n Emitter\n (encode [x]\n (encode-static x))\n\n (encode-static [_]\n (cond (= \"\" (.var c-var))\n (do\n (print-err 'could-not-encode 'ProtoImpl)\n (maybe sm/zero-sm))\n (sm/state-maybe (c-static-val (str \"(Value *)\" c-var) [] {} (.struct c-var))))))\n\n(deftype CollectFieldConsts [fields ast]\n (assert (instance? ast/params-ast fields))\n\n Stringable\n (string-list [_]\n (list \"\"))\n\n Container\n (map [x f]\n (CollectFieldConsts (f fields) (f ast)))\n\n (map [x f embed]\n (for [new-fields (f fields)\n new-ast (f ast)]\n (CollectFieldConsts new-fields new-ast)))\n\n ast/IsCode\n (ast/generates-code? [x]\n (maybe x))\n\n Emitter\n (emit [_]\n (for [expr (emit ast)\n field-constrs (get-param-constraints fields)\n curr-constrs (sm/get-in-val [.fn-context .field-constrs])\n :let [field-constrs (either (map curr-constrs (fn [curr]\n (either (c/compose-constraints\n (ast/file-name ast)\n (ast/line-number ast)\n field-constrs curr)\n (abort))))\n field-constrs)]\n _ (sm/assoc-in-val [.fn-context .field-constrs] (maybe field-constrs))]\n expr))\n\n (remove-tail [_]\n ast))\n\n(defn update-context [context update]\n (assert (instance? Maybe context))\n (flat-map (flat-map context update) second))\n\n(defn new-proto-impl [proto-sym fn-sym arg-count dispatch-type var ast param-constraints result-constraint c-fn]\n (assert (instance? Tagged proto-sym))\n (assert (instance? Tagged fn-sym))\n (assert (instance? Integer dispatch-type))\n (assert (instance? ast/fn-arity-ast ast))\n (assert (instance? ArityValPtr var))\n (assert (instance? CFnPtr c-fn))\n\n (let [ast (unwrap-tail ast)\n new-impl (ProtoImpl dispatch-type var ast param-constraints result-constraint c-fn)\n ns-sym (either (ast/namespace fn-sym)\n 'core)]\n (comp (for [_ (sm/when-not (ast/namespace fn-sym))\n _ (sm/get-in-val [.module .protocols (ast/untag proto-sym) (ast/untag fn-sym)])\n _ (sm/update-in-val [.module .protocols (ast/untag proto-sym) (ast/untag fn-sym)]\n (fn [p-disp]\n (assert (instance? ProtoDispatcher p-disp))\n (assoc-in p-disp [.p-impls arg-count dispatch-type] new-impl)))]\n '_)\n (for [ns-file (either (map (ast/namespace fn-sym)\n (fn [sym]\n (sm/get-in-val [.module .namespaces sym .path])))\n (sm/state-maybe 'core))]\n (cond (= ns-file 'core)\n (send core-agent\n (fn [mod]\n (either (update-in mod [.protocols (ast/untag proto-sym) (ast/untag fn-sym)]\n (fn [p-disp]\n (assert (instance? ProtoDispatcher p-disp))\n (assoc-in p-disp [.p-impls arg-count dispatch-type]\n new-impl)))\n (do\n (print-err \"Compiler Error: missing proto dispatcher for\"\n proto-sym fn-sym)\n (abort)))))\n (either (map (get (extract modules) ns-file)\n (fn [ast-emitter]\n (send ast-emitter\n (fn [ctxt]\n (update-context\n ctxt\n (comp (sm/update-in-val\n [.module .protocols\n (ast/untag proto-sym) (ast/untag fn-sym)]\n (fn [p-disp]\n (assert (instance? ProtoDispatcher p-disp))\n (assoc-in p-disp [.p-impls arg-count dispatch-type]\n new-impl)))\n (compilation-error \"Compiler Error: missing proto dispatcher for\"\n proto-sym fn-sym)))))))\n (do\n (print-err \"Compiler Error: missing namespace for\"\n proto-sym fn-sym)\n (abort))))))))\n\n(defn lookup-protocol [proto-sym]\n ;; Look for the protocol information\n ;; 1. using the namespace portion of the protocol symbol\n ;; 2. using `'core` for protcols defined in the core\n (comp (flat-map (sm/when (ast/namespace proto-sym))\n (fn [ns-sym]\n (sm/get-in-val [.module .namespaces ns-sym .protocols\n (ast/untag proto-sym)])))\n (sm/get-in-val [.module .protocols (ast/untag proto-sym)])\n\n (sm/when (get-in (extract core-agent) [.protocols (ast/untag proto-sym)]))))\n\n(defn get-core-proto-impl [proto-sym fn-sym arg-count type-num]\n (flat-map (sm/get-in-val [.module .index])\n (fn [curr-mod]\n (cond (= curr-mod 0)\n (sm/get-in-val [.module .protocols (ast/untag proto-sym) (ast/untag fn-sym)\n .p-impls arg-count type-num])\n (sm/new-sm\n (fn [s]\n (map (let [core-prom (promise)]\n (send core-agent\n (fn [mod]\n (deliver core-prom\n (get-in mod [.protocols (ast/untag proto-sym) (ast/untag fn-sym)\n .p-impls arg-count type-num]))\n mod))\n (extract core-prom))\n (fn [expr]\n [expr s]))))))))\n\n(defn get-proto-impl [proto-sym fn-sym arg-count type-num]\n (comp (flat-map (sm/when (ast/namespace fn-sym))\n (fn [ns-sym]\n (sm/get-in-val [.module .namespaces ns-sym .protocols\n (ast/untag proto-sym) (ast/untag fn-sym) .p-impls\n arg-count type-num])))\n (sm/get-in-val [.module .protocols (ast/untag proto-sym)\n (ast/untag fn-sym) .p-impls arg-count type-num])\n\n (get-core-proto-impl proto-sym fn-sym arg-count type-num)\n ;; (compilation-error \"Invalid protocol fn:\"\n ;; (str \"'\" fn-sym \"' in\")\n ;; (str (ast/file-name fn-sym) \",\")\n ;; (ast/line-number fn-sym))\n ))\n\n(def DefExprs (any-of c-code\n c-static-reified\n c-constructor\n c-static-str\n c-static-int\n c-static-fn\n c-static-sym\n c-maybe-fn\n c-list-fn\n c-vector-fn\n c-protocol-fn))\n\n(defn new-module-def [sym value]\n (assert (instance? ast/tagged-symbol sym))\n (assert (instance? DefExprs value))\n\n (comp (redef-proto-fn-error sym)\n (flat-map (sm/assoc-in-val [.module .declarations sym] nothing)\n (fn [_]\n (sm/assoc-in-val [.module .values sym] value)))))\n\n(defn lookup-declaration [sym]\n (flat-map (namespace-index sym)\n (fn [ns-index]\n (sm/get-in-val [.module .declarations sym '_]))))\n\n(defn already-closed-over [sym]\n (for [closure-var (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (-> s\n .fn-context\n .closed-over\n .closures\n (some (fn [[closure-var sym-literal]]\n (for [_ (= sym sym-literal)]\n [closure-var s]))))))\n _ (sm/update-in-val [.fn-context .closed-over .refs-map closure-var] inc)]\n closure-var))\n\n(def get-syms (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (maybe [(.syms (.fn-context s)) s]))))\n\n(defn set-syms [syms]\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (maybe [s (.fn-context s (.syms (.fn-context s) syms))]))))\n\n(defn set-sym [sym expr]\n ;; (sm/assoc-in-val [.fn-context .syms sym] expr)\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (let [ctxt (.fn-context s)\n syms (.syms ctxt)]\n (maybe [s (.fn-context s (.syms ctxt (assoc syms sym expr)))])))))\n\n(defn constrain-var [file-name line-number var constraint]\n (cond (or (= \"\" var)\n (instance? c/AllValues constraint))\n sm-nop\n\n (append-constraint var constraint file-name line-number)))\n\n(defn lookup-closure-sym [sym]\n (let [file-name (ast/file-name sym)\n line-number (ast/line-number sym)]\n (for [sym-info (sm/get-in-val [.fn-context .context-syms sym])\n closures (sm/get-in-val [.fn-context .closed-over .closures])\n expr (either (some closures\n (fn [[closure-var sym-literal]]\n (for [_ (= sym sym-literal)]\n ;; already added to closures\n (map (sm/update-in-val [.fn-context .closed-over .refs-map closure-var]\n inc)\n (fn [_]\n (-> sym-info\n clear-init\n (.c-var closure-var)\n (.refs-map {closure-var 1})))))))\n ;; first time sym is closed over\n (for [sym-count (sm/get-in-val [.fn-context .sym-count])\n _ (sm/update-in-val [.fn-context .sym-count] inc)\n :let [constraint (expr-constraints sym-info)\n closure-var (str \"val\" sym-count)]\n _ (set-constraint closure-var constraint)\n _ (sm/update-in-val [.fn-context .closed-over .closures]\n (fn [closures]\n (conj closures [closure-var sym])))\n _ (sm/assoc-in-val [.fn-context .closed-over .refs-map closure-var]\n 1)]\n (-> sym-info\n clear-init\n (.c-var closure-var)\n (.refs-map {closure-var 1}))))]\n expr)))\n\n(defn get-sym [sym]\n (assert (instance? ast/tagged-symbol sym))\n\n (let [file-name (ast/file-name sym)\n line-number (ast/line-number sym)]\n (either (map (ast/namespace sym)\n (fn [ns-sym]\n ;; lookup namespace-qual sym\n (comp (sm/get-in-val [.module .namespaces ns-sym\n .values (ast/tag (.base sym))])\n (sm/get-in-val [.mod-files file-name .namespaces ns-sym\n .values (ast/tag (.base sym))]))))\n (comp\n ;; lookup sym in local fn context\n (sm/get-in-val [.fn-context .syms sym])\n\n ;; lookup symbol in enclosing context of fn\n (lookup-closure-sym sym)\n\n ;; lookup in current module\n (comp (sm/get-in-val [.module .values sym])\n (sm/get-in-val [.module .declarations sym '_]))\n\n ;; lookup in core module\n (sm/new-sm (fn [s]\n (map (get-in (extract core-agent) [.values sym])\n (fn [expr]\n [expr s]))))\n\n ;; lookup in imported module by filename of sym\n (sm/get-in-val [.mod-files file-name .values sym])\n\n ;; last ditch effort to find it in core module\n (sm/new-sm (fn [s]\n (let [core-prom (promise)]\n (send core-agent (fn [mod]\n (deliver core-prom (get-in mod [.values sym]))\n mod))\n (map (extract core-prom)\n (fn [expr]\n [expr s])))))))))\n\n(defn lookup-sym [sym]\n (assert (instance? ast/tagged-symbol sym))\n\n (let [file-name (ast/file-name sym)\n line-number (ast/line-number sym)]\n (for [expr (comp (get-sym sym)\n (either (map (ast/namespace sym)\n (fn [ns-sym]\n (compilation-error \"Undefined symbol\" (str \"'\" sym \"'\") \"at\"\n (str file-name \":\") line-number)))\n (compilation-error \"Undefined symbol\" (str \"'\" sym \"'\") \"at\"\n (str file-name \":\") line-number)))\n _ (comp (constrain-var file-name line-number (.c-var expr) (expr-constraints expr))\n sm-nop)\n\n constraint (get-constraint (.c-var expr))]\n (expr-constraints expr constraint))))\n\n(extend-type ConstrainedAST\n Emitter\n (emit [x]\n (let [ast (.ast x)\n constraint (.constraint x)]\n (for [expr (emit ast)\n c (lookup-constraint constraint)\n _ (append-constraint (.c-var expr) c (ast/file-name ast) (ast/line-number ast))]\n expr))))\n\n(extend-type c-field\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n Composition\n (comp* [x xs]\n (assert-result z (instance? C-expr z))\n\n ;; TODO\n (print-err 'c-field 'comp*)\n (abort)\n empty-c-code)\n\n C-Code\n (collapse-expressions* [x y]\n (assert (instance? C-expr y))\n\n (either (for [refs (get-in y [.refs-map (.c-var x)])\n _ (< 0 refs)]\n (-> y\n (.init [(.init x)\n \"incRef(\" (.c-var x) \", \" (str refs) \");\\n\"\n ;; TODO: it would be nice to remove the need for this dec_and_free\n ;; do just one after all needed fields are extracted\n \"dec_and_free(\" (.parent x) \", 1);\\n\"\n (.init y)])\n (.refs-map (merge-with + {(.parent x) 1}\n (dissoc (.refs-map y) (.c-var x))))\n sm/state-maybe))\n (sm/state-maybe y))))\n\n(extend-type c/Constraints\n Emitter\n (encode-static [x]\n ;; TODO: for some reason, encoding the sym doesn't alwys work,\n ;; fortunately, it's not needed\n\n (cond (= c/top-type x)\n (sm/state-maybe (c-static-val \"all_values\" [] {} \"all_values_struct\"))\n\n (let [x (either (map (instance? c/SymbolConstraints x)\n (fn [x]\n (-> x\n (.var \"\")\n (.sym nothing))))\n x)]\n (comp (for [args (sm/traverse (type-args x) encode-static)\n struct (global-var \"cnstr_\")\n var (global-var \"cnstr_\")\n _ (declare [\"ReifiedVal \" struct \" = {\" (str (get-type x)) \", -2, 0, \"\n (str (count args)) (flat-map args (fn [expr]\n [\",(Value *)&\" (.c-struct expr)]))\n \"};\" line-sep\n \"Value *\" var \" = (Value *)&\" struct \";\" line-sep])\n expr (collapse-expressions (conj args (c-static-val var [] {} struct)))]\n expr)\n ;; TODO remove\n (for [_ (debug 'missing x)\n :when nothing]\n '_))))))\n\n(extend-type c/StaticConstraints\n Emitter\n (runtime-check [constraint value-info checked-var]\n [])\n\n (runtime-check [constraint value-info sym-location checked-var]\n []))\n\n(extend-type c/NoValues\n Emitter\n (runtime-check [constraint value-info checked-var]\n [\"abort();\\n#\\n\"])\n\n (runtime-check [constraint value-info sym-location checked-var]\n [\"abort();\\n#\\n\"]))\n\n(extend-type c/AllValues\n Emitter\n (emit [constraint]\n (wrap sm/zero-sm empty-c-code))\n\n (runtime-check [constraint value-info checked-var]\n [])\n\n (runtime-check [constraint value-info sym-location checked-var]\n []))\n\n(defn get-type-sym-info [type-symbol]\n (comp (either (or (map (get-in (extract core-agent) [.types (ast/untag type-symbol)])\n sm/state-maybe)\n (map (ast/namespace type-symbol)\n (fn [sym-ns]\n (sm/get-in-val [.module .namespaces sym-ns .types\n (ast/untag type-symbol)]))))\n (sm/get-in-val [.module .types (ast/untag type-symbol)]))\n (let [result-p (promise)]\n (send core-agent (fn [mod]\n (deliver result-p (get-in mod [.types (ast/untag type-symbol)]))\n mod))\n (compilation-error \"Invalid type\" (str \"'\" type-symbol \"'\") (extract result-p) \"at\"\n (ast/file-name type-symbol) (ast/line-number type-symbol)))\n (compilation-error \"Invalid type\" (str \"'\" type-symbol \"'\") \"at\"\n (ast/file-name type-symbol) (ast/line-number type-symbol))))\n\n(defn emit-sym-constraint [constraint]\n (let [file-name (ast/file-name constraint)\n line-number (ast/line-number constraint)]\n (flat-map (lookup-constraint constraint)\n (fn [constraint]\n (either (for [_ (= \"\" (c/extract-var constraint))\n sym (c/extract-sym constraint)]\n (for [expr (lookup-sym (ast/tag sym file-name line-number))\n curr-c (get-constraint (.c-var expr))\n _ (append-constraint (.c-var expr) constraint \"\" 0)\n checked-var (genlocal 'checked)]\n (cond (instance? c-param expr)\n empty-c-code\n (c-code (.c-var expr)\n (let [rt-check (runtime-check (c/update-var constraint (.c-var expr))\n curr-c \"\" 0\n checked-var)]\n (either (empty? rt-check)\n [line-sep \"if(1){int \" checked-var \" = 1;\" line-sep\n rt-check\n line-sep \"if(!\" checked-var \"){abort();}}\" line-sep]))\n ;; TODO: change 'c/top-type' to 'constraint'\n ;; (and all other calls to c-code\n {} c/top-type))))\n (map (constrain-var \"\" 0 (c/extract-var constraint) constraint)\n (fn [_]\n empty-c-code)))))))\n\n;; TODO: how many of these impls would work for ValueConstraint\n(extend-type c/SymbolConstraints\n Emitter\n (validate-field [c m fields file-name line-number]\n (either (map (.sym c)\n (fn [c-sym]\n (either (some fields (partial = c-sym))\n (do\n (print-err \"Invalid field\"\n (str \"'\" c-sym \"'\")\n \"at:\" (str file-name \":\")\n line-number)\n (abort)))\n (-> m\n (dissoc c-sym)\n (assoc c-sym (either (c/compose-constraints file-name line-number\n c\n (either (get m c-sym)\n c/top-type))\n (abort))))))\n m))\n\n (update-syms [c _]\n (either (for [old-sym (.sym c)]\n (comp (for [new-sym (sm/get-in-val [0 (ast/tag old-sym)])]\n ;; if 'new-sym' isn't Tagged, the constraint is\n ;; no longer needed\n (Right (cond (instance? Tagged new-sym)\n (c/update-sym c (ast/untag new-sym))\n c/top-type)))\n (sm/state-maybe (Right c))))\n (sm/state-maybe (Right c))))\n\n (emit [constraint]\n (emit-sym-constraint constraint)))\n\n(extend-type c/DynamicFields\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (-> (c/ReifiedFields (rest param-exprs) (.path c) (.sym c) (.var c))\n (c/update-path file-name line-number)\n sm/state-maybe))\n\n (old-reify-c [c param-exprs file-name line-number]\n (-> (c/ReifiedFields (rest param-exprs) (.path c) (.sym c) (.var c))\n (c/update-path file-name line-number)\n sm/state-maybe)))\n\n(extend-type c/DynamicParamConstraint\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (either (map (get param-exprs (.param-index c))\n (fn [param-expr]\n (map (get-constraint (.c-var param-expr))\n (fn [param-c]\n (-> (reverse (.path c))\n (reduce param-c (fn [new-c [file line]]\n (c/update-path new-c file line)))\n (c/set-type (.result-type c)))))))\n (sm/state-maybe c/top-type)))\n\n (old-reify-c [c param-exprs file-name line-number]\n (either (map (get param-exprs (.param-index c))\n (fn [param-expr]\n (map (get-constraint (.c-var param-expr))\n (fn [param-c]\n (-> (reverse (.path c))\n (reduce param-c (fn [new-c [file line]]\n (c/update-path new-c file line)))\n (c/set-type (.result-type c)))))))\n (sm/state-maybe c/top-type))))\n\n(extend-type c/DynamicItemConstraint\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (comp (for [param-expr (sm/when (get param-exprs (.param-index c)))\n param-c (get-constraint (.c-var param-expr))\n _ (debug 'dyn-item-param-c param-c)\n item-expr (-> param-c\n c/extract-dynamic-fields\n ((fn [x]\n (print-err 'dyn-fields x)\n (print-err 'item-index (.item-index c)\n (get x (.item-index c)))\n x))\n (get (.item-index c))\n sm/when)\n _ (debug 'dyn-item-item-expr item-expr)\n item-c (get-constraint (.c-var item-expr))\n _ (debug 'dyn-item-item-c item-c)]\n (-> (.path c)\n reverse\n (reduce item-c\n (fn [new-c [file line]]\n (c/update-path new-c file line)))))\n (sm/state-maybe c/top-type)))\n\n (old-reify-c [c param-exprs file-name line-number]\n (comp (for [param-expr (sm/when (get param-exprs (.param-index c)))\n param-c (get-constraint (.c-var param-expr))\n item-expr (-> param-c\n c/extract-dynamic-fields\n (get (.item-index c))\n sm/when)\n item-c (get-constraint (.c-var item-expr))]\n (-> (.path c)\n reverse\n (reduce item-c\n (fn [new-c [file line]]\n (c/update-path new-c file line)))))\n (sm/state-maybe c/top-type))))\n\n\n(extend-type c/DynamicResultConstraint\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (-> c\n .invokable-c\n c/extract-dynamic-params\n (sm/traverse (fn [dyn-c]\n (either (or (for [dyn-param (instance? c/DynamicParamConstraint dyn-c)\n expr (get param-exprs (.param-index dyn-param))]\n (get-result-constraint expr (.num-args c)))\n (for [dyn-param (instance? c/DynamicItemConstraint dyn-c)\n expr (get-in param-exprs [(.param-index dyn-param)])]\n ;; TODO: there could be multiple dyn fields because of a SumConstraint\n (for [dynamic-fields (map (get-constraint (.c-var expr))\n c/extract-dynamic-fields)\n field-expr (sm/when (get dynamic-fields (.item-index dyn-param)))\n rc (get-result-constraint field-expr (.num-args c))]\n rc)))\n sm/zero-sm)))\n (map (fn [dyn-param-cs]\n (c/sum-type dyn-param-cs)))\n (comp (sm/state-maybe c/top-type))\n (map (fn [r]\n (print-err 'dyn-result r)\n r))))\n\n (old-reify-c [c param-exprs file-name line-number]\n (-> c\n .invokable-c\n c/extract-dynamic-params\n (sm/traverse (fn [dyn-c]\n (either (or (for [dyn-param (instance? c/DynamicParamConstraint dyn-c)\n expr (get param-exprs (.param-index dyn-param))]\n (get-result-constraint expr (.num-args c)))\n (for [dyn-param (instance? c/DynamicItemConstraint dyn-c)\n expr (get-in param-exprs [(.param-index dyn-param)])]\n ;; TODO: there could be multiple dyn fields because of a SumConstraint\n (for [dynamic-fields (map (get-constraint (.c-var expr))\n c/extract-dynamic-fields)\n field-expr (sm/when (get dynamic-fields (.item-index dyn-param)))\n rc (get-result-constraint field-expr (.num-args c))]\n rc)))\n sm/zero-sm)))\n (map (fn [dyn-param-cs]\n (c/sum-type dyn-param-cs)))\n (comp (sm/state-maybe c/top-type)))))\n\n(extend-type c/DynamicConstraint\n Emitter\n (runtime-check [constraint value-info checked-var]\n [])\n\n (runtime-check [constraint value-info sym-location checked-var]\n []))\n\n(extend-type c/ItemsConstraint\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (sm/state-maybe (either (or (some (.items-constraints c) (partial = c/bottom-type))\n (= c/bottom-type (.tail-constraint c)))\n c)))\n\n (old-reify-c [c param-exprs file-name line-number]\n (for [new-items (sm/traverse (.items-constraints c)\n (fn [c]\n (old-reify-c c param-exprs file-name line-number)))\n new-tail (old-reify-c (.tail-constraint c) param-exprs file-name line-number)]\n (either (or (some new-items (partial = c/bottom-type))\n (= c/bottom-type new-tail))\n (c/ItemsConstraint new-items\n new-tail\n (.path c) (.sym c) (.var c)))))\n\n (promote-inferred [c]\n (-> c\n (.tail-constraint (promote-inferred (.tail-constraint c)))\n (.items-constraints (map (.items-constraints c) promote-inferred))))\n\n (update-syms [ast _]\n (either (map (.sym ast)\n (fn [old-sym]\n (comp (map (sm/get-in-val [0 (ast/tag old-sym)])\n (fn [new-sym]\n (Right (.sym ast (maybe (ast/untag new-sym))))))\n (sm/state-maybe (Right ast)))))\n (sm/state-maybe (Right ast))))\n\n (runtime-check [constraint value-info checked-var]\n (let [items-cs (c/extract-items-constraints constraint)]\n (cond (or (c/satisfied-by constraint value-info)\n (empty? items-cs))\n []\n\n [(let [rt-check (-> (c/TypeConstraint {c/ListType #{} c/VectorType #{}} (.path constraint) 'Sequence\n (.sym constraint) (.var constraint))\n (runtime-check value-info checked-var))]\n (either (empty? rt-check)\n [\"if (\" checked-var \"){\" rt-check \"}\"]))\n (let [min-count (str (count items-cs))]\n [\"if (\" checked-var \" && countSeq(incRef(\" (.var constraint) \", 1)) < \" min-count \") {\"\n checked-var \"= 0;\" line-sep \"}\"])\n (let [items (map (range (inc (count items-cs)))\n (partial str (.var constraint) \"_\"))\n rt-checks (for [[constraints item] (zip-lists items-cs items)]\n (let [constraints (either (map (.sym constraint)\n (partial c/update-sym constraints))\n constraints)]\n (-> constraints\n (c/update-var item)\n (runtime-check value-info checked-var))))]\n (cond (every rt-checks empty?)\n []\n\n [\"if (\" checked-var \") {\" line-sep\n \"incRef(\" (.var constraint) \", 1);\" line-sep\n (destruct-seq (.var constraint) items (str (.var constraint) \"_args\") \"\" 9999)\n rt-checks\n \"if (\" checked-var \"){\"\n (map items (fn [item]\n (str \"dec_and_free(\" item \", 1);\" line-sep)))\n \"}}\"]))\n line-sep])))\n\n (runtime-check [constraint value-info sym-location checked-var]\n (let [items-cs (c/extract-items-constraints constraint)]\n (cond (or (c/satisfied-by constraint value-info)\n (empty? items-cs))\n []\n\n [(let [rt-check (-> (c/TypeConstraint {c/ListType #{} c/VectorType #{}} (.path constraint) 'Sequence\n (.sym constraint) (.var constraint))\n (runtime-check value-info sym-location checked-var))]\n (either (empty? rt-check)\n [\"if (\" checked-var \"){\" rt-check \"}\"]))\n (let [min-count (str (count items-cs))]\n [\"if (\" checked-var \" && countSeq(incRef(\" (.var constraint) \", 1)) < \" min-count \") {\"\n ;; \"\\n#ifndef EMBEDDED\\n\"\n \"fprintf(stderr, \\\"Insufficient values for '\"\n (either (.sym constraint) \"\") \"' %s\\\\n\\\", \" sym-location \");\" line-sep\n \"fprintf(stderr, \\\"Needed \" min-count\n \", got %\\\" PRId64 \\\"\\\\n\\\", ((Integer *)count((FnArity *)0, \"\n (.var constraint) \"))->numVal);\" line-sep\n \"fprintf(stderr, \\\"\" (interpose (c/format-path constraint (inc (count (.path constraint))))\n \"\\\\n\")\n \"\\\\n\\\");\"\n ;; \"\\n#endif\\n\"\n checked-var \"= 0;\" line-sep \"}\"])\n (let [items (map (range (inc (count items-cs)))\n (partial str (.var constraint) \"_\"))\n rt-checks (for [[constraints item] (zip-lists items-cs items)]\n (let [constraints (either (map (.sym constraint)\n (partial c/update-sym constraints))\n constraints)]\n (-> constraints\n (c/update-var item)\n (runtime-check value-info sym-location checked-var))))]\n (either (map (every rt-checks empty?) (fn [_] []))\n [\"if (\" checked-var \") {\" line-sep\n \"incRef(\" (.var constraint) \", 1);\" line-sep\n (destruct-seq (.var constraint) items (str (.var constraint) \"_args\") \"\" 9999)\n rt-checks\n \"if (\" checked-var \"){\"\n (map items (fn [item]\n (str \"dec_and_free(\" item \", 1);\" line-sep)))\n \"}}\"]))\n line-sep]))))\n\n(extend-type c/InferredInner\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (sm/state-maybe (either (or (= c/bottom-type (.contents c))\n (= c/top-type (.contents c)))\n c)))\n\n (old-reify-c [c param-exprs file-name line-number]\n (map (old-reify-c (.contents c) param-exprs file-name line-number)\n (fn [new-contents]\n (either (or (= c/bottom-type new-contents)\n (= c/top-type new-contents))\n (.contents c new-contents)))))\n\n (promote-inferred [c]\n (c/extract-coll-constraint c))\n\n (runtime-check [constraint value-info checked-var]\n ;; Only checking the inside of Maybe values\n ;; Not worth the cost to check this at runtime for Lists/Vectors/HashMaps\n ;; Maybe add some kind of feature flag to do this\n (cond (c/satisfied-by constraint value-info)\n []\n\n (let [rt-check (runtime-check (-> constraint\n .contents\n (c/update-var \"inner_value\"))\n c/top-type checked-var)]\n (either (empty? rt-check)\n [\"if (\" checked-var \" && \"\n (.var constraint) \"->type == MaybeType && !isNothing(\" (.var constraint) \", \\\"\\\", 0)) {\"\n \"Value *inner_value = \" (str \"((Maybe *)\" (.var constraint) \")->value\") \";\" line-sep\n line-sep rt-check\n line-sep \"}\"]))))\n\n (runtime-check [constraint value-info sym-location checked-var]\n ;; Only checking the inside of Maybe values\n ;; Not worth the cost to check this at runtime for Lists/Vectors/HashMaps\n ;; Maybe add some kind of feature flag to do this\n (cond (c/satisfied-by constraint value-info)\n []\n\n (let [rt-check (runtime-check (-> constraint\n .contents\n (c/update-var \"inner_value\"))\n c/top-type sym-location checked-var)]\n (either (empty? rt-check)\n [\"if (\" checked-var \" && \"\n (.var constraint) \"->type == MaybeType && !isNothing(\" (.var constraint) \", \\\"\\\", 0)) {\"\n \"Value *inner_value = \" (str \"((Maybe *)\" (.var constraint) \")->value\") \";\" line-sep\n line-sep rt-check line-sep \"}\"])))))\n\n(extend-type c/CollectionOf\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (sm/state-maybe (either (or (= c/bottom-type (.contents c))\n (= c/top-type (.contents c)))\n c)))\n\n (old-reify-c [c param-exprs file-name line-number]\n (map (old-reify-c (.contents c) param-exprs file-name line-number)\n (fn [new-contents]\n (either (or (= c/bottom-type new-contents)\n (= c/top-type new-contents))\n (.contents c new-contents)))))\n\n (promote-inferred [c]\n (.contents c (promote-inferred (.contents c))))\n\n (emit [constraint]\n (emit-sym-constraint constraint))\n\n (runtime-check [constraint value-info checked-var]\n ;; Only checking the inside of Maybe values\n ;; Not worth the cost to check this at runtime for Lists/Vectors/HashMaps\n ;; Maybe add some kind of feature flag to do this\n (cond (c/satisfied-by constraint value-info)\n []\n\n (let [rt-check (runtime-check (-> constraint\n .contents\n (c/update-var \"inner_value\"))\n c/top-type checked-var)]\n ;; TODO: if there's no chance of it being a Maybe, don't generate a check\n (either (empty? rt-check)\n [\"if (\" checked-var \" && \"\n (.var constraint) \"->type == MaybeType && !isNothing(\" (.var constraint) \", \\\"\\\", 0)) {\"\n \"Value *inner_value = \" (str \"((Maybe *)\" (.var constraint) \")->value\") \";\" line-sep\n line-sep rt-check line-sep \"}\"]))))\n\n (runtime-check [constraint value-info sym-location checked-var]\n ;; Only checking the inside of Maybe values\n ;; Not worth the cost to check this at runtime for Lists/Vectors/HashMaps\n ;; Maybe add some kind of feature flag to do this\n (cond (c/satisfied-by constraint value-info)\n []\n\n (let [rt-check (runtime-check (-> constraint\n .contents\n (c/update-var \"inner_value\"))\n c/top-type sym-location checked-var)]\n (either (empty? rt-check)\n [\"if (\" checked-var \" && \"\n (.var constraint) \"->type == MaybeType && !isNothing(\" (.var constraint) \", \\\"\\\", 0)) {\"\n \"Value *inner_value = \" (str \"((Maybe *)\" (.var constraint) \")->value\") \";\" line-sep\n line-sep rt-check line-sep \"}\"])))))\n\n(extend-type c/TypeConstraint\n Emitter\n (to-constraint [ast]\n (cond (empty? (.type-maps ast))\n (map (get-type-sym-info (ast/tag (.type-sym ast)))\n (fn [constraint]\n (-> (either (map (.sym ast)\n (partial c/update-sym constraint))\n constraint)\n (c/update-var (.var ast))\n (c/replace-path (.path ast)))))\n\n (sm/state-maybe ast)))\n\n (emit [ast]\n (let [untagged (ast/untag (.type-sym ast))]\n (comp (emit-sym-constraint ast)\n (compilation-error \"Unknown type\" (str \"'\" (.type-sym ast) \"'\") \"at\"\n (str (ast/file-name ast) \":\") (ast/line-number ast)))))\n\n (runtime-check [constraint value-info checked-var]\n (cond (c/satisfied-by constraint value-info)\n []\n\n [\"if (\" checked-var \"){\"\n \"switch (\" (.var constraint) \"->type) {\"\n (map (keys (.type-maps constraint)) (fn [type-num]\n [\"case \" type-num \": \" ]))\n \"break;\\ndefault:\"\n checked-var \" = 0;}}\"]))\n\n (runtime-check [constraint value-info sym-location checked-var]\n (cond (c/satisfied-by constraint value-info)\n []\n\n (let [rt-check (runtime-check constraint value-info checked-var)]\n (either (empty? rt-check)\n [\"if (\" checked-var \"){\"\n rt-check\n \"if (!\" checked-var \"){\"\n ;; \"\\n#ifndef EMBEDDED\\n\"\n \"fprintf(stderr, \\\"Invalid type of value for '\"\n (either (.sym constraint) \"\") \"' %s\\\\n\\\", \" sym-location \");\" line-sep\n \"fprintf(stderr, \\\"Needed \" (str (.type-sym constraint))\n \", got %s\\\\n\\\", extractStr(type_name((FnArity *)0, \" (.var constraint) \")));\"\n \"fprintf(stderr, \\\"\"\n (interpose (c/format-path constraint (inc (count (.path constraint)))) \"\\\\n\")\n \"\\\\n\\\");\"\n ;; \"\\n#endif\\n\"\n \"}}\"])))))\n\n(extend-type c/MaxValue\n Emitter\n (runtime-check [constraint value-info checked-var]\n [\"if (\" checked-var \" && \"\n (str (.max constraint)) \" < ((Integer *)\" (.var constraint) \")->numVal) {\"\n checked-var \" = 0;}\"])\n\n (runtime-check [constraint value-info sym-location checked-var]\n (cond (c/satisfied-by constraint value-info)\n []\n\n (let [rt-check (runtime-check constraint value-info checked-var)]\n (either (empty? rt-check)\n [\"if (\" checked-var \"){\"\n rt-check\n \"if (!\" checked-var \") {\"\n ;; \"\\n#ifndef EMBEDDED\\n\"\n \"fprintf(stderr, \\\"Value of '\" (either (.sym constraint) \"\")\n \"' is too large %s\\\\n\\\", \" sym-location \");\" line-sep\n \"fprintf(stderr, \\\"Maximum allowed value is \" (str (.max constraint))\n \", got %\\\" PRId64 \\\"\\\\n\\\", ((Integer *)\" (.var constraint) \")->numVal);\" line-sep\n \"fprintf(stderr, \\\"\"\n (interpose (c/format-path constraint (inc (count (.path constraint)))) \"\\\\n\")\n \"\\\\n\\\");\"\n ;; \"\\n#endif\\n\"\n \"}}\"])))))\n\n(extend-type c/MinValue\n Emitter\n (runtime-check [constraint value-info checked-var]\n [\"if (\" checked-var \" && \"\n (str (.min constraint)) \" > ((Integer *)\" (.var constraint) \")->numVal) {\"\n checked-var \" = 0;}\"])\n\n (runtime-check [constraint value-info sym-location checked-var]\n (cond (c/satisfied-by constraint value-info)\n []\n\n (let [rt-check (runtime-check constraint value-info checked-var)]\n (either (empty? rt-check)\n [\"if (\" checked-var \"){\"\n rt-check\n \"if (!\" checked-var \") {\"\n ;; \"\\n#ifndef EMBEDDED\\n\"\n \"fprintf(stderr, \\\"Value of '\" (either (.sym constraint) \"\")\n \"' is too small %s\\\\n\\\", \" sym-location \");\" line-sep\n \"fprintf(stderr, \\\"Minimum allowed value is \" (str (.min constraint))\n \", got %\\\" PRId64 \\\"\\\\n\\\", ((Integer *)\" (.var constraint) \")->numVal);\" line-sep\n \"fprintf(stderr, \\\"\"\n (interpose (c/format-path constraint (inc (count (.path constraint)))) \"\\\\n\")\n \"\\\\n\\\");\"\n ;; \"\\n#endif\\n\"\n \"}}\"])))))\n\n(extend-type c/FieldConstraint\n Emitter\n (emit [constraint]\n (either (map (.sym constraint)\n (fn [sym]\n (let [sym (ast/tag sym)]\n (for [sym-info (lookup-sym sym)\n field-var (lookup-sym (ast/tag (.field constraint)))\n _ (constrain-var (ast/file-name constraint) (ast/line-number constraint)\n (.c-var sym-info) (.field-var constraint (.c-var field-var)))]\n (.refs-map sym-info (dissoc (.refs-map sym-info) (.c-var sym-info)))))))\n (wrap sm/zero-sm empty-c-code)))\n\n (runtime-check [constraint value-info checked-var]\n [\"if(\" checked-var \") {\\n\"\n \"Value *dork = hasField((FnArity *)0, incRef(\" (.var constraint) \", 1), \"\n (.field-var constraint) \");\\n\" \"if (isNothing(dork,\\\"\\\",0)) {\"\n checked-var \" = 0;}\" line-sep\n \"dec_and_free(dork, 1);}\"])\n\n (runtime-check [constraint value-info sym-location checked-var]\n (cond (c/satisfied-by constraint value-info)\n []\n\n (let [rt-check (runtime-check constraint value-info checked-var)]\n (either (empty? rt-check)\n [\"if (\" checked-var \"){\"\n rt-check\n \"if(!\" checked-var \") {\\n\"\n ;; \"\\n#ifndef EMBEDDED\\n\"\n \"fprintf(stderr, \\\"Value '\" (either (.sym constraint) \"\")\n \"' of type '%s' does not have field '\"\n (.field constraint) \"' %s\\\\n\\\", extractStr(type_name((FnArity *)0, \"\n (.var constraint) \")), \" sym-location \");\" line-sep\n \"fprintf(stderr, \\\"\"\n (interpose (c/format-path constraint (inc (count (.path constraint)))) \"\\\\n\")\n \"\\\\n\\\");\"\n ;; \"\\n#endif\\n\"\n \"}}\"])))))\n\n(extend-type c/MultiConstraint\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (sm/state-maybe (either (some (.constraints c) (partial = c/bottom-type))\n (let [new-cs (-> (.constraints c)\n (flat-map (fn [reified]\n (either (map (instance? c/MultiConstraint reified)\n .constraints)\n [reified])))\n (remove (partial = c/top-type)))]\n (either (or (and (empty? new-cs)\n (maybe c/top-type))\n (and (= 1 (count new-cs))\n (first new-cs)))\n (reduce new-cs c/top-type c/intersect))))))\n\n (old-reify-c [constraint param-exprs file-name line-number]\n (for [new-cs (sm/traverse (.constraints constraint)\n (fn [c]\n (old-reify-c c param-exprs file-name line-number)))]\n (either (some new-cs (partial = c/bottom-type))\n (let [new-cs (-> new-cs\n (flat-map (fn [reified]\n (either (map (instance? c/MultiConstraint reified) .constraints)\n [reified])))\n (remove (partial = c/top-type)))]\n (either (or (and (empty? new-cs)\n (maybe c/top-type))\n (and (= 1 (count new-cs))\n (first new-cs)))\n (reduce new-cs c/top-type c/intersect))))))\n\n (promote-inferred [c]\n (.constraints c (map (.constraints c) promote-inferred)))\n\n (validate-field [c m fields file-name line-number]\n (either (for [first-c (first (.constraints c))\n c-sym (c/extract-sym first-c)]\n (do\n (either (some fields (partial = c-sym))\n (do\n (print-err \"Invalid field\"\n (str \"'\" c-sym \"'\")\n \"at:\" (str file-name \":\")\n line-number)\n (abort)))\n (-> m\n (dissoc c-sym)\n (assoc c-sym (either (c/compose-constraints file-name line-number\n c\n (either (get m c-sym)\n c/top-type))\n (abort))))))\n m))\n\n (runtime-check [constraint value-info checked-var]\n (cond (or (some (.constraints constraint)\n (partial instance? c/StaticConstraints))\n (c/satisfied-by constraint value-info))\n []\n\n (map (.constraints constraint)\n (fn [c]\n (runtime-check c value-info checked-var)))))\n\n (runtime-check [constraint value-info sym-location checked-var]\n (cond (or (some (.constraints constraint)\n (partial instance? c/StaticConstraints))\n (c/satisfied-by constraint value-info))\n []\n\n (map (.constraints constraint)\n (fn [c]\n (runtime-check c value-info sym-location checked-var)))))\n\n (emit [constraint]\n (map (sm/traverse (.constraints constraint) emit)\n (fn [[expr & exprs]]\n (comp* expr exprs)))))\n\n(extend-type c/ResultConstraint\n Emitter\n (reify-c [c param-exprs file-name line-number]\n (sm/state-maybe (either (= c/bottom-type (.assertion c))\n c)))\n\n (old-reify-c [c param-exprs file-name line-number]\n (map (old-reify-c (.assertion c) param-exprs file-name line-number)\n (fn [new-assertion]\n (either (= c/bottom-type new-assertion)\n (.assertion c new-assertion)))))\n\n (update-syms [constraint _]\n (sm/state-maybe (Left constraint)))\n\n (emit [ast]\n (-> ast .assertion (c/update-var \"#result\") emit))\n\n (runtime-check [constraint value-info sym-location checked-var]\n ;; Handled other places\n []))\n\n(extend-type Maybe\n Emitter\n (encode-static [v]\n (comp (sm/get-in-val [.constants .encoded v])\n (either (map v (fn [v]\n (for [_ (debug 'encoding-maybe v (sha1 v))\n expr (encode-static v)\n struct (global-var \"maybe_\")\n var (global-var \"maybe_\")\n _ (declare [\"Maybe \" struct \" = (Maybe){MaybeType, -2, 0, (Value *)&\"\n (.c-struct expr) \"};\" line-sep\n \"Maybe *\" var \" = &\" struct \";\" line-sep])\n _ (sm/assoc-in-val [.constants .encoded v] (c-static-val var [] {} struct))]\n (do\n ;; TODO: we need to encode the constraints on 'var' as well\n (comp expr\n (c-static-val var [] {} struct))))))\n (wrap sm/zero-sm\n (c-static-val \"nothing\" [] {} \"nothing_struct\"))))))\n\n(extend-type List\n StringWriter\n (write-str [l] (map l write-str))\n\n Emitter\n (encode-static [l]\n (comp (sm/get-in-val [.constants .encoded l])\n (either (map (first l)\n (fn [head]\n (for [tail-expr (encode-static (rest l))\n head-expr (encode-static head)\n struct (global-var \"list_\")\n var (global-var \"list_\")\n _ (declare [\"List \" struct \" = {ListType, -2, 0, \" (str (count l))\n \", (Value *)&\" (.c-struct head-expr)\n \", &\" (.c-struct tail-expr) \"};\" line-sep])\n _ (sm/assoc-in-val [.constants .encoded l] (c-static-val var [] {} struct))]\n (comp tail-expr\n head-expr\n (c-static-val var [] {} struct)))))\n (wrap sm/zero-sm\n (c-static-val \"empty_list\" [] {} \"empty_list_struct\")))))\n\n (wrap-tail [asts args]\n (let [asts (reverse asts)]\n (Left (either (empty? asts)\n (let [[tail & init] asts]\n (-> (tail-call tail args)\n (cons init)\n reverse)))))))\n\n(defn encodeVectorInfo [v]\n (inline C Vector \"\n Vector *v = (Vector *)v_0;\n\n Vector *array = empty_vect;\n for (int i = 0; i < v->count; i++) {\n Value *val = v->tail[i];\n incRef(val, 1);\n array = mutateVectConj(array, val);\n }\n\n Vector *result = empty_vect;\n result = mutateVectConj(result, integerValue(v->shift));\n result = mutateVectConj(result, integerValue(v->tailOffset));\n if (v->root != (VectorNode *)0) {\n fprintf(stderr, \\\"Encode Vector root\\\\n\\\");\n abort();\n } else {\n result = mutateVectConj(result, nothing);\n }\n result = mutateVectConj(result, (Value *)array);\n\n dec_and_free(v_0, 1);\n return((Value *)result);\n \"))\n\n(def vector-array-len (inline C Integer \"(Value *)&(Integer){IntegerType,-2,VECTOR_ARRAY_LEN}\"))\n\n(extend-type Vector\n StringWriter\n (write-str [v] (map v write-str))\n\n Emitter\n (reify-c [v param-exprs file-name line-number]\n (sm/state-maybe (either (some v (partial = c/bottom-type))\n v)))\n\n (old-reify-c [v param-exprs file-name line-number]\n (map (sm/traverse v (fn [x]\n (old-reify-c x param-exprs file-name line-number)))\n (fn [new-v]\n (either (some new-v (partial = c/bottom-type))\n new-v))))\n\n (encode-static [v]\n (comp (sm/get-in-val [.constants .encoded v])\n (let [[shift offset root array] (encodeVectorInfo v)]\n (for [items (sm/traverse array encode-static)\n root (either (map root encode-static)\n (wrap sm/zero-sm (c-static-val \"NULL\" [] {} \"NULL\")))\n struct (global-var \"vect_\")\n var (global-var \"vect_\")\n _ (declare [\"Vector \" struct \" = {VectorType, -2, 0, \"\n (str (count array))\n \", \" (str shift) \", \" (str offset) \", \"\n (.c-struct root)\n (map items\n (fn [expr]\n (str \", (Value *)&\" (.c-struct expr))))\n (map (range (- vector-array-len (count array))) (fn [_] \", 0\"))\n \"};\" line-sep\n \"Value *\" var \" = (Value *)&\" struct \";\" line-sep])\n expr (collapse-expressions (comp items [(c-static-val var [] {} struct)]))\n _ (sm/assoc-in-val [.constants .encoded v] expr)]\n expr))))\n\n (wrap-tail [asts params]\n (Left (either (flat-map (last asts)\n (fn [tail]\n (store asts (dec (count asts))\n (tail-call tail params))))\n asts))))\n\n(defn set-result-constraint [result-var file-name line-number]\n ;; TODO: shouldn't be returning the result-constraint\n (for [result-c (get-constraint \"#result\")\n var-c (get-constraint result-var)\n :let [final (c/intersect result-c var-c)\n ;; TODO: this gets printed twice for constructor invokes. Why?\n ;; _ (print-err 'final file-name line-number result-var final)\n _ (and (= c/bottom-type final)\n (do\n (print-err \"Invalid return value for function at\" file-name line-number)\n (c/conflicting-assertions final file-name line-number)\n (abort)))]\n _ (set-constraint result-var (c/clear-vars final))\n ;; TOOD: this doesn't work if final has a SumConstraint in it.\n ;; extract-items-constraints will clear vars in that case\n _ (sm/traverse (c/extract-items-constraints final)\n (fn [c]\n (constrain-var file-name line-number (c/extract-var c) c)))]\n final))\n\n(defn extract-closures []\n (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (let [closures (-> s .fn-context .closed-over .closures)]\n (and (first closures)\n (maybe [closures s]))))))\n\n(defn free-closure-parent []\n (comp (map (extract-closures) (fn [_]\n [\"if (arity->parent) \"\n \"dec_and_free(arity->parent, 1);\" line-sep]))\n (sm/state-maybe \"\")))\n\n(deftype TailExpr [ast]\n Stringable\n (string-list [_]\n (list (str ast)))\n\n Container\n (map [x f]\n (TailExpr (f ast)))\n\n (map [x f embed]\n (map (f x) TailExpr))\n\n Emitter\n (emit [_]\n (for [expr (emit ast)\n _ (set-result-constraint (.c-var expr) \"\" 0)]\n expr)))\n\n(deftype TailHashMap [m]\n Stringable\n (string-list [_]\n (list (str m)))\n\n Container\n (map [x f]\n x)\n\n (map [x f embed]\n (embed x))\n\n Emitter\n (emit [_]\n ;; TODO: need to test freeing the parent fn in closures\n (for [init-fn-context (sm/get-val .rt-init)\n fn-context (reset-fn-context (.subs init-fn-context {}))\n value (encode m)\n init-fn-context (reset-fn-context fn-context)\n _ (sm/set-val .rt-init init-fn-context)\n _ (constrain-var \"\" 0 (.c-var value) hashmap-constraint)\n _ (set-result-constraint (.c-var value) \"\" 0)\n free-parent (free-closure-parent)]\n (c-code (.c-var value) [free-parent line-sep \"return(\" (.c-var value) \");\" line-sep]\n {} hashmap-constraint))))\n\n(defn collisionArray [m]\n (inline C Vector \"\n HashCollisionNode *node = (HashCollisionNode *)m_0;\n int cnt = node->count;\n Vector *v = empty_vect;\n for (int i = 0; i < cnt; i++) {\n Value *val = node->array[i];\n incRef(val, 1);\n v = mutateVectConj(v, val);\n }\n dec_and_free(m_0, 1);\n return((Value *)v);\n \"))\n\n(defn bmiArray [m]\n (inline C Vector \"\n BitmapIndexedNode *node = (BitmapIndexedNode *)m_0;\n int cnt = __builtin_popcount(node->bitmap);\n Vector *v = empty_vect;\n for (int i = 0; i < cnt * 2; i++) {\n Value *val = node->array[i];\n if (val == (Value *)0)\n v = mutateVectConj(v, (Value *)nothing);\n else {\n incRef(val, 1);\n v = mutateVectConj(v, maybe((FnArity *)0, (Value *)0, val));\n }\n }\n dec_and_free(m_0, 1);\n return((Value *)v);\n \"))\n\n(defn bmiBitmap [m]\n (inline C Integer \"\n BitmapIndexedNode *node = (BitmapIndexedNode *)m_0;\n Value *result = integerValue(node->bitmap);\n dec_and_free(m_0, 1);\n return((Value *)result);\n \"))\n\n(defn arrayNodeArray [m]\n (inline C Vector \"\n ArrayNode *node = (ArrayNode *)m_0;\n Vector *v = empty_vect;\n for (int i = 0; i < ARRAY_NODE_LEN; i++) {\n Value *val = node->array[i];\n if (val == (Value *)0)\n v = mutateVectConj(v, (Value *)nothing);\n else {\n incRef(val, 1);\n v = mutateVectConj(v, maybe((FnArity *)0, (Value *)0, val));\n }\n }\n dec_and_free(m_0, 1);\n return((Value *)v);\n \"))\n\n(extend-type ast/Annotated\n Emitter\n (emit [a]\n (emit (.ast a)))\n\n (emit-defined-value [a x]\n (emit-defined-value (.ast a) x))\n\n (emit-definition [a]\n (emit-definition (.ast a))))\n\n(extend-type ast/block-comment-ast\n Emitter\n (emit [ast]\n (wrap sm/zero-sm (c-code \"\" (comp [\"\\n\"]\n (map (.lines ast) (fn [line]\n (str \"//\" line \"\\n\"))))\n {} c/top-type)))\n\n (emit-defined-value [_ x] (wrap sm/zero-sm []))\n (emit-definition [_] (wrap sm/zero-sm [])))\n\n\n(extend-type HashSet\n Container\n (map [x f]\n x)\n\n (map [x f embed]\n (embed x))\n\n Emitter\n (encode-static [hs]\n (comp (sm/get-in-val [.constants .encoded hs])\n (for [m (encode-static (.set-map hs))\n struct (global-var \"set_\")\n var (global-var \"set_\")\n _ (constrain-var \"\" 0 var (c/TypeConstraint {(get-type hs) #{}}\n empty-list 'HashSet nothing \"\"))\n _ (declare [\"ReifiedVal \" struct \" = {\" (str (get-type hs))\n \", -2, 0, 1, (Value *)&\" (.c-struct m) \"};\\n\"\n \"Value *\" var \" = (Value *)&\" struct \";\" line-sep])\n :let [expr (c-static-val var [] {} struct)]\n _ (sm/assoc-in-val [.constants .encoded hs] expr)]\n expr)))\n\n (emit [hs]\n (for [expr (encode (.set-map hs))\n var (genlocal \"set_\")]\n (-> expr\n (.c-var var)\n (.init (comp (.init expr) [\"Value *\" var \" = newHashSet((FnArity *)0, \" (.c-var expr) \");\" line-sep]))))))\n\n(deftype TailCall [ast params]\n (assert (instance? Vector params))\n\n Stringable\n (string-list [expr]\n (comp (list \"\")))\n\n Container\n (map [x f]\n (TailCall (f ast) (map params f)))\n\n (map [x f embed]\n (for [new-ast (f ast)\n new-params (map params f embed)]\n (TailCall new-ast new-params)))\n\n ast/FileLineInfo\n (ast/file-name [_]\n (ast/file-name ast))\n\n (ast/line-number [_]\n (ast/line-number ast))\n\n Emitter\n (emit [_]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (comp (emit-recursive-call ast params)\n (for [expr (emit ast)\n curr-const (get-constraint (.c-var expr))\n result-const (get-constraint \"#result\")\n checked-var (genlocal 'checked)\n free-parent (free-closure-parent)\n :let [expr (cond (instance? Tagged ast)\n (.refs-map expr {})\n expr)\n check-result (cond (instance? c-param expr)\n \"\"\n (let [rt-check (runtime-check (c/update-var result-const (.c-var expr))\n curr-const file-name line-number\n checked-var)]\n (either (empty? rt-check)\n [\"if(1){int \" checked-var \" = 1;\" line-sep\n rt-check\n \"if(!\" checked-var \"){abort();}}\" line-sep])))]\n _ (constrain-var file-name line-number (.c-var expr) result-const)\n final-expr (collapse-expressions [(.init expr [(.init expr) check-result])\n (c-code (.c-var expr)\n [free-parent\n \"return(\" (.c-var expr) \");\" line-sep]\n {(.c-var expr) 1}\n c/top-type)])\n ;; TODO: periodically enable this to check on things\n ;; (print-err 'check (some return-assertions assert-return-type) return-type\n ;; (ast/file-name ast) (ast/line-number ast))\n\n _ (set-result-constraint (.c-var final-expr) file-name line-number)]\n final-expr)))))\n\n(defn make-static-string [str-val]\n ;; TODO: when adding meta data, make sure to update this as well\n (let [str-len (count str-val)]\n (for [expr (comp (sm/get-in-val [.constants .strings str-val])\n (for [expr (sm/when (-> constants\n extract\n (get-in [.strings str-val])))\n _ (sm/assoc-in-val [.constants .strings str-val]\n (.init expr []))\n _ (debug 'from-constants\n (to-str (.init expr))\n (str \"'\" str-val \"'\"))]\n expr)\n (for [str-idx (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (-> s\n .constants\n .strings\n count\n (vector s)\n maybe)))\n curr-mod (sm/get-in-val [.module .index])\n :let [str-sym (str \"m\" curr-mod \"_str\" str-idx)\n str-ptr (str \"m\" curr-mod \"_strPtr\" str-idx)\n constraint (c/TypeConstraint {c/StringBufferType #{}}\n empty-list 'String nothing str-ptr)]\n _ (sm/assoc-in-val [.constants .strings str-val]\n (c-static-str str-ptr [] {} constraint str-sym))\n _ (declare [\"struct {TYPE_SIZE type;\n REFS_SIZE refs;\n Integer *hash;\n int64_t len;\n char buffer[\"\n (inc str-len)\n \"];\\n} \" str-sym \" = {StringBufferType, -1, 0, \"\n str-len \", \\\"\" (escape-chars str-val) \"\\\"};\\n\"\n \"Value *\" str-ptr \" = (Value *)&\" str-sym \";\\n\"])]\n (c-static-str str-ptr [] {} constraint str-sym)))\n _ (constrain-var \"\" 0 (.c-var expr) (.constraints expr))]\n expr)))\n\n(extend-type String\n Container\n (map [x f]\n x)\n\n (map [x f embed]\n (embed x))\n\n Emitter\n (cache-static-constant [s expr]\n (send constants (fn [constants]\n (assoc-in constants [.strings s]\n (.init expr [\"Value *\" (.c-var expr) \";\" line-sep])))))\n\n (emit [str-val]\n (make-static-string str-val)))\n\n(defn make-static-num [num]\n (for [expr (comp (sm/get-in-val [.constants .numbers num])\n (for [expr (sm/when (-> constants\n extract\n (get-in [.numbers num])))\n _ (sm/assoc-in-val [.constants .numbers num]\n (.init expr []))\n _ (debug 'from-constants (to-str (.init expr)) num)]\n expr)\n (for [num-idx (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (-> s\n .constants\n .numbers\n count\n (vector s)\n maybe)))\n curr-mod (sm/get-in-val [.module .index])\n :let [num-sym (str \"m\" curr-mod \"_num\" num-idx)\n num-ptr (str \"m\" curr-mod \"_numPtr\" num-idx)\n constraint (c/StaticIntConstraint num empty-list nothing num-ptr)\n var (c-static-int num-ptr [] {} constraint num-sym)]\n _ (sm/assoc-in-val [.constants .numbers num] var)\n _ (declare [\"Integer \" num-sym \" = {IntegerType, -2, \" num \"};\\n\"\n \"Value *\" num-ptr \" = (Value *)&\" num-sym \";\\n\"])]\n var))\n _ (constrain-var \"\" 0 (.c-var expr) (.constraints expr))]\n expr))\n\n(extend-type Integer\n Container\n (map [x f]\n x)\n\n (map [x f embed]\n (embed x))\n\n Emitter\n (cache-static-constant [n expr]\n (send constants (fn [constants]\n (assoc-in constants [.numbers n]\n (.init expr [\"Value *\" (.c-var expr) \";\" line-sep])))))\n\n (emit [num]\n (make-static-num num)))\n\n(extend-type BitmapIndexedNode\n Emitter\n (encode-static [m]\n (comp (sm/get-in-val [.constants .encoded m])\n (for [;; _ (debug 'encoding-bmi m\n items (sm/traverse (bmiArray m) (fn [v]\n (either (map v (fn [v]\n (map (encode-static v) maybe)))\n (sm/state-maybe nothing))))\n struct (global-var \"bmi_\")\n var (global-var \"bmi_\")\n :let [new-items (cond (empty? items)\n \"0\"\n (interpose (map items\n (fn [v]\n (either (map v (fn [expr]\n (and (= \"\" (.c-struct expr))\n (do\n ;; TODO: remove sometime\n (print-err 'wtf-boom expr)\n (abort)))\n (str \"(Value *)&\"\n (.c-struct expr))))\n \"NULL\")))\n \", \"))]\n _ (constrain-var \"\" 0 var (c/TypeConstraint {c/BitmapIndexedType #{}}\n empty-list 'HashMap nothing \"\"))\n _ (declare [\"BitmapIndexedNode \" struct \" = {BitmapIndexedType, -2, 0, \"\n (str (bmiBitmap m)) \", \" new-items \"};\\n\"\n \"Value *\" var \" = (Value *)&\" struct \";\\n\"])\n expr (collapse-expressions (comp (map items (fn [v] (either v empty-c-code)))\n [(c-static-val var [] {} struct)]))\n _ (sm/assoc-in-val [.constants .encoded m] (c-static-val var [] {} struct))]\n expr))))\n\n(extend-type HashCollisionNode\n Emitter\n (encode-static [m]\n (comp (sm/get-in-val [.constants .encoded m])\n (for [;; TODO: see just what is being encoded\n ;; _ (debug 'encoding-hash-collistion m)\n items (sm/traverse (collisionArray m) encode-static)\n struct (global-var \"collision_\")\n var (global-var \"collision_\")\n :let [new-items (interpose (map items\n (fn [expr]\n (str \"(Value *)&\" (.c-struct expr))))\n \", \")]\n _ (constrain-var \"\" 0 var (c/TypeConstraint {c/HashCollisionNodeType #{}}\n empty-list 'HashMap nothing \"\"))\n _ (declare [\"HashCollisionNode \" struct \" = {HashCollisionNodeType, -2, 0, \"\n (str (count items)) \", \" new-items \"};\\n\"\n \"Value *\" var \" = (Value *)&\" struct \";\\n\"])\n expr (collapse-expressions (comp items [(c-static-val var [] {} struct)]))\n _ (sm/assoc-in-val [.constants .encoded m] (c-static-val var [] {} struct))]\n expr))))\n\n(extend-type ArrayNode\n Emitter\n (encode-static [m]\n (comp (sm/get-in-val [.constants .encoded m])\n (for [;; _ (debug 'encoding-array-node m\n items (sm/traverse (arrayNodeArray m) (fn [v]\n (either (map v (fn [v]\n (map (encode-static v) maybe)))\n (sm/state-maybe nothing))))\n struct (global-var \"arrayNode_\")\n var (global-var \"arrayNode_\")\n :let [new-items (cond (empty? items)\n \"0\"\n (interpose (map items\n (fn [v]\n (either (map v (fn [expr]\n (str \"(Value *)&\"\n (.c-struct expr))))\n \"NULL\")))\n \", \"))]\n _ (constrain-var \"\" 0 var (c/TypeConstraint {c/ArrayNodeType #{}}\n empty-list 'HashMap nothing \"\"))\n _ (declare [\"ArrayNode \" struct \" = {ArrayNodeType, -2, 0, \" new-items \"};\"\n line-sep \"Value *\" var \" = (Value *)&\" struct \";\" line-sep])\n expr (collapse-expressions (comp (map items (fn [v] (either v empty-c-code)))\n [(c-static-val var [] {} struct)]))\n _ (sm/assoc-in-val [.constants .encoded m] (c-static-val var [] {} struct))]\n expr))))\n\n(extend-type HashMap\n Container\n (map [x f]\n x)\n\n (map [x f embed]\n (embed x))\n\n ast/IsCode\n (ast/generates-code? [expr]\n (maybe expr))\n\n Emitter\n (emit [m]\n (for [init-fn-context (sm/get-val .rt-init)\n fn-context (reset-fn-context (.subs init-fn-context {}))\n value (comp (encode-static m)\n (encode m))\n init-fn-context (reset-fn-context fn-context)\n _ (sm/get-val .rt-init init-fn-context)\n _ (constrain-var \"\" 0 (.c-var value) hashmap-constraint)]\n ;; TODO: wtf? There shouldn't be a 'return' here\n (c-code (.c-var value) [\"return(\" (.c-var value) \");\" line-sep]\n {} hashmap-constraint)))\n\n (wrap-tail [m params]\n (Left (TailHashMap m)))\n\n (encode [m] (encode m \"var_\"))\n\n (encode [m var-prefix]\n (comp (encode-static m)\n (for [map-var (global-var var-prefix)\n _ (declare [\"Value *\" map-var \" = (Value *)&emptyBMI;\\n\"])\n assocs (sm/traverse (vec m)\n (fn [[sym var]]\n (for [sym-var (cond (instance? Tagged sym)\n (emit (ast/quoted-ast sym))\n (emit sym))\n expr (comp (encode-static var)\n (encode var))]\n [(.init sym-var) (.init expr)\n map-var \" = hashMapAssoc((Value *)\" map-var\n \", incRef(\" (.c-var sym-var) \", 1), \" (.c-var expr) \");\\n\"])))\n _ (constrain-var \"\" 0 map-var hashmap-constraint)]\n (c-code map-var (comp* [] assocs) {} hashmap-constraint)))))\n\n(extend-type ast/quoted-ast\n Emitter\n (update-syms [x _]\n (sm/state-maybe (Left x)))\n\n (emit [ast]\n (let [sym (.q-val ast)]\n (comp (for [expr (sm/get-in-val [.constants .symbols sym])\n _ (constrain-var (ast/file-name ast) (ast/line-number ast)\n (.c-var expr) (.constraints expr))]\n expr)\n ;; (for [expr (sm/when (-> constants\n ;; extract\n ;; (get-in [.symbols sym])))\n ;; _ (sm/assoc-in-val [.constants .symbols sym]\n ;; (.init expr []))\n ;; _ (constrain-var (ast/file-name ast) (ast/line-number ast)\n ;; (.c-var expr) (.constraints expr))\n ;; _ (debug 'from-constants (to-str (.init expr)) sym)]\n ;; expr)\n (for [sym-idx (sm/new-sm (fn [s]\n (assert (instance? GlobalContext s))\n (-> s\n .constants\n .symbols\n count\n (vector s)\n maybe)))\n curr-mod (sm/get-in-val [.module .index])\n :let [sym-var (str \"m\" curr-mod \"_sym\" sym-idx)\n sym-ptr (str \"m\" curr-mod \"_symPtr\" sym-idx)\n constraint (c/update-path sym-constraint\n (ast/file-name ast) (ast/line-number ast))]\n _ (sm/assoc-in-val [.constants .symbols sym]\n (c-static-sym sym-ptr [] {} constraint sym-var))\n _ (constrain-var (ast/file-name ast) (ast/line-number ast)\n sym-ptr constraint)\n _ (declare [\"SubString \" sym-var \" = {SymbolType, -1, 0, \" (count (str sym))\n \", 0, \\\"\" sym \"\\\"};\\n\"\n \"Value *\" sym-ptr \" = (Value *)&\" sym-var \";\\n\"])]\n (c-static-sym sym-ptr [] {} constraint sym-var))))))\n\n\n(def LiteralValues (any-of ast/quoted-ast\n ast/string-ast\n ast/integer-ast\n Integer\n String))\n\n(extend-type LiteralValues\n Emitter\n (encode-static [n]\n (emit n))\n\n (emit-defined-value [num defined-sym]\n (for [value (emit num)\n _ (new-module-def defined-sym (-> value\n (.init [])\n (.refs-map {})))]\n [value]))\n\n (wrap-tail [x params]\n (Left (TailCall x params))))\n\n(extend-type ast/string-ast\n Emitter\n (emit [ast]\n (for [expr (make-static-string (.string ast))\n _ (sm/update-in-val [.fn-context .subs (.c-var expr)]\n (fn [c]\n (c/update-path c (ast/file-name ast) (ast/line-number ast))))]\n expr)))\n\n(extend-type ast/integer-ast\n Emitter\n (emit [ast]\n (for [expr (make-static-num (.int ast))\n _ (sm/update-in-val [.fn-context .subs (.c-var expr)]\n (fn [c]\n (c/update-path c (ast/file-name ast) (ast/line-number ast))))]\n expr)))\n\n(defn constrain-contents [var constraint content-vars file-name line-number]\n (for [contents (sm/traverse content-vars get-constraint)\n :let [constraint (-> constraint\n (c/intersect (c/StaticLengthConstraint (count content-vars) empty-list\n nothing var))\n (c/intersect (c/ItemsConstraint contents c/coll-of-any empty-list\n nothing var))\n (c/update-var var))]\n _ (append-constraint var constraint file-name line-number)]\n '_))\n\n(defn call-vector [target args]\n (assert (instance? Vector args))\n\n (let [file-name (ast/file-name target)\n line-number (ast/line-number target)]\n (for [vect-sym (genlocal \"newVect\")\n result-sym (genlocal \"vect\")\n line (line-macro target \"// call-vector\")\n _ (constrain-contents result-sym vect-constraint (map args .c-var)\n file-name line-number)]\n (c-init result-sym\n [line\n \"Vector *\" vect-sym \" = empty_vect;\" line-sep\n (map args\n (fn [arg]\n (let [arg-sym (.c-var arg)]\n [vect-sym \" = mutateVectConj(\" vect-sym \", \"\n arg-sym \");\" line-sep])))\n \"Value *\" result-sym \" = (Value *)\" vect-sym \";\" line-sep]\n {} file-name line-number))))\n\n(defn call-list [target args]\n (assert (instance? Vector args))\n\n (let [file-name (ast/file-name target)\n line-number (ast/line-number target)]\n (for [line (line-macro target \"// call-list\")\n list-sym (genlocal \"newList\")\n result-sym (genlocal \"list\")\n _ (constrain-contents result-sym list-constraint (map args .c-var)\n file-name line-number)]\n (c-init result-sym\n [line \"List *\" list-sym \" = empty_list;\" line-sep\n (map (reverse args)\n (fn [arg]\n (let [arg-sym (.c-var arg)]\n [list-sym \" = listCons(\" \"(Value *)\" arg-sym\n \", \" list-sym \");\" line-sep])))\n \"Value *\" result-sym \" = (Value *)\" list-sym \";\" line-sep]\n {} file-name line-number))))\n\n(defn call-maybe [ast arg]\n (let [target (.call-target ast)\n file-name (ast/file-name target)\n line-number (ast/line-number target)]\n (for [line (line-macro target \"// call-maybe\")\n result-sym (genlocal \"maybe\")\n _ (propogate-constraint (.c-var arg) result-sym\n (fn [inner]\n (either (= inner c/top-type)\n (c/intersect maybe-constraint\n (c/InferredInner inner empty-list\n nothing result-sym))))\n file-name line-number)]\n (c-init result-sym\n [line \"Value *\" result-sym \" = (Value *)maybe((FnArity *)0, (Value *)0, \" (.c-var arg) \");\" line-sep]\n {} file-name line-number))))\n\n(def conj-like #{'conj 'mutate-vect-conj})\n\n(defn constrain-collection [coll-var v-var result-var file-name line-number]\n (for [coll-const (get-constraint coll-var)\n :let [coll-type (c/extract-collection-of coll-const)\n contents-type (c/extract-contents-constraint coll-type)]\n _ (append-constraint v-var contents-type file-name line-number)\n v-c (get-constraint v-var)]\n '_))\n\n(defn add-hash-map-constraints [ast result-var args]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (either (or (for [_ (= (.call-target ast) 'assoc)\n coll-var (map (nth args 0) .c-var)\n k-var (map (nth args 1) .c-var)\n v-var (map (nth args 2) .c-var)]\n (for [coll-const (get-constraint coll-var)\n :let [[key-c val-c] (-> coll-const\n c/extract-collection-of\n c/extract-contents-constraint\n (c/extract-items-constraints 2))]\n _ (append-constraint v-var val-c file-name line-number)\n _ (append-constraint k-var key-c file-name line-number)]\n '_))\n (and (= (.call-target ast) 'hash-map)\n (maybe (for [arg-cs (sm/traverse args (comp get-constraint .c-var))\n :let [pair-cs (-> arg-cs\n (partition 2)\n (map (fn [kv-c]\n (-> c/empty-items-constraint\n (.items-constraints (vec kv-c)))))\n vec)]\n _ (append-constraint result-var (-> (c/CollectionOf\n c/top-type empty-list nothing \"\")\n (c/intersect (-> c/empty-items-constraint\n (.items-constraints pair-cs)))\n (c/update-path file-name line-number))\n file-name line-number)]\n '_))))\n sm-nop)))\n\n(defn add-contents-constraint [ast result args]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)\n target (.call-target ast)]\n (either (or (for [_ (= target 'cons)\n v (first args)\n coll (second args)]\n (let [v-var (.c-var v)\n coll-var (.c-var coll)]\n (for [coll-const (get-constraint coll-var)\n v-const (get-constraint v-var)\n _ (append-constraint result\n (c/ItemsConstraint [v-const] coll-const\n empty-list nothing result)\n file-name line-number)]\n '_)))\n (for [_ (= target 'store)\n coll (first args)\n v (second args)]\n (for [coll-const (get-constraint (.c-var coll))\n v-const (get-constraint (.c-var v))\n :let [coll-type (c/extract-collection-of coll-const)\n contents-type (c/extract-contents-constraint coll-type)]\n _ (append-constraint (.c-var v) contents-type file-name line-number)\n _ (append-constraint result\n (c/intersect (c/CollectionOf coll-type empty-list nothing \"\")\n maybe-constraint)\n file-name line-number)]\n '_))\n (for [_ (conj-like target)\n coll (first args)\n v (second args)]\n (constrain-collection (.c-var coll) (.c-var v) result file-name line-number)))\n sm-nop)))\n\n(defn inner-constraint-for-reduce [result-var ast args]\n (and (= (.call-target ast) 'reduce)\n (= 3 (count args))\n (let [[v initial-val f] (take args 3)\n file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [arity-info (or (get-in f [.arities 2])\n (get-in f [.arities 'variadic]))]\n (let [[init-const inner-const] (-> arity-info\n .param-constraints\n (c/extract-items-constraints 2))\n inner-const (either (= c/top-type inner-const)\n (c/InferredInner inner-const (list [file-name line-number])\n nothing (.c-var v)))\n result-c (.result-constraint arity-info)]\n (for [_ (constrain-var file-name line-number (.c-var v) inner-const)\n _ (constrain-var file-name line-number (.c-var initial-val) init-const)\n _ (constrain-var file-name line-number result-var result-c)]\n '_))))))\n\n(def ignore-result-type #{'split-with 'filter 'drop-while 'take-while})\n(def map-fns #{'map 'map-vals 'list-map 'maybe-map 'add-promise-action 'add-future-action})\n\n;; TODO: with DynamicConstraints, the need for this function is questionable\n(defn add-inner-constraint [result-var ast args]\n (or (inner-constraint-for-reduce result-var ast args)\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (and (or (map-fns (.call-target ast))\n (= (.call-target ast) 'flat-map)\n (ignore-result-type (.call-target ast)))\n (< 1 (count args))\n (let [[v f] (take args 2)]\n (for [arity-info (or (get-in f [.arities 1])\n (get-in f [.arities 'variadic]))]\n (let [[inner-const] (-> arity-info\n .param-constraints\n (c/extract-items-constraints 1))\n inner-const (either (= c/top-type inner-const)\n (c/InferredInner inner-const (list [file-name line-number])\n nothing (.c-var v)))\n result-c (.result-constraint arity-info)\n result-c (cond\n (map-fns (.call-target ast))\n (-> (c/InferredInner result-c\n empty-list nothing \"\")\n (c/update-path file-name line-number))\n\n (= (.call-target ast) 'flat-map)\n (c/update-path result-c\n file-name line-number)\n\n c/top-type)]\n (for [v-c (get-constraint (.c-var v))\n _ (constrain-var file-name line-number (.c-var v) inner-const)\n _ (constrain-var file-name line-number result-var result-c)]\n '_))))))))\n\n(defn constrain-args [arg-vars param-constraints file-name line-number]\n (assert (instance? (vector-of c/ValueConstraint) param-constraints))\n (for [checked-var (genlocal 'checked)\n checks (sm/traverse (zip-lists arg-vars param-constraints)\n (fn [[expr constraint]]\n (let [var (.c-var expr)]\n (for [curr-const (get-constraint var)\n _ (constrain-var file-name line-number var constraint)]\n (either (and (instance? c-param expr)\n (maybe \"\"))\n (-> constraint\n (c/update-var var)\n (runtime-check curr-const file-name line-number checked-var)))))))]\n (either (and (every checks empty?)\n (maybe []))\n [\"if(1){int \" checked-var \" = 1;\" line-sep\n checks line-sep\n \"if(!\" checked-var \"){abort();}}\" line-sep])))\n\n(defn call-proto-impl [target arg-vars ast]\n (assert (instance? c-protocol-fn target))\n\n (let [target-ast (.call-target ast)\n num-args (count arg-vars)\n file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (either (map (first arg-vars)\n (fn [expr]\n (for [disp-type (var-type-num (.c-var expr))\n ;; _ (cond (= file-name \"runtime-tests/apply-constructor.toc\")\n ;; (debug 'cpi file-name (ast/line-number (.call-target ast))\n ;; (.call-target ast) (first arg-vars)\n ;; (.c-var expr) disp-type)\n ;; sm-nop)\n :when-not (= disp-type c/UnknownType)\n result-sym (genlocal \"rslt\")\n impl-info (get-proto-impl (.proto-sym target) target-ast num-args disp-type)\n ;; _ (cond (= file-name \"runtime-tests/apply-constructor.toc\")\n ;; (for [arg-cs (sm/traverse arg-vars (fn [var]\n ;; (get-constraint (.c-var var))))\n ;; _ (debug 'cpi file-name (ast/line-number (.call-target ast))\n ;; (.call-target ast) disp-type \"\\n\\n\" 'target target \"\\n\\n\"\n ;; 'param-cs (.param-constraints impl-info) \"\\n\\n\"\n ;; 'impl-result (.result-constraint impl-info) \"\\n\\n\"\n ;; 'arg-vars arg-vars \"\\n\\n\"\n ;; 'arg-cs \"\\n\" (interpose arg-cs \"\\n\"))\n ;; reified-c (reify-constraint (.result-constraint impl-info) arg-vars\n ;; file-name line-number)\n ;; _ (debug'reified result-sym reified-c)\n ;; ]\n ;; '_)\n ;; sm-nop)\n _ (comp (sm/update-in-val [.constants .other 'type-known-sites] inc)\n (sm/assoc-in-val [.constants .other 'type-known-sites] 1))\n check-args (constrain-args arg-vars (-> impl-info\n .param-constraints\n (c/extract-items-constraints num-args))\n file-name line-number)\n\n ;; TODO: do I really need this? Can propogate-inner-constraint handle it?\n _ (cond (or (= (.call-target ast) 'seq)\n (= (.call-target ast) 'vec))\n (let [[arg-var] arg-vars\n coll-c (cond (= (.call-target ast) 'seq)\n list-constraint\n\n vect-constraint)]\n (for [arg-c (get-constraint (.c-var arg-var))\n :let [result-c (c/set-type arg-c coll-c)\n result-c (cond (= result-c c/top-type)\n (.result-constraint impl-info)\n\n result-c)]\n _ (constrain-var file-name line-number result-sym result-c)]\n '_))\n\n (= (.call-target ast) 'instance?)\n (for [reified (reify-constraint (.result-constraint impl-info)\n arg-vars file-name line-number)\n ;; TODO: when reified is bottom-type, you could optimize the\n ;; generated code to eliminate this call to instance?.\n _ (cond (= reified c/bottom-type)\n (constrain-var file-name line-number result-sym\n (c/update-path maybe-constraint file-name line-number))\n (constrain-var file-name line-number result-sym reified))]\n '_)\n\n (flat-map (reify-constraint (.result-constraint impl-info) arg-vars\n file-name line-number)\n (partial constrain-var file-name line-number result-sym)))\n _ (sm/traverse (zip-lists (map arg-vars .c-var)\n (c/extract-items-constraints (.param-constraints impl-info)))\n (fn [[var constraint]]\n (constrain-var file-name line-number var constraint)))\n line (line-macro target-ast (str \"// call proto fn \" target-ast))\n _ (either (add-inner-constraint result-sym ast arg-vars)\n sm-nop)\n _ (add-contents-constraint ast result-sym arg-vars)\n _ (add-hash-map-constraints ast result-sym arg-vars)]\n (c-init result-sym\n [line\n check-args \"\\n// call proto function \" target-ast \"\\n\"\n \"Value *\" result-sym \" = \" (.c-fn impl-info) \"(\"\n (interpose (list* \"(FnArity *)0\" (map arg-vars .c-var)) \", \")\n \");\" line-sep]\n {} file-name line-number))))\n sm/zero-sm)))\n\n(defn inline-get-field [name args]\n (for [reified-val (nth args 0)\n field-index (nth args 1)]\n (for [;; _ (debug 'inlining (ast/file-name name) (ast/line-number name) \"\\n\" (ast/call-ast name args))\n dispatch-val (emit reified-val)\n disp-c (get-constraint (.c-var dispatch-val))\n rslt (genlocal \"rslt\")]\n ;; TODO: there could be multiple dyn fields because of a SumConstraint\n (either (flat-map (get (c/extract-dynamic-fields disp-c) field-index)\n (fn [field-var]\n (or (and (instance? c-static-fn field-var)\n ;; TODO: for some reason, static fn's don't work\n ;; (maybe (-> field-var\n ;; clear-init\n ;; (.init [\"\\n// look here static \" (str reified-val \" \" field-index \"\\n\")\n ;; \"Value *\" rslt \" = ((ReifiedVal *)\" (.c-var dispatch-val)\n ;; \")->impls[\" (str field-index) \"];\\n\"\n ;; \"incRef((Value *)\" rslt \", 1);\"\n ;; \"dec_and_free((Value *)\" (.c-var dispatch-val) \", 1);\"\n ;; line-sep])\n ;; (.c-var rslt)\n ;; (.refs-map {(.c-var dispatch-val) 1})))\n nothing\n )\n (and (instance? c-closure-fn field-var)\n (maybe (-> field-var\n clear-init\n (.init [\"\\n// look here closure \" (str reified-val \" \" field-index \"\\n\")\n \"Value *\" rslt \" = ((ReifiedVal *)\" (.c-var dispatch-val)\n \")->impls[\" (str field-index) \"];\\n\"\n \"incRef((Value *)\" rslt \", 1);\"\n \"dec_and_free((Value *)\" (.c-var dispatch-val) \", 1);\"\n line-sep])\n (.c-var rslt)\n (.refs-map {(.c-var dispatch-val) 1})))))))\n (c-field rslt [\"Value *\" rslt \" = ((ReifiedVal *)\" (.c-var dispatch-val)\n \")->impls[\" (str field-index) \"];\\n\"]\n {} c/top-type (.c-var dispatch-val))))))\n\n(defn inline-wrap-and-apply [name args]\n (for [dispatch-ast (first args)\n wrapped (second args)]\n (for [dispatch-val (emit dispatch-ast)\n dispatch-type (var-type-num (.c-var dispatch-val))\n :when-not (= c/UnknownType dispatch-type)\n ;; _ (debug 'inlining (ast/file-name name) (ast/line-number name) \"\\n\" (ast/call-ast name args))\n impl-ast (map (get-proto-impl (ast/tag 'Container) name (count args) dispatch-type)\n .ast)\n :when-not (some (.body impl-ast) (partial instance? ast/inline-ast))\n new-ast (-> impl-ast\n replace-bound-vars\n (inline-expr (list dispatch-val wrapped)))]\n new-ast)))\n\n(defn inline-flat-map [name args]\n (for [dispatch-ast (first args)\n f-ast (second args)]\n (for [\n ;; _ (cond (= (ast/file-name name) \"test.toc\")\n ;; (debug 'inlining (ast/file-name name) (ast/line-number name) \"\\n\" (ast/call-ast name args))\n ;; sm-nop)\n dispatch-val (emit dispatch-ast)\n dispatch-type (var-type-num (.c-var dispatch-val))\n ;; TODO: if this test fails, we have to emit the dispatch-ast twice\n :when-not (= c/UnknownType dispatch-type)\n impl-ast (map (get-proto-impl (ast/tag 'Container) name 2 dispatch-type)\n .ast)\n :when-not (some (.body impl-ast) (partial instance? ast/inline-ast))]\n (let [impl-ast (replace-bound-vars impl-ast)\n [dispatch-sym f-sym] (.fixed (.params impl-ast))\n result-constraint (-> (.body impl-ast)\n (filter (partial instance? c/ResultConstraint))\n (map .assertion)\n (reduce c/top-type c/intersect))\n inlined-expr (ast/let-ast [(ast/binding dispatch-sym dispatch-val)]\n (-> (.body impl-ast)\n (remove (partial instance? c/ResultConstraint))\n (replace-syms {f-sym f-ast})))]\n (cond (= c/top-type result-constraint)\n inlined-expr\n\n (ConstrainedAST inlined-expr result-constraint))))))\n\n(defn inline-zero [name args]\n (for [dispatch-ast (first args)]\n (for [;; _ (debug 'inlining (ast/file-name name) (ast/line-number name) \"\\n\" (ast/call-ast name args))\n dispatch-val (emit dispatch-ast)\n dispatch-type (var-type-num (.c-var dispatch-val))\n :when-not (= c/UnknownType dispatch-type)\n result-var (genlocal \"zeroVal\")]\n (c-code result-var [\"Value *\" result-var \" = zero((FnArity *)0, &(Value){\" (str dispatch-type)\n \", refsStatic, (Value *)0});\" line-sep] {} c/top-type))))\n\n(defn inline-first [name [arg]]\n (for [_ (instance? ast/call-ast arg)\n :let [target (.call-target arg)]\n :when (or (= target 'list)\n (= target 'vector))\n head (first (.args arg))]\n (let [head-sym (ast/tag \"#head\" (ast/file-name arg) (ast/line-number arg))]\n (sm/state-maybe (ast/let-ast [(ast/binding head-sym head)]\n (conj (rest (.args arg))\n (ast/call-ast (ast/tag 'maybe) [head-sym])))))))\n\n(defn inline-rest [name [arg]]\n (for [_ (instance? ast/call-ast arg)\n :let [target (.call-target arg)]\n :when (or (= target 'list)\n (= target 'vector))\n head (first (.args arg))]\n ;TODO: what about any ItemsConstraints or MinCount (when it arrives)\n (map (emit head)\n (fn [head]\n (cond (empty? (.init head))\n (.args arg (rest (.args arg)))\n (ast/let-ast [] [head (.args arg (rest (.args arg)))]))))))\n\n(defn make-bindings [params args]\n (-> (zip-lists (seq params) (seq args))\n (map (fn [[param val]]\n (ast/binding-ast param val)))\n (vec)))\n\n(defn inline-partial [name [call-target & args]]\n ;; TODO: some test exprs for this\n ;; (partial subs 8)\n ;; (partial subs \"bogus\" 'sym 8)\n ;; (partial subs \"bogus\" 8 9 10)\n\n (let [file (ast/file-name call-target)\n line (ast/line-number call-target)\n more-args (ast/tag \"#more-args\" file line)\n fn-sym (ast/tag (str \"partial_\" (either (instance? Tagged call-target)\n 'anon)))]\n (-> (ast/fn-ast nothing\n [(ast/fn-arity-ast fn-sym \"\"\n (ast/params [] (maybe more-args)) \"\"\n [(ast/call-ast (ast/tag 'apply file line)\n [call-target (ast/call-ast (ast/tag 'list* file line)\n (comp (vec args) [more-args]))])]\n (-> c/empty-items-constraint\n (.tail-constraint (c/CollectionOf c/top-type empty-list\n ;; TODO: another abomination\n (=* 'nill 1)\n \"\")))\n c/top-type)])\n sm/state-maybe\n maybe)))\n\n(defn inline-comp* [name [arg args]]\n (let [file (ast/file-name args)\n line (ast/line-number args)]\n (maybe (for [expr (emit arg)\n dispatch-type (var-type-num (.c-var expr))\n :when-not (= c/UnknownType dispatch-type)\n impl-ast (map (get-proto-impl (ast/tag 'Composition) 'comp* 2 dispatch-type) .ast)\n :when-not (some (.body impl-ast) (partial instance? ast/inline-ast))\n args (either (flat-map (instance? ast/call-ast args)\n (fn [ast]\n (let [target (.call-target ast)]\n (and (= target 'rest)\n (maybe (inline-expr target (.args ast)))))))\n (sm/state-maybe args))\n :when (and (instance? ast/call-ast args)\n (let [target (.call-target args)]\n (or (= target 'list)\n (= target 'vector))))\n arg-exprs (sm/traverse (.args args) emit)\n :let [impl-ast (replace-bound-vars impl-ast)\n disp-binding (ast/binding-ast (ast/tag \"dispArg\" file line) expr)\n args-bindings (-> (range (count arg-exprs))\n (map (fn [n]\n (ast/tag (str \"arg\" n) file line)))\n (make-bindings arg-exprs))\n args-ast (.args args (map args-bindings .binding))\n [dispatch-sym args-sym] (.fixed (.params impl-ast))]]\n (let [result-constraint (-> (.body impl-ast)\n (filter (partial instance? c/ResultConstraint))\n (map .assertion)\n (reduce c/top-type c/intersect))\n inlined-expr (ast/let-ast (comp [disp-binding]\n args-bindings)\n (-> (.body impl-ast)\n (remove (partial instance? c/ResultConstraint))\n (replace-syms {dispatch-sym (.binding disp-binding)\n args-sym args-ast})))]\n (cond (= c/top-type result-constraint)\n inlined-expr\n\n (ConstrainedAST inlined-expr result-constraint)))))))\n\n(defn inline-comp [name args]\n (let [file (ast/file-name args)\n line (ast/line-number args)]\n (maybe (for [exprs (sm/traverse args emit)]\n (let [[binding & bindings] (make-bindings (map (range (count args))\n (fn [n]\n (ast/tag (str \"arg\" n) file line)))\n exprs)]\n (ast/let-ast\n (comp [binding] bindings)\n [(ast/call-ast (ast/tag 'comp* file line)\n [(.binding binding)\n (ast/call-ast (ast/tag 'list file line)\n (vec (map bindings .binding)))])]))))))\n\n(def get-field-sym (ast/tag 'get-field 'core 0))\n\n(def inlined-fns\n {'wrap {2 inline-wrap-and-apply}\n 'apply {2 inline-wrap-and-apply}\n 'flat-map {2 inline-flat-map}\n 'zero {1 inline-zero}\n 'map {2 inline-flat-map}\n '= {2 (fn [name args]\n (-> '=*\n (ast/tag (ast/file-name args) (ast/line-number args))\n (ast/call-ast args)\n sm/state-maybe\n maybe))}\n get-field-sym (maybe inline-get-field)\n 'partial (maybe inline-partial)\n 'first {1 inline-first}\n 'rest {1 inline-rest}\n 'comp* {2 inline-comp*}\n 'comp (maybe inline-comp)})\n\n(extend-type Tagged\n Emitter\n (get-param-cs [sym]\n (for [expr (lookup-sym (ast/tag sym))\n c (get-constraint (.c-var expr))]\n (let [c (cond (instance? c/DynamicConstraint c)\n c/top-type\n\n c)]\n (-> c\n (c/update-var (.c-var expr))\n (c/update-sym (ast/untag sym))))))\n\n (pre-bind [x]\n (sm/state-maybe x))\n\n (bind-param-expr [binding]\n (for [r (bind binding)\n :let [bound-var (.bound r)\n param-info (c-param bound-var [] {bound-var 1} c/top-type\n (ast/file-name binding) (ast/line-number binding))]\n _ (sm/assoc-in-val [.fn-context .fn-spec .param-vars bound-var]\n param-info)\n _ (set-sym binding param-info)]\n r))\n\n (bind-expr [binding]\n (let [file-name (ast/file-name binding)\n line-number (ast/line-number binding)]\n (for [arg-var (genlocal binding \"arg\")\n :let [evalled (c-code arg-var [] {arg-var 1} c/top-type)]\n _ (comp (redef-proto-fn-error binding)\n (set-sym binding evalled))]\n (ParamBinding arg-var [] \"\" [evalled]))))\n\n (bind-expr [binding evalled]\n (let [file-name (ast/file-name binding)\n line-number (ast/line-number binding)]\n (for [_ (comp (redef-proto-fn-error binding)\n (for [_ (sm/when (instance? c-field evalled))\n expr (sm/get-in-val [.fn-context .syms (ast/tag binding)])\n :when (instance? c-param expr)\n _ (compilation-error \"The parameter\" (str \"'\" binding \"'\")\n \"shadows a field of the same name at\"\n (.file-name expr)\n (.line-number expr))]\n '_)\n (set-sym binding (clear-init evalled)))]\n (either (and (empty? (.init evalled))\n (maybe (ParamBinding (.c-var evalled) [] \"\" [evalled])))\n (ParamBinding (.c-var evalled)\n [] \"\"\n [(either (instance? c-field evalled)\n (c-init (.c-var evalled) (.init evalled)\n (.refs-map evalled) file-name line-number))])))))\n\n (emit [sym]\n (let [sym (ast/tag sym)]\n (for [expr (lookup-sym sym)\n c (get-constraint (.c-var expr))\n _ (set-constraint (.c-var expr)\n (c/update-path c (ast/file-name sym) (ast/line-number sym)))]\n expr)))\n\n (emit-defined-value [sym defined-sym]\n (for [value (emit (ast/tag sym))\n _ (new-module-def defined-sym value)]\n [value]))\n\n (wrap-tail [ast params]\n (Left (TailCall ast params)))\n\n (inline-expr [name arg-asts]\n ;; TODO: inline 'get-in', 'update-in', getters/setters\n (let [args (remove arg-asts (partial instance? ast/NoCode))\n num-args (count args)]\n (either (flat-map (get-in inlined-fns [name num-args])\n (fn [f]\n (f name args)))\n sm/zero-sm))))\n\n(extend-type Symbol\n Container\n (map [x f]\n x)\n\n (map [x f embed]\n (embed x))\n\n Emitter\n (cache-static-constant [s expr]\n (send constants (fn [constants]\n (assoc-in constants [.symbols s]\n (.init expr [\"Value *\" (.c-var expr) \";\" line-sep])))))\n\n (dissoc-sym [x]\n (for [_ (sm/update-state (fn [[subs & subs-list]]\n (cons (dissoc subs (ast/tag x))\n subs-list)))]\n (Left x)))\n\n (new-bound-var [x]\n (let [new-var (ast/tag (gensym (str x)))]\n (for [_ (sm/update-state (fn [[subs & subs-list]]\n (cons (assoc subs x new-var)\n subs-list)))]\n (Left new-var))))\n\n (update-syms [x _]\n (map (comp (sm/get-in-val [0 (ast/tag x)])\n (sm/state-maybe (ast/tag x)))\n Left))\n\n (encode-static [sym]\n (emit (ast/quoted-ast sym))))\n\n\n(extend-type ast/definition-ast\n Emitter\n (emit-definition [ast]\n (let [defined-sym (.sym ast)]\n (map (sm/traverse (.value-exprs ast) (fn [ast]\n (emit-defined-value ast defined-sym)))\n flatten))))\n\n(extend-type ast/declaration-ast\n Emitter\n (emit-definition [ast]\n (let [sym (.sym ast)]\n (comp (map (lookup-declaration sym) (fn [_] []))\n (for [c-var (global-var sym \"var\")\n _ (sm/assoc-in-val [.module .declarations sym]\n (maybe (c-code c-var [] {} c/top-type)))\n\n _ (declare [\"Value *\" c-var \";\\n\"])]\n [empty-c-code])))))\n\n(extend-type StaticFnPtr\n Emitter\n (call-site-meta-data [v f l]\n (wrap sm/zero-sm (c-code \"(FnArity *)0\" [] {} c/top-type)))\n\n (update-call-site-count [_]\n (comp (sm/update-in-val [.constants .other 'static-fixed-sites] inc)\n (sm/assoc-in-val [.constants .other 'static-fixed-sites] 1))))\n\n(extend-type ProtoDispFnPtr\n Emitter\n (call-site-meta-data [_ file-name line-number]\n (let [str-val (str \"at \" file-name \": \" line-number)]\n (map (make-static-string str-val)\n (fn [expr]\n (.c-var expr (str \"(FnArity *)\" (.c-var expr)))))))\n\n (update-call-site-count [_]\n (comp (sm/update-in-val [.constants .other 'proto-dispatch-sites] inc)\n (sm/assoc-in-val [.constants .other 'proto-dispatch-sites] 1))))\n\n(defprotocol ArityType\n (reify-arity [_ dispatch-type-num arity-ast fn-name proto-sym]\n (assert-result x (instance? sm/new-sm x))))\n\n(deftype StaticArity [arity-fn-var c-fn params param-count var-info param-constraints result-constraint]\n (assert (instance? CFnPtr c-fn))\n (assert (instance? ast/params-ast params))\n (assert (instance? C-expr var-info))\n (assert (instance? c/ItemsConstraint param-constraints))\n\n Stringable\n (string-list [_]\n (list \"(StaticArity \" (str arity-fn-var) \" \" (str param-count) \" \"\n (str var-info) \" \" (str param-constraints)\n \" \" (str result-constraint) \")\"))\n\n ArityType\n (reify-arity [_ dispatch-type-num arity-ast fn-name proto-sym]\n (for [_ (sm/update-in-val [.reify-fn-index] inc)\n _ (new-proto-impl proto-sym fn-name param-count dispatch-type-num (.c-var var-info) arity-ast\n param-constraints result-constraint c-fn)]\n var-info)))\n\n;; TODO: arity-fn-var appears to not be used\n(deftype ClosureArity [arity-fn-var params param-count var-info param-constraints result-constraint]\n (assert (instance? CFnPtr arity-fn-var))\n (assert (instance? ast/params-ast params))\n (assert (instance? C-expr var-info))\n (assert (instance? c/ItemsConstraint param-constraints))\n\n Stringable\n (string-list [_]\n (comp (list \"(ClosureArity \" (str arity-fn-var) \" \" (str params) \" \")\n (string-list var-info) \")\"))\n\n ArityType\n (reify-arity [_ dispatch-type-num arity-ast fn-name proto-sym]\n (let [param-count (count params)\n fn-arity-sym (gensym \"protoFnArity\")\n impl-fn-sym (gensym \"protoImpl\")]\n (for [reify-fn-index (sm/get-val .reify-fn-index)\n [dispArg & args] (sm/traverse (.fixed params) (fn [arg] (genlocal arg \"arg\")))\n :let [arg-decls (to-str (interpose (conj (map (cons dispArg args)\n (partial str \"Value *\"))\n (str \"FnArity *arity\"))\n \", \"))\n args (to-str (interpose (comp [dispArg] args) \", \"))]\n _ (new-proto-impl proto-sym fn-name param-count dispatch-type-num\n (ArityValPtr (str \"&\" fn-arity-sym) fn-arity-sym) arity-ast\n param-constraints result-constraint\n (StaticFnPtr (str impl-fn-sym)))\n _ (sm/update-in-val [.reify-fn-index] inc)\n _ (declare [\"// implementation of \" fn-name \"\\n\"\n \"Value *\" impl-fn-sym \"(\" arg-decls \") {\" line-sep\n \"FnArity *arityPtr = (FnArity *)((ReifiedVal *)\" dispArg\n \")->impls[\" reify-fn-index \"];\" line-sep\n \"incRef(\" dispArg \", 1);\" line-sep\n \"if (arityPtr->count != \" param-count \") {\\n\"\n \"fprintf(stderr, \\\"Compiler error: arity count != parameter count\\\\n\\\");\\nabort();\\n}\\n\"\n \"Value *rval = ((FnType\" param-count\n \" *)arityPtr->fn)(arityPtr,\" args \");\" line-sep\n \"dec_and_free(\" dispArg \", 1);\" line-sep\n ;; TODO: verify that we don't need to free the parent fn here\n \"return(rval);\" line-sep\n \"};\\n\\n\"\n \"FnArity \" fn-arity-sym \" = {FnArityType, -2, \" param-count\n \", (Vector *)0, (Value *)0, 0, \" impl-fn-sym \", (Value *)0, (Value *)0};\" line-sep])]\n var-info))))\n\n;; TODO: needs new name, get-arity-fn-ptr?\n(defn get-proto-dispatch-sym [fn-sym num-args]\n (flat-map (lookup-sym fn-sym)\n (fn [expr]\n (sm/when (get-in expr [.arities num-args .c-fn])))))\n\n;; optimize calls to static, fixed arity, functions\n(defn call-static-fixed [target arity-info arg-vars ast]\n (assert (instance? StaticArity arity-info))\n\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)\n [param-cs result-c] (either (for [_ (= (.call-target ast) 'fn-apply)\n applied-fn (first arg-vars)\n arities (get applied-fn .arities)]\n ;; TODO: catch problems at compile time\n (let [param-constraints (-> arities\n vec\n (map (fn [[_ v]]\n (-> v\n .param-constraints\n c/extract-items-constraints)))\n ((partial apply zip-lists))\n vec\n (map (fn [cs]\n (c/sum-type (vec cs)))))\n result-constraint (-> arities\n vec\n (map (fn [[_ v]]\n (.result-constraint v)))\n c/sum-type)]\n [(-> (c/ItemsConstraint [fn-constraint\n (c/ItemsConstraint param-constraints\n c/coll-of-any\n empty-list\n nothing \"\")]\n c/coll-of-any\n empty-list\n nothing \"\")\n (c/update-path file-name line-number))\n (c/update-path result-constraint file-name line-number)]))\n [(.param-constraints arity-info)\n (.result-constraint arity-info)])]\n (for [result-sym (genlocal \"rslt\")\n arg-cs (sm/traverse (map arg-vars .c-var) get-constraint)\n :let [r-c result-c]\n ;; TODO: need to get access to the args of (second arg-vars)\n ;; result-c (either (for [_ (= (.call-target ast) 'fn-apply)\n ;; coll-c (second arg-cs)]\n ;; (reify-constraint result-c\n ;; (c/extract-items-constraints coll-c 10)\n ;; file-name line-number))\n\n ;; (reify-constraint result-c arg-vars file-name line-number))\n result-c (reify-constraint result-c arg-vars file-name line-number)\n ;; _ (comp (for [_ (sm/when (= file-name \"runtime-tests/nested-destruct-1.toc\"))\n ;; _ (debug 'csf file-name line-number (.call-target ast) (.c-var target) \"\\n\\n\"\n ;; 'param-cs param-cs \"\\n\\n\" 'result result-sym r-c)\n ;; _ (debug 'arg-cs arg-cs)\n ;; _ (debug 'reified result-c)\n ;; _ (sm/traverse (zip-lists arg-vars arg-cs)\n ;; (fn [[v c]]\n ;; (debug 'v (.c-var v) 'c c)))]\n ;; '_)\n ;; sm-nop)\n check-args (constrain-args arg-vars (c/extract-items-constraints param-cs (count arg-vars))\n file-name line-number)\n _ (constrain-var file-name line-number result-sym result-c)\n\n _ (update-call-site-count (.c-fn arity-info))\n line (line-macro ast \"// static-fixed\")\n call-site-location (call-site-meta-data (.c-fn arity-info) file-name line-number)]\n (c-init result-sym\n [check-args\n line \"Value *\" result-sym \" = \" (.c-fn arity-info) \"(\"\n (interpose (cons (.c-var call-site-location)\n (seq (map arg-vars .c-var)))\n \", \")\n \");\" line-sep]\n {} file-name line-number))))\n\n(defn call-static-variadic [target arity-info arg-vars ast]\n (assert (instance? StaticArity arity-info))\n\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [_ (comp (sm/update-in-val [.constants .other 'static-variadic-sites] inc)\n (sm/assoc-in-val [.constants .other 'static-variadic-sites] 1))\n args-list (call-list (ast/tag 'list file-name line-number)\n (map arg-vars (fn [arg]\n (.init arg []))))\n result-sym (genlocal \"rslt\")\n ;; _ (cond (= (str file-name) \"assertion-tests/bad-add.toc\")\n ;; (debug 'csv file-name line-number (.call-target ast) (.c-var target) \"\\n\"\n ;; (.param-constraints arity-info) \"\\n\"\n ;; result-sym (.result-constraint arity-info))\n ;; sm-nop)\n check-args (constrain-args arg-vars (-> arity-info\n .param-constraints\n (c/extract-items-constraints (count arg-vars)))\n file-name line-number)\n _ (constrain-var file-name line-number (.c-var args-list) (.param-constraints arity-info))\n\n arg-cs (sm/traverse arg-vars (fn [var]\n (get-constraint (.c-var var))))\n _ (flat-map (reify-constraint (.result-constraint arity-info) arg-vars file-name line-number)\n (partial constrain-var file-name line-number result-sym))\n _ (cond (= (.call-target ast) 'list*)\n (for [arg-cs (map (get-constraint (.c-var args-list))\n c/extract-items-constraints)\n tail-c (sm/when (last arg-cs))\n _ (constrain-var file-name line-number result-sym\n (-> (c/ItemsConstraint (butlast arg-cs)\n (c/intersect tail-c list-constraint)\n empty-list nothing \"\")\n (c/intersect list-constraint)\n (c/update-var result-sym)\n (c/update-path file-name line-number)))]\n '_)\n\n sm-nop)\n\n line (line-macro ast \"// static-variadic\")]\n (c-init result-sym\n [(.init args-list)\n check-args\n line\n \"Value *\" result-sym \" = \" (.c-fn arity-info) \"((FnArity *)0, (Value *)\"\n (.c-var args-list) \");\" line-sep]\n {} (ast/file-name ast) (ast/line-number ast)))))\n\n(defn call-dyn-fn-value [target args ast]\n ;; TODO: eventually, we maight be able to establish some constraints for 'target'\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [arity-sym (genlocal \"arity\")\n type-num (var-type-num (.c-var target))\n :when (= c/FunctionType type-num)\n result-sym (genlocal \"rslt\")\n dyn-result-c (get-constraint (.c-var target))\n _ (set-constraint result-sym (-> (c/DynamicResultConstraint dyn-result-c (count args)\n empty-list nothing result-sym)\n (c/update-path file-name line-number)))\n ;; _ (cond (= file-name \"test.toc\")\n ;; (for [result-c (get-constraint result-sym)\n ;; _ (debug 'cdf file-name line-number (.call-target ast) (.c-var target) \"\\n\\n\"\n ;; 'target target \"\\n\\n\" 'result-c result-c)]\n ;; '_)\n ;; sm-nop)\n _ (comp (sm/update-in-val [.constants .other 'dyn-fn-sites] inc)\n (sm/assoc-in-val [.constants .other 'dyn-fn-sites] 1))\n variadic-sym (genlocal \"dynArgs\")\n fn-var (genlocal \"fn\")\n line (line-macro ast \"// dynamic fn type\")]\n (let [args (map args .c-var)\n arg-syms (comp [(str arity-sym)] args)\n num-args (count args)]\n (c-init result-sym\n [\"Value *\" result-sym \";\" line-sep\n \"FnArity *\" arity-sym \" = findFnArity(\" (.c-var target)\n \", \" num-args \");\" line-sep\n \"if(\" arity-sym \" != (FnArity *)0 && !\" arity-sym \"->variadic) { \"\n \"FnType\" num-args \" *\" fn-var \" = (FnType\" num-args \" *)\"\n arity-sym \"->fn;\" line-sep\n \"\\n\" line\n result-sym \" = \" fn-var \"(\" (to-str (interpose arg-syms \", \")) \");\" line-sep\n \"} else if(\" arity-sym \" != (FnArity *)0 && \" arity-sym \"->variadic) { \"\n \"FnType1 *\" fn-var \" = (FnType1 *)\" arity-sym \"->fn;\" line-sep\n \"List *\" variadic-sym \" = empty_list;\" line-sep\n (map (reverse (rest arg-syms))\n (fn [arg-sym]\n (str variadic-sym \" = (List *)listCons(\"\n arg-sym \", \" variadic-sym \");\" line-sep)))\n line result-sym \" = \" fn-var \"(\" (str arity-sym) \", (Value *)\"\n variadic-sym \");\" line-sep\n \"} else {\" line-sep \"fprintf(stderr, \\\"\\\\n*** no arity found for '%s' at: %s, %d.\\\\n\\\", \"\n \"((Function *)\" (.c-var target) \")->name, \\\"\" (ast/file-name ast)\n \"\\\", \" (ast/line-number ast) \");\\n abort();\\n}\\n\"\n \"dec_and_free(\"(.c-var target) \", 1);\" line-sep]\n {} (ast/file-name ast) (ast/line-number ast))))))\n\n(defn call-dyn-unknown-type [target args ast]\n ;; TODO: eventually, we maight be able to establish some constraints for 'target'\n (let [num-args (count args)\n num-invoke-args (inc num-args)\n file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [arity-sym (genlocal \"arity\")\n variadic-sym (genlocal \"dynArgs\")\n fn-sym (genlocal \"fn\")\n result-sym (genlocal \"rslt\")\n\n dyn-result-c (get-constraint (.c-var target))\n ;; _ (cond (= file-name \"test.toc\")\n ;; (debug 'cdu file-name line-number (.call-target ast) (.c-var target) \"\\n\\n\"\n ;; 'target target \"\\n\\n\" 'dyn-result-c dyn-result-c)\n ;; sm-nop)\n ;; _ (set-constraint result-sym (-> (c/DynamicResultConstraint dyn-result-c (count args)\n ;; empty-list nothing result-sym)\n ;; (c/update-path file-name line-number)))\n\n invoke-arity-sym (get-proto-dispatch-sym invoke-sym num-invoke-args)\n _ (comp (sm/update-in-val [.constants .other 'dyn-unknown-sites] inc)\n (sm/assoc-in-val [.constants .other 'dyn-unknown-sites] 1))\n line (line-macro ast \"// dynamic unknown type\")\n sym-location (emit (either (= \"\\\"\\\"\" file-name)\n (str \"\\\"at \" file-name \": \" line-number \"\\\"\")))]\n (let [args (map args .c-var)\n arg-syms (comp [(str arity-sym)] args)]\n (c-init result-sym\n [line \"Value *\" result-sym \";\" line-sep\n \"if((\" (.c-var target) \")->type != FunctionType) {\" line-sep\n result-sym \" = \" invoke-arity-sym \"(\"\n (interpose (list* (str \"(FnArity *)\" (.c-var sym-location))\n (.c-var target) args) \", \") \");\"\n line-sep \"} else {\" line-sep\n\n \"FnArity *\" arity-sym \" = findFnArity(\" (.c-var target) \", \" num-args \");\" line-sep\n \"if(\" arity-sym \" != (FnArity *)0 && !\" arity-sym \"->variadic) {\" line-sep\n \"FnType\" num-args \" *\" fn-sym \" = (FnType\" num-args \" *)\" arity-sym \"->fn;\"\n line-sep\n result-sym \" = \" fn-sym \"(\" (to-str (interpose arg-syms \", \")) \");\" line-sep\n \"} else if(\" arity-sym \" != (FnArity *)0 && \" arity-sym \"->variadic) {\" line-sep\n \"FnType1 *\" fn-sym \" = (FnType1 *)\" arity-sym \"->fn;\" line-sep\n \"List *\" variadic-sym \" = empty_list;\" line-sep\n (map (reverse (rest arg-syms))\n (fn [arg-sym]\n (str variadic-sym \" = (List *)listCons(\"\n arg-sym \", \" variadic-sym \");\" line-sep)))\n result-sym \" = \" fn-sym \"(\" (str arity-sym) \", (Value *)\"\n variadic-sym \");\" line-sep\n \"} else {\" line-sep \"fprintf(stderr, \\\"\\\\n*** no arity found for '%s'.\\\\n\\\", \"\n \"((Function *)\" (.c-var target) \")->name\"\n \");\" line-sep \" abort();\" line-sep \"}\" line-sep\n \"dec_and_free(\"(.c-var target) \", 1);\" line-sep \"}\" line-sep]\n {} file-name line-number)))))\n\n(defn call-invoke [target arg-vars ast]\n (let [arg-vars (comp [target] arg-vars)\n num-args (count arg-vars)\n file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [target-type (var-type-num (.c-var target))\n :when-not (= c/UnknownType target-type)\n _ (comp (sm/update-in-val [.constants .other 'invoke-sites] inc)\n (sm/assoc-in-val [.constants .other 'invoke-sites] 1))\n invoke-info (get-core-proto-impl Function-sym invoke-sym num-args target-type)\n result-sym (genlocal \"rslt\")\n ;; _ (cond (= file-name \"test.toc\")\n ;; (for [_ (debug 'ci file-name line-number (.call-target ast) num-args\n ;; 'target-type target-type \"\\n\\n\"\n ;; ;; (.param-constraints invoke-info) \"\\n\\n\"\n ;; 'result result-sym (.result-constraint invoke-info)\n ;; )\n ;; _ (apply debug (list* 'arg-vars \"\\n\" (interpose arg-vars \"\\n\")))\n ;; ;; _ (debug 'target-c target-c)\n ;; ;; _ (debug 'fn-c fn-c)\n ;; ;; _ (debug 'fn-var fn-var)\n ;; ;; _ (debug 'fn-result-c fn-result-c)\n ;; ;; _ (debug 'arg-vars arg-vars)\n ;; ;; _ (debug 'param-consts (.param-constraints invoke-info))\n ;; ]\n ;; '_)\n ;; sm-nop)\n\n target-c (get-constraint (.c-var target))\n result-c (reify-constraint (.result-constraint invoke-info)\n arg-vars file-name line-number)\n check-args (constrain-args arg-vars (-> invoke-info\n .param-constraints\n (c/extract-items-constraints num-args))\n file-name line-number)\n ;; _ (cond (= file-name \"test.toc\")\n ;; (debug 'reified result-sym result-c)\n ;; sm-nop)\n _ (constrain-var file-name line-number result-sym result-c)\n ;; _ (cond (= file-name \"test.toc\")\n ;; (flat-map (get-constraint result-sym)\n ;; (partial debug 'set-c))\n ;; sm-nop)\n\n _ (sm/traverse (zip-lists (map arg-vars .c-var)\n (c/extract-items-constraints (.param-constraints invoke-info)))\n (fn [[var constraint]]\n (constrain-var file-name line-number var constraint)))\n\n line (line-macro ast \"// call invoke\")]\n (c-init result-sym\n [line check-args \"\\n// call invoke function\\n\"\n \"Value *\" result-sym \" = \" (.c-fn invoke-info) \"(\"\n (interpose (list* \"(FnArity *)0\" (map arg-vars .c-var)) \", \")\n \");\" line-sep]\n {} file-name line-number))))\n\n(defprotocol CallSite\n (emit-call-site [target args ast]\n (comp (call-invoke target args ast)\n (call-dyn-fn-value target args ast)\n (call-dyn-unknown-type target args ast))))\n\n(extend-type c-static-reified\n CallSite\n (emit-call-site [target args ast]\n (comp (call-invoke target args ast)\n (compilation-error \"No implementation of 'Function/invoke' with\"\n (count args) \"arguments\"\n (either (map (instance? Tagged (.call-target ast))\n (fn [sym]\n (str \"for '\" sym \"'\")))\n \"\")\n \"at:\" (ast/file-name ast) (ast/line-number ast)))))\n\n(extend-type c-constructor\n Emitter\n (clear-init [cc]\n (.init cc []))\n\n CallSite\n (emit-call-site [target args ast]\n (comp (call-invoke target args ast)\n (compilation-error \"No implementation of 'Function/invoke' with\"\n (count args) \"arguments\"\n (either (map (instance? Tagged (.call-target ast))\n (fn [sym]\n (str \"for '\" sym \"'\")))\n \"\")\n \"at:\" (ast/file-name ast) (ast/line-number ast)))))\n\n(defn static-call-site [target args ast]\n (comp (for [expr (either (or (map (get-in target [.arities (count args)])\n (fn [arity-info]\n (call-static-fixed target arity-info args ast)))\n (map (get-in target [.arities 'variadic])\n (fn [arity-info]\n (call-static-variadic target arity-info args ast))))\n sm/zero-sm)\n _ (either (add-inner-constraint (.c-var expr) ast args)\n sm-nop)\n _ (add-hash-map-constraints ast (.c-var expr) args)\n _ (add-contents-constraint ast (.c-var expr) args)]\n expr)\n (compilation-error \"No arity with\" (count args) \"arguments found\"\n (either (map (instance? Tagged (.call-target ast))\n (fn [sym]\n (str \"for '\" sym \"'\")))\n \"\")\n \"at:\" (ast/file-name ast) (ast/line-number ast))))\n\n(extend-type c-maybe-fn\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n CallSite\n (emit-call-site [target args ast]\n (either (map (and (= 1 (count args))\n (first args))\n (partial call-maybe ast))\n (compilation-error \"Call to 'maybe' in\" (ast/file-name ast) \"at line\" (ast/line-number ast)\n \"has the wrong number of arguments. Only a single argument is valid.\"))))\n\n(extend-type c-list-fn\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n CallSite\n (emit-call-site [target args ast]\n (call-list (.call-target ast) args)))\n\n(extend-type c-vector-fn\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n CallSite\n (emit-call-site [target args ast]\n (call-vector (.call-target ast) args)))\n\n;; TODO: test add-inner-constraint on state-maybe values\n;; TODO: add inner constraint to Strings\n;; TODO: insert InferredInner into anon fn passed to higher order fn\n\n(def returns-inner #{'seq 'vec 'rest 'butlast 'reverse 'vals 'last 'nth 'get 'first})\n\n(defn propogate-inner-constraint [result-var ast args]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n ;; TODO: do hash-seq, list-concat, comp-vect as well\n (or (for [_ (or (returns-inner (.call-target ast))\n (= (.call-target ast) 'extract))\n arg (first args)]\n (propogate-constraint (.c-var arg) result-var\n (fn [constraint]\n (let [inner-c (c/extract-coll-constraint constraint)]\n (either (and (= (.call-target ast) 'extract)\n (maybe (c/extract-contents-constraint inner-c)))\n inner-c)))\n file-name line-number))\n\n (for [_ (= (.call-target ast) 'comp-vect)\n arg (first args)\n rest-args (second args)]\n (for [rest-cs (get-constraint (.c-var rest-args))\n r (propogate-constraint (.c-var arg) result-var\n (fn [constraint]\n (-> rest-cs\n c/extract-items-constraints\n (conj constraint)\n (remove (fn [c]\n (-> c\n c/extract-items-constraints\n count\n (= 0))))\n (map c/extract-contents-constraint)\n c/sum-type\n (c/InferredInner empty-list nothing result-var)\n (c/intersect vect-constraint)))\n file-name line-number)]\n r))\n )))\n\n(extend-type c-static-fn\n CallSite\n (emit-call-site [target args ast]\n (for [expr (static-call-site target args ast)\n _ (either (propogate-inner-constraint (.c-var expr) ast args)\n sm-nop)]\n expr)))\n\n(extend-type c-protocol-fn\n Emitter\n (get-result-constraint [expr num-args]\n (sm/when (get-in expr [.arities num-args .result-constraint])))\n\n (clear-init [expr]\n (-> expr\n (.init [])\n (.refs-map {(.c-var expr) 1})))\n\n CallSite\n (emit-call-site [target args ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [expr (comp (call-proto-impl target args ast)\n (static-call-site target args ast))\n _ (either (propogate-inner-constraint (.c-var expr) ast args)\n sm-nop)]\n expr))))\n\n(extend-type c/SumConstraint\n Emitter\n (reify-c [ast param-exprs file-name line-number]\n (sm/state-maybe (either (some (.alts ast) (partial = c/bottom-type))\n (let [new-alts (reduce (.alts ast) []\n (fn [new-alts new-c]\n (cond\n (some new-alts (partial = new-c)) new-alts\n (conj new-alts new-c))))]\n (either (and (= 1 (count new-alts))\n (first new-alts))\n (.alts ast new-alts))))))\n\n (old-reify-c [ast param-exprs file-name line-number]\n (for [new-alts (sm/traverse (.alts ast)\n (fn [alt-c]\n (old-reify-c alt-c param-exprs file-name line-number)))]\n (either (some new-alts (partial = c/bottom-type))\n (let [new-alts (reduce new-alts []\n (fn [new-alts new-c]\n (cond\n (some new-alts (partial = new-c)) new-alts\n (conj new-alts new-c))))]\n (either (and (= 1 (count new-alts))\n (first new-alts))\n (.alts ast new-alts))))))\n\n (runtime-check [constraint value-info sym-location checked-var]\n (let [alts (.alts constraint)\n var (c/extract-var constraint)]\n\n (either (and (c/satisfied-by constraint value-info)\n (maybe []))\n [\"if (\" checked-var \"){\"\n \"int checkPassed = 0;\"\n (reduce alts []\n (fn [ss alt]\n (comp ss\n [\"if(!checkPassed){\" line-sep\n checked-var \" = 1;\" line-sep\n ;; TODO: what if runtime-check is empty?\n (runtime-check (c/update-var alt var)\n value-info checked-var)\n \"if(\" checked-var \"){checkPassed = 1;}\"])))\n (repeat (count alts) \"}\")\n \"if (!checkPassed){\"\n ;; \"\\n#ifndef EMBEDDED\\n\"\n \"fprintf(stderr, \\\"Invalid type of value for '\"\n (either (.sym constraint) \"\") \"' %s\\\\n\\\", \" sym-location \");\" line-sep\n ;; TODO: this error message needs to be more clearer\n \"fprintf(stderr, \\\"Got %s\\\\n\\\", extractStr(type_name((FnArity *)0, \" var \")));\"\n \"fprintf(stderr, \\\"Needed a value specified in\\\\n\"\n (interpose (c/format-path constraint (inc (count (.path constraint)))) \"\\\\n\")\n \"\\\\n\\\");\"\n ;; \"\\n#endif\\n\"\n \"abort();}}\" line-sep])))\n\n (runtime-check [constraint value-info checked-var]\n (let [alts (.alts constraint)\n var (c/extract-var constraint)]\n (either (and (c/satisfied-by constraint value-info)\n (maybe []))\n [\"if (\" checked-var \"){\"\n checked-var \" = 0;\" line-sep\n (reduce alts []\n (fn [ss alt]\n (comp ss\n [\"if(!\" checked-var \"){\" line-sep\n checked-var \" = 1;\" line-sep\n ;; TODO: what if runtime-check is empty?\n (runtime-check (c/update-var alt var)\n value-info checked-var)])))\n (repeat (count alts) \"}\") \"}\" line-sep])))\n\n (emit [ast]\n (emit-sym-constraint ast)))\n\n(extend-type c/ValueConstraint\n Emitter\n (emit-defined-value [constraint defined-sym]\n (let [file-name (ast/file-name constraint)\n line-number (ast/line-number constraint)\n x* (ast/tag \"#x\")\n y* (ast/tag \"#y\")]\n (for [constraint (lookup-constraint constraint)\n :let [constraint (c/update-type-name constraint defined-sym)\n types-info (either (c/extract-type-map constraint)\n {})]\n _ (sm/assoc-in-val [.module .types (ast/untag defined-sym)] constraint)\n exprs (emit-defined-value\n (ast/reified\n ;; TODO: total hack, should be\n ;; nothing\n (= 0 1)\n {(ast/tag Eq-sym file-name line-number)\n {=*-sym\n [(ast/fn-arity-ast\n (ast/tag (str defined-sym \"_EQ_QMARK_\") file-name line-number) \"\"\n (ast/params [x* y*]) \"\"\n [(ast/and-ast\n [(ast/call-ast =*-sym\n [(ast/call-ast get-type-sym [x*])\n (ast/call-ast get-type-sym [y*])])\n (ast/call-ast maybe-sym [x*])])]\n c/empty-items-constraint c/top-type)]}\n\n (ast/tag Type-sym file-name line-number)\n {instance?-sym\n [(ast/fn-arity-ast\n (ast/tag (str defined-sym \"_instance_QMARK_\") file-name line-number) \"\"\n (ast/params [x* y*]) \"\"\n [(-> maybe-constraint\n (c/intersect (c/InferredInner constraint empty-list nothing \"\"))\n c/ResultConstraint)\n (ast/and-ast\n ;; TODO: this needs to be replace with runtime-check\n [(ast/call-ast some-sym\n [(ast/call-ast list-sym (vec (keys types-info)))\n (ast/call-ast partial-sym\n [=*-sym\n (ast/call-ast get-type-sym [y*])])])\n (ast/call-ast maybe-sym [y*])])]\n c/empty-items-constraint c/top-type)]\n\n type-mapping-sym\n [(ast/fn-arity-ast\n (ast/tag (str defined-sym \"_type_mapping\") file-name line-number) \"\"\n (ast/params [x*]) \"\"\n [(map-vals types-info (fn [field-set]\n (map field-set ast/quoted-ast)))]\n c/empty-items-constraint c/top-type)]}\n\n (ast/tag Stringable-sym file-name line-number)\n {string-list-sym\n [(ast/fn-arity (ast/params [x*]) \"\"\n [(ast/call-ast list-sym [\"\"])])]}})\n defined-sym)]\n exprs))))\n\n(defn define-enum-element [file-name line-number sym]\n (cond (instance? ast/tagged-symbol sym)\n (comp (flat-map (get-sym sym)\n (fn [expr]\n (compilation-error \"Invalid enum value \" (str \"'\" sym \"'\")\n \" at:\" file-name line-number)))\n (let [x* (ast/tag 'x file-name line-number)\n y* (ast/tag 'y file-name line-number)\n reified-type-num (extract type-counter)]\n (for [_ (emit-defined-value\n (ast/reified (maybe reified-type-num)\n {(ast/tag Type-sym file-name line-number)\n {type-name-sym\n [(ast/fn-arity-ast\n (ast/tag (str sym \"_const_type_name\") file-name line-number) \"\"\n (ast/params [(ast/tag '_)]) \"\"\n [(str \"'\" sym \"' enum value at \" file-name \": \" line-number)]\n c/empty-items-constraint c/top-type)]}\n\n (ast/tag Stringable-sym file-name line-number)\n {string-list-sym\n [(ast/fn-arity (ast/params [(ast/tag 'z)]) \"\"\n [(ast/call-ast list-sym [(str sym)])])]}})\n sym)]\n {reified-type-num #{}}))\n (flat-map (debug 'here-maybe)\n (fn [_]\n (compilation-error \"wtf\" file-name line-number))))\n (compilation-error \"Invalid enum expression at:\"\n file-name line-number)))\n\n(defn define-enum-type [fn-val defined-sym]\n (let [file-name (ast/file-name defined-sym)\n line-number (ast/line-number defined-sym)]\n (cond (= (.call-target fn-val) 'enum)\n (for [type-maps (sm/traverse (.args fn-val) (partial define-enum-element file-name line-number))\n _ (debug 'type-maps type-maps)\n :let [type-map (comp* {} type-maps)\n x* (ast/tag \"#x\")\n y* (ast/tag \"#y\")\n reified-type-num (extract type-counter)\n constraint (-> (c/TypeConstraint type-map empty-list defined-sym nothing \"\")\n (c/update-path file-name line-number))]\n _ (sm/assoc-in-val [.module .types (ast/untag defined-sym)]\n constraint)\n exprs (emit-defined-value\n (ast/reified\n (maybe reified-type-num)\n {Type-sym\n {instance?-sym\n [(ast/fn-arity-ast\n (ast/tag (str defined-sym \"_instance_QMARK_\") file-name line-number) \"\"\n (ast/params [x* y*]) \"\"\n [(-> maybe-constraint\n (c/intersect (c/InferredInner constraint empty-list nothing \"\"))\n c/ResultConstraint)\n (ast/and-ast\n [(ast/call-ast some-sym\n [(ast/call-ast list-sym (vec (keys type-map)))\n (ast/call-ast partial-sym\n [=*-sym (ast/call-ast get-type-sym [y*])])])\n (ast/call-ast maybe-sym [y*])])]\n c/empty-items-constraint c/top-type)]\n\n type-mapping-sym\n [(ast/fn-arity-ast\n (ast/tag (str defined-sym \"_type_mapping\") file-name line-number) \"\"\n (ast/params [x*]) \"\"\n [(map-vals type-map (fn [field-set]\n (map field-set ast/quoted-ast)))]\n c/empty-items-constraint c/top-type)]}\n\n Stringable-sym\n {string-list-sym\n [(ast/fn-arity (ast/params [(ast/tag 'z)]) \"\"\n [(ast/call-ast list-sym\n [\"\"])])]}})\n defined-sym)]\n exprs)\n sm/zero-sm)))\n\n(defn init-at-runtime [ast defined-sym]\n (for [map-var (lookup-sym (ast/tag symbols-sym (ast/file-name defined-sym) (ast/line-number defined-sym)))\n init-fn-context (sm/get-val .rt-init)\n fn-context (reset-fn-context (.subs init-fn-context {}))\n\n sym-var (emit (ast/quoted-ast defined-sym))\n value (emit ast)\n global-var (comp (map (lookup-declaration defined-sym) .c-var)\n (for [var (global-var defined-sym \"var\")\n _ (sm/assoc-in-val [.module .declarations defined-sym]\n (maybe (c-code var [] {} c/top-type)))\n _ (declare [\"Value *\" var \";\\n\"])]\n var))\n\n constraint (get-constraint (.c-var value))\n init-fn-context (reset-fn-context fn-context)\n _ (sm/set-val .rt-init init-fn-context)\n _ (constrain-var (ast/file-name ast) (ast/line-number ast) global-var constraint)\n _ (cond (empty? (.init value))\n sm-nop\n (sm/update-in-val [.setup .cleanup]\n (fn [cleanup]\n (conj cleanup [\"freeGlobal(\" global-var \");\" line-sep]))))]\n (let [init (either (and (empty? (.init value))\n (maybe [global-var \" = \" (.c-var value) \";\" line-sep]))\n (comp (.init value)\n [global-var \" = \" (.c-var value) \";\" line-sep\n \"if (\" global-var \"->refs > 0) \"\n global-var \"->refs = -1;\"]))]\n (-> value\n (.c-var global-var)\n (.init [init line-sep\n (.c-var map-var) \" = hashMapAssoc((Value *)\" (.c-var map-var) \", \" line-sep\n (.c-var sym-var) \", \" global-var \");\" line-sep])))))\n\n(extend-type ast/inline-ast\n Emitter\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (cond (= (.lang ast) 'C)\n (for [line-info (line-macro ast \"// inline\")\n :let [init [line-info (.txt ast) \"\\n#\\n\"]]\n\n expr (comp (for [constraint (lookup-constraint (.result-type ast))\n c-var (genlocal \"rslt\")\n _ (constrain-var file-name line-number c-var constraint)]\n (c-code c-var init {} constraint))\n (wrap sm/zero-sm (c-code \"\" init {} c/top-type)))\n _ (set-result-constraint (.c-var expr) file-name line-number)]\n expr)\n\n sm/zero-sm)))\n\n (emit-defined-value [ast defined-sym]\n (cond (= (.lang ast) 'C)\n (for [constraint (lookup-constraint (.result-type ast))\n c-var (comp (map (lookup-declaration defined-sym) .c-var)\n (global-var defined-sym \"var\"))\n _ (new-module-def defined-sym (c-code (str c-var) [] {} constraint))\n line-info (line-macro ast \"// inline\")\n _ (declare [line-info \"Value *\" c-var \" = \" (.txt ast) \";\" line-sep \"\\n#\\n\"])\n sym-var (emit (ast/quoted-ast defined-sym))\n _ (constrain-var (ast/file-name defined-sym) (ast/line-number defined-sym) c-var constraint)]\n [(c-code c-var [] {} constraint)])\n\n sm/zero-sm))\n\n (emit-definition [ast]\n ;; TODO: what about the result-type\n (for [target-lang (wrap sm/zero-sm 'C)\n :when (= (.lang ast) target-lang)\n _ (declare [(.txt ast)])]\n [empty-c-code]))\n\n (wrap-tail [ast params]\n (Left (TailExpr ast))))\n\n(extend-type ast/call-ast\n Emitter\n (emit-recursive-call [ast params]\n ;; TODO: check for closures and insert dec_and_free(arity->parent, 1);\n (for [_ (sm/when (instance? Tagged (.call-target ast)))\n target (emit (.call-target ast))\n _ (sm/get-in-val [.fn-context .fn-spec .arity-info (.c-var target) (count (.args ast))])\n args (sm/traverse (.args ast) emit)\n line (line-macro ast \"// recursive-fixed\")]\n (do\n ;; TODO: collapse-expressions doesn't seem to work\n ;; (collapse-expressions (comp args\n ;; [(c-code \"\"\n ;; [line\n ;; (map (zip-lists params (map args .c-var))\n ;; (fn [[param arg]]\n ;; [param \" = \" arg \";\" line-sep]))]\n ;; {} c/top-type)]))\n (comp* empty-c-code (comp args\n [(c-code \"\"\n [line\n (map (zip-lists params (map args .c-var))\n (fn [[param arg]]\n [param \" = \" arg \";\" line-sep]))]\n {} c/top-type)])))))\n\n (emit-defined-value [fn-val defined-sym]\n (comp (define-enum-type fn-val defined-sym)\n (for [value (init-at-runtime fn-val defined-sym)\n constraint (get-constraint (.c-var value))\n _ (new-module-def defined-sym (c-code (.c-var value) [] {} constraint))]\n [(c-init (.c-var value) [(.init value) (.c-var value) \" = \" (.c-var value) \";\" \"\\n#\\n\"]\n (.refs-map value) (ast/file-name fn-val) (ast/line-number fn-val))])))\n\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)\n ast (.call-target ast (either (instance? Symbol (.call-target ast))\n (.call-target ast)))]\n (comp (flat-map (inline-expr (.call-target ast) (.args ast))\n (fn [x]\n ;; (cond (= file-name \"test.toc\")\n ;; (for [_ (debug 'old file-name line-number \"\\n\" ast)\n ;; _ (debug 'new \"\\n\" x)\n ;; r (emit x)]\n ;; r))\n\n (emit x)))\n ;; TODO: this is a refactoring of the below expression, but not sure it's better\n ;; (for [target (emit (.call-target ast))\n ;; expr (comp (for [args (sm/traverse (.args ast) emit)\n ;; call-site (comp (emit-call-site target args ast)\n ;; (compilation-error \"Could not compile call site at:\"\n ;; file-name line-number))]\n ;; (do\n ;; ;; TODO: why does 'collapse-expressions' not work here?\n ;; ;; (collapse-expressions (comp [target] args [call-site]))\n ;; (comp* target (comp args [call-site])))))]\n ;; expr)\n (flat-map (sm/traverse (.args ast) emit)\n (fn [args]\n (comp (for [target (emit (.call-target ast))\n call-site (emit-call-site target args ast)]\n (do\n ;; TODO: why does 'collapse-expressions' not work here?\n ;; (collapse-expressions (comp [target] args [call-site]))\n (comp* target (comp args [call-site]))))\n (compilation-error \"Could not compile call site at:\"\n file-name line-number)))))))\n\n (wrap-tail [ast params]\n (Left (TailCall ast params)))\n\n (inline-expr [ast arg-asts]\n (let [target (.call-target ast)\n file-name (ast/file-name target)\n line-number (ast/line-number target)]\n (comp (for [_ (sm/when (instance? ast/tagged-symbol target))\n ;; TODO; this is not general enough. Needs to handle more than one field\n ;; and multiple fields being fn's\n constructor (lookup-sym target)\n :when (instance? c-constructor constructor)\n invoke-info (get-core-proto-impl Function-sym invoke-sym\n (-> ast .args count inc)\n (.type-num constructor))\n new-params (sm/when (map (get-in invoke-info [.ast .params])\n (fn [params]\n (ast/params-ast (rest (.fixed params))\n nothing))))\n new-body (sm/when (for [ast-body (get-in invoke-info [.ast .body])\n let-ast (some ast-body (partial instance? ast/let-ast))]\n (.body let-ast)))\n fn-ast (sm/when (flat-map (first (.args ast))\n (partial instance? ast/fn-ast)))\n fn-field (sm/when (first (.fields constructor)))\n new-ast (-> (ast/fn-arity new-params\n (ast/block-comment file-name line-number [])\n new-body)\n replace-bound-vars\n (replace-syms {fn-field fn-ast})\n (inline-expr arg-asts))]\n new-ast)\n (for [new-call-target (inline-expr target (.args ast))\n new-ast (inline-expr new-call-target arg-asts)]\n new-ast)))))\n\n;; TODO: when a proto impl is wrong (ie; wrong number of args)\n;; the error message is trash\n(extend-type C-expr\n ast/IsCode\n (ast/generates-code? [expr]\n (maybe expr))\n\n Emitter\n (wrap-tail [expr _]\n (Left (TailExpr expr)))\n\n (emit [x]\n (sm/state-maybe x)))\n\n(extend-type c-code\n C-Code\n (expr-constraints [expr new-c]\n (.constraints expr new-c))\n\n (expr-constraints [expr]\n (.constraints expr)))\n\n(extend-type c-field\n C-Code\n (expr-constraints [expr new-c]\n (.constraints expr new-c))\n\n (expr-constraints [expr]\n (.constraints expr)))\n\n(extend-type c-param\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n C-Code\n (expr-constraints [expr new-c]\n (.constraints expr new-c))\n\n (expr-constraints [expr]\n (.constraints expr)))\n\n(extend-type c-constructor\n C-Code\n (expr-constraints [expr new-c]\n (.constraints expr new-c))\n\n (expr-constraints [expr]\n (.constraints expr)))\n\n(extend-type c-static-reified\n Emitter\n (get-result-constraint [expr num-args]\n (map (get-core-proto-impl Function-sym invoke-sym (inc num-args) (.type-num expr))\n .result-constraint))\n\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n C-Code\n (expr-constraints [expr new-c]\n (.constraints expr new-c))\n\n (expr-constraints [expr]\n (.constraints expr)))\n\n(extend-type c-protocol-fn\n C-Code\n (expr-constraints [expr]\n fn-constraint))\n\n(extend-type c-static-int\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n C-Code\n (expr-constraints [expr new-c]\n (.constraints expr new-c))\n\n (expr-constraints [expr]\n (.constraints expr)))\n\n(extend-type c-static-str\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n C-Code\n (expr-constraints [expr new-c]\n (.constraints expr new-c))\n\n (expr-constraints [expr]\n (.constraints expr)))\n\n(extend-type c-static-sym\n Emitter\n (clear-init [expr]\n (c-code (.c-var expr) [] {(.c-var expr) 1} c/top-type))\n\n C-Code\n (expr-constraints [expr new-c]\n (.constraints expr new-c))\n\n (expr-constraints [expr]\n (.constraints expr)))\n\n(extend-type c-closure-fn\n CallSite\n (emit-call-site [target args ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (comp (for [arity-info (sm/when (or (get-in target [.arities (count args)])\n (map (get-in target [.arities 'variadic])\n (fn [arity-info]\n (either (c/compose-constraints\n file-name line-number\n (c/StaticLengthConstraint (count args)\n empty-list nothing \"\")\n (.param-constraints arity-info))\n (abort))\n arity-info))))\n ;; _ (debug 'call-closure file-name line-number (.call-target ast) (.c-var target) \"\\n\"\n ;; (.param-constraints arity-info) \"\\n\"\n ;; 'result-c (.result-constraint arity-info))\n _ (constrain-args args (-> arity-info\n .param-constraints\n (c/extract-items-constraints (count args)))\n file-name line-number)\n expr (call-dyn-fn-value target args ast)\n _ (flat-map (reify-constraint (.result-constraint arity-info) args file-name line-number)\n (partial constrain-var file-name line-number (.c-var expr)))\n ;; TODO: restore\n ;; _ (either (add-inner-constraint (.c-var expr) ast args)\n ;; (wrap sm/zero-sm '_))\n ;; _ (add-hash-map-constraints ast (.c-var expr) args)\n ;; _ (add-contents-constraint ast (.c-var expr) args)\n ]\n expr)\n (compilation-error \"No arity with\" (count args) \"arguments found\"\n (either (map (instance? Tagged (.call-target ast))\n (fn [sym]\n (str \"for '\" sym \"'\")))\n \"\")\n \"at:\" (ast/file-name ast) (ast/line-number ast)))))\n\n Emitter\n (get-result-constraint [expr num-args]\n ;; TODO: add variadic\n (sm/when (get-in expr [.arities num-args .result-constraint])))\n\n (clear-init [expr]\n (-> expr\n (.init [])\n (.refs-map {(.c-var expr) 1})))\n\n C-Code\n (expr-constraints [expr]\n fn-constraint))\n\n(extend-type c-static-fn\n Emitter\n (get-result-constraint [expr num-args]\n ;; TODO: add variadic\n (sm/when (get-in expr [.arities num-args .result-constraint])))\n\n (clear-init [expr]\n (-> expr\n (.init [])\n (.refs-map {(.c-var expr) 1})))\n\n C-Code\n (expr-constraints [expr]\n fn-constraint))\n\n(extend-type ast/tagged-symbol\n Emitter\n (dissoc-sym [x]\n (for [_ (sm/update-state (fn [[subs & subs-list]]\n (cons (dissoc subs (ast/tag x))\n subs-list)))]\n (Left x)))\n\n (new-bound-var [x]\n (let [new-var (ast/tag (gensym (str x))\n (ast/file-name x)\n (ast/line-number x))]\n (for [_ (sm/update-state (fn [[subs & subs-list]]\n (cons (assoc subs x new-var)\n subs-list)))]\n (Left new-var))))\n\n (update-syms [x _]\n (map (comp (sm/get-in-val [0 x])\n (sm/state-maybe x))\n Left))\n\n (encode-static [x]\n (emit (ast/quoted-ast (.sym x))))\n\n (all-symbols [ast]\n [ast]))\n\n(defn bind-list [param-var fixed-bindings tail-binding file-name line-number]\n (let [tail-var (.bound tail-binding)\n content-vars (map fixed-bindings .bound)\n fixed-count (count fixed-bindings)]\n (for [_ (set-sym param-var (c-code param-var [] {} c/top-type))\n dest-args (genlocal \"destArgs\")\n _ (cond (= 0 fixed-count)\n sm-nop\n (constrain-var file-name line-number\n param-var\n (rdr/assert-min-count file-name line-number fixed-count)))\n items-constraints (map (get-constraint param-var)\n c/extract-items-constraints)\n _ (sm/traverse (zip-lists content-vars items-constraints)\n (fn [[var const]]\n (append-constraint var const file-name line-number)))\n _ (append-constraint tail-var (-> list-constraint\n (c/update-var tail-var))\n file-name line-number)]\n (ParamBinding param-var\n fixed-bindings tail-var\n (comp [(c-code \"\"\n (destruct-seq param-var\n (conj content-vars tail-var)\n (str dest-args) file-name line-number)\n {param-var 1} c/top-type)]\n (map (conj content-vars tail-var)\n (fn [var]\n (c-init var [] {} file-name line-number)))\n (flat-map (conj fixed-bindings tail-binding) .destruct))))))\n\n(extend-type ast/params-ast\n Emitter\n (wrap-tail [ast params]\n (Left ast))\n\n (all-symbols [params]\n (comp* (either (.variadic params)\n [])\n (seq (.fixed params))))\n\n (get-param-cs [params]\n (sm/state-maybe (-> c/empty-items-constraint\n (.tail-constraint (either (.variadic params)\n c/top-type))\n (.items-constraints (.fixed params)))))\n\n (pre-bind [params]\n (sm/state-maybe (cond (.variadic params)\n params\n\n (.variadic params (maybe (ast/tag \"restArgs\"))))))\n\n (bind-param-expr [params]\n (flat-map (genlocal \"arg\")\n (fn [param-var]\n (bind-list param-var\n (.fixed params)\n (either (.variadic params)\n (do\n (print-err \"Compiler error at toccata.toc:\" _LINE_)\n (abort)))\n (ast/file-name params)\n (ast/line-number params)))))\n\n\n\n (bind-expr [params]\n (flat-map (genlocal \"arg\")\n (fn [param-var]\n (bind-list param-var\n (.fixed params)\n (either (.variadic params)\n (do\n (print-err \"Compiler error at toccata.toc:\" _LINE_)\n (abort)))\n (ast/file-name params)\n (ast/line-number params)))))\n\n (bind-expr [params evalled]\n (let [evalled (.refs-map evalled (dissoc (.refs-map evalled) (.c-var evalled)))]\n (for [tail-binding (bind (either (.variadic params)\n (ast/tag \"restArgs\")))\n fixed-bindings (sm/traverse (.fixed params) bind)\n _ (cond (empty? (.init evalled))\n (set-sym (.c-var evalled) evalled)\n sm-nop)\n binding (bind-list (.c-var evalled)\n fixed-bindings\n tail-binding\n (ast/file-name params)\n (ast/line-number params))]\n (.destruct binding (-> evalled\n (.refs-map (dissoc (.refs-map evalled) (.c-var evalled)))\n vector\n (comp (.destruct binding)))))))\n\n (new-bound-var [ast]\n (sm/state-maybe (Right ast)))\n\n (dissoc-sym [ast]\n (sm/state-maybe (Right ast)))\n\n (update-syms [ast handle-bindings]\n (either (map (.variadic ast) (fn [var]\n (for [new-fixed (map (.fixed ast)\n (fn [param]\n (apo handle-bindings param sm/state-maybe))\n sm/state-maybe)\n new-var (apo handle-bindings var sm/state-maybe)]\n (Left (ast/params-ast new-fixed (maybe new-var))))))\n\n (map (map (.fixed ast)\n (fn [param]\n (apo handle-bindings param sm/state-maybe))\n sm/state-maybe)\n (fn [new-fixed]\n (Left (ast/params-ast new-fixed nothing)))))))\n\n\n(extend-type ast/binding-ast\n Emitter\n (update-syms [ast handle-bindings]\n (for [new-val (elgot (fn [ast]\n (update-syms ast handle-bindings))\n pop-subs (.val ast) sm/state-maybe)\n new-bound (apo handle-bindings (.binding ast) sm/state-maybe)]\n (Left (ast/binding-ast new-bound new-val))))\n\n (emit [ast]\n (flat-map (emit (.val ast))\n (partial bind (.binding ast)))))\n\n(extend-type ast/let-ast\n Emitter\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [locals get-syms\n bindings (sm/traverse (.bindings ast) emit)\n body-exprs (sm/traverse (.body ast) emit)\n _ (sm/traverse bindings constrain-params)\n code (collapse-expressions (comp (flat-map bindings .destruct) body-exprs))\n result-var (either (map (= \"\" (.c-var code)) sm/state-maybe)\n (genlocal \"let_rslt\"))\n _ (propogate-constraint (.c-var code) result-var identity\n file-name line-number)\n _ (set-syms locals)]\n (c-init result-var\n [(.init code)\n (either (= \"\" result-var)\n [line-sep \"Value *\" result-var \" = \" (.c-var code) \";\" line-sep])]\n (.refs-map code) file-name line-number))))\n\n (emit-defined-value [ast defined-sym]\n (for [value (init-at-runtime ast defined-sym)\n val-constraint (get-constraint (.c-var value))\n _ (new-module-def defined-sym (c-code (.c-var value) [] {} val-constraint))]\n [(c-init (.c-var value) [(.init value) (.c-var value) \" = \" (.c-var value) \";\" \"\\n#\\n\"]\n (.refs-map value) (ast/file-name ast) (ast/line-number ast))]))\n\n (wrap-tail [ast params]\n ;; TODO: move this filtering of the body to the Vector implementation of wrap-tail\n (-> ast\n (.body (comp (filter (.body ast) (partial instance? c/Constraints))\n (-> ast\n .body\n (filter ast/generates-code?)\n (tail-call params))))\n Left))\n\n (update-syms [ast _]\n (for [_ (sm/update-state (fn [subs-list]\n (either (map (first subs-list)\n (fn [head]\n (cons head subs-list)))\n (list {}))))]\n (Right ast)))\n\n (pop-subs [ast]\n (map (sm/update-state rest)\n (fn [subs]\n (or (= (str (ast/file-name ast)) \"core\")\n (maybe (print-err 'subs subs)))\n ast)))\n\n (inline-expr [ast arg-asts]\n (let [unique-syms (map arg-asts (fn [_]\n (ast/tag (gensym \"#arg\") (ast/file-name ast) (ast/line-number ast))))\n new-body (either (empty? (.body ast))\n (let [[tail & init] (-> (.body ast)\n (remove (partial instance? ast/NoCode))\n reverse)]\n (-> (ast/call-ast tail unique-syms)\n (cons init)\n reverse\n vec)))\n new-body (comp (filter (.body ast) (partial instance? c/Constraints))\n new-body)]\n (sm/state-maybe (ast/let-ast\n (comp (make-bindings unique-syms arg-asts)\n (.bindings ast))\n new-body)))))\n\n\n(defn index [coll]\n (let [coll (seq coll)]\n (zip-lists (range (count coll)) coll)))\n\n(defn closure-reified-value [constraint type-num impl-fns]\n (let [inits (map impl-fns .init)\n file-name (ast/file-name constraint)\n line-number (ast/line-number constraint)]\n (for [reified-sym (genlocal \"reifiedDyn\")\n _ (constrain-var file-name line-number\n reified-sym constraint)]\n (c-init reified-sym\n [inits\n \"Value *\" reified-sym \" = (Value *)malloc_reified(\"\n (count impl-fns) \");\" line-sep\n \"((ReifiedVal *)\" reified-sym \")->type = \" type-num \";\" line-sep\n \"((ReifiedVal *)\" reified-sym \")->implCount = \" (count impl-fns) \";\" line-sep\n (-> impl-fns\n (map .c-var)\n (index)\n (map (fn [[index sym]]\n [\"((ReifiedVal *)\" reified-sym\n \")->impls[\" index \"] = (Value *)\" sym \";\" line-sep])))]\n (apply merge-with (list* + (map impl-fns .refs-map))) file-name line-number))))\n\n(defn static-reified-value [constraint type-num impl-fns]\n (for [reified-sym (global-var \"reifiedStatic\")\n reified-ptr (global-var \"reifiedPtr\")\n :let [constraint (c/update-var constraint reified-ptr)]\n _ (constrain-var (ast/file-name constraint) (ast/line-number constraint)\n reified-ptr constraint)\n _ (declare [\"ReifiedVal \" reified-sym \" = {\"\n type-num \", -2, 0, \"\n \"0, {}};\" line-sep\n \"Value *\" reified-ptr \" = (Value *)&\" reified-sym \";\" line-sep])]\n (c-static-reified type-num reified-ptr [] {} constraint reified-sym)))\n\n(defn checking-fn [fn-sym params param-vars arity-fn-var constraints]\n (let [file-name (ast/file-name params)\n line-number (ast/line-number params)\n constraints-list (c/extract-items-constraints constraints)]\n (for [dest-args (genlocal \"destArgs\")\n checking-fn-var (global-var fn-sym \"paramCheckerFn\")\n line (line-macro params \"// param checking fn\")\n checked-var (genlocal 'checked)]\n (cond\n (.variadic params)\n (c-code checking-fn-var\n [\"Value *\" checking-fn-var\n \"(FnArity *arity, Value *args) {\\n\"\n line\n \"int \" checked-var \"= 1;\"\n (-> constraints\n (c/update-var \"args\")\n ;; TODO: what if runtime-check is empty?\n (runtime-check c/top-type file-name line-number checked-var))\n \"if(!\" checked-var \"){abort();}\" line-sep\n \"return(\" arity-fn-var\n \"(arity, args));\\n};\\n\"]\n {} c/top-type)\n (every constraints-list (partial = c/top-type))\n (c-code arity-fn-var [] {} c/top-type)\n\n (c-code checking-fn-var\n [\"Value *\" checking-fn-var \"(\"\n (-> param-vars\n (map (fn [param] (str \"Value *\" param)))\n (seq)\n (conj \"FnArity *arity\")\n (interpose \", \"))\n \") {\\n\"\n line\n \"int \" checked-var \"= 1;\"\n (for [[constraint var] (zip-lists constraints-list\n param-vars)]\n ;; TODO: what if runtime-check is empty?\n (-> constraint\n (c/update-var var)\n (runtime-check c/top-type file-name line-number checked-var)))\n \"if(!\" checked-var \"){abort();}\" line-sep\n \"return(\" arity-fn-var \"(\"\n (-> param-vars\n (seq)\n (conj \"arity\")\n (interpose \", \"))\n \"));\\n};\\n\"]\n {} c/top-type)))))\n\n(def vect-array-len (inline C Integer \"(Value *)&(Integer){IntegerType, -2, VECTOR_ARRAY_LEN};\"))\n\n(defn destruct-closures [closure-info]\n (let [closure-count (count closure-info)]\n (cond (<= closure-count vect-array-len)\n (sm/state-maybe (conj (map (vec (zip-lists (range closure-count) closure-info))\n ;; TODO: the runtime error message for this version is awful\n ;; (fn [[idx [arg _ constraint]]]\n (fn [[idx [arg _]]]\n (c-init arg [\"Value *\" arg \" = arity->closures->tail[\" idx \"];\"\n \" incRef(\" arg \",1);\" line-sep]\n {} \"\" 0)))\n (c-code \"\" [\"if (arity->parent) incRef(arity->parent, 1);\" line-sep]\n {} c/top-type)))\n\n (for [destArgs (genlocal \"destArgs\")]\n (let [closures (-> closure-info\n (map (fn [[arg]] arg))\n vec\n (conj \"closuresTail\"))\n closure-count (count closures)]\n (comp [(c-code \"\"\n [(map closures (fn [arg] [\"Value *\" arg \";\" line-sep]))\n \"incRef((Value *)arity->closures, 1);\" line-sep\n \"Value **\" destArgs \"[\" closure-count \"] = {\"\n (interpose (map closures (partial vector \"&\")) \", \")\n \"};\" line-sep\n \"destructValue(\\\"\\\", \\\"\\\", (Value *)arity->closures\"\n \", \" closure-count \", \" destArgs \");\" line-sep\n \"if (arity->parent) incRef(arity->parent, 1);\" line-sep]\n {} c/top-type)]\n (map (vec closure-info)\n (fn [[arg _]]\n (c-init arg [] {} \"\" 0)))))))))\n\n(defn emit-closure-arity [fn-sym fn-var fn-context c-fn params param-vars body-exprs]\n (assert (instance? String fn-var))\n (assert (instance? CFnPtr c-fn))\n\n (let [file-name (ast/file-name fn-sym)\n line-number (ast/line-number fn-sym)]\n (for [closures (extract-closures)\n closure-subs (get-subs)\n closures-destruct (destruct-closures closures)\n body (collapse-expressions (comp closures-destruct\n (either (= \"\" fn-var)\n [(c-init fn-var [\"Value *\" fn-var \" = arity->parent;\"\n \" incRef(\" fn-var \",1);\" line-sep]\n {} \"\" 0)])\n body-exprs))\n\n result-constraint (get-constraint (.c-var body))\n param-constraints (flat-map (get-param-constraints params)\n (fn [param-constraints]\n (reify-constraint param-constraints [] \"\" 0)))\n _ (reset-fn-context fn-context)\n closed-over (sm/traverse closures (fn [[closed-over sym]]\n (map (lookup-sym sym)\n (fn [expr]\n [closed-over (.c-var expr)]))))\n _ (sm/traverse (for [[closure outer] closed-over\n :let [closure-c (get closure-subs closure)]\n :when closure-c]\n [outer (extract closure-c)])\n (fn [[outer-var constraint]]\n (append-constraint outer-var constraint file-name line-number)))\n arity-var (genlocal fn-sym \"dynArity\")\n closure-vars (sm/traverse closures (fn [[closed-over sym]]\n (for [closure (lookup-sym sym)]\n (c-code \"\"\n [arity-var \"->closures = mutateVectConj(\"\n \"(Vector *)\" arity-var \"->closures\"\n \", (Value *)\" (.c-var closure) \");\" line-sep]\n {(.c-var closure) 1}\n (c/update-var list-constraint (str (.c-var closure)))))))\n\n line (line-macro fn-sym \"// paramChecker\")\n checked-var (genlocal 'checked)\n :let [check-params (either (for [_ (.variadic params)\n var-args (first param-vars)]\n (-> param-constraints\n (c/update-var var-args)\n (runtime-check c/top-type file-name line-number checked-var)))\n (for [[constraint var] (zip-lists\n (c/extract-items-constraints param-constraints\n (count param-vars))\n param-vars)]\n ;; TODO: what if runtime-check is empty?\n (-> constraint\n (c/update-var var)\n (runtime-check c/top-type file-name line-number checked-var))))]\n _ (declare [\"Value *\" c-fn \"(\"\n (-> param-vars\n (map (partial str \"Value *\"))\n (seq)\n (conj \"FnArity *arity\")\n (interpose \", \"))\n \") {\\n\"\n \"\\nwhile (1) {\\n\"\n line\n \"if(1){int \" checked-var \" = 1;\" line-sep\n check-params\n \"if(!\" checked-var \"){abort();}}\" line-sep\n (.init body)\n line-sep \"};};\\n\"])\n :let [arity-init [\"FnArity *\" arity-var\n \" = malloc_fnArity();\" line-sep\n arity-var \"->count = \" (count param-vars)\n \";\" line-sep\n arity-var \"->variadic = \"\n (cond (.variadic params)\n \"1\"\n \"0\")\n \";\" line-sep\n arity-var \"->fn = \" c-fn \";\" line-sep\n arity-var \"->closures = empty_vect;\" line-sep]]\n expr (collapse-expressions (comp [(c-code arity-var arity-init {} c/top-type)]\n closure-vars\n [(c-init arity-var [] {} file-name line-number)]))]\n (ClosureArity c-fn params (cond (.variadic params)\n 'variadic\n (count params))\n expr\n param-constraints (c/clear-vars result-constraint)))))\n\n(defn emit-static-arity [fn-sym fn-context fn-var c-fn params param-vars body-exprs]\n (assert (instance? ast/params-ast params))\n (assert (instance? CFnPtr c-fn))\n\n (let [file-name (ast/file-name fn-sym)\n line-number (ast/line-number fn-sym)]\n (for [body (collapse-expressions body-exprs)\n arity-var (global-var fn-sym \"staticArity\")\n result-constraint (get-constraint (.c-var body))\n param-constraints (flat-map (get-param-constraints params)\n (fn [param-constraints]\n (reify-constraint param-constraints [] \"\" 0)))\n runtime-check-fn (checking-fn fn-sym params param-vars c-fn param-constraints)\n _ (reset-fn-context fn-context)\n ;; TODO: put back in when rstoring the interpreter\n ;; param-struct (encode-static param-constraints)\n ;; rslt-struct (encode-static result-constraint)\n ]\n (let [expr (c-static-arity (ArityValPtr (str \"&\" arity-var) arity-var) [] {} arity-var)]\n ;; TODO: use this to eliminate unknown return type values\n ;; (and (= c/UnknownType result-type)\n ;; (maybe (print-err 'unknown-return-type fn-sym\n ;; (ast/file-name body-exprs) (ast/line-number body-exprs))))\n (StaticArity fn-var c-fn params (cond (.variadic params)\n 'variadic\n (count params))\n (.init expr [\"Value *\" c-fn \"(\"\n (-> param-vars\n (map (partial str \"Value *\"))\n (seq)\n (conj \"FnArity *arity\")\n (interpose \", \"))\n \") {\\nwhile (1) {\\n\"\n (.init body)\n line-sep \"};};\\n\"\n (.init runtime-check-fn)\n \"FnArity \" arity-var \" = {FnArityType, -2, \"\n (count param-vars)\n \", (Vector *)0, (Value *)0, \" (cond (.variadic params)\n \"1\"\n \"0\")\n \", \" (.c-var runtime-check-fn)\n ;; TODO: put back in when rstoring the interpreter\n ;; \", (Value *)&\" (.c-struct param-struct)\n ;; \", (Value *)&\" (.c-struct rslt-struct)\n \", (Value *)0, (Value *)0\"\n \"};\" line-sep])\n param-constraints (c/clear-vars result-constraint))))))\n\n(defn emit-fn-arity\n ([fn-sym fn-var params body]\n (flat-map (global-var fn-sym \"arityImpl\")\n (fn [c-fn]\n (emit-fn-arity fn-sym fn-var params body (StaticFnPtr c-fn)))))\n\n ([fn-sym fn-var params body c-fn]\n (assert (instance? CFnPtr c-fn))\n\n ;; TODO: there are two ResultConstraint's in 'body'\n (either (and (empty? (remove body (partial instance? ast/NoCode)))\n (maybe sm/zero-sm))\n ;; TODO: I'm tired of file-name not being accurate for compiler-generated fns\n (let [file-name (ast/file-name body)\n line-number (ast/line-number body)\n constraints (filter body (partial instance? c/Constraints))\n body (remove body (partial instance? ast/NoCode))\n fn-constraint (-> fn-constraint\n (c/update-var (str fn-var))\n (c/update-sym (ast/untag fn-sym)))\n fn-sym (either (instance? ast/tagged-symbol fn-sym)\n (ast/tag fn-sym file-name line-number))]\n (for [fn-context (reset-fn-context)\n ;; _ (debug \"------------\\n\" (ast/file-name fn-sym) (ast/line-number fn-sym) 'fn-arity fn-sym)\n p-bindings (bind-param params)\n _ (cond (.variadic params)\n sm-nop\n (sm/assoc-in-val [.fn-context .fn-spec .arity-info\n fn-var (count params)] '_))\n :let [param-vars (map p-bindings .bound)\n param-destruct (cond\n (some body (partial instance? ast/inline-ast))\n []\n\n (.variadic params)\n (flat-map p-bindings .destruct)\n\n (comp (map param-vars\n (fn [var]\n (c-init var [] {}\n (ast/file-name params)\n (ast/line-number params))))\n (flat-map p-bindings .destruct)))]\n _ (sm/traverse param-vars\n (fn [var]\n (set-constraint var c/top-type)))\n _ (sm/traverse (zip-lists (.fixed params) (range (count (.fixed params))))\n (fn [[sym index]]\n (cond (instance? ast/params-ast sym)\n sm-nop\n\n (flat-map (map (lookup-sym sym) .c-var)\n (fn [var]\n (set-constraint var (c/DynamicParamConstraint\n index empty-list (maybe sym) var\n c/top-type)))))))\n _ (set-constraint \"#result\" c/top-type)\n\n syms get-syms\n _ (either (map (get syms fn-sym) sm/state-maybe)\n (set-sym fn-sym (c-code fn-var [] {fn-var 1} fn-constraint)))\n body-exprs (-> (comp param-destruct constraints body)\n (tail-call param-vars)\n ;; ((fn [b]\n ;; (and (= fn-sym 'bogus)\n ;; (do\n ;; (print-err 'params param-destruct)\n ;; (print-err 'body \"\\n\" (interpose b \"\\n\"))\n ;; nothing))\n ;; b))\n (sm/traverse emit))\n arity-info (comp (emit-closure-arity fn-sym fn-var fn-context c-fn params\n param-vars body-exprs)\n (emit-static-arity fn-sym fn-context fn-var c-fn params\n param-vars body-exprs))\n ;; _ (debug \"============\")\n ]\n arity-info)))))\n\n(deftype ProtoImplDeclaration [proto-sym fn-name arity-ast arity-var c-fn]\n (assert (instance? Tagged proto-sym))\n (assert (instance? Tagged fn-name))\n (assert (instance? ArityValPtr arity-var))\n (assert (instance? CFnPtr c-fn))\n (assert (instance? ast/fn-arity-ast arity-ast))\n\n Stringable\n (string-list [_]\n (list \"\")))\n\n(defn declare-impl [type-str type-num [proto-sym fn-sym arity-ast]]\n (assert (instance? Integer type-num))\n\n (let [num-args (count (.params arity-ast))]\n (for [impl-fn-var (global-var fn-sym \"staticImpl\")\n arity-impl-var (global-var (str type-str fn-sym) \"arityImpl\")\n c-fn (global-var (str type-str fn-sym) \"arityFn\")\n :let [arity-impl-var (ArityValPtr arity-impl-var \"\")\n c-fn (ProtoDispFnPtr c-fn)]\n dispatcher-info (lookup-sym fn-sym)\n dispatcher-info (sm/when (get-in dispatcher-info [.arities num-args]))\n\n ;; [arity-fn-var c-fn param-count var-info param-constraints result-constraint]\n\n :let [sym-map (reduce (zip-lists (-> dispatcher-info .params .fixed)\n (-> arity-ast .params .fixed))\n {} (fn [m [old-sym new-sym]]\n (cond (= old-sym new-sym)\n m\n (assoc m old-sym new-sym))))]\n :let [param-assertions (-> dispatcher-info\n .param-constraints\n (replace-syms sym-map)\n c/extract-items-constraints\n (map (fn [c]\n (c/update-var c \"\"))))\n arity-ast (.body arity-ast (comp [(c/ResultConstraint (.result-constraint dispatcher-info))]\n param-assertions (.body arity-ast)))]\n _ (new-proto-impl proto-sym fn-sym num-args type-num arity-impl-var arity-ast\n (-> c/empty-items-constraint\n (.items-constraints param-assertions))\n c/top-type c-fn)\n _ (declare [\"Value *\" c-fn \"(\"\n (-> arity-ast\n .params\n .fixed\n (map (fn [_] \"Value *\"))\n (seq)\n (conj \"FnArity *arity\")\n (interpose \", \"))\n \");\\n\"\n \"FnArity *\" arity-impl-var \";\\n\"])]\n (ProtoImplDeclaration proto-sym fn-sym\n arity-ast\n arity-impl-var c-fn))))\n\n(deftype ConstrainVar [constraint]\n (assert (instance? c/ValueConstraint constraint))\n\n Stringable\n (string-list [_]\n (list \"(ConstrainVar \" (str constraint) \")\"))\n\n Container\n (map [x f]\n (ConstrainVar (f constraint)))\n\n (map [x f embed]\n (map (f constraint) ConstrainVar))\n\n ast/IsCode\n (ast/generates-code? [x]\n (maybe x))\n\n Emitter\n (emit [_]\n (either (map (c/extract-sym constraint)\n (fn [sym]\n (for [sym-info (-> sym\n (ast/tag (ast/file-name constraint) (ast/line-number constraint))\n lookup-sym)\n _ (constrain-var (ast/file-name constraint) (ast/line-number constraint)\n (.c-var sym-info) constraint)]\n empty-c-code)))\n (wrap sm/zero-sm empty-c-code))))\n\n(defn emit-impl [type-str disp-constraint type-num impl-decl]\n (assert (instance? ProtoImplDeclaration impl-decl))\n\n (let [[proto-sym fn-sym arity-ast arity-var c-fn] (type-args impl-decl)\n params (.params arity-ast)\n [disp-param] (.fixed params)\n num-args (count params)\n file-name (ast/file-name fn-sym)\n line-number (ast/line-number fn-sym)\n disp-constraint (either (for [type-map (c/extract-type-map disp-constraint)\n fields (get type-map type-num)]\n (c/TypeConstraint {type-num fields} empty-list\n (symbol type-str)\n (maybe (ast/untag disp-param)) \"\"))\n disp-constraint)]\n (for [;; _ (debug 'impl file-name line-number type-str fn-sym num-args \"\\n\" disp-constraint)\n default-impl (get-proto-impl proto-sym fn-sym num-args 0)\n ext-fn (comp (emit-fn-arity (symbol (str type-str fn-sym))\n (.fn-var arity-ast)\n params\n (comp [(-> disp-constraint\n (c/update-path file-name line-number))\n (-> (.result-constraint default-impl)\n (c/update-path file-name line-number)\n c/ResultConstraint)]\n (.body arity-ast))\n c-fn)\n (compilation-error \"Could not compile protocol fn:\"\n (str \"'\" fn-sym \"' in\")\n (str file-name \",\") line-number))\n ext-fn (cond (instance? StaticArity ext-fn)\n (-> ext-fn\n .var-info\n .init\n declare\n (map (fn [_]\n (.var-info ext-fn (.init (.var-info ext-fn) [])))))\n\n (sm/state-maybe ext-fn))\n :let [ext-fn (cond (= fn-sym 'instance?)\n (either (update-in ext-fn [.param-constraints .items-constraints]\n (fn [cs]\n (either (store cs 1 c/top-type)\n cs)))\n ext-fn)\n\n ext-fn)]\n reified (reify-arity ext-fn type-num arity-ast fn-sym proto-sym)\n ;; _ (debug \"---------\")\n ]\n (-> reified\n (.c-var arity-var)\n (.init (either (or (empty? (.init reified))\n (and (instance? StaticArity ext-fn)\n (maybe (.init reified))))\n [(.init reified)\n \"FnArity *\" arity-var \" = \" (.c-var reified) \";\\n\"]))))))\n\n(defn extend-type* [ast constraint type-num]\n (assert (instance? Integer type-num))\n\n (let [impl-arities (for [[proto-sym impl-fns] (vec (.impls ast))\n [fn-name arities] (vec impl-fns)\n impl-arity arities]\n [proto-sym fn-name (.fn-var impl-arity (str (.fn-var impl-arity)))])]\n (cond (empty? impl-arities)\n (sm/state-maybe [])\n (for [type-str (comp (map (sm/get-in-val [.constants .type-names type-num]) str)\n (wrap sm/zero-sm (str \"_\" type-num \"_\")))\n _ (sm/traverse (keys (.impls ast))\n (fn [proto-sym]\n (comp (lookup-protocol proto-sym)\n (compilation-error \"Invalid protocol:\" proto-sym \"in\"\n (str (ast/file-name proto-sym) \",\")\n (ast/line-number proto-sym)))))\n ;; TODO: make sure the proto-name/fn-name exists\n ;; especially that the fn-name doesn't exist in a different proto-name\n impl-arities (sm/traverse impl-arities (partial declare-impl type-str type-num))\n [head-fn & fns] (sm/traverse impl-arities (partial emit-impl type-str constraint type-num))]\n (cons head-fn fns)))))\n\n(extend-type ast/reify-ast\n Emitter\n (emit [ast]\n (let [file (ast/file-name ast)\n line (ast/line-number ast)\n reified-type-num (either (.type-num ast)\n (extract type-counter))\n constraint (c/TypeConstraint {reified-type-num #{}} (list [file line])\n (symbol (str \"reified at \" file \": \" line))\n nothing \"\")]\n (for [reify-fn-index (sm/get-val .reify-fn-index)\n _ (sm/set-val .reify-fn-index 0)\n impl-fns (extend-type* ast constraint reified-type-num)\n _ (sm/set-val .reify-fn-index reify-fn-index)\n reified-result (either (map (every impl-fns (partial instance? c-static-arity))\n (fn [_]\n (static-reified-value constraint reified-type-num impl-fns)))\n (closure-reified-value constraint reified-type-num impl-fns))]\n reified-result)))\n\n (emit-defined-value [ast defined-sym]\n (let [x* (ast/tag \"#x\")\n y* (ast/tag \"#y\")\n file-name (ast/file-name ast)\n line-number (ast/line-number ast)\n ast (cond (get-in ast [.impls Eq-sym =*-sym])\n ast\n (assoc-in ast [.impls Eq-sym =*-sym]\n [(ast/fn-arity-ast\n (ast/tag (str defined-sym \"_EQ_QMARK_\") file-name line-number) \"\"\n (ast/params [x* y*]) \"\"\n [(ast/and-ast\n [(ast/call-ast =*-sym\n [(ast/call-ast get-type-sym [x*])\n (ast/call-ast get-type-sym [y*])])\n (ast/call-ast maybe-sym [y*])])]\n (-> c/empty-items-constraint\n (.items-constraints [c/top-type c/top-type]))\n c/top-type)]))]\n (for [value (init-at-runtime ast defined-sym)\n _ (new-module-def defined-sym (c-static-reified (.type-num value)\n (.c-var value) [] {}\n (.constraints value)\n (.c-struct value)))]\n [value])))\n\n (wrap-tail [ast params]\n (Left (TailCall ast params))))\n\n(defn filter-vals [m f]\n (reduce (vec m) {}\n (fn [m [k v]]\n (either (map (f v) (fn [_] (assoc m k v)))\n m))))\n\n(defn decrement-refs [refs-map [var var-refs]]\n (either (update-in refs-map [var] (fn [refs]\n (- refs var-refs)))\n refs-map))\n\n(defn conditional-rt-checks [vars final-subs init-subs file-name line-number]\n (sm/traverse vars\n (fn [var]\n (let [init-c (either (get init-subs var)\n c/top-type)\n final-c (either (get final-subs var)\n c/top-type)]\n (cond (c/satisfied-by final-c init-c)\n (sm/state-maybe [])\n\n (for [checked-var (genlocal 'checked)\n _ (append-constraint var final-c file-name line-number)]\n [\"int \" checked-var \" = 1;\" line-sep\n (runtime-check final-c init-c\n file-name line-number checked-var)\n line-sep \"if(!\" checked-var \"){abort();}\"]))))))\n\n(defprotocol EmitCond\n (emit-cond-clause [clause]\n (let [file-name (ast/file-name clause)\n line-number (ast/line-number clause)]\n (for [syms get-syms\n init-subs (get-subs)\n expr (emit clause)\n final-subs (get-subs)\n curr-const (get-constraint (.c-var expr))\n _ (constrain-var file-name line-number (.c-var expr) maybe-constraint)\n _ (set-syms syms)\n rt-checks (-> expr\n .refs-map\n (dissoc (.c-var expr))\n keys\n (conditional-rt-checks final-subs init-subs file-name line-number))\n checked-var (genlocal 'checked)]\n (cond (= (.c-var expr) \"\")\n expr\n (.init expr [rt-checks\n (.init expr)\n (cond (instance? c-param expr)\n \"\"\n (let [rt-check (-> maybe-constraint\n (c/update-path file-name line-number)\n (c/update-var (.c-var expr))\n (runtime-check curr-const file-name line-number checked-var))]\n (either (empty? rt-check)\n [\"if(1){int \" checked-var \" = 1;\" line-sep\n rt-check\n line-sep \"if(!\" checked-var \"){abort();}}\" line-sep])))]))))))\n\n(extend-type TailCall\n EmitCond\n (emit-cond-clause [clause]\n (emit clause)))\n\n(extend-type Tagged\n EmitCond\n (emit-cond-clause [sym]\n (let [file-name (ast/file-name sym)\n line-number (ast/line-number sym)]\n (for [expr (emit sym)\n curr-const (get-constraint (.c-var expr))\n _ (constrain-var file-name line-number (.c-var expr) maybe-constraint)\n checked-var (genlocal 'checked)]\n (.init expr [(.init expr)\n (cond (instance? c-param expr)\n \"\"\n (let [rt-check (-> maybe-constraint\n (c/update-path file-name line-number)\n (c/update-var (.c-var expr))\n (c/update-sym (ast/untag sym))\n (runtime-check curr-const file-name line-number checked-var))]\n (either (empty? rt-check)\n [\"if(1){int \" checked-var \" = 1;\" line-sep\n rt-check\n line-sep \"if(!\" checked-var \"){abort();}}\" line-sep])))])))))\n\n(defn cond-clause-init [cond-test result-var [init refs-map] clause]\n (assert (instance? Vector init))\n (assert (instance? C-expr clause))\n\n (let [refs-map (-> (.refs-map clause)\n seq\n (reduce refs-map decrement-refs))]\n [(conj init\n [(.init clause)\n result-var \" = \" (.c-var clause) \";\" line-sep\n (either (empty? cond-test)\n [cond-test result-var \",\\\"\\\",0)) {\" line-sep])\n (map (vec refs-map) (fn [[c-sym remaining]]\n (either (and (= 0 remaining)\n (maybe \"\"))\n [\"dec_and_free(\" c-sym \", \" remaining \");\" line-sep])))])\n refs-map]))\n\n(defn clause-inits [evalled-clauses cond-test refs-map result-var]\n (let [[clause-inits] (reduce (butlast evalled-clauses)\n [[] refs-map]\n (partial cond-clause-init cond-test result-var))\n last-clause (either (last evalled-clauses)\n (do\n (print-err \"Booom!!!\")\n (abort)))\n last-init [(.init last-clause)\n (either (= \"\" (.c-var last-clause))\n [result-var \" = \" (.c-var last-clause) \";\" line-sep])]]\n (conj clause-inits last-init)))\n\n(defn clause-refs [exprs result-var]\n (-> (apply merge-with (list* + (map exprs .refs-map)))\n (dissoc result-var)))\n\n(defn emit-and-expr [result-var clauses tail-return]\n (let [file-name (ast/file-name clauses)\n line-number (ast/line-number clauses)]\n (either (map (first clauses)\n (fn [clause]\n (for [expr (emit-cond-clause clause)\n final-subs (get-subs)\n expr-cs (sm/traverse (rest clauses)\n (fn [clause]\n (for [expr (emit-cond-clause clause)\n constraint (get-constraint (.c-var expr))]\n [constraint expr])))\n _ (sm/assoc-in-val [.fn-context .subs] final-subs)\n exprs (sm/traverse expr-cs\n (fn [[c expr]]\n (map (constrain-var file-name line-number (.c-var expr) c)\n (fn [_]\n expr))))\n :let [exprs (comp [expr] exprs)]\n\n last-expr (sm/when (last exprs))\n _ (propogate-constraint (.c-var last-expr) result-var\n identity file-name line-number)\n free-parent (cond (= tail-return \"\")\n (sm/state-maybe \"\")\n\n (free-closure-parent))]\n (let [tail-return [free-parent line-sep tail-return]\n refs-map (clause-refs exprs result-var)]\n (c-init result-var\n [\"Value *\" result-var \";\" line-sep\n (-> exprs\n (clause-inits \"if (isNothing(\" refs-map result-var)\n (interpose [tail-return \"} else {\" line-sep\n \"dec_and_free(\" result-var \", 1);\" line-sep]))\n (-> (count exprs)\n dec\n (repeat (str \"}\" line-sep)))]\n refs-map file-name line-number)))))\n (wrap sm/zero-sm empty-c-code))))\n\n(deftype TailAnd [clauses]\n (assert (instance? Vector clauses))\n\n Stringable\n (string-list [expr]\n (comp (list \"\")))\n\n Container\n (map [x f]\n (TailAnd (map clauses f)))\n\n (map [x f embed]\n (map (map clauses f embed) TailAnd))\n\n ast/FileLineInfo\n (ast/file-name [_]\n (ast/file-name clauses))\n (ast/line-number [_]\n (ast/line-number clauses))\n\n Emitter\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [result-var (genlocal \"andRslt\")\n _ (constrain-var file-name line-number \"#result\" maybe-constraint)\n check-fn (global-var 'checker)\n ;; TODO: test a closure with a TailAnd\n expr (emit-and-expr result-var (remove (.clauses ast) (partial instance? ast/NoCode))\n (str \"return(nothing);\" line-sep))\n result-const (get-constraint \"#result\")\n expr-const (get-constraint (.c-var expr))\n checked-var (genlocal 'checked)\n _ (declare [\"Value *\" check-fn \"(Value *arg){\" line-sep\n (let [rt-check (runtime-check (c/update-var result-const \"arg\")\n expr-const file-name line-number checked-var)]\n (either (empty? rt-check)\n [\"int \" checked-var \" = 1;\" line-sep\n rt-check\n line-sep \"if(!\" checked-var \"){abort();}\"]))\n line-sep \"return(arg);}\" line-sep])\n _ (set-result-constraint (.c-var expr) file-name line-number)]\n expr))))\n\n(extend-type ast/and-ast\n Emitter\n (emit [ast]\n (let [clauses (remove (.clauses ast) (partial instance? ast/NoCode))]\n (flat-map (genlocal \"andRslt\")\n (fn [result-var]\n (emit-and-expr result-var clauses \"\")))))\n\n (wrap-tail [ast params]\n (-> (.clauses ast)\n ;; TODO: move this filtering to the Vector wrap-tail\n (filter ast/generates-code?)\n (tail-call params)\n TailAnd\n Left)))\n\n(defn assert-maybe-of [type-expr]\n (assert (instance? c/ValueConstraint type-expr))\n\n (let [path (list [(ast/file-name type-expr) (ast/line-number type-expr)])]\n (c/MultiConstraint [maybe-constraint (c/CollectionOf type-expr path nothing \"\")])))\n\n(defn emit-or-expr [result-var clauses tail-return]\n (let [file-name (ast/file-name clauses)\n line-number (ast/line-number clauses)]\n (either (map (first clauses)\n (fn [clause]\n (for [expr (emit-cond-clause clause)\n final-subs (get-subs)\n\n expr-cs (sm/traverse (rest clauses)\n (fn [clause]\n (for [expr (emit-cond-clause clause)\n constraint (get-constraint (.c-var expr))]\n [constraint expr])))\n _ (sm/assoc-in-val [.fn-context .subs] final-subs)\n exprs (sm/traverse expr-cs\n (fn [[c expr]]\n (map (constrain-var file-name line-number (.c-var expr) c)\n (fn [_]\n expr))))\n :let [result-c (-> expr-cs\n (map (fn [[c]]\n (c/extract-contents-constraint c)))\n (conj (either (map (get final-subs (.c-var expr))\n c/extract-contents-constraint)\n c/top-type))\n c/sum-type\n assert-maybe-of\n (c/update-path file-name line-number))]\n _ (constrain-var file-name line-number result-var result-c)\n free-parent (cond (= tail-return \"\")\n (sm/state-maybe \"\")\n\n (free-closure-parent))]\n (let [tail-return [free-parent line-sep tail-return]\n exprs (comp [expr]\n (map expr-cs (fn [[_ expr]] expr)))\n refs-map (clause-refs exprs result-var)]\n (c-init result-var\n [\"Value *\" result-var \";\" line-sep\n (-> exprs\n (clause-inits \"if (!isNothing(\" refs-map result-var)\n (interpose [tail-return \"} else {\" line-sep\n \"dec_and_free(\" result-var \", 1);\" line-sep]))\n (-> (count exprs)\n dec\n (repeat (str \"}\" line-sep)))]\n refs-map file-name line-number)))))\n (wrap sm/zero-sm empty-c-code))))\n\n(deftype TailOr [clauses]\n (assert (instance? Vector clauses))\n\n Stringable\n (string-list [expr]\n (comp (list \"\")))\n\n Container\n (map [x f]\n (TailOr (map clauses f)))\n\n (map [x f embed]\n (map (map clauses f embed) TailOr))\n\n ast/FileLineInfo\n (ast/file-name [_]\n (ast/file-name clauses))\n (ast/line-number [_]\n (ast/line-number clauses))\n\n Emitter\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [result-var (genlocal \"orRslt\")\n _ (constrain-var file-name line-number \"#result\" maybe-constraint)\n check-fn (global-var 'checker)\n ;; TODO: test closure with tail or expr\n expr (emit-or-expr result-var (remove (.clauses ast) (partial instance? ast/NoCode))\n (str \"return(\" check-fn \"(\" result-var \"));\" line-sep))\n result-const (get-constraint \"#result\")\n expr-const (get-constraint (.c-var expr))\n checked-var (genlocal 'checked)\n _ (declare [\"Value *\" check-fn \"(Value *arg){\" line-sep\n (let [rt-check (runtime-check (c/update-var result-const \"arg\")\n expr-const file-name line-number checked-var)]\n (either (empty? rt-check)\n [\"int \" checked-var \" = 1;\" line-sep\n rt-check\n line-sep \"if(!\" checked-var \"){abort();}\"]))\n line-sep \"return(arg);}\" line-sep])\n _ (set-result-constraint (.c-var expr) file-name line-number)]\n expr))))\n\n(extend-type ast/or-ast\n Emitter\n (emit [ast]\n (flat-map (genlocal \"orRslt\")\n (fn [result-var]\n (emit-or-expr result-var (remove (.clauses ast) (partial instance? ast/NoCode)) \"\"))))\n\n (wrap-tail [ast params]\n (-> (.clauses ast)\n ;; TODO: move this filtering to the Vector wrap-tail\n (filter ast/generates-code?)\n (tail-call params)\n TailOr\n Left)))\n\n(deftype TailEither [clause alt]\n\n Stringable\n (string-list [expr]\n (list \"(TailEither \" (str clause) \"\\n\" (str alt) \")\"))\n\n Container\n (map [x f]\n (TailEither (f clause) (f alt)))\n\n (map [x f embed]\n (for [new-clause (f clause)\n new-alt (f alt)]\n (TailEither new-clause new-alt)))\n\n ast/FileLineInfo\n (ast/file-name [_]\n (ast/file-name clause))\n (ast/line-number [_]\n (ast/line-number clause))\n\n Emitter\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n ;; TODO: this is so fantastically wrong.\n ;; How does the alt result-var get constrained?\n (for [cond-val (emit-cond-clause clause)\n alt-val (emit alt)\n result-var (genlocal \"tailEither_rslt\")\n result-const (get-constraint \"#result\")\n cond-constraint (get-constraint (.c-var cond-val))\n alt-constraint (get-constraint (.c-var alt-val))\n :let [expr-const (-> (c/sum-type [(c/extract-contents-constraint cond-constraint)\n alt-constraint])\n (c/update-path file-name line-number))]\n _ (constrain-var file-name line-number result-var expr-const)\n _ (set-result-constraint result-var file-name line-number)\n free-parent (free-closure-parent)\n checked-var (genlocal 'checked)]\n (let [cond-rslt (.c-var cond-val)\n refs-map (merge-with + (.refs-map cond-val) (.refs-map alt-val))]\n (c-code result-var\n [(.init cond-val)\n \"Value *\" result-var \";\" line-sep\n \"if (!isNothing(\" cond-rslt \",\\\"\\\",0)) {\" line-sep\n result-var \" = maybeExtract(\" cond-rslt \");\" line-sep\n (map (vec (.refs-map alt-val))\n (fn [[c-sym remaining]]\n (either (and (= 0 remaining)\n (maybe \"\"))\n [\"dec_and_free(\" c-sym \", \" remaining \");\" line-sep])))\n (let [rt-check (runtime-check (c/update-var result-const result-var)\n expr-const file-name line-number checked-var)]\n (either (empty? rt-check)\n [\"int \" checked-var \" = 1;\" line-sep\n rt-check\n line-sep \"if(!\" checked-var \"){abort();}\" line-sep]))\n free-parent\n \"return(\" result-var \");\" line-sep\n \"} else {\" line-sep\n \"dec_and_free(\" cond-rslt \", 1);\" line-sep\n (.init alt-val)\n (either (= \"\" (.c-var alt-val))\n [result-var \" = \" (.c-var alt-val) \";\" line-sep])\n \"}\" line-sep]\n refs-map\n c/top-type))))))\n\n(extend-type ast/either-ast\n Emitter\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [result-var (genlocal \"eitherRslt\")\n cond-val (emit-cond-clause (.clause ast))\n syms get-syms\n alt-val (emit (.alt ast))\n _ (set-syms syms)\n cond-constraint (get-constraint (.c-var cond-val))\n alt-constraint (get-constraint (.c-var alt-val))\n _ (constrain-var file-name line-number result-var\n (c/sum-type [(c/extract-contents-constraint cond-constraint)\n alt-constraint]))]\n (let [cond-rslt (.c-var cond-val)\n refs-map (-> (merge-with + (.refs-map cond-val) (.refs-map alt-val))\n (filter-vals (partial < 0)))]\n (c-init result-var\n [(.init cond-val)\n \"Value *\" result-var \";\" line-sep\n \"if (!isNothing(\" cond-rslt \",\\\"\\\",0)) {\" line-sep\n result-var \" = maybeExtract(\" cond-rslt \");\" line-sep\n (map (vec (.refs-map alt-val))\n (fn [[c-sym remaining]]\n (either (and (= 0 remaining)\n (maybe \"\"))\n [\"dec_and_free(\" c-sym \", \" remaining \");\" line-sep])))\n \"} else {\" line-sep\n \"dec_and_free(\" cond-rslt \", 1);\" line-sep\n (.init alt-val)\n result-var \" = \" (.c-var alt-val) \";\" line-sep\n \"}\" line-sep]\n refs-map file-name line-number)))))\n\n ;; TODO: add back later\n ;; (emit-defined-value [ast defined-sym]\n ;; (for [value (emit ast)\n ;; _ (new-module-def defined-sym value)]\n ;; [value]))\n\n (wrap-tail [ast params]\n (Left (TailEither (.clause ast)\n (tail-call (.alt ast) params)))))\n\n(extend-type ast/cond-val-ast\n EmitCond\n (emit-cond-clause [ast]\n (let [file-name (ast/file-name (.value ast))\n line-number (ast/line-number (.value ast))]\n (for [init-subs (get-subs)\n cond-val (emit-cond-clause (.conditional ast))\n syms get-syms\n final-subs (get-subs)\n value (emit (.value ast))\n value-c (get-constraint (.c-var value))\n final-final-subs (get-subs)\n _ (sm/assoc-in-val [.fn-context .subs] final-subs)\n _ (set-syms syms)\n result-var (genlocal \"cvRslt\")\n _ (constrain-var file-name line-number result-var value-c)\n do-value (genlocal \"doValue\")\n :let [refs-map (-> (merge-with + (.refs-map cond-val) (.refs-map value))\n (filter-vals (partial < 0)))]\n rt-checks (-> (.refs-map cond-val)\n keys\n (conditional-rt-checks final-subs init-subs\n (ast/file-name (.conditional ast))\n (ast/line-number (.conditional ast))))\n value-rt-checks (-> (.refs-map value)\n (dissoc (.c-var value))\n keys\n (conditional-rt-checks final-final-subs final-subs\n (ast/file-name (.value ast))\n (ast/line-number (.value ast))))]\n (c-init result-var\n [rt-checks\n (.init cond-val)\n \"Value *\" result-var \" = \" (.c-var cond-val) \";\" line-sep\n \"int \" do-value \" = !isNothing(\" result-var \",\\\"\\\",0);\" line-sep\n \"if (\" do-value \") {\" line-sep\n \"dec_and_free(\" result-var \", 1);\" line-sep\n value-rt-checks\n (.init value)\n result-var \" = \" (.c-var value) \";\" line-sep\n \"} else {\" line-sep\n (map (vec (.refs-map value)) (fn [[c-sym remaining]]\n (either (and (= 0 remaining)\n (maybe \"\"))\n [\"dec_and_free(\" c-sym \", \" remaining \");\" line-sep])))\n \"}\" line-sep \"if (\" do-value \") {\" line-sep]\n refs-map file-name line-number)))))\n\n(defn emit-cond-expr [ast result-var tail-return]\n (let [[clause & clauses] (.conditionals ast)\n file-name (ast/file-name clause)\n line-number (ast/line-number clause)]\n (for [initial-subs (get-subs)\n expr (emit-cond-clause clause)\n first-const (get-constraint (.c-var expr))\n expr-cs (sm/traverse clauses\n (fn [clause]\n (for [_ (sm/assoc-in-val [.fn-context .subs] initial-subs)\n expr (emit-cond-clause clause)\n constraint (get-constraint (.c-var expr))]\n [constraint expr])))\n clauses-subs (get-subs)\n _ (sm/assoc-in-val [.fn-context .subs] initial-subs)\n default-expr (emit (.default ast))\n default-subs (get-subs)\n def-const (get-constraint (.c-var default-expr))\n default-rt-checks (-> (.refs-map default-expr)\n (dissoc (.c-var default-expr))\n keys\n (conditional-rt-checks default-subs clauses-subs\n (ast/file-name (.default ast))\n (ast/line-number (.default ast))))\n _ (sm/assoc-in-val [.fn-context .subs] initial-subs)\n :let [default-expr (.init default-expr\n [default-rt-checks\n (.init default-expr)])\n exprs (comp [expr]\n (map expr-cs (fn [[_ expr]] expr))\n [default-expr])\n result-c (-> expr-cs\n vec\n (map (fn [[c]] c))\n (comp [def-const first-const])\n c/sum-type\n (c/update-path file-name line-number))]\n _ (constrain-var file-name line-number result-var result-c)\n free-parent (cond (= \"\" tail-return)\n (sm/state-maybe \"\")\n\n (free-closure-parent))]\n (let [refs-map (clause-refs exprs result-var)\n [exprs] (reduce (rest exprs) [[expr ] (.c-var expr)]\n (fn [[exprs prev-var] expr]\n [(conj exprs (.init expr [\"dec_and_free(\" prev-var \", 1);\" line-sep\n (.init expr)]))\n (.c-var expr)]))]\n (c-init result-var\n [\"Value *\" result-var \";\" line-sep\n (-> exprs\n (clause-inits \"\" refs-map result-var)\n (interpose [free-parent line-sep tail-return \"} else {\" line-sep]))\n (-> (count exprs)\n dec\n (repeat (str \"}\" line-sep)))]\n refs-map file-name line-number)))))\n\n(deftype TailCond [conditionals default]\n Stringable\n (string-list [_]\n (list \"(TailCond \" (str conditionals) \" \" (str default) \")\"))\n\n Container\n (map [x f]\n (TailCond (map conditionals f) (f default)))\n\n (map [x f embed]\n (for [new-conds (map conditionals f embed)\n new-default (f default)]\n (TailCond new-conds new-default)))\n\n ast/FileLineInfo\n (ast/file-name [_]\n (ast/file-name conditionals))\n\n (ast/line-number [_]\n (ast/line-number conditionals))\n\n Emitter\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (for [result-var (genlocal \"condRslt\")\n check-fn (global-var 'checker)\n expr (emit-cond-expr ast result-var\n (str \"return(\" check-fn \"(\" result-var \"));\" line-sep))\n result-const (get-constraint \"#result\")\n expr-const (get-constraint (.c-var expr))\n checked-var (genlocal 'checked)\n _ (declare [\"Value *\" check-fn \"(Value *arg){\" line-sep\n (let [rt-check (runtime-check (c/update-var result-const \"arg\")\n expr-const file-name line-number checked-var)]\n (either (empty? rt-check)\n [\"int \" checked-var \" = 1;\" line-sep\n rt-check\n line-sep \"if(!\" checked-var \"){abort();}\"]))\n line-sep \"return(arg);}\" line-sep])\n _ (set-result-constraint (.c-var expr) file-name line-number)]\n expr))))\n\n(extend-type ast/cond-ast\n Emitter\n (emit [ast]\n (flat-map (genlocal \"condRslt\")\n (fn [result-var]\n (emit-cond-expr ast result-var \"\"))))\n\n (wrap-tail [ast params]\n (Left (TailCond (.conditionals ast)\n (tail-call (.default ast) params)))))\n\n(extend-type ast/main-ast\n Emitter\n (emit-definition [ast]\n (for [\n ;; _ (debug \"=======\\n*** \" 'main-fn)\n ;; TODO: add param assertions\n fn-arity (emit-fn-arity (ast/tag 'main) \"\" (.params ast) (.body ast))\n fn-arity (cond (instance? StaticArity fn-arity)\n (-> fn-arity\n .var-info\n .init\n declare\n (map (fn [_]\n (.var-info fn-arity (.init (.var-info fn-arity) [])))))\n\n (sm/state-maybe fn-arity))\n ;; _ (debug \"======= done main\")\n _ (sm/assoc-in-val [.module .values 'main] fn-arity)]\n [empty-c-code])))\n\n\n(defn static-fn [fn-sym fn-var arities]\n (for [struct-var (global-var fn-sym \"fnStruct\")\n :let [arity-count (count arities)\n fn-constraint (c/update-path fn-constraint\n (ast/file-name fn-sym) (ast/line-number fn-sym))]\n _ (constrain-var (ast/file-name fn-sym) (ast/line-number fn-sym)\n fn-var fn-constraint)\n _ (declare [\"Value *\" fn-var \";\\n\"])\n _ (sm/traverse arities (fn [arity]\n (-> arity .var-info .init declare)))\n _ (declare [\"Function \" struct-var \" = {FunctionType, -2, \\\"\"\n fn-sym \"\\\", \" arity-count \", \"\n \"{\" (-> arities\n (map (fn [arity]\n (-> arity .var-info .c-var)))\n (interpose \", \")\n (to-str))\n \"}};\\n\"\n \"Value *\" fn-var \" = (Value *)&\" struct-var \";\\n\\n\"])]\n (let [arities (map arities (fn [arity]\n (.var-info arity (.init (.var-info arity) []))))]\n (cond\n (= fn-sym 'list)\n (c-list-fn fn-var [] {} struct-var)\n\n (= fn-sym 'maybe)\n (c-maybe-fn fn-var [] {} struct-var)\n\n (= fn-sym 'vector)\n (c-vector-fn fn-var [] {} struct-var)\n\n (c-static-fn fn-var [] {} struct-var\n (reduce arities {}\n (fn [m arity]\n (assoc m (.param-count arity) arity))))))))\n\n(defn closure-fn [fn-sym fn-var arities]\n (for [_ (sm/when (some arities (partial instance? ClosureArity)))\n struct-var (global-var fn-sym \"fnStruct\")\n line (line-macro fn-sym (str \"// creating \" fn-sym))\n _ (declare (-> arities\n (filter (partial instance? StaticArity))\n (map (fn [arity]\n (-> arity\n .var-info\n .init)))))]\n (let [emitted-arities (map arities (fn [arity]\n (either (map (instance? StaticArity arity)\n (fn [arity]\n (-> arity\n .var-info\n (.init []))))\n (.var-info arity))))\n arity-count (count arities)]\n (c-closure-fn (str fn-var)\n [(map emitted-arities .init)\n line \"Function *\" struct-var \" = malloc_function(\" arity-count \");\" line-sep\n \"Value *\" fn-var \" = (Value *)\" struct-var \";\" line-sep\n struct-var \"->name = \\\"\" fn-sym \"\\\";\" line-sep\n struct-var \"->arityCount = \" arity-count \";\" line-sep\n (map (zip-lists (map emitted-arities .c-var)\n (range arity-count))\n (fn [[sym index]]\n [sym \"->parent = \" fn-var \";\" line-sep\n struct-var \"->arities[\" index \"] = \" sym \";\" line-sep]))]\n (apply merge-with (list* + (map emitted-arities .refs-map)))\n (reduce arities {}\n (fn [m arity]\n (assoc m (.param-count arity) arity)))\n (ast/file-name fn-sym) (ast/line-number fn-sym)))))\n\n(defn call-universal-proto-fn [fn-sym disp-arg args]\n (let [args (cons disp-arg args)]\n [\"Value *protoRslt;\\n\"\n \"if (universalProtoFn != 0){\\n\"\n \" List *args = empty_list;\\n\"\n (to-str (flat-map (reverse args)\n (fn [arg]\n (list \" args = listCons(\" \"(Value *)\" arg \", args);\\n\"))))\n \" args = listCons(symbol(stringValue(\\\"\" fn-sym \"\\\")), args);\\n\"\n \" args = listCons(stringValue(\\\"\" (ast/file-name fn-sym) \"\\\"), args);\\n\"\n \" protoRslt = fnApply(universalProtoFn, (Value *)args);\\n\"\n \" if (protoRslt->type == MaybeType && !isNothing(protoRslt,\\\"\\\",0)) {\\n\"\n \" Value *result = ((Maybe *)protoRslt)->value;\\n\"\n \" incRef(result, 1);\\n\"\n \" dec_and_free(protoRslt, 1);\\n\"\n \" dec_and_free(\" disp-arg \", 1);\\n\"\n \" return(result);\\n\"\n \"}\\n} else {\\n\"\n (flat-map args (fn [arg]\n (list\n \" dec_and_free(\" arg \", 1);\\n\")))\n \"protoRslt = nothing;}\\n\"]))\n\n(deftype InsertCode [fn-sym prototype]\n Stringable\n (string-list [_]\n (list \"\"))\n\n Container\n (map [x f]\n (InsertCode fn-sym (f prototype)))\n\n (map [x f]\n (map (f prototype)\n (partial InsertCode fn-sym)))\n\n Emitter\n (emit [_]\n (let [num-args (-> prototype .params .fixed count)\n [disp-arg & args] (map (zip-lists (-> prototype .params .fixed)\n (range num-args))\n (fn [[arg idx]]\n (check-C-var (str arg \"_\" idx) (str \"arg\" idx))))]\n (sm/state-maybe (c-code \"protoRslt\"\n [(call-universal-proto-fn fn-sym disp-arg args)]\n (reduce args {disp-arg 1}\n (fn [m arg]\n (assoc m arg 1)))\n c/top-type)))))\n\n(defn missing-impl-body [proto-sym fn-sym prototype]\n (let [num-args (-> prototype .params .fixed count)\n [disp-arg & args] (map (zip-lists (-> prototype .params .fixed)\n (range num-args))\n (fn [[arg idx]]\n (check-C-var (str arg \"_\" idx) (str \"arg\" idx))))]\n (comp (filter (.default-body prototype) (partial instance? c/Constraints))\n [(c-code \"\"\n [\"incRef(\" disp-arg \", 1);\"\n ;; TODO: maybe use 'InsertCode' instead\n (call-universal-proto-fn fn-sym disp-arg args)\n (line-marker (ast/file-name fn-sym) (ast/line-number fn-sym) \"\")\n \"if (arity != (FnArity *)0) {\"\n \"fprintf(stderr,\\\"*** Could not find implementation of '\" proto-sym \"/\" fn-sym\n \"' for type '%s' with %d arguments %s\\\\n\\\", \"\n \"((String *)type_name((FnArity *)0, \" disp-arg \"))->buffer, \" num-args\n \", ((String *)arity)->buffer);abort();\"\n \"} else {\"\n \"fprintf(stderr,\\\"*** Could not find implementation of '\" proto-sym \"/\" fn-sym\n \"' for type '%s' with %d arguments.\\\\n\\\", \"\n \"((String *)type_name((FnArity *)0, \" disp-arg \"))->buffer, \" num-args \");abort();\"\n \"}\"]\n (reduce args {disp-arg 1}\n (fn [m arg]\n (assoc m arg 1)))\n c/top-type)])))\n\n(defn emit-proto-default [protocol-sym fn-sym disp-fn-var prototype]\n (let [default-body (missing-impl-body protocol-sym fn-sym prototype)\n default-constraints (filter (.default-body prototype)\n (partial instance? c/Constraints))\n body (remove (.default-body prototype) (partial instance? ast/NoCode))\n arity-ast (ast/fn-arity (.params prototype) \"\"\n (cond (empty? body)\n default-body\n body))\n params (.params prototype)\n default-fn-sym (str \"Default_\" fn-sym)]\n (for [arity-impl-var (map (global-var default-fn-sym \"arityImpl\")\n ProtoDispFnPtr)\n fn-context (reset-fn-context)\n\n ;; create vars for all the parameters\n p-bindings (bind-param params)\n\n ;; clear any constraints for the parameter vars\n _ (-> p-bindings\n (map .bound)\n (sm/traverse (fn [var]\n (set-constraint var c/top-type))))\n\n ;; constrain those vars with the given assertions\n _ (sm/traverse default-constraints emit)\n\n ;; save the constraints specified for the parameters\n pcs (get-param-constraints params)\n _ (reset-fn-context fn-context)\n\n ;; compute the given result constraints\n result-constraint (-> (.default-body prototype)\n (filter (partial instance? c/ResultConstraint))\n (map .assertion)\n (sm/traverse lookup-constraint)\n (map (fn [result-constraints]\n (reduce result-constraints c/top-type c/intersect))))\n\n ;; emit the default proto function\n static-arity (emit-fn-arity (symbol default-fn-sym) disp-fn-var params\n (comp default-constraints\n (cond (empty? body)\n default-body\n [(ast/either-ast\n (InsertCode fn-sym prototype)\n (ast/let-ast [] body))]))\n arity-impl-var)\n static-arity (cond (instance? StaticArity static-arity)\n (-> static-arity\n .var-info\n .init\n declare\n (map (fn [_]\n (.var-info static-arity (.init (.var-info static-arity) [])))))\n\n (compilation-error \"Compiler error! Default proto impl must be a static arity.\"))\n\n :let [param-count (.param-count static-arity)\n default-impl (ProtoImpl 0 (.c-var (.var-info static-arity)) arity-ast\n pcs result-constraint arity-impl-var)]\n\n _ (sm/update-in-val [.module .values fn-sym .arities param-count]\n (fn [static-arity]\n (assert (instance? StaticArity static-arity))\n (-> static-arity\n (.result-constraint result-constraint)\n (.param-constraints pcs))))\n\n ;; this is the info used to emit the implementations\n _ (comp (sm/update-in-val [.module .protocols\n (ast/untag protocol-sym) (ast/untag fn-sym)]\n (fn [p-disp]\n (assert (instance? ProtoDispatcher p-disp))\n (assoc-in p-disp [.p-impls param-count 0]\n default-impl)))\n (sm/assoc-in-val [.module .protocols\n (ast/untag protocol-sym) (ast/untag fn-sym)]\n (ProtoDispatcher (ast/untag fn-sym)\n (cond (= 'core (ast/file-name protocol-sym))\n \"\"\n (ast/file-name protocol-sym))\n {param-count {0 default-impl}})))]\n static-arity)))\n\n(defn create-dispatcher [proto-sym [fn-sym arities]]\n (for [_ (emit (ast/quoted-ast proto-sym))\n _ (emit (ast/quoted-ast fn-sym))\n\n fn-var (comp (map (lookup-declaration fn-sym) .c-var)\n (global-var (str \"dispFn_\" fn-sym) \"fn\"))\n _ (new-module-def fn-sym (c-protocol-fn fn-var [] {} \"\" proto-sym {}))\n arities-info (sm/traverse arities\n (fn [arity]\n (let [params (.params arity)\n arg-count (count params)\n param-cs (-> c/empty-items-constraint\n (.items-constraints (repeat arg-count c/top-type)))]\n (for [c-fn (global-var (str \"disp_\" fn-sym) \"dispatcher\")\n _ (sm/assoc-in-val [.module .values\n fn-sym .arities arg-count]\n ;; TODO: removing the ProtoDispFnPtr causes a\n ;; useless error message because of inlining\n (StaticArity fn-var (ProtoDispFnPtr c-fn)\n params arg-count\n ;; TODO: what should be here? Is it used?\n empty-c-code\n param-cs\n c/top-type))]\n [\"Value *\" c-fn \"(\"\n (-> (map (range arg-count) (partial str \"Value *arg\"))\n (conj \"FnArity *arity\")\n (interpose \", \"))\n \");\\n\"]))))\n _ (declare [\"\\n// proto fn for \" proto-sym \"/\" fn-sym \"\\n\"\n \"\\n// --------- \" fn-sym \" -------------\\n\"\n \"Value *\" fn-var \";\\n\"\n arities-info])]\n []))\n\n(extend-type ast/protocol-ast\n Emitter\n (emit-definition [ast]\n (let [proto-name (.protocol-sym ast)\n prototypes (-> (.prototypes ast)\n (reduce {}\n (fn [m prototype]\n (either (update m (.fn-name prototype)\n (fn [prototypes]\n (conj prototypes prototype)))\n (assoc m (.fn-name prototype) [prototype]))))\n (vec))]\n (for [_ (comp (flat-map (lookup-protocol proto-name)\n (fn [_]\n (compilation-error \"Duplicate protocol\"\n (str \"'\" proto-name \"'\") \"at\"\n (str (ast/file-name proto-name) \":\")\n (ast/line-number proto-name))))\n sm-nop)\n _ (sm/traverse prototypes\n (partial create-dispatcher proto-name))\n _ (sm/traverse prototypes\n (fn [[fn-sym arities]]\n (flat-map (map (lookup-sym fn-sym) .c-var)\n (fn [fn-var]\n (sm/traverse arities (partial emit-proto-default proto-name\n fn-sym fn-var))))))]\n [empty-c-code]))))\n\n(extend-type ast/fn-arity-ast\n Emitter\n (update-syms [ast _]\n (for [_ (sm/update-state (fn [subs-list]\n (either (map (first subs-list)\n (fn [head]\n (cons head subs-list)))\n (list {}))))]\n (Right ast)))\n\n (pop-subs [ast]\n (map (sm/update-state rest)\n (fn [_]\n ast)))\n\n (emit [ast]\n ;; TODO: doesn't look like the arity's ast gets saved\n (emit-fn-arity (cond (= \"\" (.fn-sym ast))\n 'anon\n (.fn-sym ast))\n (str (.fn-var ast)) (.params ast) (.body ast)))\n\n (inline-expr [ast arg-asts]\n (let [file-name (ast/file-name arg-asts)\n line-number (ast/line-number arg-asts)\n fixed-args (take arg-asts (count (.fixed (.params ast))))\n new-bindings (make-bindings (.fixed (.params ast)) fixed-args)\n new-bindings (either (map (.variadic (.params ast))\n (fn [var-args]\n (conj new-bindings\n (ast/binding-ast\n var-args\n (ast/call-ast list-sym\n (-> arg-asts\n (drop (count (.fixed (.params ast))))\n vec))))))\n new-bindings)\n ;; TODO: put this back in later, we're tryint to tag all the symbols in the arity for\n ;; better error messages\n ;; tagged-bindings (reduce (all-symbols new-bindings) {}\n ;; (fn [m sym]\n ;; (either (instance? Tagged sym)\n ;; (print-err 'boom new-bindings))\n\n ;; (assoc m\n ;; (ast/untag sym) (ast/tag sym file-name line-number))))\n ;; inlined-expr (replace-syms (ast/let-ast new-bindings\n ;; (remove (.body ast) (partial instance? c/ResultConstraint)))\n ;; tagged-bindings)\n inlined-expr (ast/let-ast new-bindings\n (remove (.body ast) (partial instance? c/ResultConstraint)))\n result-constraint (-> (.body ast)\n (filter (partial instance? c/ResultConstraint))\n (map .assertion)\n (reduce c/top-type c/intersect))]\n (cond (= c/top-type result-constraint)\n (sm/state-maybe inlined-expr)\n\n (sm/state-maybe (ConstrainedAST inlined-expr result-constraint))))))\n\n\n(extend-type ast/fn-ast\n Emitter\n (emit [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)]\n (either (map (.fn-sym ast)\n (fn [fn-sym]\n (for [;; _ (debug \"=========\")\n ;; _ (debug 'fn-sym fn-sym (ast/file-name fn-sym) (ast/line-number fn-sym))\n fn-var (comp (map (lookup-declaration fn-sym) .c-var)\n (global-var fn-sym \"fn\"))\n _ (declare [\"\\n// --------- \" fn-sym \" -------------\\n\"])\n _ (constrain-var file-name line-number fn-var fn-constraint)\n arities (sm/traverse (map (.arities ast) (fn [arity]\n (-> arity\n (.fn-sym fn-sym)\n (.fn-var fn-var))))\n emit)\n fn-expr (comp (closure-fn fn-sym fn-var arities)\n (static-fn fn-sym fn-var arities))\n ;; _ (debug \"---------\")\n ]\n fn-expr)))\n (let [fn-sym (symbol (str \"anonymous function at \" (ast/file-name ast) \": \" (ast/line-number ast)))]\n (for [fn-var (global-var \"fn\")\n ;; _ (declare [\"Value *\" fn-var \";\\n\"])\n _ (constrain-var file-name line-number fn-var fn-constraint)\n arities (sm/traverse (.arities ast) emit)\n fn-expr (comp (closure-fn fn-sym fn-var arities)\n (static-fn fn-sym fn-var arities))]\n fn-expr)))))\n\n (emit-defined-value [fn-val defined-sym]\n (for [value (emit fn-val)\n _ (new-module-def defined-sym (-> value\n (.init [])\n (.refs-map {})))]\n [value]))\n\n (wrap-tail [x params]\n (Left (TailCall x params)))\n\n (inline-expr [ast arg-asts]\n (either (or (map (.fn-sym ast) (fn [_]\n sm/zero-sm))\n (map (-> (.arities ast)\n (filter (fn [arity]\n (= (count arg-asts) (count (.params arity)))))\n first)\n (fn [arity]\n (inline-expr arity arg-asts))))\n sm/zero-sm)))\n\n(extend-type ast/extend-ast\n Emitter\n (emit-definition [ast]\n (let [type-sym (.type ast)]\n (comp (for [constraint (lookup-constraint (c/TypeConstraint {} empty-list type-sym nothing \"\"))\n fns (flat-map (get-type-sym-info type-sym)\n (fn [constraint]\n (-> (either (c/extract-type-map constraint)\n {})\n keys\n (sm/traverse (partial extend-type* ast constraint))\n (map flatten))))]\n fns)\n (compilation-error \"Could not extend type: \"\n (str \"'\" type-sym \"'\") \"at\"\n (str (ast/file-name (.type ast)) \":\")\n (ast/line-number (.type ast)))))))\n\n\n(defn emit-constructor [new-type-name type-num new-type-constraint fields assertions]\n (assert (instance? ast/tagged-symbol new-type-name))\n (assert (instance? c/TypeConstraint new-type-constraint))\n (assert (instance? (vector-of Symbol) fields))\n (assert (instance? c/ItemsConstraint assertions))\n\n (let [file-name (ast/file-name new-type-name)\n line-number (ast/line-number new-type-name)\n x* (ast/tag \"#x\" file-name line-number)\n y* (ast/tag \"#y\" file-name line-number)\n field-count (count fields)\n args (map (range field-count)\n (fn [n]\n (ast/tag (str \"arg\" n))))\n args-map (reduce (zip-lists fields args) {}\n (fn [m [k v]]\n (cond (= k v)\n m\n (assoc m k v))))\n assertions (replace-syms assertions args-map)\n reified-type-num (extract type-counter)\n ast (ast/reified (maybe reified-type-num)\n {(ast/tag Eq-sym file-name line-number)\n {(ast/tag =*-sym file-name line-number)\n [(ast/fn-arity-ast\n (ast/tag (str new-type-name \"_EQ_QMARK_\") file-name line-number) \"\"\n (ast/params [x* y*]) \"\"\n [(ast/and-ast\n [(ast/call-ast =*-sym\n [type-num\n (ast/call-ast get-type-sym [y*])])\n (ast/call-ast maybe-sym [y*])])]\n c/empty-items-constraint c/top-type)]}\n\n (ast/tag Type-sym file-name line-number)\n {type-name-sym\n [(ast/fn-arity-ast\n (ast/tag (str new-type-name \"_const_type_name\") file-name line-number) \"\"\n (ast/params [(ast/tag '_)]) \"\"\n [(str \"* \" new-type-name \" constructor at \" file-name \": \" line-number \" *\")]\n c/empty-items-constraint c/top-type)]\n type-mapping-sym\n [(ast/fn-arity-ast\n (ast/tag (str new-type-name \"_const_type_map\") file-name line-number) \"\"\n (ast/params [(ast/tag '_)]) \"\"\n [(map-vals (.type-maps new-type-constraint)\n (fn [field-set]\n (map field-set ast/quoted-ast)))]\n c/empty-items-constraint c/top-type)]\n\n instance?-sym\n [(ast/fn-arity-ast\n (ast/tag (str new-type-name \"_instance_QMARK_\") file-name line-number) \"\"\n (ast/params [x* y*]) \"\"\n [(-> maybe-constraint\n (c/intersect (c/InferredInner new-type-constraint empty-list nothing \"\"))\n c/ResultConstraint)\n (ast/and-ast\n [(ast/call-ast =*-sym\n [type-num\n (ast/call-ast get-type-sym [y*])])\n (ast/call-ast maybe-sym [y*])])]\n c/empty-items-constraint c/top-type)]}\n\n (ast/tag Function-sym file-name line-number)\n {invoke-sym\n [(ast/fn-arity-ast\n (ast/tag (str new-type-name \"_invoke\") file-name line-number) \"\"\n (ast/params (comp [(ast/tag '_)] args)) \"\"\n (comp [(c/ResultConstraint (-> (c/DynamicFields empty-list nothing \"\")\n (c/update-sym (symbol \"#result\"))))]\n (c/extract-items-constraints assertions (count fields))\n [(c/update-var new-type-constraint \"#result\")\n (ast/inline-ast (ast/tag 'C)\n new-type-constraint\n (str \"ReifiedVal *rv = malloc_reified(\"\n field-count \");\\n\"\n \"#ifdef SINGLE_THREADED\\n\"\n \"rv->refs = refsInit;\\n#else\\n\"\n \" __atomic_store(&rv->refs,\"\n \" &refsInit, __ATOMIC_RELAXED);\\n\"\n \"#endif\\n\"\n \"rv->type = \" type-num \";\\n\"\n (to-str (map (range field-count)\n (fn [idx]\n (str \"rv->impls[\" idx \"] = arg\" idx\n \"_\" (inc idx) \";\\n\"))))\n \"return((Value *)rv);\\n\")\n \"\" 0)])\n c/empty-items-constraint c/top-type)]}\n\n (ast/tag Container-sym file-name line-number)\n {apply-sym\n [(ast/fn-arity-ast\n (ast/tag (str new-type-name \"_apply_ST_\") file-name line-number) \"\"\n (ast/params [(ast/tag '_) (ast/tag 'fields)]) \"\"\n [(-> assertions\n (c/intersect seq-constraint)\n (c/update-path file-name line-number)\n (c/update-var \"fields_1\"))\n\n (ast/inline-ast (ast/tag 'C)\n new-type-constraint\n (str \"return(newTypeValue(\" type-num \", (Vector *)fields_1));\")\n \"\" 0)]\n c/empty-items-constraint c/top-type)]}\n\n (ast/tag Stringable-sym file-name line-number)\n {string-list-sym\n [(ast/fn-arity (ast/params [(ast/tag 'z)]) \"\"\n [(ast/call-ast list-sym\n [\"\"])])]}})]\n (for [value (init-at-runtime ast new-type-name)\n _ (new-module-def new-type-name (c-constructor (.c-var value) [] {}\n (.constraints value)\n (.c-struct value)\n type-num fields))]\n [value])))\n\n(defn default-type-impls [type-sym type-num fields]\n (let [x* (ast/tag \"#x\")\n y* (ast/tag \"#y\")\n file-name (ast/file-name type-sym)\n line-number (ast/line-number type-sym)\n field* (ast/tag \"#field\")\n ctxt* (ast/tag \"#ctxt\")]\n {Type-sym\n [[type-name-sym\n [(ast/fn-arity-ast\n (ast/tag (str type-sym \"_type_name\") file-name line-number) \"\"\n (ast/params [x*]) \"\"\n [(str type-sym)]\n c/empty-items-constraint c/top-type)]]\n [has-field-sym\n [(ast/fn-arity-ast\n (ast/tag (str type-sym \"_has_field\") file-name line-number) \"\"\n (ast/params [x* field*]) \"\"\n [(ast/or-ast\n (conj (map fields\n (fn [field]\n (ast/call-ast identical-sym\n [(ast/tag (str \".\" field))\n field*])))\n nothing-sym))]\n c/empty-items-constraint c/top-type)]]]\n\n Eq-sym\n [[=*-sym\n [(ast/fn-arity-ast\n (ast/tag (str type-sym \"_EQ_STAR_\") file-name line-number) \"\"\n (ast/params [x* y*]) \"\"\n [(ast/and-ast\n [(ast/call-ast\n =*-sym [(ast/call-ast get-type-sym [x*])\n (ast/call-ast get-type-sym [y*])])\n (ast/call-ast\n =*-sym [(ast/call-ast default-type-args-sym [x*])\n (ast/call-ast default-type-args-sym [y*])])\n (ast/call-ast maybe-sym [x*])])]\n c/empty-items-constraint c/top-type)]]]\n\n Associative-sym\n [[get-symb\n [(ast/fn-arity-ast\n (ast/tag (str type-sym \"_get\") file-name line-number) \"\"\n (ast/params [x* field*]) \"\"\n [(c-code \"\" [\"// TODO: this seems to do runtime checks for 'has-field' result\\n// and the result returned\\n\"]\n {} c/top-type)\n (ast/and-ast\n [(ast/call-ast has-field-sym [x* field*])\n (ast/call-ast maybe-sym\n [(ast/call-ast field* [x*])])])]\n c/empty-items-constraint c/top-type)]]\n\n [assoc-sym\n [(ast/fn-arity-ast\n (ast/tag (str type-sym \"_assoc_\") file-name line-number) \"\"\n (ast/params [x* field* (ast/tag 'new-value)]) \"\"\n [(ast/cond-ast\n [(ast/cond-val-ast (ast/call-ast has-field-sym [x* field*])\n (ast/call-ast field* [x* 'new-value]))]\n x*)]\n c/empty-items-constraint c/top-type)]]]\n\n Hashable-sym\n [[sha1-update-sym\n [(ast/fn-arity-ast\n (ast/tag (str type-sym \"_sha1_update\") file-name line-number) \"\"\n (ast/params [x* ctxt*]) \"\"\n [(ast/call-ast sha1-update-type-sym [x* ctxt*])\n (ast/call-ast\n sha1-update-sym\n [(ast/call-ast default-type-args-sym [x*]) ctxt*])]\n c/empty-items-constraint c/top-type)]]\n [sha1-sym\n [(ast/fn-arity-ast\n (ast/tag (str type-sym \"_sha1\") file-name line-number) \"\"\n (ast/params [x*]) \"\"\n [(ast/call-ast\n sha1-finalize-sym\n [(ast/call-ast\n sha1-update-sym\n [x* (ast/call-ast sha1-init-sym [])])])]\n c/empty-items-constraint c/top-type)]]]}))\n\n(defn declare-getter [getter-sym]\n (let [tagged-getter (ast/tag getter-sym)\n arities [(ast/prototype tagged-getter\n (ast/params [(ast/tag \"#x\")])\n (ast/block-comment \"\" 0 [])\n [(c/FieldConstraint getter-sym \"\" empty-list (maybe (symbol \"#x\")) \"\")])\n (ast/prototype tagged-getter\n (ast/params [(ast/tag \"#x\") (ast/tag \"#y\")])\n (ast/block-comment \"\" 0 [])\n [(c/FieldConstraint getter-sym \"\" empty-list (maybe (symbol \"#x\")) \"\")])]]\n (flat-map (sm/get-in-val [.module .index])\n (fn [curr-mod]\n (comp (sm/get-in-val [.module .protocols 'Type tagged-getter])\n (for [_ (create-dispatcher Type-sym [tagged-getter arities])\n fn-var (map (lookup-sym tagged-getter) .c-var)\n _ (sm/traverse arities (partial emit-proto-default Type-sym\n tagged-getter fn-var))]\n '_))))))\n\n(defn declare-getters [new-type-name fields]\n (comp (for [curr-mod (sm/get-in-val [.module .index])\n _ (cond (= 0 curr-mod)\n (sm/traverse fields\n (fn [field]\n (declare-getter (symbol (str \".\" field)))))\n (let [prom (promise)]\n (map (get (extract modules) 'core)\n (fn [ast-emitter]\n (send ast-emitter\n (fn [ctxt]\n (update-context\n ctxt\n (map (sm/traverse\n fields\n (fn [field]\n (let [getter-sym (symbol (str \".\" field))]\n (for [_ (declare-getter getter-sym)\n _ (map (sm/get-in-val [.fn-context .decl]) write-strings)\n _ (sm/assoc-in-val [.fn-context .decl] [])\n proto (sm/get-in-val [.module .protocols 'Type getter-sym])\n disp (lookup-sym (ast/tag getter-sym))]\n (send core-agent\n (fn [mod]\n (either (and (get-in mod [.values (ast/tag getter-sym)])\n (maybe mod))\n (-> mod\n (assoc-in [.values (ast/tag getter-sym)]\n disp)\n (assoc-in [.protocols 'Type getter-sym]\n proto)))))))))\n (partial deliver prom)))))))\n (sm/state-maybe (extract prom))))]\n '_)))\n\n(defn create-getters [sym fields field-constraints]\n (let [type-value (ast/tag \"#value\")\n field-arg (ast/tag \"#field\")\n file-name (ast/file-name sym)\n line-number (ast/line-number sym)]\n {Type-sym\n (map (zip-lists (seq fields) (range (count fields)) field-constraints)\n (fn [[field field-index field-constraint]]\n (let [field-constraint (c/update-path field-constraint\n (ast/file-name sym) (ast/line-number sym))]\n [(ast/tag (str \".\" field) file-name line-number)\n [(ast/fn-arity-ast\n (ast/tag (str sym \"_\" field) file-name line-number) \"\"\n (ast/params [type-value field-arg]) \"\"\n [(c/update-sym field-constraint (ast/untag field-arg))\n ;; TODO: add replacing of dynamic field constraint\n (ast/inline-ast (ast/tag 'C)\n (c/TypeConstraint {} empty-list sym nothing \"\")\n (str \"return(updateField(value_0, field_1, \"\n field-index \"));\\n\")\n \"\" 0)]\n c/empty-items-constraint c/top-type)\n (let [field-constraint (-> field-constraint\n (c/intersect (c/DynamicItemConstraint 0 field-index\n empty-list nothing \"\"))\n c/clear-sym)]\n (ast/fn-arity-ast\n (ast/tag (str sym \"_\" field) file-name line-number) \"\"\n (ast/params [type-value]) \"\"\n [(ast/inline-ast (ast/tag 'C) field-constraint\n (str \"\n Value *result = incRef(((ReifiedVal *)value_0)->impls[\" field-index \"], 1);\n dec_and_free(value_0, 1);\n return(result);\n\")\n \"\" 0)]\n c/empty-items-constraint c/top-type))]])))}))\n\n(defn destruct-impl-fields [type-const field-constraints ast arity]\n (assert (instance? ast/type-ast ast))\n (assert (instance? ast/fn-arity-ast arity))\n\n (let [[type-value-parameter] (.fixed (.params arity))\n fields (.fixed (.fields ast))\n field-count (count fields)\n body-exprs (remove (.body arity) (partial instance? c/Constraints))\n body-exprs (either (flat-map (last body-exprs)\n (fn [last-expr]\n (store body-exprs (dec (count body-exprs))\n (CollectFieldConsts (.fields ast) last-expr))))\n body-exprs)\n new-body (comp (filter (.body arity) (partial instance? c/Constraints))\n [(ConstrainVar (c/update-sym type-const (ast/untag type-value-parameter)))\n (-> (zip-lists fields (range field-count))\n (map (fn [[field-sym index]]\n (assert (instance? Integer index))\n\n (ast/binding field-sym\n (ast/call-ast get-field-sym\n [type-value-parameter index]))))\n vec\n (ast/let-ast (-> (c/extract-items-constraints field-constraints)\n (zip-lists fields (range field-count))\n (map (fn [[field-c field-sym field-index]]\n (ConstrainVar\n (c/intersect field-c\n (c/DynamicItemConstraint\n 0 field-index\n empty-list\n (maybe (ast/untag field-sym))\n (c/extract-var field-c))))))\n vec\n (comp body-exprs))))])]\n (-> arity\n (.body new-body)\n (.fn-sym (-> ast\n .sym\n (str \"_\" fn-name)\n (ast/tag (ast/file-name ast) (ast/line-number ast)))))))\n\n(defn destructure-fields [type-const field-constraints ast]\n (let [impls (comp* {} (-> (.impls ast)\n (filter (partial instance? HashMap))))]\n (map-vals impls\n (fn [impl-arities]\n (map (vec impl-arities)\n (fn [[fn-name arities]]\n [fn-name (map arities\n (partial destruct-impl-fields type-const field-constraints ast))]))))))\n\n(def pre-defed-types {'HashSet c/HashSetType\n 'ProtoDispatcher c/ProtoDispatcherType\n 'TypeConstraint c/TypeConstraintType\n 'NoValues c/NoValuesType\n 'AllValues c/AllValuesType\n 'MultiConstraint c/MultiConstraintType\n 'ResultConstraint c/ResultConstraintType\n 'ItemsConstraint c/ItemsConstraintType\n 'FieldConstraint c/FieldConstraintType\n 'StaticIntConstraint c/StaticIntConstraintType\n 'MinValue c/MinValueType\n 'MaxValue c/MaxValueType\n 'InferredInner c/InferredInnerType\n 'StaticLengthConstraint c/StaticLengthConstraintType\n 'StaticStrConstraint c/StaticStrConstraintType\n 'ContentsConstraint c/ContentsConstraintType\n 'SumConstraint c/SumConstraintType})\n\n(defn new-type-number [type-symbol]\n (assert (instance? Tagged type-symbol))\n (either (get pre-defed-types type-symbol)\n (extract type-counter)))\n\n(extend-type ast/type-ast\n Emitter\n (emit-definition [ast]\n (let [file-name (ast/file-name ast)\n line-number (ast/line-number ast)\n sym (ast/untag (.sym ast))\n fields (-> (.fields ast)\n .fixed\n (map ast/untag))\n const-arity-index (inc (count fields))\n field-assertions (filter (.impls ast) (partial instance? c/ValueConstraint))]\n (comp (for [_ (comp (sm/get-in-val [.module .types sym])\n (sm/when (get-in (extract core-agent) [.types sym])))\n _ (compilation-error (str \"Trying to re-define type name: '\" sym \"' in module \"\n (cond (= file-name 'core)\n \"$TOCCATA_DIR/core.toc\"\n file-name)\n \", \" line-number))]\n \"\")\n\n (let [type-num (new-type-number sym)\n type-map {type-num (-> fields\n (map (fn [name]\n (symbol (str \".\" name))))\n set)}\n new-type-constraint (c/TypeConstraint type-map (list [file-name line-number])\n (.sym ast) nothing \"\")]\n (for [_ (emit-definition (ast/declaration-ast (.sym ast)))\n _ (sm/assoc-in-val [.module .types sym] new-type-constraint)\n _ (sm/assoc-in-val [.constants .type-names type-num] (str sym))\n _ (declare-getters sym fields)\n\n ;; TODO: this whole section is bogus\n field-assertions (sm/traverse field-assertions lookup-constraint)\n :let [field-map (reduce field-assertions\n {} (fn [m c]\n (validate-field c m fields file-name line-number)))\n field-constraints (c/ItemsConstraint\n (map fields (fn [field]\n (either (get field-map field)\n c/top-type)))\n c/coll-of-any\n empty-list (maybe (symbol (str sym \" fields\"))) \"\")\n impls (merge-with comp\n (default-type-impls sym type-num fields)\n (destructure-fields new-type-constraint field-constraints ast))\n impl-arities (for [[proto-sym impl-fns] (vec impls)\n [fn-name arities] (vec impl-fns)\n impl-arity arities]\n [proto-sym fn-name (.fn-var impl-arity (str (.fn-var impl-arity)))])]\n _ (sm/assoc-in-val [.fn-context .field-constrs] (maybe field-constraints))\n\n impl-arities (sm/traverse impl-arities (partial declare-impl (str sym) type-num))\n _ (sm/traverse impl-arities\n (partial emit-impl (str sym) new-type-constraint type-num))\n new-field-constrs (sm/get-in-val [.fn-context .field-constrs])\n :let [field-constraints (either (map new-field-constrs\n (fn [fc]\n (-> fc\n (c/update-var \"\")\n (c/update-sym (symbol (str sym \" fields\")))\n (.items-constraints (map (.items-constraints fc)\n (fn [c]\n (c/update-var c \"\")))))))\n field-constraints)\n\n field-constraints (promote-inferred field-constraints)\n getter-arities (create-getters (.sym ast) fields\n (c/extract-items-constraints field-constraints))\n getter-arities (for [[proto-sym impl-fns] (vec getter-arities)\n [fn-name arities] (vec impl-fns)\n impl-arity arities]\n [proto-sym fn-name (.fn-var impl-arity (str (.fn-var impl-arity)))])]\n\n getter-arities (sm/traverse getter-arities (partial declare-impl (str sym) type-num))\n _ (sm/traverse getter-arities (partial emit-impl (str sym) new-type-constraint type-num))\n _ (sm/assoc-in-val [.fn-context .field-constrs] nothing)\n\n type-constructor (emit-constructor (.sym ast) type-num new-type-constraint\n fields field-constraints)]\n type-constructor))))))\n\n;; (defn js-callable-arity [[num-args expr]]\n;; (for [c-fn-name (global-var (str (.sym ast) \"_\" num-args))\n;; :let [c-fn-name (either (check-C-var c-fn-name)\n;; c-fn-name)\n;; js-wrapper (c-code \"\"\n;; [\"\\nEM_ASM(\\n\" (str (.sym ast)) \" = function(\"\n;; (interpose (map (range num-args) (partial str \"arg\")) \", \") \") {\\n\"\n;; \"_\" c-fn-name \"(\"\n;; (interpose (map (range num-args)\n;; (fn [idx]\n;; [\"sendValue(arg\" idx \")\"]))\n;; \", \")\n;; \");\\n return; \\n};);\\n\"]\n;; [] {} {})]\n;; _ (sm/update-in-val [.rt-init .exprs] (fn [exprs]\n;; (conj exprs js-wrapper)))]\n;; [c-fn-name num-args]\n;; [(c-code \"\" []\n;; [\"EMSCRIPTEN_KEEPALIVE\\n void \" c-fn-name \"(\"\n;; (interpose (map (range num-args) (partial str \"int64_t arg\")) \", \")\n;; \") {\\ndec_and_free(\"\n;; (.c-var expr) \"(\"\n;; (interpose (cons \"empty_list\"\n;; (map (range num-args)\n;; (fn [idx]\n;; [\"(Value *)arg\" idx])))\n;; \", \")\n;; \"), 1);\\n return; \\n};\\n\"]\n;; {} {})]))\n\n(extend-type ast/JS-callable\n Emitter\n (emit-definition [ast]\n (let [num-args (.num-args ast)]\n (comp (for [fn-var (lookup-sym (.sym ast))\n expr (sm/when (get-in fn-var [.arities num-args]))\n c-fn-name (global-var (str (.sym ast)))\n :let [js-wrapper (c-code \"\"\n [\"\\n#ifdef TOCCATA_WASM\\n\"\n \"EM_ASM(\\n\" (str (.sym ast)) \" = function(\"\n (interpose (map (range num-args) (partial str \"arg\")) \", \") \") {\\n\"\n \"return _\" c-fn-name \"(\"\n (interpose (map (range num-args)\n (fn [idx]\n [\"sendValue(arg\" idx \")\"]))\n \", \")\n \");\\n};);\\n\"\n \"#endif\\n\"]\n {} c/top-type)\n _ (send rt-exprs conj js-wrapper)]\n _ (declare [\"\\n#ifdef TOCCATA_WASM\\n\"\n \"EMSCRIPTEN_KEEPALIVE\\n Value * \" c-fn-name \"(\"\n (interpose (map (range num-args) (partial str \"int arg\")) \", \")\n \") {\\nreturn(\"\n (.c-fn expr) \"(\"\n (interpose (cons \"(FnArity *)0\"\n (map (range num-args)\n (partial str \"(Value *)arg\")))\n \", \")\n \"));\\n};\\n\"\n \"#endif\\n\"])]\n [empty-c-code])\n (compilation-error \"Could not find function\" (.sym ast) \"or an arity with\" num-args \"arguments.\")))))\n\n(defprotocol FreeGlobal\n (free-global [_]\n (assert-result x (instance? Vector x))\n []))\n\n(extend-type c-init\n Emitter\n (get-result-constraint [expr num-args]\n (for [type-num (var-type-num (.c-var expr))\n :when-not (= c/UnknownType type-num)\n invoke-info (get-core-proto-impl Function-sym invoke-sym (inc num-args) type-num)]\n (.result-constraint invoke-info)))\n\n FreeGlobal\n (free-global [c-info]\n [\"freeGlobal(\" (.c-var c-info) \");\\n\"]))\n\n(defn declare-dispatcher [mod-index [fn-sym arities]]\n (let [arities (.p-impls arities)]\n (for [disp-fn (sm/get-in-val [.module .values (ast/tag fn-sym)])\n :let [fn-var (.c-var disp-fn)]\n c-fns (sm/traverse (vec (.arities disp-fn))\n (fn [[arg-count static-arity]]\n (assert (instance? StaticArity static-arity))\n (for [arity-var (global-var \"arity\")]\n [arg-count arity-var (.c-fn static-arity)])))\n struct-var (global-var \"dispFnStruct\")\n\n _ (sm/assoc-in-val [.module .values (ast/tag fn-sym) .c-struct] struct-var)\n checked-var (genlocal 'checked)\n _ (declare [(map c-fns\n (fn [[arg-count arity-var c-fn]]\n ;; TODO: this should be done in the traverse above\n (let [impls (extract (get arities arg-count))]\n [\"Value *\" c-fn \"(FnArity *\"\n (interpose (cons \"closures\" (map (range arg-count)\n (partial str \"Value *arg\")))\n \",\")\n \") {\\nFnArity *arity;\\n#\\n\"\n \"FnType\" arg-count \" *_fn;\\n\"\n \"int \" checked-var \"= 1;\"\n \"switch (arg0->type) {\\n\"\n (-> impls\n (dissoc 0)\n (vec)\n (map (fn [[type-num arity-info]]\n (assert (instance? ProtoImpl arity-info))\n\n [\"case \" (str type-num) \": arity = \"\n (.c-var arity-info) \";\\n_fn = (FnType\"\n arg-count \" *)\" (.c-fn arity-info) \";\\n\"\n (for [[constraint var] (-> (.param-constraints arity-info)\n (c/extract-items-constraints arg-count)\n (zip-lists (map (range arg-count)\n (partial str \"arg\")))\n rest)]\n (-> constraint\n (c/update-var var)\n (runtime-check c/top-type\n (str \"(closures == (FnArity *)0 ? \\\"\\\" : \"\n \"((String *)closures)->buffer)\")\n checked-var)))\n \"\\nclosures = arity;\\nbreak;\\n\"])))\n (let [arity-info (extract (get impls 0))]\n [\"default:\\n\"\n (for [[constraint var] (-> (.param-constraints arity-info)\n (c/extract-items-constraints arg-count)\n (zip-lists (map (range arg-count)\n (partial str \"arg\")))\n rest)]\n (-> constraint\n (c/update-var var)\n (runtime-check c/top-type\n (str \"(closures == (FnArity *)0 ? \\\"\\\" : \"\n \"((String *)closures)->buffer)\")\n checked-var)))\n \"_fn = (FnType\" arg-count\n \" *)\" (.c-fn arity-info) \";\\nbreak;\\n\"])\n \"}\\n\"\n \"if(!\" checked-var \"){abort();}\" line-sep\n ;; \"FnType\" arg-count \" *_fn = (FnType\" arg-count \" *)arity->fn;\\n\"\n \"return(_fn(closures, \" (-> (range arg-count)\n (map (partial str \"arg\"))\n (interpose \", \"))\n \"));\\n}\\n\"\n \"FnArity \" arity-var \" = {FnArityType, -2, \"\n arg-count\n \", (Vector *)0, (Value *)0, 0, \" c-fn \", (Value *)0, (Value *)0};\\n\"])))\n \"Function \" struct-var \" = {FunctionType, -2, \\\"\"\n fn-sym \"\\\", \" (count c-fns) \", \"\n \"{\" (interpose (map c-fns (fn [[_ arity-var]] (str \"&\" arity-var))) \", \")\n \"}};\\n\"\n \"Value *\" (.c-var disp-fn) \" = (Value *)&\" struct-var \";\\n\\n\"])]\n '_)))\n\n(def gather-protocols\n (comp (for [mod-index (sm/get-in-val [.module .index])\n protocols (sm/get-in-val [.module .protocols])\n ;; expr (encode-static protocols)\n x (apply (wrap sm/zero-sm list)\n (map (for [[_ proto-fns] (vec protocols)\n [fn-sym arities] (vec proto-fns)]\n [fn-sym arities])\n (partial declare-dispatcher mod-index)))\n ;; protos-var (sm/get-in-val [.module .values protocols-sym])\n ;; r (collapse-expressions [expr\n ;; (c-code (.c-var protos-var)\n ;; [(.c-var protos-var) \" = \" (.c-var expr) \";\\n\"]\n ;; {} c/top-type)])\n ]\n ;; r\n empty-c-code\n )\n (for [path (sm/get-in-val [.module .path])\n _ (compilation-error \"Could not gather the protocols for\" (str \"'\" path \"'\"))]\n '_)))\n\n(def gather-symbols\n (for [symbols (sm/get-in-val [.module .values])\n file-name (sm/get-in-val [.module .path])\n expr (-> symbols\n (dissoc symbols-sym 'main protocols-sym)\n (assoc 'filename (either (instance? String file-name)\n \"\"))\n seq\n (reduce {} (fn [m [k v]]\n (either (and (instance? c-code v)\n (maybe m))\n (assoc m k v))))\n (encode \"symbols_\"))\n sym-var (sm/get-in-val [.module .values symbols-sym])\n r (collapse-expressions [expr\n (c-code (.c-var sym-var)\n [(.c-var sym-var) \" = \" (.c-var expr) \";\\n\"]\n {} c/top-type)])]\n r))\n\n(defn map-modules [operation]\n (assert (instance? sm/new-sm operation))\n\n (let [results-prom (promise)\n _ (send modules\n (fn [mods]\n (deliver results-prom\n (map (vec mods)\n (fn [[_ ast-emitter]]\n (let [result-prom (promise)]\n (send ast-emitter\n (fn [ctxt]\n (update-context ctxt\n (map (comp operation\n (sm/state-maybe \"\"))\n (partial deliver result-prom)))))\n result-prom))))\n mods))]\n ;; TODO: this probably doesn't work\n ;; (extract (apply (promise vector)\n ;; (extract results-prom)))\n\n ;; 'results-prom' is a promise where a vector of promises will be delivered\n ;; we have to wait for all those promises to be delivered as well\n (map (extract results-prom) extract)))\n\n(defn emit-main [main-module]\n (let [main-fn (either (get-in main-module [.values 'main])\n (do\n (print-err \"'main' function is missing\")\n (abort)))\n wait-prom (promise)\n _ (send modules\n (fn [mods]\n (map (get mods 'core)\n (fn [ast-emitter]\n (send ast-emitter\n (fn [ctxt]\n (map ctxt\n (fn [ctxt]\n (.module ctxt (extract core-agent))))))\n (send ast-emitter\n (fn [ctxt]\n (map ctxt\n (fn [ctxt]\n (deliver wait-prom '_)\n ctxt))))))\n mods))\n _ (extract wait-prom)\n inits (map-modules (for [proto-expr gather-protocols\n ;; syms-expr gather-symbols\n ]\n (comp (.init proto-expr)\n ;; (.init syms-expr)\n )))\n decls (map-modules (sm/get-in-val [.fn-context .decl]))\n values-prom (promise)\n _ (send rt-exprs (partial deliver values-prom))\n values (extract values-prom)]\n (write-strings decls)\n (write-strings [\"\\n#\\n\"\n \"\\nint main (int argc, char **argv) {\\n\"\n \"prErrSTAR = &defaultPrErrSTAR;\\n\"\n \"#ifdef SINGLE_THREADED\\n\"\n \"#ifdef CHECK_MEM_LEAK\\n\"\n \"fprintf(stderr, \\\"Cannot use SINGLE_THREADED (or TOCCATA_WASM) and CHECK_MEM_LEAK \"\n \"at same time.\\\");\\n \"\n \"abort();\\n\"\n \"#endif\\n\"\n \"#endif\\n\"\n \"maybeNothing = maybe((FnArity *)0, (Value *)0, nothing);\\n\"\n \"maybeNothing->refs = -1;\\n\"\n \"outstream = stdout;\\n\"\n \"__atomic_store(&futuresQueue.input, &empty_list, __ATOMIC_RELAXED);\\n\"\n \"futuresQueue.output = empty_list;\\n\"\n \"pthread_mutex_init(&futuresQueue.mutex, NULL);\\n\"\n \"pthread_cond_init(&futuresQueue.notEmpty, NULL);\\n\"\n \"pthread_mutex_init(&shutDown.access, NULL);\\n\"\n \"startWorkers();\\n\"\n inits\n (map values .init)\n \"init_module_0();\\n\"\n \"init_module_1();\\n\"\n \"\\n#\\n\"\n \" List *argList = malloc_list();\\n\"\n \" argList->len = 0;\\n\"\n \" argList->head = (Value *)0;\\n\"\n \" argList->tail = (List *)0;\\n\"\n \" List *tail = argList;\\n\"\n \" for(int i = 0; i < argc; i++) {\\n\"\n \" List *newTail = malloc_list();\\n\"\n \" newTail->len = 0;\\n\"\n \" newTail->tail = (List *)0;\\n\"\n \" newTail->head = (Value *)0;\\n\"\n \" tail->head = stringValue(argv[i]);\\n\"\n \" tail->tail = newTail;\\n\"\n \" tail = newTail;\\n\"\n \" argList->len++;\\n}\\n\"\n \" argList->refs = -1;\\n\"\n \"Value *the_final_answer = \" (.c-fn main-fn)\n \"((FnArity *)0, (Value *)argList);\\n\\n\"\n \"#ifdef CHECK_MEM_LEAK\\n\"\n \"cleaningUp = 1;\\n\"\n \"mainThreadDone = 1;\\n\"\n \"waitForWorkers();\\n\"\n (map-modules (for [expr (sm/get-in-val [.module .values symbols-sym])]\n (free-global (c-init (.c-var expr) [] {} \"\" 0))))\n (map-modules (sm/get-in-val [.setup .cleanup]))\n (map values free-global)\n \"\\n#\\n\"\n \"for(List *l = argList; l != (List *)0; l = l->tail) {\\n\"\n \" l->refs = 1;\\n\"\n \"}\\n\"\n \" cleanupMemory(the_final_answer, maybeNothing, argList);\\n\"\n \" if (malloc_count - free_count != 0)\\n\"\n \" return(1);\\n\"\n \"#endif\"\n \"\\n#\\n\"\n \" return(0);\\n};\\n\"\n \"\\nint typeCount = \" (str (extract type-counter)) \";\\n\"])))\n\n(defn new-module [context module-name module-index]\n (update-context context\n (for [_ (sm/set-val .module (Module module-name module-index {} {} {} {} {} empty-list))\n protos-var (global-var \"protos_\")\n _ (new-module-def protocols-sym (c-code protos-var [] {} c/top-type))\n symbols-var (global-var \"symbols_\")\n _ (new-module-def symbols-sym (c-code symbols-var [] {} c/top-type))\n _ (declare [\"Value *\" protos-var \" = (Value *)&emptyBMI;\\n\"\n \"Value *\" symbols-var \" = (Value *)&emptyBMI;\\n\"])]\n '_)))\n\n(defprotocol TypeChecker\n (strip-constraints [ast]\n ast)\n\n (strip-asts [ast]\n ast)\n\n (check-call-site [ast args]\n (assert-result x (instance? se/new-se x)))\n\n (recover-type-constraint [x]\n (se/state-error x))\n\n (param-types [_]\n (assert-result x (instance? se/new-se x)))\n\n (pre-check [ast]\n (assert-result r (instance? se/new-se r))\n\n (flat-map (se-debug 'pre (type-name ast) \"\\n\" ast)\n (fn [_]\n (se/state-error ast))))\n\n (type-check [ast old-ast]\n (assert-result r (instance? se/new-se r))))\n\n(extend-type ConstrainedAST\n TypeChecker\n (strip-asts [ast]\n (.ast ast))\n\n (strip-constraints [ast]\n (.constraint ast))\n\n (check-call-site [ast args]\n ;; TODO: seems a little bogus\n (check-call-site (.ast ast) args)))\n\n(defn sm-translate [se-val]\n (sm/new-sm (fn [s]\n (let [se-result (se-val s)]\n (cond (= se/Failure se-result)\n sm/zero-sm\n\n (instance? se/Error se-result)\n ((compilation-error (.val se-result))\n (.state se-result))\n\n (maybe se-result))))))\n\n(defn se-translate [sm-val]\n (se/new-se (fn [s]\n (either (sm-val s)\n se/Failure))))\n\n(defn get-param-types [params]\n (assert (instance? ast/params-ast params))\n\n (cata param-types params se/state-error))\n\n(defn recover-types [params]\n (assert (instance? ast/params-ast params))\n\n (ana recover-type-constraint params se/state-error))\n\n(defn get-type-constraint [sym]\n ;; TODO: make this work\n ;; (assert-result r (instance? (all-of se/new-se\n ;; (contains ConstrainedAST))\n ;; r))\n (assert (instance? Tagged sym))\n (comp (se/get-in-val [.module .value-types 0 sym])\n (-> [\"Could not find type constraint for\" (str \"'\" sym \"'\")\n \"at\" (str (ast/file-name sym) \":\") (ast/line-number sym)]\n (interpose \" \")\n to-str\n se/throw)))\n\n(defn set-type-constraint [sym constraint]\n (assert (instance? Tagged sym))\n (assert (instance? ConstrainedAST constraint))\n\n (se/update-in-val [.module .value-types]\n (fn [types-list]\n (either (map (first types-list)\n (fn [value-types]\n (cons (assoc value-types (ast/untag sym) constraint)\n (rest types-list))))\n (list {(ast/untag sym) constraint})))))\n\n(defn remove-type-constraint [sym]\n (assert (instance? Tagged sym))\n (se/update-in-val [.module .value-types]\n (fn [types-list]\n (either (map (first types-list)\n (fn [value-types]\n (cons (dissoc value-types (ast/untag sym))\n (rest types-list))))\n types-list))))\n\n(defn append-type-constraint [sym constraint]\n (assert (instance? Tagged sym))\n (assert (instance? c/Constraints constraint))\n\n (cond (= constraint c/top-type)\n se-nop\n\n (for [curr-const (se/try\n (get-type-constraint sym)\n (fn [_]\n (se/state-error (ConstrainedAST sym c/top-type))))\n :let [new-const (c/trim (c/intersect (.constraint curr-const) constraint))]\n _ (cond (= new-const c/bottom-type)\n se-nop\n (set-type-constraint sym (.constraint curr-const new-const)))]\n new-const)))\n\n(defn push-types\n ([]\n (flat-map (se/get-in-val [.module .value-types])\n (fn [types-list]\n (se/assoc-in-val [.module .value-types]\n (either (map (first types-list)\n (fn [value-types]\n (conj types-list value-types)))\n types-list)))))\n ([value-types]\n (flat-map (se/get-in-val [.module .value-types])\n (fn [types-list]\n (se/assoc-in-val [.module .value-types]\n (conj types-list value-types))))))\n\n(defn nip-types []\n ;; Bringing the Forth to Toccata\n (flat-map (se/get-in-val [.module .value-types])\n (fn [types-list]\n (se/assoc-in-val [.module .value-types]\n (either (map (first types-list)\n (fn [value-types]\n (cons value-types (rest types-list))))\n types-list)))))\n\n(extend-type ast/Annotated\n TypeChecker\n (pre-check [ast]\n (pre-check (.ast ast))))\n\n(extend-type ast/definition-ast\n TypeChecker\n (pre-check [ast]\n (-> ast\n (.value-exprs (-> (.value-exprs ast)\n (remove (partial instance? ast/block-comment-ast))\n (map (fn [inner-ast]\n (either (map (instance? ast/fn-ast inner-ast)\n (fn [fn-ast]\n (.fn-sym fn-ast (maybe (.sym ast)))))\n inner-ast)))))\n se/state-error))\n\n (type-check [ast old-ast]\n (let [constrained (either (last (.value-exprs ast))\n (ConstrainedAST old-ast c/top-type))]\n (for [x (set-type-constraint (.sym old-ast) constrained)\n _ (se/state-error 'wtf)]\n (do\n ;; (print-err 'def (.sym old-ast) constrained)\n constrained)))))\n\n(extend-type ast/inline-ast\n TypeChecker\n (pre-check [ast]\n ;; TODO: remove eventually\n ;; disables printing of pre-check message\n (se/state-error ast))\n\n (type-check [ast old-ast]\n (for [c (se-translate (lookup-constraint (.result-type ast)))]\n (ConstrainedAST (.result-type ast c) c))))\n\n(extend-type ast/tagged-symbol\n TypeChecker\n (check-call-site [ast args]\n (map (get-type-constraint ast)\n (fn [c-ast]\n (print-err 'c-ast ast c-ast)\n (Right (.constraint c-ast)))))\n\n (pre-check [ast]\n ;; TODO: remove eventually\n ;; disables printing of pre-check message\n (se/state-error ast))\n\n (recover-type-constraint [sym]\n (flat-map (se/get-in-val [.module .value-types])\n (fn [types-list]\n (assert (instance? List types-list))\n (either (for [value-types (nth types-list 1)\n prev-constraint (get value-types (ast/untag sym))]\n (set-type-constraint sym prev-constraint))\n (remove-type-constraint sym)))))\n\n (param-types [sym]\n (for [c (get-type-constraint sym)]\n (cond (instance? c/DynamicConstraint (.constraint c))\n (.constraint c c/top-type)\n\n c)))\n\n (type-check [s old-s]\n (get-type-constraint s)))\n\n(extend-type ast/params-ast\n TypeChecker\n (pre-check [ast]\n ;; TODO: remove eventually\n ;; disables printing of pre-check message\n (se/state-error ast))\n\n (param-types [params]\n (se/state-error (-> c/empty-items-constraint\n (.tail-constraint (either (.variadic params)\n c/top-type))\n (.items-constraints (.fixed params)))))\n\n (type-check [ast old-ast]\n (either (map (.variadic old-ast)\n (fn [var-sym]\n (for [_ (set-type-constraint var-sym (ConstrainedAST var-sym list-constraint))]\n old-ast)))\n (se/state-error old-ast))))\n\n(extend-type ast/fn-arity-ast\n TypeChecker\n (pre-check [ast]\n (for [_ (push-types)\n _ (se/traverse (all-syms (.params ast))\n (fn [sym]\n (set-type-constraint sym (ConstrainedAST sym c/top-type))))]\n (.body ast (remove (.body ast) (partial instance? ast/block-comment-ast)))))\n\n (type-check [ast old-ast]\n (for [pts (get-param-types (.params old-ast))\n result-c (se/try\n (get-type-constraint (symbol \"#result\"))\n (fn [_]\n (se/state-error (ConstrainedAST (symbol \"#result\") c/top-type))))\n _ (remove-type-constraint (symbol \"#result\"))\n _ (recover-types (.params old-ast))\n _ (nip-types)]\n (let [result-c (c/intersect (.constraint result-c)\n (either (map (last (.body ast)) .constraint)\n c/top-type))]\n (either (map (= c/bottom-type result-c)\n (fn [_]\n (c/conflicting-assertions result-c \"type checker testing\" _LINE_)\n ;; (abort)\n (se/throw result-c)))\n (-> ast\n (.result-const (cata strip-constraints result-c))\n (.param-consts (cata strip-constraints pts))))))))\n\n(extend-type ast/fn-ast\n TypeChecker\n (check-call-site [ast args]\n (let [arg-count (count args)]\n (either (map (or (some (.arities ast) (fn [arity]\n (and (-> arity\n .params\n .fixed\n count\n (= arg-count))\n (maybe arity))))\n (some (.arities ast) (fn [arity]\n (and (-> arity\n .params\n .variadic)\n (-> arity\n .params\n .fixed\n count\n (<= arg-count))\n (maybe arity)))))\n (fn [arity]\n (-> arity\n .result-const\n Left\n se/state-error)))\n (se/throw (str \"Could not find implementation of \" (str \"'\" (.fn-sym ast) \"'\")\n ;; TOOD: add location\n \"with \" arg-count \"arguments.\")))))\n\n (pre-check [ast]\n (either (map (.fn-sym ast)\n (fn [sym]\n (map (set-type-constraint sym (ConstrainedAST sym fn-constraint))\n (fn [_]\n (.arities ast (map (.arities ast)\n (fn [arity]\n (.fn-sym arity sym))))))))\n (se/state-error ast)))\n\n (type-check [ast old-ast]\n (either (map (.fn-sym ast)\n (fn [_]\n (se/state-error (ConstrainedAST ast fn-constraint))))\n (flat-map (se-debug 'checked (type-name ast) \"\\n\" ast)\n (fn [_]\n (se/state-error (ConstrainedAST ast fn-constraint)))))))\n\n(extend-type ast/prototype-ast\n TypeChecker\n (pre-check [ast]\n (for [_ (push-types)\n _ (se/traverse (all-syms (.params ast))\n (fn [sym]\n (set-type-constraint sym (ConstrainedAST sym c/top-type))))]\n ast))\n\n (type-check [ast old-ast]\n (for [pts (get-param-types (.params old-ast))\n result-c (se/try\n (get-type-constraint (symbol \"#result\"))\n (fn [_]\n (se/state-error (ConstrainedAST (symbol \"#result\") c/top-type))))\n _ (remove-type-constraint (symbol \"#result\"))\n _ (recover-types (.params old-ast))\n _ (nip-types)]\n (-> ast\n (.result-const (cata strip-constraints result-c))\n (.param-consts (cata strip-constraints pts))))))\n\n(deftype PrototypeImpls [fn-sym impls]\n (assert (instance? (map-of Integer HashMap) impls))\n\n Stringable\n (string-list [_]\n (list \"(PrototypeImpls \" (str fn-sym) \"\\n\" (str impls) \")\"))\n\n Container\n (map [x f]\n (PrototypeImpls fn-sym\n (map-vals impls (fn [impl-fns]\n (map-vals impl-fns (fn [arities]\n (map arities f)))))))\n\n (map [x f embed]\n (map (contextual-map-vals impls (fn [impl-fns]\n (contextual-map-vals impl-fns\n (fn [arities]\n (map arities f))\n embed))\n embed)\n (partial PrototypeImpls fn-sym)))\n\n TypeChecker\n (check-call-site [proto-impls args]\n (let [num-args (count args)]\n (either (map (first args)\n (fn [disp-arg]\n (let [type-num (constraint-type-num (.constraint disp-arg))\n param-cs (either (or (get-in proto-impls [.impls type-num num-args .param-consts])\n (get-in proto-impls [.impls c/UnknownType num-args .param-consts]))\n c/top-type)\n result-c (either (or (get-in proto-impls [.impls type-num num-args .result-const])\n (get-in proto-impls [.impls c/UnknownType num-args .result-const]))\n c/top-type)]\n (for [_ (se/traverse (zip-lists args (c/extract-items-constraints param-cs num-args))\n (fn [[arg c]]\n (either (map (instance? Tagged (.ast arg))\n (fn [sym]\n ;; TODO: need to check if 'sym' satisfies 'c'\n ;; and add runtime-check notation if not\n (append-type-constraint sym c)))\n se-nop)))]\n (Left result-c)))))\n (-> [(str \"'\" fn-sym \"'\") \"requires at least one argument at\"\n ;; TODO: add locatio\n ]\n (interpose \" \")\n to-str\n se/throw))))\n\n (pre-check [ast]\n ;; TODO: remove eventually\n ;; disables printing of pre-check message\n (se/state-error ast))\n\n (type-check [ast old-ast]\n (set-type-constraint fn-sym (ConstrainedAST ast fn-constraint))))\n\n(deftype ProtocolWithImpls [protocol default-impls]\n Stringable\n (string-list [_]\n (list \"(ProtocolWithImpls \" (str protocol) \"\\n\\n\" (str default-impls) \")\"))\n\n Container\n (map [_ f]\n (ProtocolWithImpls (f protocol) (map default-impls f)))\n\n (map [_ f embed]\n (for [new-impls (-> default-impls\n vec\n (map (fn [[k v]]\n (map (f v) (partial vector k)))\n embed)\n (map (fn [kv-pairs]\n (reduce kv-pairs {}\n (fn [m [k v]]\n (assoc m k v))))))\n new-proto (f protocol)]\n (ProtocolWithImpls new-proto new-impls)))\n\n TypeChecker\n (type-check [ast old-ast]\n (se/state-error ast)))\n\n(extend-type ast/protocol-ast\n TypeChecker\n (pre-check [ast]\n (let [prototypes (reduce (.prototypes ast) nothing\n (fn [protos proto]\n ;; TODO: check for shadowing of field names here\n (or (for [_ (-> (.default-body proto)\n (filter ast/generates-code?)\n first)\n :let [arg-count (count (.fixed (.params proto)))\n proto-arity (ast/fn-arity-ast (.fn-name proto)\n \"\"\n (.params proto)\n (.doc proto)\n (.default-body proto)\n c/empty-items-constraint\n c/top-type)]\n protos (or protos\n (maybe {}))\n new-protos (or (update-in protos [(.fn-name proto) .impls 0]\n (fn [arities]\n (assoc arities arg-count proto-arity)))\n (maybe (assoc-in protos [(.fn-name proto)]\n (PrototypeImpls\n (.fn-name proto)\n {c/UnknownType\n {arg-count proto-arity}}))))]\n new-protos)\n protos)))\n new-protocol (.prototypes ast\n (map (.prototypes ast)\n (fn [proto]\n (.default-body proto (filter (.default-body proto)\n (partial instance? c/Constraints))))))]\n (se/state-error (either (map prototypes\n (partial ProtocolWithImpls new-protocol))\n new-protocol))))\n\n (type-check [ast old-ast]\n (for [_ (se/traverse (.prototypes ast)\n (fn [proto]\n (let [arg-count (count (.fixed (.params proto)))\n proto-arity (ast/fn-arity-ast (.fn-name proto)\n \"\"\n (.params proto)\n (.doc proto)\n []\n (cata strip-constraints (.param-consts proto))\n (cata strip-constraints (.result-const proto)))]\n (comp (for [final (se/get-in-val [.module .value-types 0 (ast/untag (.fn-name proto))\n .impls c/UnknownType arg-count])]\n (do\n ;; TODO: this won't ever be called during type checking\n (print-err 'final-proto (ast/untag (.fn-name proto)) arg-count \"\\n\"\n (.param-consts final) \"\\n\\n\"\n (.result-const final))\n (abort)\n '_))\n (set-type-constraint (.fn-name proto)\n (ConstrainedAST (PrototypeImpls\n (.fn-name proto)\n {c/UnknownType\n {arg-count proto-arity}})\n fn-constraint))))))\n _ (se-debug 'checked (type-name ast) \"\\n\" ast)\n ;; _ (se-debug 'protos (-> (.prototypes ast)\n ;; (map (fn [ast]\n ;; (str \"(\" (str (.fn-name ast)) \" \" (.params ast) \"\\n\"\n ;; (-> (.param-consts ast)\n ;; c/extract-items-constraints\n ;; (remove (fn [c]\n ;; (= c/top-type (.constraint c))))\n ;; (interpose \"\\n\")\n ;; to-str)\n ;; \"\\n\\n\"\n ;; (.result-const ast) \")\")))\n ;; (interpose \"\\n\\n\")\n ;; to-str))\n _ (set-type-constraint (.protocol-sym ast) (ConstrainedAST ast c/top-type))]\n '_)))\n\n(defn extend-prototypes [type-num impls]\n (se/traverse (for [[proto-name impls] (vec impls)\n [fn-sym arities] (vec impls)\n arity arities]\n [(ast/untag proto-name) (ast/untag fn-sym) (.fn-sym arity fn-sym)])\n (fn [[proto-name fn-sym arity]]\n (let [arg-count (count (.fixed (.params arity)))]\n (for [prototypes (se/get-in-val [.module .value-types 0 (ast/untag proto-name)\n .ast .prototypes])\n :let [prototype (either\n (some prototypes\n (fn [prototype]\n (and (= (.fn-sym arity)\n (.fn-name prototype))\n (= arg-count\n (count (.fixed (.params prototype))))\n (maybe prototype))))\n (do\n (print-err 'booomers-line _LINE_)\n (abort)))\n param-cs (c/intersect (.param-consts prototype)\n (.param-consts arity))\n result-c (c/intersect (.result-const prototype)\n (.result-const arity))\n new-arity (-> arity\n (.param-consts param-cs)\n (.result-const result-c))\n _ (either (map (or (= c/bottom-type param-cs)\n (= c/bottom-type result-c))\n (fn [failure-c]\n (c/conflicting-assertions failure-c\n \"type checker testing\" _LINE_)\n (abort)))\n '_)]\n _ (se/update-in-val [.module .value-types]\n (fn [[value-types & types-list]]\n (cons (assoc-in value-types\n [fn-sym .impls type-num\n (count (.fixed (.params new-arity)))]\n new-arity)\n types-list)))]\n [proto-name fn-sym new-arity])))))\n\n(extend-type ast/reify-ast\n TypeChecker\n (pre-check [ast]\n ;; TODO: remove eventually\n ;; disables printing of pre-check message\n (se/state-error ast))\n\n (type-check [ast old-ast]\n (let [reified-type-num (either (.type-num ast)\n (extract type-counter))]\n (flat-map (extend-prototypes reified-type-num (.impls ast))\n (fn [arities]\n (let [arities (reduce arities {}\n (fn [m [proto-name fn-sym arity]]\n (either (and (get-in m [proto-name fn-sym])\n (update-in m [proto-name fn-sym]\n (fn [arities]\n (conj arities arity))))\n (assoc-in m [proto-name fn-sym] [arity]))))]\n (se/state-error (ConstrainedAST (ast/reify-ast (maybe reified-type-num) arities)\n (c/TypeConstraint {reified-type-num #{}}\n empty-list (symbol \"reified value at\")\n ;; TODO: add location\n nothing \"\")))))))))\n\n(extend-type ast/call-ast\n TypeChecker\n (pre-check [ast]\n ;; TODO: remove eventually\n ;; disables printing of pre-check message\n (se/state-error ast))\n\n (type-check [ast old-ast]\n (for [result-type (apo (fn [inner-ast]\n (check-call-site inner-ast (.args ast)))\n (.call-target ast) se/state-error)]\n (ConstrainedAST old-ast result-type))))\n\n(extend-type ast/extend-ast\n TypeChecker\n (pre-check [ast]\n ;; TODO: remove eventually\n ;; disables printing of pre-check message\n (se/state-error ast))\n\n (type-check [ast old-ast]\n (comp (for [type-num (map (se-translate (get-type-sym-info (.type ast)))\n constraint-type-num)\n :when-not (= type-num c/UnknownType)\n _ (extend-prototypes type-num (.impls ast))]\n (do\n (print-err 'checked (type-name ast) \"\\n\" ast)\n ast))\n (-> [\"Could not find type\" (str \"'\" (.type ast) \"'\")\n \"at\" (str (ast/file-name (.type ast)) \":\") (ast/line-number (.type ast))]\n (interpose \" \")\n to-str\n se/throw))))\n\n(extend-type ast/let-ast\n TypeChecker\n (pre-check [ast]\n (-> ast\n (.body (remove (.body ast) (partial instance? ast/block-comment-ast)))\n se/state-error))\n\n (type-check [ast old-ast]\n (map (se/traverse (reverse (.bindings old-ast))\n (fn [binding-ast]\n (for [_ (se/traverse (all-syms (.binding binding-ast))\n recover-type-constraint)\n _ (nip-types)]\n '_)))\n (fn [_]\n (let [result-c (either (map (last (.body ast)) .constraint)\n c/top-type)]\n (print-err 'checked ast)\n (ConstrainedAST ast (c/clear-sym result-c)))))))\n\n(extend-type ast/binding-ast\n TypeChecker\n (pre-check [ast]\n (let [binding-syms (all-syms (.binding ast))]\n (for [_ (push-types)\n _ (se/traverse binding-syms\n (fn [sym]\n (set-type-constraint sym (ConstrainedAST sym c/top-type))))]\n ast)))\n\n (type-check [ast old-ast]\n (se/state-error ast)))\n\n(extend-type ast/either-ast\n TypeChecker\n (type-check [ast old-ast]\n (let [clause-c (c/intersect (.constraint (.clause ast))\n maybe-constraint)]\n (either (map (= c/bottom-type clause-c)\n (fn [_]\n (c/conflicting-assertions clause-c \"type checker testing\" _LINE_)\n (se/throw clause-c)))\n (for [_ (either (map (instance? Tagged (.ast (.clause ast)))\n (fn [sym]\n (append-type-constraint sym (-> maybe-constraint\n (c/update-sym sym)))))\n se-nop)]\n (-> ast\n (.clause (-> (.clause ast)\n (.constraint clause-c)))\n (ConstrainedAST (c/sum-type [(c/extract-contents-constraint clause-c)\n (.constraint (.alt ast))]))))))))\n\n(extend-type ast/declaration-ast\n TypeChecker\n (type-check [ast old-ast]\n (set-type-constraint (.sym ast) (ConstrainedAST c/top-type c/top-type))))\n\n(extend-type c/Constraints\n TypeChecker\n (pre-check [c]\n (se-translate (to-constraint c))))\n\n(extend-type c/SymbolConstraints\n TypeChecker\n (type-check [c old-c]\n (map (either (map (.sym old-c)\n (fn [sym]\n (append-type-constraint sym c)))\n se-nop)\n (fn [_]\n (ConstrainedAST c c)))))\n\n(extend-type c/MultiConstraint\n TypeChecker\n (pre-check [c]\n (se-translate (to-constraint c)))\n (type-check [c old-c]\n (se/state-error (ConstrainedAST c c))))\n\n(extend-type c/ResultConstraint\n TypeChecker\n (type-check [c old-c]\n (let [rc (-> c\n .assertion\n .constraint)]\n (map (append-type-constraint (symbol \"#result\") rc)\n (fn [_]\n (ConstrainedAST (c/ResultConstraint rc) rc))))))\n\n(defn type-check-ast [ast]\n (flat-map (pre-check ast)\n (fn [new-ast]\n (flat-map (map new-ast type-check-ast se/state-error)\n (fn [newer-ast]\n (type-check newer-ast new-ast))))))\n\n(defn emit-ast [context ast]\n (update-context context\n (comp (sm-translate (type-check-ast ast))\n ;; (for [emitted (emit-definition ast)\n ;; static-strs (sm/get-in-val [.constants .strings])\n ;; static-nums (sm/get-in-val [.constants .numbers])\n ;; static-syms (sm/get-in-val [.constants .symbols])\n ;; :let [constants (extract constants)\n ;; ;; TODO: 'vec' here segfaults\n ;; ;; _ (map (seq static-strs)\n ;; ;; (fn [[k v]]\n ;; ;; (either (get-in constants [.strings k])\n ;; ;; (cache-static-constant k v))))\n ;; ;; _ (map (seq static-nums)\n ;; ;; (fn [[k v]]\n ;; ;; (either (get-in constants [.numbers k])\n ;; ;; (cache-static-constant k v))))\n ;; ;; _ (map (seq static-syms)\n ;; ;; (fn [[k v]]\n ;; ;; (either (get-in constants [.symbols k])\n ;; ;; (cache-static-constant k v))))\n ;; ]\n ;; _ (map (sm/get-in-val [.fn-context .decl]) write-strings)\n ;; _ (sm/assoc-in-val [.fn-context .decl] [])\n ;; _ (sm/update-in-val [.setup .init] (fn [x]\n ;; (comp x emitted)))]\n ;; \"\")\n (compilation-error \"Could not emit code for expression at \"\n (ast/file-name ast) (ast/line-number ast)))))\n\n\n(def fixup-native-symbols*\n (apply (wrap sm/zero-sm (fn [& decl]\n (write-strings decl)))\n (list (map (get-proto-dispatch-sym (ast/tag 'type-name) 1)\n (fn [arity-sym]\n [\"Value *(*type_name)(FnArity *, Value *) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'zero) 1)\n (fn [arity-sym]\n [\"Value *(*zero)(FnArity *, Value *) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'invoke) 1)\n (fn [arity-sym]\n [\"Value *(*invoke0Args)(FnArity *, Value *) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'invoke) 2)\n (fn [arity-sym]\n [\"Value *(*invoke1Arg)(FnArity *, Value *, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'invoke) 3)\n (fn [arity-sym]\n [\"Value *(*invoke2Args)(FnArity *, Value *, Value*, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag '=*) 2)\n (fn [arity-sym]\n [\"Value *(*equalSTAR)(FnArity *, Value *, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'hash-seq) 2)\n (fn [arity-sym]\n [\"Value *(*hashSeq)(FnArity *, Value*, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'count) 1)\n (fn [arity-sym]\n [\"Value *(*count)(FnArity *, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'vals) 1)\n (fn [arity-sym]\n [\"Value *(*vals)(FnArity *, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'first) 1)\n (fn [arity-sym]\n [\"Value *(*first)(FnArity *, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'rest) 1)\n (fn [arity-sym]\n [\"Value *(*rest)(FnArity *, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'seq) 1)\n (fn [arity-sym]\n [\"Value *(*seq)(FnArity *, Value*) = \" arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'sha1) 1)\n (fn [arity-sym]\n [\"Value *(*sha1)(FnArity *, Value*) = \" arity-sym \";\\n\"]))\n\n ;; TODO: no longer needed\n (map (get-proto-dispatch-sym (ast/tag 'dissoc*) 4)\n (fn [arity-sym]\n [\"Value *(*dissoc)(FnArity *, Value*, Value*, Value*, Value*) = \"\n arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'has-field) 2)\n (fn [arity-sym]\n [\"Value *(*hasField)(FnArity *, Value*, Value*) = \"\n arity-sym \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'show) 1)\n (fn [arity-ptr]\n [\"Value *(*showFn)(FnArity *, Value *) = \" arity-ptr \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'new-hash-set) 1)\n (fn [arity-ptr]\n [\"Value *(*newHashSet)(FnArity *, Value *) = \" arity-ptr \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'apply) 2)\n (fn [arity-ptr]\n [\"Value *(*fn_apply)(FnArity *, Value*, Value*) = \" arity-ptr \";\\n\"]))\n\n (map (get-proto-dispatch-sym (ast/tag 'pr-value) 1)\n (fn [arity-ptr]\n [\"Value *(*prValue)(FnArity *, Value*) = \" arity-ptr \";\\n\"]))\n )))\n\n(defn fixup-native-symbols [context]\n (update-context context\n (comp (for [r fixup-native-symbols*\n _ (map (sm/get-val .module)\n (fn [core-mod]\n (send core-agent (fn [_] core-mod))))]\n r)\n (compilation-error \"Compilation error (Could not fixup native symbols.)\"))))\n\n(defprotocol ASTEmitter\n (load-module [ast root-dir proj-dir]\n (assert-result r (instance? Promise r))))\n\n(defn add-module-file [module]\n (for [_ (sm/assoc-in-val [.mod-files (.path module)] module)\n _ (sm/traverse (vals (.namespaces module)) add-module-file)]\n '_))\n\n(defn analyze-forms [ast-emitter]\n (rd/parser\n (grmr/catch-error (fn [error curr-state]\n (abort))\n (grmr/none-or-more\n (grmr/any\n (grmr/one-or-more\n (apply-to (fn [ast root-dir proj-dir]\n (let [ns-sym (ast/untag (.ns-sym ast))\n waiter-prom (load-module (.mod ast) root-dir proj-dir)]\n (send ast-emitter\n (fn [context]\n (update-context\n context\n (let [module (extract waiter-prom)]\n (for [_ (sm/assoc-in-val [.module .namespaces ns-sym]\n module)\n _ (sm/update-in-val [.setup .init]\n (fn [mod-init]\n (conj mod-init\n (c-code \"\"\n [\"init_module_\"\n (str (.index module))\n \"();\\n\"]\n {} c/top-type))))\n _ (add-module-file module)]\n '_)))))))\n rdr/read-add-ns\n (grmr/get-value 'root-directory)\n (grmr/get-value 'project-directory)))\n (apply-to (fn [ast]\n (send ast-emitter emit-ast ast))\n rdr/top-level))))))\n\n(defn fixup-generated-symbols [context file-name protocols-sym symbols-sym]\n ;; TODO: make sure .declarations is empty\n (update-context context\n (for [protocols-var (sm/get-in-val [.module .values protocols-sym])\n _ (sm/assoc-in-val [.module .values 'protocols]\n protocols-var)\n symbols-var (sm/get-in-val [.module .values symbols-sym])\n _ (sm/assoc-in-val [.module .values 'symbols]\n symbols-var)\n mod-init (sm/get-in-val [.setup .init])\n cleanup (sm/get-in-val [.setup .cleanup])\n module (sm/get-val .module)\n :let [mod-index (.index module)\n inited-var (str \"m\" mod-index \"_inited\")\n _ (write-strings [\"int \" inited-var \" = 0;\\n\"\n \"void init_module_\" (str mod-index) \"() {\\n\"\n \"if (!\" inited-var \") {\\n\"\n (either (empty? mod-init)\n (.init (apply comp mod-init)))\n \"if(\" (.c-var symbols-var) \"->refs > 0)\\n\"\n (.c-var symbols-var) \"->refs = -1;\\n\"\n inited-var \"= 1;\\n}}\\n\"])\n\n _ (write-strings [\"void cleanup_module_\" (str mod-index) \"() {\\n\"\n cleanup\n \"}\\n\"])]\n _ (sm/assoc-in-val [.setup .cleanup] [\"cleanup_module_\" (str mod-index) \"();\\n\"])\n _ (sm/update-val .loaded (fn [loaded-prom]\n (deliver loaded-prom module)))]\n '_)))\n\n(defn init-core-module [context]\n (update-context\n context\n (sm/assoc-in-val [.module .types]\n {'Integer int-constraint\n 'StringBuffer (c/TypeConstraint {c/StringBufferType #{}}\n empty-list 'String nothing \"\")\n 'SubString (c/TypeConstraint {c/SubStringType #{}}\n empty-list 'String nothing \"\")\n 'FnArity (c/TypeConstraint {c/FnArityType #{}}\n empty-list 'FnArity nothing \"\")\n 'BitmapIndexedNode (c/TypeConstraint {c/BitmapIndexedType #{}}\n empty-list 'BitmapIndexedNode\n nothing \"\")\n 'ArrayNode (c/TypeConstraint {c/ArrayNodeType #{}}\n empty-list 'ArrayNode nothing \"\")\n 'HashCollisionNode (c/TypeConstraint\n {c/HashCollisionNodeType #{}}\n empty-list 'HashCollisionNode nothing \"\")\n 'Fn fn-constraint\n 'List list-constraint\n 'Maybe maybe-constraint\n 'Vector vect-constraint\n 'Symbol sym-constraint\n 'HashMap hashmap-constraint\n 'Promise (c/TypeConstraint {c/PromiseType #{}} empty-list\n 'Promise nothing \"\")\n 'Future (c/TypeConstraint {c/FutureType #{}} empty-list\n 'Future nothing \"\")\n 'Agent (c/TypeConstraint {c/AgentType #{}} empty-list\n 'Agent nothing \"\")\n 'Opaque (c/TypeConstraint {c/OpaqueType #{}} empty-list\n 'Opaque nothing \"\")})))\n\n(def global-context (GlobalContext (FunctionArityContext (FnSpec {} {}) 0 {} {} empty-closures [] {} nothing)\n (FunctionArityContext (FnSpec {} {}) 0 {} {} empty-closures [] {} nothing)\n (Module 'core 0 {} {} {} {} {} empty-list)\n (ConstantValues {} {} {} type-names {} {})\n 0 ;; reify-fn-index\n (promise) ;; loaded\n (ModuleSetup [] []) ;; setup\n {} ;; mod-files\n ))\n\n(defn wait-for-module [waiter-prom ctxt]\n (assert (instance? (maybe-of GlobalContext) ctxt))\n\n (update-context ctxt\n (sm/update-val .loaded\n (fn [mod-prom]\n (map mod-prom (partial deliver waiter-prom))\n mod-prom))))\n\n(defn compile-module [module-agents file-name waiter-prom root-dir proj-dir]\n (assert (instance? (map-of String Agent) module-agents))\n\n (either (map (get module-agents file-name)\n (fn [ast-emitter]\n (send ast-emitter\n (fn [ctxt]\n (update-context ctxt\n (sm/update-val .loaded (fn [mod-prom]\n (map mod-prom (partial deliver waiter-prom))\n mod-prom)))))\n module-agents))\n (let [core-prom (promise)\n module-agents (cond (= file-name 'core)\n module-agents\n (compile-module module-agents 'core core-prom root-dir proj-dir))\n ast-emitter (-> global-context\n (.loaded waiter-prom)\n maybe\n agent)\n module-index (count module-agents)]\n (send ast-emitter new-module file-name module-index)\n (cond (= file-name 'core)\n (send ast-emitter init-core-module)\n (send ast-emitter\n (fn [context]\n (extract core-prom)\n context)))\n (future (fn []\n (either (map (fio/file-in (cond (= file-name 'core)\n path-to-core\n file-name))\n (fn [file-in]\n (do\n ((analyze-forms ast-emitter)\n {'file-name file-name\n 'root-directory root-dir\n 'project-directory proj-dir\n 'line-number 1}\n (lazy-list file-in))\n (and (= file-name 'core)\n (maybe (send ast-emitter fixup-native-symbols)))\n (send ast-emitter\n fixup-generated-symbols file-name\n protocols-sym symbols-sym))))\n (do\n (print-err \"Could not compile\" file-name)\n (abort)))))\n (assoc module-agents file-name ast-emitter))))\n\n\n(extend-type ast/module-ast\n ;; ev/Evaluator\n ;; (ev/eval [x]\n ;; (let [file (.file-path x)]\n ;; (comp (for [curr-file-name (sm/get-val .file-name)\n ;; curr-file-path (sm/when (sys/file-directory curr-file-name))\n ;; :let [file (str curr-file-path file)]\n ;; mod-syms (comp (sm/get-in-val [.ns file .syms])\n ;; (for [asts (sm/when (for [file-in (fio/file-in file)\n ;; asts (ev/parse {'file-name file\n ;; 'line-number 1}\n ;; (lazy-list file-in))]\n ;; asts))\n ;; _ (sm/set-val .file-name file)\n ;; base-imports (sm/get-val .base-imports)\n ;; _ (sm/assoc-in-val [.ns file] (ev/EvalNamespace file base-imports {}\n ;; {} [{}]))\n ;; _ (ev/eval asts)\n ;; mod-syms (sm/get-in-val [.ns file .syms])]\n ;; mod-syms))\n ;; _ (sm/assoc-in-val [.ns curr-file-name .imports file] mod-syms)]\n ;; mod-syms)\n ;; (ev/abort-interp \"Could not import module\" (str \"'\" file \"'\") \"at\"\n ;; (ev/ast-location-str x)))))\n\n ASTEmitter\n (load-module [ast root-dir proj-dir]\n (let [waiter (promise)\n file-path (str root-dir (.file-path ast))]\n (send modules compile-module file-path waiter root-dir proj-dir)\n waiter)))\n\n(def repo-cloner (agent {}))\n\n(defn clone-repo* [ast proj-dir]\n (let [opts (.args ast)\n checkout (either (or (get opts 'tag)\n (get opts 'sha)\n (get opts 'branch))\n \"master\")\n branch (either (or (get opts 'tag)\n (get opts 'branch))\n \"master\")\n dep-path (str proj-dir \"dependencies/git/\" (.repo ast) \"/\" checkout)]\n (either (and (sh/command \"/usr/bin/git\" (list \"clone\" \"--branch\" branch\n (.repo ast) dep-path))\n (or (map (get opts 'sha)\n (fn [sha]\n ;; working with the OS. Give it a chance to catch up\n (sys/sleep 3)\n (or (sh/command \"/usr/bin/git\"\n (list \"-C\" dep-path \"checkout\" sha))\n (do\n (print-err \"Failed checkout of\" sha \"in\" dep-path)\n (abort)))\n (sys/sleep 3)))\n (maybe (sys/sleep 3))))\n (do\n (print-err \"Cloning git dependency\" (.repo ast) \"failed.\")\n (abort)))\n dep-path))\n\n(defn clone-repo [cloned ast waiter proj-dir]\n (assert (instance? HashMap cloned))\n (let [opts (.args ast)\n checkout (either (or (get opts 'tag)\n (get opts 'sha)\n (get opts 'branch))\n \"master\")\n dep-path (str proj-dir \"dependencies/git/\" (.repo ast) \"/\" checkout)\n module-path (str dep-path \"/\" (.file ast))]\n (either (or (map (sys/access module-path) (fn [_]\n (deliver waiter dep-path)\n cloned))\n (and (sys/access dep-path)\n (do\n (print-err \"Dependency file\" (.file ast)\n \"missing from existing copy of repository\"\n (.repo ast) \":\" (ast/file-name ast) (ast/line-number ast))\n (abort)))\n (update cloned dep-path (fn [cloning-future]\n (map cloning-future (partial deliver waiter))\n cloning-future)))\n (assoc cloned dep-path (future (fn []\n (let [dep-path (clone-repo* ast proj-dir)]\n (deliver waiter dep-path)\n dep-path)))))))\n\n(extend-type ast/git-dep-ast\n ;; ev/Evaluator\n ;; (ev/eval [ast]\n ;; ;; Only called when interpreting a file (I think)\n ;; (let [file (.file ast)]\n ;; (either (and (-> file\n ;; seq\n ;; (some (partial = \"/\")))\n ;; (maybe (ev/abort-interp \"For git dependencies,\"\n ;; \"files may only be imported from root of repository,\"\n ;; file \"is invalid.\")))\n ;; (comp (for [script-dir (sm/get-val .script-dir)\n ;; :let [clone-waiter (promise)\n ;; dep-path (do\n ;; (clone-repo {} ast clone-waiter script-dir)\n ;; (extract clone-waiter))\n ;; module-path (str dep-path \"/\" file)\n ;; _ (or (sys/access module-path)\n ;; (do\n ;; (print-err \"Dependency file\" file \"missing from cloned repository\"\n ;; (.repo ast) \":\" (ast/file-name ast) (ast/line-number ast))\n ;; (abort)))]\n ;; curr-file-name (sm/get-val .file-name)\n ;; _ (sm/set-val .file-name module-path)\n ;; r (ev/eval (ast/module-ast file))\n ;; _ (sm/set-val .file-name curr-file-name)]\n ;; r)\n ;; (ev/abort-interp \"Could not import module\" (str \"'\" file \"'\") \"from git repo at\"\n ;; (ev/ast-location-str ast))))))\n\n ASTEmitter\n (load-module [ast root-dir proj-dir]\n (let [file (.file ast)]\n (or (-> file\n seq\n (filter (partial = \"/\"))\n empty?)\n (do\n (print-err \"For git dependencies,\"\n \"files may only be imported from root of repository,\"\n file \"is invalid.\")\n (abort)))\n\n (let [clone-waiter (promise)\n dep-path (do\n (send repo-cloner clone-repo ast clone-waiter proj-dir)\n (extract clone-waiter))\n waiter (promise)\n module-path (str dep-path \"/\" file)]\n (or (sys/access module-path)\n (do\n (print-err \"Dependency file\" file \"missing from cloned repository\"\n (.repo ast) \":\" (ast/file-name ast) (ast/line-number ast))\n (abort)))\n (send modules compile-module module-path waiter (str dep-path \"/\") proj-dir)\n waiter))))\n\n;; (extend-type ev/Thunk\n;; rd/RecursiveDescent\n;; (rd/recursive-descent [f]\n;; (wrap sm/zero-sm (fn [& rules]\n;; (apply (wrap sm/zero-sm (fn [& parsed-values]\n;; (apply f (remove parsed-values rd/ignore?))))\n;; rules)))))\n\n;; (extend-type ev/EvalState\n;; Emitter\n;; (encode-static [x]\n;; (for [args (ev/traverse (type-args x) encode-static)\n;; struct (global-var \"cnstr_\")\n;; var (global-var \"cnstr_\")\n;; _ (declare [\"ReifiedVal \" struct \" = {\" (str (get-type x)) \", -2, 0, \"\n;; (str (count args)) (flat-map args (fn [expr]\n;; [\",(Value *)&\" (.c-struct expr)]))\n;; \"};\" line-sep\n;; \"Value *\" var \" = (Value *)&\" struct \";\" line-sep])\n;; expr (collapse-expressions (conj args (c-static-val var [] {} struct)))]\n;; expr)))\n\n(extend-type ProtoDispatcher\n Emitter\n (encode-static [x]\n (for [args (sm/traverse (type-args x) encode-static)\n struct (global-var \"cnstr_\")\n var (global-var \"cnstr_\")\n _ (declare [\"ReifiedVal \" struct \" = {\" (str (get-type x)) \", -2, 0, \"\n (str (count args)) (flat-map args (fn [expr]\n [\",(Value *)&\" (.c-struct expr)]))\n \"};\" line-sep\n \"Value *\" var \" = (Value *)&\" struct \";\" line-sep])\n expr (collapse-expressions (conj args (c-static-val var [] {} struct)))]\n expr))\n\n rd/RecursiveDescent\n (rd/recursive-descent [f]\n (se/state-error (fn [& rules]\n (apply (se/state-error (fn [& parsed-values]\n (apply f (remove parsed-values rd/ignore?))))\n rules)))))\n\n;; (extend-type sm/new-sm\n;; ev/Evaluator\n;; (ev/apply-fn [mv [state]]\n;; (wrap sm/zero-sm (mv state))))\n\n;; (defn interpret-file [[_ option file-name & args]]\n;; (or (and (= \"--script\" option)\n;; (flat-map (or (sys/file-directory file-name)\n;; (do\n;; (print-err \"Could not open file:\" file-name)\n;; (abort)))\n;; (fn [script-dir]\n;; (interp/interp-file\n;; file-name script-dir\n;; [(interp/CompiledNs 'file (either (get fio/symbols 'filename)\n;; \"\")\n;; fio/symbols fio/protocols)\n;; (interp/CompiledNs 'reader (either (get rdr/symbols 'filename)\n;; \"\")\n;; rdr/symbols rdr/protocols)\n;; (interp/CompiledNs 'grammar (either (get grmr/symbols 'filename)\n;; \"\")\n;; grmr/symbols grmr/protocols)\n;; (interp/CompiledNs 'parse (either (get rd/symbols 'filename)\n;; \"\")\n;; rd/symbols rd/protocols)\n;; (interp/CompiledNs 'ast (either (get ast/symbols 'filename)\n;; \"\")\n;; ast/symbols ast/protocols)\n;; (interp/CompiledNs 'sys (either (get sys/symbols 'filename)\n;; \"\")\n;; sys/symbols sys/protocols)\n;; (interp/CompiledNs 'state-maybe (either (get sm/symbols 'filename)\n;; \"\")\n;; sm/symbols sm/protocols)\n;; (interp/CompiledNs 'const (either (get c/symbols 'filename)\n;; \"\")\n;; c/symbols c/protocols)\n;; (interp/CompiledNs 'shell (either (get sh/symbols 'filename)\n;; \"\")\n;; sh/symbols sh/protocols)\n;; (interp/CompiledNs 'strm (either (get strm/symbols 'filename)\n;; \"\")\n;; strm/symbols strm/protocols)]\n;; args))))\n;; (do\n;; (print-err \"The only option for the compiler is '--script'\")\n;; (maybe -1))))\n\n(main [params]\n (either (and (< (count params) 2)\n (do\n (print-err \"A filename to compile must be provided.\")\n (maybe -1)))\n (let [[_ file-name] params\n waiter (promise)]\n (or (map (sys/file-directory file-name)\n (fn [root-dir]\n (write-strings [\"\\n#define _XOPEN_SOURCE 600\"\n \"\\n#include \"\n \"\\n#include \\\"core.h\\\"\\n\"])\n (send modules compile-module file-name waiter root-dir root-dir)))\n (do\n (print-err \"Could not find \" (str \"'\" file-name \"'\"))\n (abort)))\n (extract waiter)\n (emit-main (extract waiter))\n ;; (send ast-emitter (fn [ctxt]\n ;; (map (get-in ctxt ['_ .constants .other])\n ;; (fn [counts]\n ;; (apply print-err (list* \"\\n\" (interpose (map (seq counts)\n ;; (fn [[k v]]\n ;; (str k \": \" v)))\n ;; \"\\n\")))\n ;; (print-err \"number of types\" type-count)))))\n ;; wait for agents to clear their queues\n (map-modules sm-nop)\n (let [waiter (promise)]\n (send string-writer (partial deliver waiter))\n (extract waiter)))))\n" }, { "path": "update-deps", "content": "#!/bin/bash\n\nset -e\n\ncd /home/jim/toccata\n\ndir=`find . -name $1`\n\nnewDir=${dir/$1/$2}\n\nfor file in `grep -R --include=*.toc -l $1`\ndo\n echo $file\n sed -i \"s/$1/$2/\" $file\ndone\n\nmv $dir $newDir\n\n# TODO: someday make this work\n# find -L . -depth -type d -name \"$1\" -exec mv {} \"../$2\" \\;\n" } ]