Showing preview only (911K chars total). Download the full file or copy to clipboard to get everything.
Repository: Toccata-Lang/toccata
Branch: master
Commit: 99a1515380cc
Files: 346
Total size: 26.4 MB
Directory structure:
gitextract_85yw3pm4/
├── .gitattributes
├── .gitignore
├── CMakeLists.txt
├── HISTORY.md
├── LICENSE
├── README.md
├── assertion-tests/
│ ├── add-items-list-1.toc
│ ├── add-items-list-2.toc
│ ├── and-constraints-1.toc
│ ├── and-constraints-2.toc
│ ├── apply-constructor.toc
│ ├── bad-add.toc
│ ├── bad-and-1.toc
│ ├── bad-and-2.toc
│ ├── bad-and-clause.toc
│ ├── bad-apply-constructor.toc
│ ├── bad-arity-1.toc
│ ├── bad-constructor-call.toc
│ ├── bad-constructor-param-1.toc
│ ├── bad-constructor-param-2.toc
│ ├── bad-dipatch-type.toc
│ ├── bad-enum-1.toc
│ ├── bad-enum-2.toc
│ ├── bad-enum-3.toc
│ ├── bad-enum-4.toc
│ ├── bad-field-1.toc
│ ├── bad-field-2.toc
│ ├── bad-field-3.toc
│ ├── bad-field-4.toc
│ ├── bad-field-5.toc
│ ├── bad-flat-map-inner.toc
│ ├── bad-function-returns-1.toc
│ ├── bad-function-returns-2.toc
│ ├── bad-impl-arity.toc
│ ├── bad-impl-return-value.toc
│ ├── bad-inline-result-type.toc
│ ├── bad-inner-1.toc
│ ├── bad-inner-10.toc
│ ├── bad-inner-11.toc
│ ├── bad-inner-12.toc
│ ├── bad-inner-13.toc
│ ├── bad-inner-14.toc
│ ├── bad-inner-15.toc
│ ├── bad-inner-16.toc
│ ├── bad-inner-2.toc
│ ├── bad-inner-3.toc
│ ├── bad-inner-4.toc
│ ├── bad-inner-5.toc
│ ├── bad-inner-6.toc
│ ├── bad-inner-7.toc
│ ├── bad-inner-8.toc
│ ├── bad-inner-9.toc
│ ├── bad-inner-or.toc
│ ├── bad-let.toc
│ ├── bad-list-of-1.toc
│ ├── bad-nested-let.toc
│ ├── bad-or-1.toc
│ ├── bad-or-2.toc
│ ├── bad-result-sum-type.toc
│ ├── bad-return-value.toc
│ ├── bad-setter-call-1.toc
│ ├── bad-setter-call-2.toc
│ ├── bad-state-maybe-value-1.toc
│ ├── bad-state-maybe-value-2.toc
│ ├── bad-type-comp.toc
│ ├── bad-vector-of-1.toc
│ ├── checked-map-1.toc
│ ├── checked-map-2.toc
│ ├── closure-1.toc
│ ├── closure-2.toc
│ ├── closure-constraint.toc
│ ├── closure-param.toc
│ ├── comp-bad-type-1.toc
│ ├── comp-bad-type-2.toc
│ ├── conj-to-getter-result-1.toc
│ ├── conj-to-getter-result-2.toc
│ ├── constructor-param-1.toc
│ ├── constructor-param-2.toc
│ ├── constructor-param-3.toc
│ ├── contents-2.toc
│ ├── deeply-nested-vector-1.toc
│ ├── deeply-nested-vector-2.toc
│ ├── destruct-variadic-tail-2.toc
│ ├── dup-protocol-name.toc
│ ├── dynamic-call-1.toc
│ ├── dynamic-call-2.toc
│ ├── dynamic-call-3.toc
│ ├── dynamic-call-4.toc
│ ├── dynamic-call-5.toc
│ ├── dynamic-call-6.toc
│ ├── dynamic-call-7.toc
│ ├── dynamic-call-8.toc
│ ├── dynamic-field-type-1.toc
│ ├── dynamic-field-type-2.toc
│ ├── dynamic-nested-value-1.toc
│ ├── dynamic-proto-param-1.toc
│ ├── empty-defn.toc
│ ├── field-and-seq-conflict.toc
│ ├── field-constraint.toc
│ ├── field-shadow.toc
│ ├── flat-map-param.toc
│ ├── impl-violates-proto.toc
│ ├── incompatible-tails.toc
│ ├── init-type.toc
│ ├── insufficient-static-elements-1.toc
│ ├── insufficient-static-elements-2.toc
│ ├── insufficient-static-elements-3.toc
│ ├── insufficient-static-elements-4.toc
│ ├── int-too-large.toc
│ ├── items-constraints-1.toc
│ ├── items-constraints-2.toc
│ ├── items-constraints-3.toc
│ ├── key-violation.toc
│ ├── list-items-types.toc
│ ├── literal-hash-map-1.toc
│ ├── literal-hash-map-2.toc
│ ├── min-count.toc
│ ├── missing-namespaced-sym.toc
│ ├── multi-constraint-violated.toc
│ ├── nested-destruct-1.toc
│ ├── nested-destruct-2.toc
│ ├── nested-destruct.toc
│ ├── nested-items-conflict.toc
│ ├── or-prop.toc
│ ├── param-in-and.toc
│ ├── param-in-or.toc
│ ├── partial-param.toc
│ ├── preserve-asserts.toc
│ ├── preserve-static-info-1.toc.test
│ ├── preserve-static-info-2.toc.test
│ ├── preserve-static-info-3.toc.test
│ ├── propogate-inner-1.toc
│ ├── propogate-inner-2.toc
│ ├── propogate-through-let.toc
│ ├── propogate-through-seq.toc
│ ├── propogate-through-vec.toc
│ ├── proto-fn-constraint-prop.toc
│ ├── proto-fn-min-count.toc
│ ├── proto-fn-param.toc
│ ├── restrict-conflict.toc
│ ├── restrict-nested-item.toc
│ ├── restrict-param.toc
│ ├── return-bad-type.toc
│ ├── return-generic-1.toc
│ ├── return-list-of-1.toc
│ ├── return-list-of-2.toc
│ ├── return-sum-type.toc
│ ├── simple-conflict.toc
│ ├── static-fixed-dynamic-result-type-1.toc
│ ├── static-fixed-dynamic-result-type-2.toc
│ ├── unkown-field.toc
│ ├── update-field-1.toc
│ ├── variadic-constraints.toc
│ ├── variadic-count-1.toc
│ ├── variadic-count-2.toc
│ └── vect-len.toc
├── bin/
│ ├── build-toccata.sh
│ └── toccata.sh
├── core.c
├── core.h
├── core.toc
├── ebnf.md
├── em-run
├── examples/
│ ├── apply-maybe.toc
│ ├── apply-vector.toc
│ ├── config-file.toc
│ ├── debugging.toc
│ ├── flat-map-list.toc
│ ├── flat-map-maybe.toc
│ ├── greeting.toc
│ ├── howdy.toc
│ ├── json-ebnf.toc
│ ├── json-graph.toc
│ ├── json-parser.toc
│ ├── json.toc
│ ├── map-maybe.toc
│ ├── map-vector.toc
│ ├── number-option.toc
│ └── tictactoe.toc
├── foundry/
│ └── docker/
│ ├── Development.docker
│ ├── README.md
│ ├── bashrc
│ ├── build-devenv
│ ├── build-devenv.cmd
│ ├── enter-dev
│ └── enter-dev.cmd
├── interpreter-tests/
│ ├── abort-memory-leak.toc
│ ├── bad-and-clause-type-1.toc
│ ├── bad-apply-arg-1.toc
│ ├── bad-apply-arg-2.toc
│ ├── bad-constructor-arg-1.toc
│ ├── bad-constructor-arg-2.toc
│ ├── bad-default-proto-param.toc
│ ├── bad-field-1.toc
│ ├── bad-field-2.toc
│ ├── bad-proto-impl-param-const.toc
│ ├── bad-proto-param.toc
│ ├── bad-proto-return-type.toc
│ ├── bad-reify-arg-1.toc
│ ├── bad-reify-arg-2.toc
│ ├── bad-reify-arg-3.toc
│ ├── constrain-let-expr.toc
│ ├── constrain-tagged.toc
│ ├── insufficient-apply-args-1.toc
│ ├── insufficient-apply-args-2.toc
│ └── insufficient-invoke-args-1.toc
├── par-test
├── regression-tests/
│ ├── Boomer.toc
│ ├── agent-regressions.toc
│ ├── and-prop.toc
│ ├── boom.toc
│ ├── comment-in-deftype.toc
│ ├── cond-expr-1.toc
│ ├── cond-expr-2.toc
│ ├── cond-expr-3.toc
│ ├── cond-expr-4.toc
│ ├── cond-expr-5.toc
│ ├── destruct-test.toc
│ ├── free-static-value.toc
│ ├── function-regressions.toc
│ ├── future-regressions.toc
│ ├── hash-map-regressions.toc
│ ├── integer-regressions.toc
│ ├── interpreter-test.toc
│ ├── lazy-list-regressions.toc
│ ├── list-regressions.toc
│ ├── maybe-regressions.toc
│ ├── or-and-constraints.toc
│ ├── promise-regressions.toc
│ ├── regression-tester.toc
│ ├── string-regressions.toc
│ ├── symbol-regressions.toc
│ ├── tail-cond-1.toc
│ ├── test-apply-constructor.toc
│ ├── test-comment-in-let.toc
│ ├── test-def-empty.test
│ ├── test-either.toc
│ ├── test-for.toc
│ ├── test-gensym.toc
│ ├── test-global-empty-list.toc
│ ├── test-hlist-cons.toc
│ ├── test-ignore-inferred.toc
│ ├── test-inline-invoke.toc
│ ├── test-inline-namespaced-sym.toc
│ ├── test-inline-sym-literal.toc
│ ├── test-inlined-result-constraint.toc
│ ├── test-or-comment.toc
│ ├── test-parser-efficience.toc
│ ├── test-proto-def-constraints.toc
│ ├── test-proto-impl-destruct.toc
│ ├── test-recursive-map-fn.toc
│ ├── test-regressions.toc
│ ├── test-tail-recur-1.toc
│ ├── test-tail-recur-2.toc
│ ├── test-tail-recur-3.toc
│ ├── test-threading.toc
│ ├── test-trailing-comment.toc
│ ├── test-type-of-tail.toc
│ ├── test-underscore-inline.toc
│ ├── test-uni.toc
│ ├── test1.toc
│ ├── test10.toc
│ ├── test11.toc
│ ├── test12.toc
│ ├── test13.toc
│ ├── test14.toc
│ ├── test15.toc
│ ├── test16.toc
│ ├── test17.toc
│ ├── test18.toc
│ ├── test19.toc
│ ├── test20.toc
│ ├── test3.toc
│ ├── test4.toc
│ ├── test5.toc
│ ├── test6.toc
│ ├── test7.toc
│ ├── test8.toc
│ ├── test9.toc
│ ├── types-regressions.toc
│ └── vector-regressions.toc
├── run
├── runtime-tests/
│ ├── agent-loop.toc
│ ├── apply-constructor.toc
│ ├── bad-arity-1.toc
│ ├── bad-arity-2.toc
│ ├── bad-enum-1.toc
│ ├── bad-field-1.toc
│ ├── bad-field-2.toc
│ ├── bad-maybe-flat-map.toc
│ ├── bad-param.toc
│ ├── bad-proto-param-1.toc
│ ├── bad-proto-param-2.toc
│ ├── bad-proto-param-3.toc
│ ├── bad-proto-param-4.toc
│ ├── bad-variadic-param.toc
│ ├── check-and-1.toc
│ ├── check-and-2.toc
│ ├── check-and-3.toc
│ ├── check-and-4.toc
│ ├── check-every-time.toc
│ ├── check-or-1.toc
│ ├── check-or-2.toc
│ ├── check-or-3.toc
│ ├── check-or-4.toc
│ ├── check-params-1.toc
│ ├── check-params-2.toc
│ ├── check-return-sum-type.toc
│ ├── check-tail-either.toc
│ ├── closure-param.toc
│ ├── constructor-param.toc
│ ├── default-impl-parameter.toc
│ ├── default-proto.toc
│ ├── destruct-variadic-tail-1.toc
│ ├── flat-map-param.toc
│ ├── higher-order-fn.toc
│ ├── higher-order-variadic.toc
│ ├── insufficient-elements.toc
│ ├── int-too-large-1.toc
│ ├── int-too-large-2.toc
│ ├── int-too-large.toc
│ ├── int-too-small.toc
│ ├── invalid-type.toc
│ ├── invoke-param.toc
│ ├── list-len-1.toc
│ ├── list-len-2.toc
│ ├── list-len-3.toc
│ ├── nested-destruct-1.toc
│ ├── nested-destruct-2.toc
│ ├── nested-destruct.toc
│ ├── param-in-cond-2.toc
│ ├── param-in-cond.toc
│ ├── preserve-asserts.toc
│ ├── promise-loop.toc
│ ├── proto-fn-arg.toc
│ ├── test-tail-and.toc
│ ├── test-tail-or.toc
│ ├── update-field-2.toc
│ └── variadic-count-2.toc
├── test
├── test-assertion
├── test-regression
├── test-runtime-check
├── toccata.c
├── toccata.toc
└── update-deps
================================================
FILE CONTENTS
================================================
================================================
FILE: .gitattributes
================================================
*.toc linguist-language=Clojure
================================================
FILE: .gitignore
================================================
*.DS_Store
dependencies
*.dSYM
build
toccata
================================================
FILE: CMakeLists.txt
================================================
cmake_minimum_required(VERSION 3.9.4)
project(toccata)
add_definitions(-std=c99)
set (CORE_LIBS pthread)
add_executable(toccata toccata.c core.c)
target_link_libraries(toccata ${CORE_LIBS})
================================================
FILE: HISTORY.md
================================================
# Rationale
The first (almost) usuable version of Toccata is finally nearing completion. By reading
through the commits and the entries in this file, you should be able to watch Toccata
grow from nothing to a usable language. This is not a historical record. The real
development effort (and resulting code) was very ugly with lots of dead ends, painful bugs,
and tears. (Not really on the tears part, but close)
This repo is to capture the organizational structure of the code.
New entries will be added to the end, and so should be read from the top down.
Happy Reading and Pull Requests welcome!
Jim Duey
# Story
## Entry 1:
In the beginning, God created the Heavens and the Earth. Gen. 1:1
Unlike in Genesis, a lot of work has preceded this commit. Until this compiler is
self-hosting, you won't be able to compile and run it. Nor compile the various regression
tests. I'm using the previous version of Toccata to cross-compile this code until that point.
Now, let us begin.
The `regression-tests` directory will contain a collection of Toccata programs that
exercise various parts of the compiler. `main1.toc` is the simplest program possible.
But already, there's a ton of code required. We have to ...
open the file
read it
parse the contents into a nested list structure
convert the parsed structure to an AST (Abstract Syntax Tree)
traverse the AST and emit C code to stdout
If the C code has been written to a file, it can be compiled to an executable using
LLVM or GCC.
So `toccata.toc` is what it takes to do the above steps. This is about as simple a
compiler for Toccata as possible. Everything else builds from there.
## Entry 2:
When an expression is emitted, it is converted to a list of data structures. Each data structure
has the following
A string that holds the C variable the result of the expression is assigned to
A list of strings of C code to declare static C values
A list of strings of C code that produces the expressions result
A number that signifies the type of the result of the expression
A hash-map of of C variables that are used in the expression to the number of times their used
Also, `inline` expressions can appear at the top level of a file just like the `main` expression
## Entry 3:
Comment blocks are AST nodes also, this allows easy literate programming and code formatting
## Entry 4:
Defining symbols is the next step. Toccata source files are called modules and eventually there will be
a system for compiling multiple modules into a program. The C variable for each symbol in a module
is added to the global context so it can be looked up later.
## Entry 5:
Now we're able to assign numbers to symbols
## Entry 6:
And now string literals to symbols
## Entry 7:
When doing the next commit, I discovered a need to refactor some code
## Entry 8:
And 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.
## Entry 9:
Since 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.
## Entry 10:
Now 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.
## Entry 11:
Add 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.
## Entry 12:
Add `let` expressions to bind values to symbols
## Entry 13:
Inline 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.
## Entry 14:
Add `do` expressions for side-effecting code
## Entry 15:
Selecting 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.
## Entry 16:
Though 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.
## Entry 17:
And 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.
## Entry 18:
The first hints of where I want to take Toccata appear in `core.toc`.
## Entry 19:
A rather large commit to enable extending types with additional protocol function implementations
## Entry 20:
Well 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.
## Entry 21:
Being able to create functions that close over values in their context is a key part of functional programming. This commit adds that.
## Entry 22:
And now, we can finally write ... 'println'!
(defn println [& vs]
(map (flat-map (interpose vs " ") string-list) pr*)
(pr* "\n"))
As 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.
## Entry 23:
Before 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.
## Entry 24:
We 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.
## Entry 25:
Next 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.
## Entry 26:
Symbol literals are even simpler than strings. You create them by putting a `'` befoer a symbol. Useful as keys in hash-maps.
## Entry 27:
`Maybe` is the simplest type whose values can contain other values, so it's the first time we implement the very important `Container` protocol.
## Entry 28:
A 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 :) )
## Entry 29:
Another container is the `Vector` type. Among other things, it adds the idea of accessing the values it contains by an integer index.
## Entry 30:
Being able to create new datatypes by combining existing ones is a key form of abstraction. This commit adds the `deftype` form to allow this.
## Entry 31:
Ensure the Function type performs as expected
## Entry 32:
One of the most-used data structures (in Clojure, at least) is the HashMap. Here's the implementation for it in Toccata.
## Entry 33:
No modern programming language is complete without a concurrency story. For Toccata, that revolves around the Promise and Future datatypes. This is their story.
## Entry 34:
The final 'built-in' datatype also rounds out the concurrency story. This commit implements the Agent functionality.
## Entry 35:
Just clean up some loose ends that were dangling before proceeding
## Entry 36:
Fixed a bug in the recursive descent parser code.
## Entry 37:
A 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.
## Entry 38:
Sharing libraries for others to use is a huge part of usability. This commit allows any git repository to be imported as a Toccata dependency.
## Entry 39:
One of the most used special forms is 'for'.
## Entry 40:
Another 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.
## Entry 41:
Add some "nice to haves" to the core library
## Entry 42:
Add 'gensym' to let you generate unique symbols.
## Entry 43:
A thread-safe, lazy list implementation
## Entry 44:
Going 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.
## Entry 45:
And doing the same for the Future data type. Async programming in Toccata is going to be awesome!
## Entry 46:
So 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.
## Entry 47:
And we finally have a compiler that will compile itself with not-too-bad performance.
To use it, compile toccata.c with
clang -g -O3 -fno-objc-arc -std=c99 -c core.c
clang -g -O3 -fno-objc-arc -o toccata -std=c99 core.o toccata.c -lpthread
You can leave off the `-fno-objc-arg` if you're on Linux
And thus ends the history.
================================================
FILE: LICENSE
================================================
Mozilla Public License Version 2.0
==================================
1. Definitions
--------------
1.1. "Contributor"
means each individual or legal entity that creates, contributes to
the creation of, or owns Covered Software.
1.2. "Contributor Version"
means the combination of the Contributions of others (if any) used
by a Contributor and that particular Contributor's Contribution.
1.3. "Contribution"
means Covered Software of a particular Contributor.
1.4. "Covered Software"
means Source Code Form to which the initial Contributor has attached
the notice in Exhibit A, the Executable Form of such Source Code
Form, and Modifications of such Source Code Form, in each case
including portions thereof.
1.5. "Incompatible With Secondary Licenses"
means
(a) that the initial Contributor has attached the notice described
in Exhibit B to the Covered Software; or
(b) that the Covered Software was made available under the terms of
version 1.1 or earlier of the License, but not also under the
terms of a Secondary License.
1.6. "Executable Form"
means any form of the work other than Source Code Form.
1.7. "Larger Work"
means a work that combines Covered Software with other material, in
a separate file or files, that is not Covered Software.
1.8. "License"
means this document.
1.9. "Licensable"
means having the right to grant, to the maximum extent possible,
whether at the time of the initial grant or subsequently, any and
all of the rights conveyed by this License.
1.10. "Modifications"
means any of the following:
(a) any file in Source Code Form that results from an addition to,
deletion from, or modification of the contents of Covered
Software; or
(b) any new file in Source Code Form that contains any Covered
Software.
1.11. "Patent Claims" of a Contributor
means any patent claim(s), including without limitation, method,
process, and apparatus claims, in any patent Licensable by such
Contributor that would be infringed, but for the grant of the
License, by the making, using, selling, offering for sale, having
made, import, or transfer of either its Contributions or its
Contributor Version.
1.12. "Secondary License"
means either the GNU General Public License, Version 2.0, the GNU
Lesser General Public License, Version 2.1, the GNU Affero General
Public License, Version 3.0, or any later versions of those
licenses.
1.13. "Source Code Form"
means the form of the work preferred for making modifications.
1.14. "You" (or "Your")
means an individual or a legal entity exercising rights under this
License. For legal entities, "You" includes any entity that
controls, is controlled by, or is under common control with You. For
purposes of this definition, "control" means (a) the power, direct
or indirect, to cause the direction or management of such entity,
whether by contract or otherwise, or (b) ownership of more than
fifty percent (50%) of the outstanding shares or beneficial
ownership of such entity.
2. License Grants and Conditions
--------------------------------
2.1. Grants
Each Contributor hereby grants You a world-wide, royalty-free,
non-exclusive license:
(a) under intellectual property rights (other than patent or trademark)
Licensable by such Contributor to use, reproduce, make available,
modify, display, perform, distribute, and otherwise exploit its
Contributions, either on an unmodified basis, with Modifications, or
as part of a Larger Work; and
(b) under Patent Claims of such Contributor to make, use, sell, offer
for sale, have made, import, and otherwise transfer either its
Contributions or its Contributor Version.
2.2. Effective Date
The licenses granted in Section 2.1 with respect to any Contribution
become effective for each Contribution on the date the Contributor first
distributes such Contribution.
2.3. Limitations on Grant Scope
The licenses granted in this Section 2 are the only rights granted under
this License. No additional rights or licenses will be implied from the
distribution or licensing of Covered Software under this License.
Notwithstanding Section 2.1(b) above, no patent license is granted by a
Contributor:
(a) for any code that a Contributor has removed from Covered Software;
or
(b) for infringements caused by: (i) Your and any other third party's
modifications of Covered Software, or (ii) the combination of its
Contributions with other software (except as part of its Contributor
Version); or
(c) under Patent Claims infringed by Covered Software in the absence of
its Contributions.
This License does not grant any rights in the trademarks, service marks,
or logos of any Contributor (except as may be necessary to comply with
the notice requirements in Section 3.4).
2.4. Subsequent Licenses
No Contributor makes additional grants as a result of Your choice to
distribute the Covered Software under a subsequent version of this
License (see Section 10.2) or under the terms of a Secondary License (if
permitted under the terms of Section 3.3).
2.5. Representation
Each Contributor represents that the Contributor believes its
Contributions are its original creation(s) or it has sufficient rights
to grant the rights to its Contributions conveyed by this License.
2.6. Fair Use
This License is not intended to limit any rights You have under
applicable copyright doctrines of fair use, fair dealing, or other
equivalents.
2.7. Conditions
Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
in Section 2.1.
3. Responsibilities
-------------------
3.1. Distribution of Source Form
All distribution of Covered Software in Source Code Form, including any
Modifications that You create or to which You contribute, must be under
the terms of this License. You must inform recipients that the Source
Code Form of the Covered Software is governed by the terms of this
License, and how they can obtain a copy of this License. You may not
attempt to alter or restrict the recipients' rights in the Source Code
Form.
3.2. Distribution of Executable Form
If You distribute Covered Software in Executable Form then:
(a) such Covered Software must also be made available in Source Code
Form, as described in Section 3.1, and You must inform recipients of
the Executable Form how they can obtain a copy of such Source Code
Form by reasonable means in a timely manner, at a charge no more
than the cost of distribution to the recipient; and
(b) You may distribute such Executable Form under the terms of this
License, or sublicense it under different terms, provided that the
license for the Executable Form does not attempt to limit or alter
the recipients' rights in the Source Code Form under this License.
3.3. Distribution of a Larger Work
You may create and distribute a Larger Work under terms of Your choice,
provided that You also comply with the requirements of this License for
the Covered Software. If the Larger Work is a combination of Covered
Software with a work governed by one or more Secondary Licenses, and the
Covered Software is not Incompatible With Secondary Licenses, this
License permits You to additionally distribute such Covered Software
under the terms of such Secondary License(s), so that the recipient of
the Larger Work may, at their option, further distribute the Covered
Software under the terms of either this License or such Secondary
License(s).
3.4. Notices
You may not remove or alter the substance of any license notices
(including copyright notices, patent notices, disclaimers of warranty,
or limitations of liability) contained within the Source Code Form of
the Covered Software, except that You may alter any license notices to
the extent required to remedy known factual inaccuracies.
3.5. Application of Additional Terms
You may choose to offer, and to charge a fee for, warranty, support,
indemnity or liability obligations to one or more recipients of Covered
Software. However, You may do so only on Your own behalf, and not on
behalf of any Contributor. You must make it absolutely clear that any
such warranty, support, indemnity, or liability obligation is offered by
You alone, and You hereby agree to indemnify every Contributor for any
liability incurred by such Contributor as a result of warranty, support,
indemnity or liability terms You offer. You may include additional
disclaimers of warranty and limitations of liability specific to any
jurisdiction.
4. Inability to Comply Due to Statute or Regulation
---------------------------------------------------
If it is impossible for You to comply with any of the terms of this
License with respect to some or all of the Covered Software due to
statute, judicial order, or regulation then You must: (a) comply with
the terms of this License to the maximum extent possible; and (b)
describe the limitations and the code they affect. Such description must
be placed in a text file included with all distributions of the Covered
Software under this License. Except to the extent prohibited by statute
or regulation, such description must be sufficiently detailed for a
recipient of ordinary skill to be able to understand it.
5. Termination
--------------
5.1. The rights granted under this License will terminate automatically
if You fail to comply with any of its terms. However, if You become
compliant, then the rights granted under this License from a particular
Contributor are reinstated (a) provisionally, unless and until such
Contributor explicitly and finally terminates Your grants, and (b) on an
ongoing basis, if such Contributor fails to notify You of the
non-compliance by some reasonable means prior to 60 days after You have
come back into compliance. Moreover, Your grants from a particular
Contributor are reinstated on an ongoing basis if such Contributor
notifies You of the non-compliance by some reasonable means, this is the
first time You have received notice of non-compliance with this License
from such Contributor, and You become compliant prior to 30 days after
Your receipt of the notice.
5.2. If You initiate litigation against any entity by asserting a patent
infringement claim (excluding declaratory judgment actions,
counter-claims, and cross-claims) alleging that a Contributor Version
directly or indirectly infringes any patent, then the rights granted to
You by any and all Contributors for the Covered Software under Section
2.1 of this License shall terminate.
5.3. In the event of termination under Sections 5.1 or 5.2 above, all
end user license agreements (excluding distributors and resellers) which
have been validly granted by You or Your distributors under this License
prior to termination shall survive termination.
************************************************************************
* *
* 6. Disclaimer of Warranty *
* ------------------------- *
* *
* Covered Software is provided under this License on an "as is" *
* basis, without warranty of any kind, either expressed, implied, or *
* statutory, including, without limitation, warranties that the *
* Covered Software is free of defects, merchantable, fit for a *
* particular purpose or non-infringing. The entire risk as to the *
* quality and performance of the Covered Software is with You. *
* Should any Covered Software prove defective in any respect, You *
* (not any Contributor) assume the cost of any necessary servicing, *
* repair, or correction. This disclaimer of warranty constitutes an *
* essential part of this License. No use of any Covered Software is *
* authorized under this License except under this disclaimer. *
* *
************************************************************************
************************************************************************
* *
* 7. Limitation of Liability *
* -------------------------- *
* *
* Under no circumstances and under no legal theory, whether tort *
* (including negligence), contract, or otherwise, shall any *
* Contributor, or anyone who distributes Covered Software as *
* permitted above, be liable to You for any direct, indirect, *
* special, incidental, or consequential damages of any character *
* including, without limitation, damages for lost profits, loss of *
* goodwill, work stoppage, computer failure or malfunction, or any *
* and all other commercial damages or losses, even if such party *
* shall have been informed of the possibility of such damages. This *
* limitation of liability shall not apply to liability for death or *
* personal injury resulting from such party's negligence to the *
* extent applicable law prohibits such limitation. Some *
* jurisdictions do not allow the exclusion or limitation of *
* incidental or consequential damages, so this exclusion and *
* limitation may not apply to You. *
* *
************************************************************************
8. Litigation
-------------
Any litigation relating to this License may be brought only in the
courts of a jurisdiction where the defendant maintains its principal
place of business and such litigation shall be governed by laws of that
jurisdiction, without reference to its conflict-of-law provisions.
Nothing in this Section shall prevent a party's ability to bring
cross-claims or counter-claims.
9. Miscellaneous
----------------
This License represents the complete agreement concerning the subject
matter hereof. If any provision of this License is held to be
unenforceable, such provision shall be reformed only to the extent
necessary to make it enforceable. Any law or regulation which provides
that the language of a contract shall be construed against the drafter
shall not be used to construe this License against a Contributor.
10. Versions of the License
---------------------------
10.1. New Versions
Mozilla Foundation is the license steward. Except as provided in Section
10.3, no one other than the license steward has the right to modify or
publish new versions of this License. Each version will be given a
distinguishing version number.
10.2. Effect of New Versions
You may distribute the Covered Software under the terms of the version
of the License under which You originally received the Covered Software,
or under the terms of any subsequent version published by the license
steward.
10.3. Modified Versions
If you create software not governed by this License, and you want to
create a new license for such software, you may create and use a
modified version of this License if you rename the license and remove
any references to the name of the license steward (except to note that
such modified license differs from this License).
10.4. Distributing Source Code Form that is Incompatible With Secondary
Licenses
If You choose to distribute Source Code Form that is Incompatible With
Secondary Licenses under the terms of this version of the License, the
notice described in Exhibit B of this License must be attached.
Exhibit A - Source Code Form License Notice
-------------------------------------------
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at http://mozilla.org/MPL/2.0/.
If it is not possible or desirable to put the notice in a particular
file, then You may include the notice in a location (such as a LICENSE
file in a relevant directory) where a recipient would be likely to look
for such a notice.
You may add additional accurate notices of copyright ownership.
Exhibit B - "Incompatible With Secondary Licenses" Notice
---------------------------------------------------------
This Source Code Form is "Incompatible With Secondary Licenses", as
defined by the Mozilla Public License, v. 2.0.
================================================
FILE: README.md
================================================
Toccata
=======
> "Pithy quote."
> - Unknown
An incomplete, buggy, undocumented, Clojure-inspired Lisp dialect that compiles to native executable using the Clang compiler
# Quick start (for macOS, Linux should be similar)
Make 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.
* Clone this repo and switch to the cloned directory
* Compile `core.c`
clang -O3 -g -fno-objc-arc -std=c99 -c core.c
* Compile the Toccata compiler itself
clang -O3 -g -fno-objc-arc -o toccata -std=c99 core.o toccata.c -lpthread -latomic
* Set the TOCCATA_DIR environment variable to the directory that contains `core.toc`
export TOCCATA_DIR=/Users/jduey/toccata
* Add that same directory to the C_INCLUDE_PATH environment variable
export C_INCLUDE_PATH=$C_INCLUDE_PATH:$TOCCATA_DIR
* For convenience, make sure the `toccata` executable is on the $PATH.
export PATH=$PATH:$TOCCATA_DIR
# Compile your first program
* Paste this text to a file named `hw.toc`
(main [_]
(println "Howdy, folks"))
* Compile it to C code
toccata hw.toc > hw.c
* Compile the C code using `clang` and link with `core.o`
clang -g -fno-objc-arc -o hw -std=c99 $TOCCATA_DIR/core.o hw.c -lpthread -latomic
* Run it
./hw
# But wait!
## READ THIS SECTION! It will save you hours of frustration.
See that phrase at the very top? I'll put it here just to make sure
"inspired by Clojure"
Toccata 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.
* `for` is not just for sequences. It works on any data type that implements the `flat-map` protocol function
* `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.
* 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.
* 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.
* 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.
* 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.
# And now ...
This 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.
Check the HISTORY.md file for a detailed description.
You can learn more about Toccata by following the [blog here](http://toccata.io)
================================================
FILE: assertion-tests/add-items-list-1.toc
================================================
(def CrazyType (any-of List
Vector
Integer))
(defn f [x]
(assert (instance? CrazyType x))
(str x))
(defn g [[a b]]
(inc b))
(defn h [y]
(g y)
(f y))
(main [_]
(println (h ['a 'b]))
(println 'bogus))
================================================
FILE: assertion-tests/add-items-list-2.toc
================================================
(def CrazyType (any-of List
Vector
Integer))
(defn f [x]
(assert (instance? CrazyType x))
(str x))
(defn g [[a b]]
(inc b))
(defn h [y]
(f y)
(g y))
(main [_]
(println (h ['a 'b]))
(println 'bogus))
================================================
FILE: assertion-tests/and-constraints-1.toc
================================================
(defn foo [zs p]
(let [mv (maybe zs)]
(and (let [t (extract mv)]
(maybe (inc p)))
mv)))
(main [_]
(println (foo ["xx"] "p"))
(println 'done))
================================================
FILE: assertion-tests/and-constraints-2.toc
================================================
(defn foo [zs p]
(let [mv (maybe zs)
p (str p)]
(and mv
(let [t (extract mv)]
(maybe (inc p)))
(maybe (subs p 1)))))
(main [_]
(println (foo ["xx"] 72))
(println 'done))
================================================
FILE: assertion-tests/apply-constructor.toc
================================================
(deftype Popper [x y]
(assert (instance? Symbol x))
(assert (instance? Integer y)))
(defn g [& vs]
(apply Popper vs))
(main [_]
(print-err (g 's "8")))
================================================
FILE: assertion-tests/bad-add.toc
================================================
(def a "z")
(def b 's)
(main [_]
(+ 8 b a))
================================================
FILE: assertion-tests/bad-and-1.toc
================================================
(defn f [x]
(and nothing
{'a 1}))
(main [_]
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/bad-and-2.toc
================================================
(defn f [x]
(and nothing
1)
'bogus)
(main [_]
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/bad-and-clause.toc
================================================
(defn add-commas [x-str]
(assert (instance? String x-str))
(assert-result l (instance? List l))
(let [prefix-len (mod (count x-str) 3)
prefix (subs x-str 0 (mod (count x-str) 3))]
(either (or (and (empty? x-str)
(maybe empty-list))
(and (= prefix-len 0)
(list* "," (subs x-str 0 3)
(add-commas (subs x-str 3)))))
(list* "," (subs x-str 0 prefix-len)
(add-commas (subs x-str prefix-len))))))
(main [_]
(print-err (add-commas "140"))
(print-err 'done))
================================================
FILE: assertion-tests/bad-apply-constructor.toc
================================================
(deftype Bogus [a b c]
Stringable
(string-list [_]
(list "<BC " (str a) " " (str b) " " (str c) ">")))
(main [_]
(apply Bogus [4 5]))
================================================
FILE: assertion-tests/bad-arity-1.toc
================================================
(defn bad [a b]
a)
(main [_]
(bad "Bogus"))
================================================
FILE: assertion-tests/bad-constructor-call.toc
================================================
(deftype AnotherType [x z]
Stringable
(string-list [_] (list "<AnotherType " (str z) ">")))
(def boomer (AnotherType 1))
(main [_]
(println "Fail!!!!"))
================================================
FILE: assertion-tests/bad-constructor-param-1.toc
================================================
(deftype Boogie [xs]
(assert (instance? (vector-of Integer) xs))
Stringable
(string-list [_]
(list "Boogie " (str xs))))
(main [_]
(print-err 'bgi (Boogie [1 2 'p])))
================================================
FILE: assertion-tests/bad-constructor-param-2.toc
================================================
(defprotocol Pookie
(pook [_]
(assert-result r (instance? (list-of (any-of StringBuffer
SubString))
r))))
(deftype Boogie [xs]
Stringable
(string-list [_]
(list "Boogie " (str xs)))
Pookie
(pook [_]
(map xs (fn [n]
(str (inc n))))))
(main [_]
(print-err 'bgi (Boogie [1 2 'p])))
================================================
FILE: assertion-tests/bad-dipatch-type.toc
================================================
(defprotocol BogusProto
(bogus [x]
(assert (instance? String x))))
(deftype BogusType [y]
BogusProto
(bogus [z]
(str y)))
(main [_]
(print-err 'c1))
================================================
FILE: assertion-tests/bad-enum-1.toc
================================================
(def en (enum r3 r1 2))
(defn r-str [r]
(assert (instance? en r))
(print-err 'r r))
(main [_]
(r-str r3))
================================================
FILE: assertion-tests/bad-enum-2.toc
================================================
(def en (enum r3 r1 Integer))
(defn r-str [r]
(assert (instance? en r))
(print-err 'r r))
(main [_]
(r-str r3))
================================================
FILE: assertion-tests/bad-enum-3.toc
================================================
(deftype Bogus [])
(def en (enum r3 r1 Bogus))
(defn r-str [r]
(assert (instance? en r))
(print-err 'r r))
(main [_]
(r-str r2))
================================================
FILE: assertion-tests/bad-enum-4.toc
================================================
(def en (enum r3 r1 (+ 4 2)))
(defn r-str [r]
(assert (instance? en r))
(print-err 'r r))
(main [_]
(r-str r2))
================================================
FILE: assertion-tests/bad-field-1.toc
================================================
(deftype Ooops [not-there])
(deftype Bogus [x-field])
(main [_]
(.not-there (Bogus 99)))
================================================
FILE: assertion-tests/bad-field-2.toc
================================================
(deftype Ooops [not-there])
(deftype Bogus [x-field])
(defn f [x]
(.not-there x))
(defn g [v]
(assert (instance? Bogus v))
(.x-field v))
(defn h [z]
(g z)
(f z))
(main [_]
(println 'bogus))
================================================
FILE: assertion-tests/bad-field-3.toc
================================================
(deftype Ooops [not-there])
(deftype Bogus [x-field])
(defn f [x]
(.not-there x))
(defn g [v]
(assert (instance? Bogus v))
(.x-field v))
(defn h [z]
(f z)
(g z))
(main [_]
(println 'bogus))
================================================
FILE: assertion-tests/bad-field-4.toc
================================================
(deftype Ooops [not-there])
(deftype Bogus [x-field])
(main [_]
(-> (Bogus 99)
(.x-field 3)
.not-there))
================================================
FILE: assertion-tests/bad-field-5.toc
================================================
(deftype Ooops [not-there])
(deftype Bogus [x-field])
(defn f [x]
(-> (.x-field 3)
.not-there))
(main [_]
(f (Bogus 99)))
================================================
FILE: assertion-tests/bad-flat-map-inner.toc
================================================
(defn f [s]
(for [x (maybe (inc s))
y (maybe (symbol x))]
(str y)))
(main [_]
(print-err (for [x (f 8)]
(subs x 1))))
================================================
FILE: assertion-tests/bad-function-returns-1.toc
================================================
(deftype Failure [])
(deftype new-se [invoke-fn]
;; (assert (instance? Fn invoke-fn))
(assert (instance? (function-returns Vector) invoke-fn))
Stringable
(string-list [x]
(comp (list "<new-se ")
(string-list (.invoke-fn x))
(list ">")))
Function
(invoke [ev s]
(invoke-fn s)))
(def state-error
(reify
Function
(invoke [_ v]
(new-se (fn [s] v)))))
(main [_]
(print-err (state-error 8)))
================================================
FILE: assertion-tests/bad-function-returns-2.toc
================================================
(deftype Failure [])
(deftype new-se [invoke-fn]
;; (assert (instance? Fn invoke-fn))
(assert (instance? (function-returns Vector) invoke-fn))
Stringable
(string-list [x]
(comp (list "<new-se ")
(string-list (.invoke-fn x))
(list ">")))
Function
(invoke [ev s]
(invoke-fn s))
Container
(map [ev f]
(new-se (fn [s]
(let [x (invoke-fn s)]
(either (= Failure x)
(let [[v new-s] x]
[(f v) new-s]))))))
(wrap [_ v]
(new-se (fn [s]
[v s])))
(flat-map [ev f]
(new-se (fn [s]
(let [x (invoke-fn s)]
(either (= Failure x)
(let [[v new-s] x]
((f v) new-s))))))))
(def state-error
(reify
Function
(invoke [_ v]
(new-se (fn [s]
[v s])))))
(main [_]
(print-err ((for [x (state-error 8)
y (state-error 9)]
(subs y 1))
'state)))
================================================
FILE: assertion-tests/bad-impl-arity.toc
================================================
(main [_]
(take "Bogus"))
================================================
FILE: assertion-tests/bad-impl-return-value.toc
================================================
(defprotocol Proto
(some-getter [tc]
(assert-result r (instance? (maybe-of Symbol) r))
nothing))
(deftype KeysConstraint [fld]
(assert (instance? (maybe-of Symbol) fld))
Proto
(some-getter [tc]
(maybe fld)))
(main [_]
(print-err 'FAILURE))
================================================
FILE: assertion-tests/bad-inline-result-type.toc
================================================
(defn bad-f [x]
(inline C BogusType "// shouldn't matter
"))
(main [_]
(println "FAIL!!!"))
================================================
FILE: assertion-tests/bad-inner-1.toc
================================================
(main [_]
(map [1 2 3] (fn [n]
(subs n 1)))
(print-err 'howdy))
================================================
FILE: assertion-tests/bad-inner-10.toc
================================================
(defn f [vs]
(reduce vs {} (fn [m [x y]]
(assoc m x [(inc x) y]))))
(main [_]
(f [(list 1 2)
['x]
[3 6]]))
================================================
FILE: assertion-tests/bad-inner-11.toc
================================================
(defn f [x]
(map x inc))
(defn g [x]
(maybe (subs x 1)))
(main [_]
(-> "x"
g
f))
================================================
FILE: assertion-tests/bad-inner-12.toc
================================================
(defn f [x]
(-> x
(map str)
first
(map inc)))
(main [_]
(print-err 'howdy))
================================================
FILE: assertion-tests/bad-inner-13.toc
================================================
(defn f [x]
(-> x
(map str)
(map inc)))
(main [_]
(print-err 'howdy))
================================================
FILE: assertion-tests/bad-inner-14.toc
================================================
(defn f [x]
(-> x
(map str)
last
(map inc)))
(main [_]
(print-err 'howdy))
================================================
FILE: assertion-tests/bad-inner-15.toc
================================================
(main [_]
(-> (maybe "1")
extract
inc))
================================================
FILE: assertion-tests/bad-inner-16.toc
================================================
(defn f [x]
(for [_ (maybe 3)]
(inc x)))
(defn g [x]
(for [y (f x)]
(do
(assert (instance? Integer y))
y)))
(defn h [x]
(for [_ (maybe 3)]
(symbol x)))
(defn i [x]
(for [y (h x)]
i))
(defn j [x]
(for [y (g x)
_ (i y)]
x))
(main [_]
(print-err (j 8)))
================================================
FILE: assertion-tests/bad-inner-2.toc
================================================
(main [_]
(map (list (inc 3)) (fn [n]
(subs n 1)))
(print-err 'howdy))
================================================
FILE: assertion-tests/bad-inner-3.toc
================================================
(defn f [x]
(map x inc))
(defn g [x]
(map x (fn [n] (subs n 1))))
(defn h [x]
(f x)
(g x))
(main [_]
(print-err 'howdy))
================================================
FILE: assertion-tests/bad-inner-4.toc
================================================
(main [_]
(-> [1 2 3]
(map inc)
(drop-while (fn [n]
(= "" (subs n 1)))))
(print-err 'howdy))
================================================
FILE: assertion-tests/bad-inner-5.toc
================================================
(defn f [x]
(map x inc))
(defn g [x]
(map x (fn [n] (subs n 1))))
(defn h [x]
(-> x f g))
(main [_]
(print-err 'howdy))
================================================
FILE: assertion-tests/bad-inner-6.toc
================================================
(defn f [vs]
(map vs (fn [v]
(map v inc))))
(main [_]
(f [[1 2]
[3 5 "bogus"]
[3 6]]))
================================================
FILE: assertion-tests/bad-inner-7.toc
================================================
(defn f [vs]
(flat-map vs
(fn [v]
(flat-map v inc))))
(main [_]
(f [[1 2]
[3 5 "bogus"]
[3 6]]))
================================================
FILE: assertion-tests/bad-inner-8.toc
================================================
(defn f [vs]
(for [v vs
x v]
(inc x)))
(main [_]
(f [[1 2]
[3 5 "bogus"]
[3 6]]))
================================================
FILE: assertion-tests/bad-inner-9.toc
================================================
(defn f [vs]
(map vs (fn [[x y]]
[(inc x) y])))
(main [_]
(f [(list 1 2)
[]
[3 6]]))
================================================
FILE: assertion-tests/bad-inner-or.toc
================================================
(defn f []
(maybe "9"))
(defn g []
(maybe "88"))
(defn h []
(map (or (f)
(g))
inc))
(main [_]
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/bad-let.toc
================================================
(defn bad [x]
(let [x (inc x)
x (str x)]
(subs x 1)))
(main [_]
(bad 99)
(bad "99")
(print-err 'done))
================================================
FILE: assertion-tests/bad-list-of-1.toc
================================================
(defprotocol TestListOf
(returns-list-of-string [x]
(assert-result x (instance? (list-of String) x))))
(deftype BogusType [x]
(assert (instance? Integer x))
TestListOf
(returns-list-of-string [_]
;; TODO: error message needs improvement
(list "<BogusType" x ">")))
(main [_]
(print-err 'FAIL!!!!))
================================================
FILE: assertion-tests/bad-nested-let.toc
================================================
(defn bad [x]
(let [y (inc 8)]
(let [x (inc x)
x (str y)]
(subs x 1))))
(main [_]
(println (bad 99))
(println (bad "99"))
(println 'done))
================================================
FILE: assertion-tests/bad-or-1.toc
================================================
;; TODO: error message is unhelpful
(defn g []
{'a 1})
(defn f [x]
(or nothing
(g)
nothing))
(main [_]
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/bad-or-2.toc
================================================
(defn f [x]
(or nothing
{'a 1}
nothing)
'bogus)
(main [_]
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/bad-result-sum-type.toc
================================================
(defprotocol Proto
(proto-fn [_]
(assert-result r (instance? (maybe-of Integer) r))))
(deftype IC [x]
Proto
(proto-fn [c]
(or (maybe 'bog)
(maybe "88"))))
(main [_]
(print-err 'done (str "'" (proto-fn (IC 8)) "'" )))
================================================
FILE: assertion-tests/bad-return-value.toc
================================================
;; TODO: the path on the error generated is incomplete
(defprotocol C
(eic [_]
(assert-result r (instance? Vector r))
[]))
(deftype IC [items]
Stringable
(string-list [_]
(list "<IC " (str items) ">")))
(deftype MC [cs]
C
(eic [mc]
(-> (.cs mc)
(some (partial instance? IC))
(map .items))))
(defn b [_]
(assert-result r (instance? Vector r))
(some [1 2 4] (partial instance? String)))
(main [_]
(eic (MC [1 (IC 2) 3]))
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/bad-setter-call-1.toc
================================================
(deftype Bogus [x]
Stringable
(string-list [_]
(list "Bogus" x)))
(deftype Boogie [xs]
(assert (instance? (vector-of Integer) xs))
Stringable
(string-list [_]
(list "Boogie " (str xs))))
(main [_]
(.xs (Boogie [1 2 3]) [1 2 'plop]))
================================================
FILE: assertion-tests/bad-setter-call-2.toc
================================================
(defprotocol Pookie
(pook [_]
(assert-result r (instance? (list-of (any-of StringBuffer
SubString))
r))))
(deftype Boogie [xs]
Stringable
(string-list [_]
(list "Boogie " (str xs)))
Pookie
(pook [_]
(map xs (fn [n]
(str (inc n))))))
(main [_]
(.xs (Boogie [1 2 3]) [1 2 'plop]))
================================================
FILE: assertion-tests/bad-state-maybe-value-1.toc
================================================
(deftype new-sm [invoke-fn]
Stringable
(string-list [x]
(comp (list "<new-sm ")
(string-list (.invoke-fn x))
(list ">")))
Function
(invoke [ev s]
(invoke-fn s))
Container
(map [mv f]
(new-sm (fn [s]
(let [a (invoke-fn s)]
(and a (let [[v new-s] (extract a)]
(maybe [(f v) new-s])))))))
(wrap [b v]
(new-sm (fn [s]
(maybe [v s]))))
(flat-map [ev f]
(new-sm (fn [s]
(let [d (invoke-fn s)]
(and d (let [[v ss] (extract d)]
((f v) ss)))))))
Composition
(zero [_] (new-sm (fn [_] nothing))))
(def state-maybe
(reify
Type
(type-name [_]
"*state-maybe wrapper*")
Container
(apply [_ [v]]
(new-sm (fn [s]
(maybe [v s]))))
Function
(invoke [_ v]
(new-sm (fn [s]
(maybe [v s]))))
Composition
(zero [_] (new-sm (fn [_] nothing)))))
(def zero-sm
(zero state-maybe))
(main [_]
(flat-map (new-sm (fn [s]
(maybe ['a s])))
(fn [x]
(state-maybe (inc x))))
(print-err 'done))
================================================
FILE: assertion-tests/bad-state-maybe-value-2.toc
================================================
(deftype new-sm [invoke-fn]
Stringable
(string-list [x]
(comp (list "<new-sm ")
(string-list (.invoke-fn x))
(list ">")))
Function
(invoke [ev s]
(invoke-fn s))
Container
(map [mv f]
(new-sm (fn [s]
(let [a (invoke-fn s)]
(and a (let [[v new-s] (extract a)]
(maybe [(f v) new-s])))))))
(wrap [b v]
(new-sm (fn [s]
(maybe [v s]))))
(flat-map [ev f]
(new-sm (fn [s]
(let [d (invoke-fn s)]
(and d (let [[v ss] (extract d)]
((f v) ss)))))))
Composition
(zero [_] (new-sm (fn [_] nothing))))
(def state-maybe
(reify
Type
(type-name [_]
"*state-maybe wrapper*")
Container
(apply [_ [v]]
(new-sm (fn [s]
(maybe [v s]))))
Function
(invoke [_ v]
(new-sm (fn [s]
(maybe [v s]))))
Composition
(zero [_] (new-sm (fn [_] nothing)))))
(def zero-sm
(zero state-maybe))
(main [_]
(map (wrap zero-sm 'a)
(fn [x]
(inc x)))
(print-err 'done))
================================================
FILE: assertion-tests/bad-type-comp.toc
================================================
(deftype Type1 [int]
Stringable
(string-list [_] (list (str int))))
(deftype Type2 [int]
Stringable
(string-list [_] (list (str int))))
(defn not-type [x]
(inc x))
(def Types (any-of Type1
not-type
Type2))
(main [_]
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/bad-vector-of-1.toc
================================================
(defn g [v]
(assert (instance? (vector-of Integer) v))
(map v (fn [x]
(subs x 1))))
(main [_]
(print-err 'FAIL!!!!))
================================================
FILE: assertion-tests/checked-map-1.toc
================================================
(main [_]
(let [m {}]
(assert (instance? (map-of String Integer) m))
(assoc m "bogus" 'bogus)
(println 'done)))
================================================
FILE: assertion-tests/checked-map-2.toc
================================================
(main [_]
(let [m {}]
(assert (instance? (map-of Integer Symbol) m))
(assoc m "bogus" 'bogus)
(println 'done)))
================================================
FILE: assertion-tests/closure-1.toc
================================================
(defn foo [zs p]
(flat-map (list zs)
(fn [t]
(list (subs p 1))))
(flat-map (list zs)
(fn [t]
(list (inc p)))))
(main [_]
(println (foo ["xx"] "p"))
(println 'done))
================================================
FILE: assertion-tests/closure-2.toc
================================================
(defn foo [zs p]
(flat-map (list zs)
(fn [t]
(list (inc p)))))
(main [_]
(println (foo ["xx"] "p"))
(println 'done))
================================================
FILE: assertion-tests/closure-constraint.toc
================================================
(defprotocol Boomer
(boom [_ y]
(print-err 'booooom)
(abort)))
(deftype Dummy [nope])
(deftype Slider []
Boomer
(boom [_ y]
(print-err 'pop (.nope y))))
(defn f [marvelous]
(assert (instance? Slider marvelous))
(fn []
(boom marvelous 8)))
(main [_]
(f (Slider))
(print-err 'done ;; ((f 1) {})
))
================================================
FILE: assertion-tests/closure-param.toc
================================================
(main [_]
(let [x 8
f (fn [z]
(+ x z))]
(println (f "100")))
(println 'done))
================================================
FILE: assertion-tests/comp-bad-type-1.toc
================================================
(def BadType (any-of NoType
List))
(main [_]
(println "FAIL!!!"))
================================================
FILE: assertion-tests/comp-bad-type-2.toc
================================================
(def BadType (any-of List
NoType))
(main [_]
(println "FAIL!!!"))
================================================
FILE: assertion-tests/conj-to-getter-result-1.toc
================================================
(deftype Boogie [xs]
(assert (instance? (vector-of Integer) xs))
Stringable
(string-list [_]
(list "Boogie " (str xs))))
(main [_]
(-> (.xs (Boogie [1 2 3]))
(conj 'plop)))
================================================
FILE: assertion-tests/conj-to-getter-result-2.toc
================================================
(defprotocol Pookie
(pook [_]
(assert-result r (instance? (list-of (any-of StringBuffer
SubString))
r))))
(deftype Boogie [xs]
Stringable
(string-list [_]
(list "Boogie " (str xs)))
Pookie
(pook [_]
(map xs (fn [n]
(str (inc n))))))
(main [_]
(let [bgi (Boogie [1 2 3])]
(print-err 'pook (pook (.xs bgi (conj (.xs bgi) 'plop))))))
================================================
FILE: assertion-tests/constructor-param-1.toc
================================================
(deftype SomeType [a b]
(assert (instance? Symbol a))
(assert (instance? String b)))
(main [_]
(SomeType (str 'symbol) "9"))
================================================
FILE: assertion-tests/constructor-param-2.toc
================================================
(deftype SomeType [a b]
(assert (instance? Symbol a))
(assert (instance? String b)))
(defn f [x]
(SomeType x "9"))
(main [_]
(f (str 'symbol)))
================================================
FILE: assertion-tests/constructor-param-3.toc
================================================
(deftype SomeType [a b]
(assert (instance? (min-count 1) a))
(assert (instance? String b)))
(defn f [xs]
(SomeType xs "9"))
(main [_]
(f []))
================================================
FILE: assertion-tests/contents-2.toc
================================================
(defn f [x]
(cons 'bogus x))
(defn g [x]
(map x inc))
(main [_]
(g (f empty-list)))
================================================
FILE: assertion-tests/deeply-nested-vector-1.toc
================================================
(defn g []
["str"])
(defn f [x]
(assert (instance? Integer x))
(assert-result r (instance? (vector-of String) r))
(comp []
[(g)]
[]))
(main [_]
(print-err 'strs (f 3)))
================================================
FILE: assertion-tests/deeply-nested-vector-2.toc
================================================
(defn f [x]
(assert (instance? Integer x))
(assert-result r (instance? (vector-of String) r))
TODO: this test needs to be fixed
(cond (< 0 x)
[(f (dec x))]
[]))
(main [_]
(print-err 'strs (f 3)))
================================================
FILE: assertion-tests/destruct-variadic-tail-2.toc
================================================
;; TODO: error message is empty
(defn f [x]
(assert (instance? Integer x))
(str x))
(defn g [& y]
(let [[x] y]
(f x)))
(main [_]
(print-err "Line number should be 12")
(print-err 'wut (g))
(print-err 'done))
================================================
FILE: assertion-tests/dup-protocol-name.toc
================================================
(defprotocol Stringable
(pf [x y z]
(assert (instance? Integer y))
(subs z 1)))
(defn f []
(pf 'x 3 3))
(main [_]
(print-err "FAIL!!!"))
================================================
FILE: assertion-tests/dynamic-call-1.toc
================================================
(deftype nougie [invoke-fn]
(assert (instance? Fn invoke-fn))
Stringable
(string-list [x]
(comp (list "<nougie ")
(string-list (.invoke-fn x))
(list ">")))
Function
(invoke [ev s]
(invoke-fn s)))
(main [_]
(let [a 'a
wrapper (nougie (fn [s]
(maybe [a s])))]
(nougie (fn [s]
(let [d (wrapper s)]
(and d (let [[v ss] (extract d)]
(maybe [(inc v) ss])))))))
(print-err 'done))
================================================
FILE: assertion-tests/dynamic-call-2.toc
================================================
(defn g [f]
(assert (instance? Fn f))
(f 8))
(defn f [n]
(str n))
(main [_]
(inc (g f)))
================================================
FILE: assertion-tests/dynamic-call-3.toc
================================================
TODO: make this test work
(defn g [f]
(f 8))
(def f
(reify
Function
(invoke [_ n]
(str n))))
(main [_]
(inc (g f)))
================================================
FILE: assertion-tests/dynamic-call-4.toc
================================================
(deftype nougie [invoke-fn]
(assert (instance? Fn invoke-fn))
Stringable
(string-list [x]
(comp (list "<nougie ")
(string-list (.invoke-fn x))
(list ">")))
Function
(invoke [ev s]
(invoke-fn s)))
(main [_]
(let [a 'a
wrapper (nougie (fn [s]
(maybe ['a s])))]
(nougie (fn [s]
(let [d (wrapper s)]
(and d (let [[v ss] (extract d)]
(maybe [(inc v) ss])))))))
(print-err 'done))
================================================
FILE: assertion-tests/dynamic-call-5.toc
================================================
TODO: Detecting this error will require a much different technique
Probably build a function to be executed at the call site
(defn g [f]
(assert (instance? Fn f))
(f 'a))
(defn f [n]
[n])
(main [_]
(map (g f) inc))
================================================
FILE: assertion-tests/dynamic-call-6.toc
================================================
TODO: Detecting this error will require a much different technique
Probably build a function to be executed at the call site
(defn g [f]
(f 'a))
(def f
(reify
Function
(invoke [_ n]
[n])))
(main [_]
(map (g f) inc))
================================================
FILE: assertion-tests/dynamic-call-7.toc
================================================
TODO: make this test work
(defn g [f]
(f 8))
(defn f [x]
(reify
Function
(invoke [_ n]
(str n " " x))))
(main [_]
(inc (g (f 77))))
================================================
FILE: assertion-tests/dynamic-call-8.toc
================================================
(deftype nougie [invoke-fn]
(assert (instance? Fn invoke-fn))
Stringable
(string-list [x]
(comp (list "<nougie ")
(string-list (.invoke-fn x))
(list ">")))
Function
(invoke [ev s]
(invoke-fn s)))
(main [_]
(let [a 'a
wrapper (nougie (fn [s]
(maybe [a s])))]
(nougie (fn [s]
(let [d (wrapper s)]
(and d (let [[v ss] (extract d)]
(maybe [(inc v) ss])))))))
(print-err 'done))
================================================
FILE: assertion-tests/dynamic-field-type-1.toc
================================================
(deftype AType [x])
(main [_]
(inc (.x (AType 'x)))
(print-err 'FAIL))
================================================
FILE: assertion-tests/dynamic-field-type-2.toc
================================================
(deftype AType [x])
TODO: re-enable this test eventually
(main [_]
(-> (AType 9)
(.x 'x)
.x
(inc)))
================================================
FILE: assertion-tests/dynamic-nested-value-1.toc
================================================
(defn g [_ x]
(maybe [x]))
(main [_]
(map (either (g 'nope 'bogus)
;; TODO: this should cause an assertion error
;; []
['nada])
inc))
================================================
FILE: assertion-tests/dynamic-proto-param-1.toc
================================================
(defprotocol AProto
(dorf [x y]))
(deftype AType [x]
AProto
(dorf [_ y]
y))
(main [_]
(inc (dorf (AType 99) 'nope)))
================================================
FILE: assertion-tests/empty-defn.toc
================================================
(defn f []
)
(main [_]
(println "FAIL"))
================================================
FILE: assertion-tests/field-and-seq-conflict.toc
================================================
(deftype Bogus [boom])
(defn f [x]
(.boom x))
(defn g [[x y]]
y)
(defn h [x]
(g x)
(f x))
(main [_]
(print-err 'howdy))
================================================
FILE: assertion-tests/field-constraint.toc
================================================
(defprotocol Proto
(proto-f [_]))
(deftype Bogus [x]
(assert (instance? Integer x))
Proto
(proto-f [_]
(subs x 1)))
(main [_]
(print-err 'FAIL))
================================================
FILE: assertion-tests/field-shadow.toc
================================================
(defprotocol Foo
(foor [v x]))
(deftype OneType [x s]
(assert (instance? Integer x))
Foo
(foor [v x]
(print-err 'FAIL)
(abort))
Stringable
(string-list [_] (list "<OneType " (str x) ">")))
(main [_]
(print-err (foor (OneType (inc 8) (symbol (str "1" "2"))) 99)))
================================================
FILE: assertion-tests/flat-map-param.toc
================================================
(deftype and-ast [clauses]
(assert (instance? Vector clauses))
Stringable
(string-list [_]
(comp (list "<AndAST ")
(flat-map clauses string-list)
(list ">"))))
(defn traverse [asts f]
(reduce (reverse asts) (maybe empty-list)
(fn [l ast]
(flat-map (f ast)
(fn [emitted]
(map l (fn [x]
(cons emitted x))))))))
;; TODO: the error path has too much info in it
(main [_]
(let [aa (and-ast ['a 'b])]
(println (map (traverse ['a 'b] maybe)
(fn [nc]
(.clauses aa nc)))))
(println 'done))
================================================
FILE: assertion-tests/impl-violates-proto.toc
================================================
(deftype FirstType [x y])
(deftype SecondType [x])
(defprotocol Proto
(proto-fn [a b]
(assert (instance? SecondType b))
'wtf))
(extend-type FirstType
Proto
(proto-fn [a b]
(let [n (print-err (.y b) (.x a))]
(either (= n 99)
(.y b n)))))
(main [_]
(print-err 'FAIL))
================================================
FILE: assertion-tests/incompatible-tails.toc
================================================
(defn f [xs]
(let [[x y & more] xs]
(map more inc)
(inc x)
(subs y 1)))
(defn g [xs]
(let [[x y & more] xs]
(map more (fn [m]
(subs m 1)))
(inc x)
(subs y 1)))
(defn h [ys]
(f ys)
(g ys))
(main [_]
(let [xs [1 "33" 8]]
(print-err 'h (h xs))))
================================================
FILE: assertion-tests/init-type.toc
================================================
(def ints [1 2 3])
(def ints (-> ints
(reverse)
(take 2)
(map inc)))
(defn f [l]
(cons 5 l))
(main [_]
(f ints))
================================================
FILE: assertion-tests/insufficient-static-elements-1.toc
================================================
(defn f [[a b]]
(inc a))
(main [_]
(f [9]))
================================================
FILE: assertion-tests/insufficient-static-elements-2.toc
================================================
(defn f [y]
(let [[[a x] b] '((a) 1)]
(inc a)))
(main [_]
(f ['a 9]))
================================================
FILE: assertion-tests/insufficient-static-elements-3.toc
================================================
(defn f [x]
(let [[[a b x y z] c & d] [[2] 4 6]]
a))
(main [_]
(f ['a 9]))
================================================
FILE: assertion-tests/insufficient-static-elements-4.toc
================================================
(defn f [y]
(let [[a b] y]
(println 'a (inc a))))
(main [_]
(println (f [9])))
================================================
FILE: assertion-tests/int-too-large.toc
================================================
(defn f [n]
;; TODO: can't read this assertion
(assert (max 4) n)
(inc n))
(main [_]
(f 5)
(print-err 'howdy))
================================================
FILE: assertion-tests/items-constraints-1.toc
================================================
(defn f []
(let [[a b] ['a 9]]
(inc a)))
(main [_]
(f))
================================================
FILE: assertion-tests/items-constraints-2.toc
================================================
(defn f [y]
(let [[a b] y]
(inc a)))
(main [_]
(f ['a 9]))
================================================
FILE: assertion-tests/items-constraints-3.toc
================================================
(defn f [y]
(let [[a b] y
a (inc a)]
(str a)))
(main [_]
(f ['a 9]))
================================================
FILE: assertion-tests/key-violation.toc
================================================
(defn f [m s v]
(assert (instance? (map-of Symbol Integer) m))
(assoc m s v))
(main [_]
(print-err 'FAIL (f {} "7" 88)))
================================================
FILE: assertion-tests/list-items-types.toc
================================================
(defn f [[a b & c]]
(inc b))
(main [_]
(f [1 'b]))
================================================
FILE: assertion-tests/literal-hash-map-1.toc
================================================
(defn f []
(assert-result r (instance? (map-of Symbol Integer) r))
{'a 1
"b" 2
'c 3})
(main [_]
(print-err (f)))
================================================
FILE: assertion-tests/literal-hash-map-2.toc
================================================
(defn f []
(assert-result r (instance? (map-of Symbol Integer) r))
{'a 1
'b "2"
'c 3})
(main [_]
(print-err (f)))
================================================
FILE: assertion-tests/min-count.toc
================================================
(defn f [x]
(assert (min-count x 3))
x)
(main [_]
(f [1 2]))
================================================
FILE: assertion-tests/missing-namespaced-sym.toc
================================================
(def puke "puke")
(main [_]
(println 'puke ll/puke))
================================================
FILE: assertion-tests/multi-constraint-violated.toc
================================================
(def Bands (all-of Integer
(min 4)
(max 8)))
(defn pr-bands [n]
(assert (instance? Bands n))
(print-err 'bands n))
(main [_]
(pr-bands 4)
(pr-bands 10)
(print-err 'FAIL))
================================================
FILE: assertion-tests/nested-destruct-1.toc
================================================
(defn f [[a b]]
(println 'a (inc a) 'b b)
nothing)
(main [_]
(f (either (maybe [["19" 3] 4 6])
nothing))
(println 'done))
================================================
FILE: assertion-tests/nested-destruct-2.toc
================================================
(defn f [[[a b] c & d]]
(println 'a (inc a) 'b b 'c c)
nothing)
(main [_]
(f (either (maybe [["19" 3] 4 6])
nothing))
(println 'done))
================================================
FILE: assertion-tests/nested-destruct.toc
================================================
(defn f [y]
(let [[[a b] c & d] y]
(inc a)
(print-err 'a a 'b b 'c c)
nothing))
(main [_]
(f [["2" 3] 4 6]))
================================================
FILE: assertion-tests/nested-items-conflict.toc
================================================
(defn f [[a b]]
(inc a))
(defn g [[a b]]
(subs a 2))
(defn h [x]
(f x)
(g x))
(main [_]
(print-err 'bogus))
================================================
FILE: assertion-tests/or-prop.toc
================================================
(def SomeVal (any-of Integer
String))
(defn f [x y]
(assert (instance? SomeVal x))
(or (and (do
(print-err 'y (inc y))
(instance? Integer x))
(maybe (inc x)))
(and (do
(print-err 'y (+ 4 y))
(instance? String x))
(maybe (subs x 1)))))
(main [_]
(print-err "1)" (f 4 9))
(print-err "2)" (f "212" 3))
(print-err "3)" (f "212" "34")))
================================================
FILE: assertion-tests/param-in-and.toc
================================================
(defn f [x]
(and nothing
x))
(main [_]
(print-err (f 1)))
================================================
FILE: assertion-tests/param-in-or.toc
================================================
(defn f [x]
(or nothing
x))
(main [_]
(print-err (f 1)))
================================================
FILE: assertion-tests/partial-param.toc
================================================
(main [_]
(partial subs 8))
================================================
FILE: assertion-tests/preserve-asserts.toc
================================================
(deftype Checked [m]
(assert (instance? HashMap m))
Associative
(assoc [_ k v]
(assert (instance? HashSet v))
(or (instance? HashSet v)
(abort))
(Checked (assoc m k v))))
(main [_]
(assoc (Checked {}) "bogus" 'bogus)
(println 'done))
================================================
FILE: assertion-tests/preserve-static-info-1.toc.test
================================================
(defn f [x]
(let [y [2]]
(and x (let [[[a b] c & d] y]
(println 'a a 'b b 'c c)
nothing))))
(main [_]
(f (maybe [1 2]))
(println 'done))
================================================
FILE: assertion-tests/preserve-static-info-2.toc.test
================================================
(defn f [x]
(let [y [[2] 4 6]]
(and x (let [;; [result new-s] (extract x)
[[a b] c & d] y]
(println 'a a 'b b 'c c)
nothing))))
(main [_]
(f (maybe [1 2]))
(println 'done))
================================================
FILE: assertion-tests/preserve-static-info-3.toc.test
================================================
(defn f [x]
(let [y [["2" 3] 4 6]]
(and x (let [;; [result new-s] (extract x)
[[a b] c & d] y]
(inc a)
(println 'a a 'b b 'c c)
nothing))))
(main [_]
(f (maybe [1 2]))
(println 'done))
================================================
FILE: assertion-tests/propogate-inner-1.toc
================================================
(defn f [l v]
(assert (instance? (vector-of Integer) l))
(conj l v))
(main [_]
(print-err (f [] "99")))
================================================
FILE: assertion-tests/propogate-inner-2.toc
================================================
(defn f [m v]
(assert (instance? (map-of Symbol Integer) m))
(assoc m 'sym v))
(main [_]
(print-err (f {'sym 88} "99")))
================================================
FILE: assertion-tests/propogate-through-let.toc
================================================
(defn f [vs]
(let [v vs]
(inc v)))
(main [_]
(f "bogus"))
================================================
FILE: assertion-tests/propogate-through-seq.toc
================================================
(main [_]
(map (seq (vector 'a 'b 2)) inc))
================================================
FILE: assertion-tests/propogate-through-vec.toc
================================================
(main [_]
(map (vec (list 'a 'b 2)) inc))
================================================
FILE: assertion-tests/proto-fn-constraint-prop.toc
================================================
(defn f [x]
(inc x))
(defprotocol Proto
(g [_ x]))
(deftype SomeType [y]
Proto
(g [_ z]
(f z)))
(main [_]
(g (SomeType 'nop) "62"))
================================================
FILE: assertion-tests/proto-fn-min-count.toc
================================================
(defprotocol TempProto
(bogus [z u]
(assert (instance? (min-count 2) u))))
(deftype Bogus [s]
TempProto
(bogus [_ y]
(conj y 'a)))
(main [_]
(bogus (Bogus 1) [3]))
================================================
FILE: assertion-tests/proto-fn-param.toc
================================================
(main [_]
(nth [1 2 3] "2"))
================================================
FILE: assertion-tests/restrict-conflict.toc
================================================
(deftype OneType [x]
Stringable
(string-list [_] (list "<OneType " (str x) ">")))
(deftype AnotherType [x z]
Stringable
(string-list [_] (list "<AnotherType " (str z) ">")))
(def BothTypes (any-of OneType
AnotherType))
(defn only-one [xtreme]
(assert (instance? OneType xtreme))
xtreme)
(defn only-another [xtreme]
(assert (instance? AnotherType xtreme))
xtreme)
(defn bad [xtreme]
(assert (instance? BothTypes xtreme))
[(only-one xtreme)
(only-another xtreme)])
(main [_]
(println 'FAIL!!!))
================================================
FILE: assertion-tests/restrict-nested-item.toc
================================================
(deftype OneType [x]
Stringable
(string-list [_] (list "<OneType " (str x) ">")))
(deftype AnotherType [x z]
Stringable
(string-list [_] (list "<AnotherType " (str z) ">")))
(def BothTypes (any-of OneType
AnotherType))
(defn only-one [[a b [c x]]]
(assert (instance? OneType x))
x)
(defn only-another [[a b [c x]]]
(assert (instance? AnotherType x))
x)
(defn bad [x]
[(only-one x)
(only-another x)])
(main [_]
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/restrict-param.toc
================================================
(deftype OneType [x]
Stringable
(string-list [_] (list "<OneType " (str x) ">")))
(deftype AnotherType [x z]
Stringable
(string-list [_] (list "<AnotherType " (str z) ">")))
(def BothTypes (any-of OneType
AnotherType))
(defn only-one [x]
(assert (instance? OneType x))
x)
(defn bad [x]
(assert (instance? BothTypes x))
(only-one x))
(main [_]
(bad (AnotherType 'x 'z))
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/return-bad-type.toc
================================================
(defprotocol SomeProto
(f [x]
(assert-result l (instance? List l))))
(deftype SomeType [x]
SomeProto
(f [y]
(assert-result l (instance? String l))
""))
(main [_]
(print-err "FAIL!!!"))
================================================
FILE: assertion-tests/return-generic-1.toc
================================================
(defn bloop [x]
(assert-result r (instance? (vector-of Integer) r))
[x])
(main [_]
(print-err (bloop "9")))
================================================
FILE: assertion-tests/return-list-of-1.toc
================================================
(defprotocol BProt
(bloop [_ z]
(assert-result r (instance? (list-of Integer) r))))
(deftype Bogus [x]
BProt
(bloop [_ z]
(list z 88)))
(main [_]
(print-err (bloop (Bogus "9") 'bogus)))
================================================
FILE: assertion-tests/return-list-of-2.toc
================================================
(defprotocol BProt
(bloop [_]
(assert-result r (instance? (list-of Integer) r))))
(deftype Bogus [x]
Stringable
(string-list [_]
(list "<Bogus>"))
BProt
(bloop [_]
(list x 88)))
(main [_]
(print-err (Bogus "9")))
================================================
FILE: assertion-tests/return-sum-type.toc
================================================
(defn foo [x]
(assert-result y (instance? HashMap y))
"")
(main [_]
(println 'foo (foo 88)))
================================================
FILE: assertion-tests/simple-conflict.toc
================================================
(defn bad [x]
[(inc x)
(subs x 1)])
(main [_]
(bad "one")
(println 'done))
================================================
FILE: assertion-tests/static-fixed-dynamic-result-type-1.toc
================================================
(defn f [x]
[x])
(main [_]
(map (f 'bogus) inc)
(print-err 'FAIL))
================================================
FILE: assertion-tests/static-fixed-dynamic-result-type-2.toc
================================================
(defn f [x]
;; TODO: this line does not appear in the constraint path in the error message
x)
(defn g [_ x]
(f x))
(main [_]
(inc (g 'nope 'bogus)))
================================================
FILE: assertion-tests/unkown-field.toc
================================================
(deftype Bogus [int]
(assert (instance? Integer string))
Stringable
(string-list [_] (list (str int))))
(main [_]
(print-err 'FAIL!!!))
================================================
FILE: assertion-tests/update-field-1.toc
================================================
(deftype SomeType [x y]
(assert (instance? String x))
(assert (instance? Integer y))
Stringable
(string-list [_]
(list "<SomeType " (str x) " " (str y) ">")))
(main [_]
(println (.x (SomeType "string" 7) 3))
(println 'done))
================================================
FILE: assertion-tests/variadic-constraints.toc
================================================
(defn f [x y & z]
(subs y 1))
(main [_]
(f 1 2 3))
================================================
FILE: assertion-tests/variadic-count-1.toc
================================================
(defn f [x y & t]
(println 'x x))
(main [_]
(f 1))
================================================
FILE: assertion-tests/variadic-count-2.toc
================================================
(main [_]
(let [a 'bogus
f (fn [x y & t]
(println a x))]
(print-err "Line number should be" (inc _LINE_))
(f 1)))
================================================
FILE: assertion-tests/vect-len.toc
================================================
(defn f [l]
(let [[x y & z] l]
(println 'x x)
(println 'y y)
(println 'z z)))
(main [_]
(f ['a])
(println 'done))
================================================
FILE: bin/build-toccata.sh
================================================
#! /bin/sh
TOCCATA_DIR="$(cd -P -- $(dirname -- $0)/../ && pwd)"
clang -g \
-v \
-fno-objc-arc \
-o toccata \
-I$TOCCATA_DIR \
-std=c99 \
-DCHECK_MEM_LEAK=1 \
$TOCCATA_DIR/core.c \
toccata.c \
-lpthread
================================================
FILE: bin/toccata.sh
================================================
#! /bin/sh
export TOCCATA_DIR="$(cd -P -- $(dirname -- $0)/../ && pwd)"
PATH=$PATH:$TOCCATA_DIR
usage() {
echo "Usage: ./bin/toccata.sh input.toc > output.c"
exit 1
}
if [ "$#" -lt 1 ]; then
usage
fi
toccata "$@"
================================================
FILE: core.c
================================================
#include <stdlib.h>
#include <stdatomic.h>
#include "core.h"
REFS_SIZE refsInit = 1;
REFS_SIZE refsError = -10;
REFS_SIZE refsConstant = -1;
REFS_SIZE refsStatic = -2;
Value *universalProtoFn = (Value *)0;
Integer const0 = {IntegerType, -2, 0};
Value *const0Ptr = (Value *)&const0;
int cleaningUp = 0;
// Immutable hash-map ported from Clojure
BitmapIndexedNode emptyBMI = {BitmapIndexedType, -2, 0, 0};
// threads that have been replaced, but haven't exited
pthread_mutex_t lingeringAccess = PTHREAD_MUTEX_INITIALIZER;
Value *lingeringThreads = (Value *)&emptyBMI;
void prefs(char *tag, Value *v) {
if (v != (Value *)0)
fprintf(stderr, "%s: %p %d\n", tag, v, v->refs);
else
fprintf(stderr, "%s: %p\n", tag, v);
}
int64_t malloc_count = 0;
int64_t free_count = 0;
int64_t type_mallocs[20] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
int64_t type_frees[20] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
void incTypeMalloc(TYPE_SIZE type, int delta) {
if (type < 0) {
fprintf(stderr, "type malloc inc failure\n");
abort();
}
else if (type == TypeCount)
__atomic_fetch_add(&type_mallocs[19], delta, __ATOMIC_ACQ_REL);
else if (type > OpaqueType)
__atomic_fetch_add(&type_mallocs[0], delta, __ATOMIC_ACQ_REL);
else if (type == SymbolType)
__atomic_fetch_add(&type_mallocs[5], delta, __ATOMIC_ACQ_REL);
else
__atomic_fetch_add(&type_mallocs[type], delta, __ATOMIC_ACQ_REL);
}
void incTypeFree(TYPE_SIZE type, int delta) {
if (type < 0) {
fprintf(stderr, "type free inc failure\n");
abort();
}
else if (type == TypeCount)
__atomic_fetch_add(&type_frees[19], delta, __ATOMIC_ACQ_REL);
else if (type > OpaqueType)
__atomic_fetch_add(&type_frees[0], delta, __ATOMIC_ACQ_REL);
else if (type == SymbolType)
__atomic_fetch_add(&type_frees[5], delta, __ATOMIC_ACQ_REL);
else
__atomic_fetch_add(&type_frees[type], delta, __ATOMIC_ACQ_REL);
}
Maybe nothing_struct = {MaybeType, -2, 0, 0};
Value *nothing = (Value *)¬hing_struct;
List empty_list_struct = (List){ListType,-2,0,0,0,0};
List *empty_list = &empty_list_struct;
Vector empty_vect_struct = (Vector){VectorType,-2,0,0,5,0,0};
Vector *empty_vect = &empty_vect_struct;;
ReifiedVal all_values_struct = {AllValuesType, -2, 0};
Value *all_values = (Value *)&all_values_struct;
#ifdef SINGLE_THREADED
#define NUM_WORKERS 1
#else
#ifndef NUM_WORKERS
#define NUM_WORKERS 10
#endif
#endif
pthread_t workers[NUM_WORKERS];
int32_t runningWorkers = NUM_WORKERS;
int8_t mainThreadDone = 0;
int mask(int64_t hash, int shift) {
return (hash >> shift) & 0x1f;
}
int bitpos(int64_t hash, int shift) {
return 1 << mask(hash, shift);
}
Value *my_malloc(int64_t sz) {
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 1, __ATOMIC_ACQ_REL);
#endif
Value *val = malloc(sz);
if (sz > sizeof(Value)) {
#ifndef SINGLE_THREADED
#ifdef FAST_INCS
fprintf(stderr, "FAST_INCS can only be defined when SINGLE_THREADED is defined.\n");
abort();
#endif
#ifdef FAST_DECS
fprintf(stderr, "FAST_DECS can only be defined when SINGLE_THREADED is defined.\n");
abort();
#endif
#endif
val->refs = refsInit;
}
return(val);
}
void cleanupMemory (Value *the_final_answer, Value *maybeNothing, List *argList) {
#ifdef CHECK_MEM_LEAK
dec_and_free(the_final_answer, 1);
freeGlobal((Value *)argList);
freeGlobal(maybeNothing);
freeAll();
#endif
}
typedef struct {Value *head; uintptr_t aba;} FreeValList;
Value *removeFreeValue(FreeValList *freeList) {
Value *item = (Value *)0;
FreeValList orig;
#ifdef SINGLE_THREADED
orig = *freeList;
FreeValList next = orig;
item = orig.head;
if (item == (Value *)0) {
return((Value *)0);
} else {
next.head = item->next;
freeList = &next;
if (item->refs != refsError) {
fprintf(stderr, "failure in removeFreeValue: %d\n", item->refs);
abort();
}
return(item);
}
#else
__atomic_load((FreeValList *)freeList, (FreeValList *)&orig, __ATOMIC_RELAXED);
FreeValList next = orig;
if (orig.head != (Value *)0) {
do {
item = orig.head;
next.head = item->next;
next.aba = orig.aba + 1;
} while (!__atomic_compare_exchange((FreeValList *)freeList,
(FreeValList *)&orig,
(FreeValList *)&next, 1,
__ATOMIC_RELAXED, __ATOMIC_RELAXED) &&
orig.head != (Value *)0);
if (orig.head == (Value *)0)
item = (Value *)0;
}
if (item == (Value *)0) {
return((Value *)0);
} else {
REFS_SIZE refs;
__atomic_load(&item->refs, &refs, __ATOMIC_RELAXED);
if (refs != refsError) {
fprintf(stderr, "failure in removeFreeValue: %d\n", refs);
abort();
}
return(item);
}
#endif
}
int decRefs(Value *v, int deltaRefs) {
#ifndef FAST_DECS
#ifdef SINGLE_THREADED
if (v->refs == refsConstant || v->refs == refsStatic)
return(v->refs);
if (v->refs < deltaRefs) {
fprintf(stderr, "\nfailure in decRefs, refs too small: %d %p\n", v->refs, v);
abort();
} else if (v->refs == deltaRefs)
v->refs = refsError;
else
v->refs -= deltaRefs;
return(v->refs);
#else
if (v->refs == refsConstant || v->refs == refsStatic)
return(v->refs);
REFS_SIZE newRefs = __atomic_fetch_sub(&v->refs, deltaRefs, __ATOMIC_ACQ_REL);
if (newRefs > deltaRefs)
return(newRefs - deltaRefs);
else if (newRefs == deltaRefs) {
v->refs = refsError;
return(refsError);
}
fprintf(stderr, "\nfailure in decRefs, refs too small: %d %d %p\n", deltaRefs, v->refs, v);
abort();
return(refsError);
#endif
#else
if (v->refs == refsConstant ||
v->refs == refsStatic)
return(v->refs);
if (v->refs == deltaRefs)
v->refs = refsError;
else
v->refs -= deltaRefs;
return(v->refs);
#endif
}
void moveToCentral(FreeValList *freeList, FreeValList *centralList) {
Value *tail = freeList->head;
while (tail != (Value *)0 && tail->next != (Value *)0) {
tail = tail->next;
}
if (tail == (Value *)0)
return;
else {
FreeValList orig;
#ifdef SINGLE_THREADED
orig = *centralList;
FreeValList next = orig;
tail->next = orig.head;
next.head = freeList->head;
next.aba = orig.aba + 1;
*centralList = next;
#else
FreeValList next;
__atomic_load((FreeValList *)centralList, (FreeValList *)&orig, __ATOMIC_RELAXED);
do {
tail->next = orig.head;
next.head = freeList->head;
next.aba = orig.aba + 1;
} while (!__atomic_compare_exchange((FreeValList *)centralList,
(FreeValList *)&orig,
(FreeValList *)&next,
1, __ATOMIC_RELAXED, __ATOMIC_RELAXED));
#endif
freeList->head = (Value *)0;
return;
}
}
void decValuePtrRef(Value **ptr) {
Value *toFree = (Value *)0;
Value *oldPtr = (Value *)0;
__atomic_exchange(ptr, &toFree, &oldPtr, __ATOMIC_RELAXED);
if (oldPtr != (Value *)0) {
dec_and_free((Value *)oldPtr, 1);
}
}
FreeValList centralFreeIntegers = (FreeValList){(Value *)0, 0};
__thread FreeValList freeIntegers = {(Value *)0, 0};
Integer *malloc_integer() {
Integer *newInteger = (Integer *)freeIntegers.head;
if (newInteger == (Integer *)0) {
newInteger = (Integer *)removeFreeValue(¢ralFreeIntegers);
if (newInteger == (Integer *)0) {
Integer *numberStructs = (Integer *)my_malloc(sizeof(Integer) * 100);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 99, __ATOMIC_ACQ_REL);
// incTypeMalloc(TypeCount, 1);
#endif
for (int i = 1; i < 99; i++) {
numberStructs[i].refs = refsError;
((Value *)&numberStructs[i])->next = (Value *)&numberStructs[i + 1];
}
numberStructs[99].refs = refsError;
((Value *)&numberStructs[99])->next = (Value *)0;
freeIntegers.head = (Value *)&numberStructs[1];
moveToCentral(&freeIntegers, ¢ralFreeIntegers);
newInteger = numberStructs;
}
} else {
freeIntegers.head = freeIntegers.head->next;
}
// incTypeMalloc(IntegerType, 1);
newInteger->type = IntegerType;
newInteger->refs = refsInit;
return(newInteger);
}
void freeInteger(Value *v) {
v->next = freeIntegers.head;
freeIntegers.head = v;
}
FreeValList centralFreeStrings = (FreeValList){(Value *)0, 0};
__thread FreeValList freeStrings = {(Value *)0, 0};
#define STRING_RECYCLE_LEN 100
String *malloc_string(int len) {
String *str;
if (len > STRING_RECYCLE_LEN) {
str = (String *)my_malloc(sizeof(String) + len + 4);
memset(str->buffer, 0, len + 4);
} else {
str = (String *)freeStrings.head;
if (str == (String *)0) {
str = (String *)removeFreeValue(¢ralFreeStrings);
if (str == (String *)0) {
str = (String *)my_malloc(sizeof(String) + STRING_RECYCLE_LEN + 4);
memset(str->buffer, 0, STRING_RECYCLE_LEN);
}
} else {
freeStrings.head = freeStrings.head->next;
}
}
// incTypeMalloc(StringBufferType, 1);
str->refs = refsInit;
str->hashVal = 0;
str->type = StringBufferType;
str->len = len;
return(str);
}
void freeString(Value *v) {
int64_t len = ((String *)v)->len;
if (len <= STRING_RECYCLE_LEN) {
v->next = freeStrings.head;
freeStrings.head = v;
} else {
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
#endif
if (!cleaningUp)
free(v);
}
}
FreeValList centralFreeSubStrings = (FreeValList){(Value *)0, 0};
__thread FreeValList freeSubStrings = {(Value *)0, 0};
SubString *malloc_substring() {
SubString *subStr = (SubString *)freeSubStrings.head;
if (subStr == (SubString *)0) {
subStr = (SubString *)removeFreeValue(¢ralFreeSubStrings);
if (subStr == (SubString *)0) {
subStr = (SubString *)my_malloc(sizeof(SubString));
}
} else {
freeSubStrings.head = freeSubStrings.head->next;
}
// incTypeMalloc(SubStringType, 1);
subStr->refs = refsInit;
subStr->hashVal = 0;
return(subStr);
}
void freeSubString(Value *v) {
Value *src = ((SubString *)v)->source;
if (src != (Value *)0) {
dec_and_free(src, 1);
}
v->next = freeSubStrings.head;
freeSubStrings.head = v;
}
FreeValList centralFreeFnArities = (FreeValList){(Value *)0, 0};
__thread FreeValList freeFnArities = {(Value *)0, 0};
FnArity *malloc_fnArity() {
FnArity *newFnArity = (FnArity *)freeFnArities.head;
if (newFnArity == (FnArity *)0) {
newFnArity = (FnArity *)removeFreeValue(¢ralFreeFnArities);
if (newFnArity == (FnArity *)0) {
newFnArity = (FnArity *)my_malloc(sizeof(FnArity));
}
} else {
freeFnArities.head = freeFnArities.head->next;
}
// incTypeMalloc(FnArityType, 1);
newFnArity->parent = (Value *)0;
newFnArity->type = FnArityType;
newFnArity->refs = refsInit;
return(newFnArity);
}
void freeFnArity(Value *v) {
FnArity *arity = (FnArity *)v;
dec_and_free((Value *)arity->closures, 1);
v->next = freeFnArities.head;
freeFnArities.head = v;
}
FreeValList centralFreeFunctions[10] = {(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0}};
__thread FreeValList freeFunctions[10] = {{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0}};
Function *malloc_function(int arityCount) {
Function *newFunction;
if (arityCount > 9) {
newFunction = (Function *)my_malloc(sizeof(Function) + sizeof(FnArity *) * arityCount);
} else {
newFunction = (Function *)freeFunctions[arityCount].head;
if (newFunction == (Function *)0) {
newFunction = (Function *)removeFreeValue(¢ralFreeFunctions[arityCount]);
if (newFunction == (Function *)0) {
newFunction = (Function *)my_malloc(sizeof(Function) + sizeof(FnArity *) * arityCount);
}
} else {
freeFunctions[arityCount].head = freeFunctions[arityCount].head->next;
}
}
// incTypeMalloc(FunctionType, 1);
newFunction->type = FunctionType;
((Function *)newFunction)->refs = refsInit;
return((Function *)newFunction);
}
void freeFunction(Value *v) {
Function *f = (Function *)v;
for (int i = 0; i < f->arityCount; i++) {
dec_and_free((Value *)f->arities[i], 1);
}
// fprintf(stderr, "%p freed\n", v);
if (f->arityCount < 10) {
v->next = freeFunctions[f->arityCount].head;
freeFunctions[f->arityCount].head = v;
} else {
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
#endif
if (!cleaningUp)
free(v);
}
}
FreeValList centralFreeLists = (FreeValList){(Value *)0, 0};
__thread FreeValList freeLists = (FreeValList){(Value *)0, 0};
List *malloc_list() {
List *newList = (List *)freeLists.head;
if (newList == (List *)0) {
newList = (List *)removeFreeValue(¢ralFreeLists);
if (newList == (List *)0) {
List *listStructs = (List *)my_malloc(sizeof(List) * 100);
#ifdef CHECK_MEM_LEAK
// incTypeMalloc(TypeCount, 1);
__atomic_fetch_add(&malloc_count, 99, __ATOMIC_ACQ_REL);
#endif
for (int i = 1; i < 99; i++) {
listStructs[i].refs = refsError;
((Value *)&listStructs[i])->next = (Value *)&listStructs[i + 1];
}
listStructs[99].refs = refsError;
((Value *)&listStructs[99])->next = freeLists.head;
freeLists.head = (Value *)&listStructs[1];
moveToCentral(&freeLists, ¢ralFreeLists);
newList = listStructs;
}
} else {
freeLists.head = freeLists.head->next;
}
// incTypeMalloc(ListType, 1);
newList->type = ListType;
newList->refs = refsInit;
newList->hashVal = 0;
newList->head = (Value *)0;
newList->tail = (List *)0;
newList->len = 0;
return(newList);
}
void freeList(Value *v) {
List *l = (List *)v;
Value *head = l->head;
if (head != (Value *)0)
dec_and_free(head, 1);
List *tail = l->tail;
l->tail = (List *)0;
v->next = freeLists.head;
freeLists.head = v;
#ifdef SINGLE_THREADED
if (tail != (List *)0) {
if (tail->refs == 1) {
tail->refs = refsError;
freeList((Value *)tail);
} else {
decRefs((Value *)tail, 1);
}
}
#else
if (tail != (List *)0) {
REFS_SIZE refs = tail->refs;
if (refs != 1) {
decRefs((Value *)tail, 1);
} else {
tail->refs = refsError;
freeList((Value *)tail);
}
}
#endif
}
FreeValList centralFreeMaybes = (FreeValList){(Value *)0, 0};
__thread FreeValList freeMaybes = {(Value *)0, 0};
Maybe *malloc_maybe() {
Maybe *newMaybe = (Maybe *)freeMaybes.head;
if (newMaybe == (Maybe *)0) {
newMaybe = (Maybe *)removeFreeValue(¢ralFreeMaybes);
if (newMaybe == (Maybe *)0) {
Maybe *maybeStructs = (Maybe *)my_malloc(sizeof(Maybe) * 50);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 49, __ATOMIC_ACQ_REL);
#endif
for (int i = 1; i < 49; i++) {
maybeStructs[i].refs = refsError;
((Value *)&maybeStructs[i])->next = (Value *)&maybeStructs[i + 1];
}
maybeStructs[49].refs = refsError;
((Value*)&maybeStructs[49])->next = (Value *)0;
freeMaybes.head = (Value *)&maybeStructs[1];
moveToCentral(&freeMaybes, ¢ralFreeMaybes);
newMaybe = maybeStructs;
}
} else {
freeMaybes.head = freeMaybes.head->next;
}
// incTypeMalloc(MaybeType, 1);
newMaybe->type = MaybeType;
newMaybe->refs = refsInit;
newMaybe->hashVal = 0;
newMaybe->value = (Value *)0;
return(newMaybe);
}
void freeMaybe(Value *v) {
Value *value = ((Maybe *)v)->value;
if (value != (Value *)0)
dec_and_free(value, 1);
v->next = freeMaybes.head;
freeMaybes.head = v;
}
FreeValList centralFreeVectorNodes = (FreeValList){(Value *)0, 0};
__thread FreeValList freeVectorNodes = {(Value *)0, 0};
VectorNode *malloc_vectorNode() {
VectorNode *newVectorNode = (VectorNode *)freeVectorNodes.head;
if (newVectorNode == (VectorNode *)0) {
newVectorNode = (VectorNode *)removeFreeValue(¢ralFreeVectorNodes);
if (newVectorNode == (VectorNode *)0) {
VectorNode *nodeStructs = (VectorNode *)my_malloc(sizeof(VectorNode) * 50);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 49, __ATOMIC_ACQ_REL);
#endif
for (int i = 1; i < 49; i++) {
nodeStructs[i].refs = refsError;
((Value *)&nodeStructs[i])->next = (Value *)&nodeStructs[i + 1];
}
nodeStructs[49].refs = refsError;
((Value*)&nodeStructs[49])->next = (Value *)0;
freeVectorNodes.head = (Value *)&nodeStructs[1];
moveToCentral(&freeVectorNodes, ¢ralFreeVectorNodes);
newVectorNode = nodeStructs;
}
} else {
freeVectorNodes.head = freeVectorNodes.head->next;
}
// incTypeMalloc(VectorNodeType, 1);
newVectorNode->type = VectorNodeType;
newVectorNode->refs = refsInit;
memset(&newVectorNode->array, 0, sizeof(Value *) * VECTOR_ARRAY_LEN);
return(newVectorNode);
}
void freeVectorNode(Value *v) {
for (int i = 0; i < VECTOR_ARRAY_LEN; i++) {
if (((VectorNode *)v)->array[i] != (Value *)0) {
dec_and_free(((VectorNode *)v)->array[i], 1);
}
}
v->next = freeVectorNodes.head;
freeVectorNodes.head = v;
}
FreeValList centralFreeVectors = (FreeValList){(Value *)0, 0};
__thread FreeValList freeVectors = {(Value *)0, 0};
Vector *malloc_vector() {
Vector *newVector = (Vector *)freeVectors.head;
if (newVector == (Vector *)0) {
newVector = (Vector *)removeFreeValue(¢ralFreeVectors);
if (newVector == (Vector *)0) {
Vector *vectorStructs = (Vector *)my_malloc(sizeof(Vector) * 300);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 299, __ATOMIC_ACQ_REL);
#endif
for (int i = 1; i < 299; i++) {
vectorStructs[i].refs = refsError;
((Value *)&vectorStructs[i])->next = (Value *)&vectorStructs[i + 1];
}
vectorStructs[299].refs = refsError;
((Value*)&vectorStructs[299])->next = (Value *)0;
freeVectors.head = (Value *)&vectorStructs[1];
moveToCentral(&freeVectors, ¢ralFreeVectors);
newVector = vectorStructs;
}
} else {
freeVectors.head = freeVectors.head->next;
}
// incTypeMalloc(VectorType, 1);
newVector->type = VectorType;
newVector->refs = refsInit;
newVector->count = 0;
newVector->shift = 5;
newVector->root = (VectorNode *)0;
newVector->hashVal = 0;
memset(&newVector->tail, 0, sizeof(Value *) * VECTOR_ARRAY_LEN);
return(newVector);
}
void freeVector(Value *v) {
Value *root = (Value *)((Vector *)v)->root;
if (root != (Value *)0) {
dec_and_free((Value *)root, 1);
}
for (int i = 0; i < VECTOR_ARRAY_LEN; i++) {
if (((Vector *)v)->tail[i] != (Value *)0)
dec_and_free(((Vector *)v)->tail[i], 1);
}
v->next = freeVectors.head;
freeVectors.head = v;
}
FreeValList centralFreeReified[20] = {(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0}};
__thread FreeValList freeReified[20] = {{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0}};
ReifiedVal *malloc_reified(int64_t implCount) {
ReifiedVal *newReifiedVal;
if (implCount > 19) {
newReifiedVal = (ReifiedVal *)my_malloc(sizeof(ReifiedVal) + sizeof(Function *) * implCount);
} else {
newReifiedVal = (ReifiedVal *)freeReified[implCount].head;
if (newReifiedVal == (ReifiedVal *)0) {
newReifiedVal = (ReifiedVal *)removeFreeValue(¢ralFreeReified[implCount]);
if (newReifiedVal == (ReifiedVal *)0) {
int rvSize = sizeof(ReifiedVal) + sizeof(Function *) * implCount;
int rvCount = 100000;
char *reifiedStructs = (char *)my_malloc(rvSize * rvCount);
for (int i = 1; i < (rvCount - 1); i++) {
((ReifiedVal *)&reifiedStructs[i * rvSize])->refs = refsError;
((Value *)&reifiedStructs[i * rvSize])->next = (Value *)&reifiedStructs[(i + 1) * rvSize];
}
((ReifiedVal *)&reifiedStructs[(rvCount - 1) * rvSize])->refs = refsError;
((Value *)&reifiedStructs[(rvCount - 1) * rvSize])->next = (Value *)0;
freeReified[implCount].head = (Value *)&reifiedStructs[rvSize];
moveToCentral(&freeReified[implCount], ¢ralFreeReified[implCount]);
newReifiedVal = (ReifiedVal *)reifiedStructs;
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, (rvCount - 1), __ATOMIC_ACQ_REL);
#endif
}
} else {
freeReified[implCount].head = freeReified[implCount].head->next;
}
}
// incTypeMalloc(0, 1);
newReifiedVal->refs = refsInit;
newReifiedVal->hashVal = 0;
newReifiedVal->implCount = implCount;
return(newReifiedVal);
}
#define BMI_RECYCLE_COUNT 20
FreeValList centralFreeBMINodes[BMI_RECYCLE_COUNT] = {(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0},
(FreeValList){(Value *)0, 0}};
__thread FreeValList freeBMINodes[BMI_RECYCLE_COUNT] = {{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0},
{(Value *)0, 0}};
BitmapIndexedNode *malloc_bmiNode(int itemCount) {
int nodeSize = sizeof(BitmapIndexedNode) + sizeof(Value *) * (itemCount * 2);
BitmapIndexedNode *bmiNode;
if (itemCount >= BMI_RECYCLE_COUNT) {
bmiNode = (BitmapIndexedNode *)my_malloc(nodeSize);
} else {
bmiNode = (BitmapIndexedNode *)freeBMINodes[itemCount].head;
if (bmiNode == (BitmapIndexedNode *)0) {
bmiNode = (BitmapIndexedNode *)removeFreeValue(¢ralFreeBMINodes[itemCount]);
if (bmiNode == (BitmapIndexedNode *)0) {
BitmapIndexedNode *bmiNodes;
bmiNodes = (BitmapIndexedNode *)my_malloc(nodeSize * 10);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 9, __ATOMIC_ACQ_REL);
#endif
bmiNode = (BitmapIndexedNode *)((void *)bmiNodes + nodeSize);
for (int i = 1; i < 9; i++) {
bmiNode->refs = refsError;
((Value *)bmiNode)->next = (Value *)((void *)bmiNode + nodeSize);
bmiNode = (BitmapIndexedNode *)((Value *)bmiNode)->next;
}
bmiNode = (BitmapIndexedNode *)((void *)bmiNodes + (9 * nodeSize));
bmiNode->refs = refsError;
((Value *)bmiNode)->next = (Value *)0;
freeBMINodes[itemCount].head = (Value *)((void *)bmiNodes + nodeSize);
moveToCentral(&freeBMINodes[itemCount], ¢ralFreeBMINodes[itemCount]);
bmiNode = bmiNodes;
}
} else {
// fprintf(stderr, "%d from local node: %p\n", itemCount, bmiNode);
freeBMINodes[itemCount].head = freeBMINodes[itemCount].head->next;
}
}
// incTypeMalloc(BitmapIndexedType, 1);
bmiNode->type = BitmapIndexedType;
bmiNode->refs = refsInit;
bmiNode->hashVal = 0;
bmiNode->bitmap = 0;
memset(&bmiNode->array, 0, sizeof(Value *) * (itemCount * 2));
return(bmiNode);
}
void freeBitmapNode(Value *v) {
BitmapIndexedNode *node = (BitmapIndexedNode *)v;
int cnt = __builtin_popcount(node->bitmap);
for (int i = 0; i < (2 * cnt); i++) {
if (node->array[i] != (Value *)0) {
dec_and_free(node->array[i], 1);
}
}
if (cnt >= BMI_RECYCLE_COUNT) {
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
#endif
if (!cleaningUp)
free(v);
} else {
v->next = freeBMINodes[cnt].head;
freeBMINodes[cnt].head = v;
}
}
HashCollisionNode *malloc_hashCollisionNode(int itemCount) {
if (itemCount > 30000) {
fprintf(stderr, "Catastrophic failure: Too many hash collisions\n");
abort();
}
int nodeSize = sizeof(HashCollisionNode) + sizeof(Value *) * (itemCount * 2);
HashCollisionNode *collisionNode;
collisionNode = (HashCollisionNode *)my_malloc(nodeSize);
// incTypeMalloc(HashCollisionNodeType, 1);
memset(collisionNode, 0, nodeSize);
collisionNode->type = HashCollisionNodeType;
collisionNode->count = itemCount * 2;
collisionNode->hashVal = 0;
collisionNode->refs = refsInit;
return(collisionNode);
}
void freeHashCollisionNode(Value *v) {
HashCollisionNode *node = (HashCollisionNode *)v;
for (int i = 0; i < node->count; i++) {
if (node->array[i] != (Value *)0) {
dec_and_free(node->array[i], 1);
}
}
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
#endif
if (!cleaningUp)
free(v);
}
FreeValList centralFreeArrayNodes = (FreeValList){(Value *)0, 0};
__thread FreeValList freeArrayNodes = {(Value *)0, 0};
ArrayNode *malloc_arrayNode() {
ArrayNode *arrayNode = (ArrayNode *)freeArrayNodes.head;
if (arrayNode == (ArrayNode *)0) {
arrayNode = (ArrayNode *)removeFreeValue(¢ralFreeArrayNodes);
if (arrayNode == (ArrayNode *)0) {
ArrayNode *arrayNodes = (ArrayNode *)my_malloc(sizeof(ArrayNode) * 10);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 9, __ATOMIC_ACQ_REL);
#endif
for (int i = 1; i < 9; i++) {
arrayNodes[i].refs = refsError;
((Value *)&arrayNodes[i])->next = (Value *)&arrayNodes[i + 1];
}
arrayNodes[9].refs = refsError;
((Value *)&arrayNodes[9])->next = (Value *)0;
freeArrayNodes.head = (Value *)&arrayNodes[1];
moveToCentral(&freeArrayNodes, ¢ralFreeArrayNodes);
arrayNode = arrayNodes;
}
} else {
freeArrayNodes.head = freeArrayNodes.head->next;
}
// incTypeMalloc(ArrayNodeType, 1);
memset(arrayNode, 0, sizeof(ArrayNode));
arrayNode->type = ArrayNodeType;
arrayNode->hashVal = 0;
arrayNode->refs = refsInit;
return(arrayNode);
}
void freeArrayNode(Value *v) {
ArrayNode *node = (ArrayNode *)v;
for (int i = 0; i < ARRAY_NODE_LEN; i++) {
if (node->array[i] != (Value *)0) {
dec_and_free(node->array[i], 1);
}
}
v->next = freeArrayNodes.head;
freeArrayNodes.head = v;
}
FreeValList centralFreePromises = (FreeValList){(Value *)0, 0};
__thread FreeValList freePromises = {(Value *)0, 0};
Promise *malloc_promise() {
Promise *newPromise = (Promise *)freePromises.head;
if (newPromise == (Promise *)0) {
newPromise = (Promise *)removeFreeValue(¢ralFreePromises);
if (newPromise == (Promise *)0) {
Promise *promises = (Promise *)my_malloc(sizeof(Promise) * 10);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 9, __ATOMIC_ACQ_REL);
#endif
for (int i = 1; i < 9; i++) {
promises[i].refs = refsError;
((Value *)&promises[i])->next = (Value *)&promises[i + 1];
}
promises[9].refs = refsError;
((Value *)&promises[9])->next = (Value *)0;
freePromises.head = (Value *)&promises[1];
moveToCentral(&freePromises, ¢ralFreePromises);
newPromise = promises;
}
} else {
freePromises.head = freePromises.head->next;
}
// incTypeMalloc(PromiseType, 1);
memset(newPromise, 0, sizeof(Promise));
newPromise->type = PromiseType;
newPromise->refs = refsInit;
newPromise->result = (Value *)0;
newPromise->actions = empty_list;
pthread_cond_init(&newPromise->delivered, NULL);
pthread_mutex_init(&newPromise->access, NULL);
return(newPromise);
}
void freePromise(Value *v) {
// TODO: make sure this is thread safe
Promise *p = (Promise *)v;
if (p->actions != (List *)0) {
Value *action = ((List *)p->actions)->head;
dec_and_free((Value *)(p->actions), 1);
}
if (p->result != (Value *)0) {
dec_and_free(p->result, 1);
}
v->next = freePromises.head;
freePromises.head = v;
}
FreeValList centralFreeFutures = (FreeValList){(Value *)0, 0};
__thread FreeValList freeFutures = {(Value *)0, 0};
Future *malloc_future(int line) {
Future *newFuture = (Future *)freeFutures.head;
if (newFuture == (Future *)0) {
newFuture = (Future *)removeFreeValue(¢ralFreeFutures);
if (newFuture == (Future *)0) {
Future *futures = (Future *)my_malloc(sizeof(Future) * 10);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 9, __ATOMIC_ACQ_REL);
#endif
for (int i = 1; i < 9; i++) {
futures[i].refs = refsError;
((Value *)&futures[i])->next = (Value *)&futures[i + 1];
}
futures[9].refs = refsError;
((Value *)&futures[9])->next = (Value *)0;
freeFutures.head = (Value *)&futures[1];
moveToCentral(&freeFutures, ¢ralFreeFutures);
newFuture = futures;
}
} else {
freeFutures.head = freeFutures.head->next;
}
// incTypeMalloc(FutureType, 1);
memset(newFuture, 0, sizeof(Future));
newFuture->type = FutureType;
newFuture->refs = refsInit;
newFuture->result = (Value *)0;
newFuture->action = (Value *)0;
newFuture->errorCallback = (Value *)0;
pthread_cond_init(&newFuture->delivered, NULL);
pthread_mutex_init(&newFuture->access, NULL);
return(newFuture);
}
void freeFuture(Value *v) {
List *actions = ((Future *)v)->actions;
if (actions != (List *)0)
dec_and_free((Value *)actions, 1);
Value *action = ((Future *)v)->action;
if (action != (Value *)0)
dec_and_free(action, 1);
Value *result = ((Future *)v)->result;
if (result != (Value *)0)
dec_and_free(result, 1);
v->next = freeFutures.head;
freeFutures.head = v;
}
void emptyAgent(Agent *agent) {
pthread_mutex_lock (&agent->access);
REFS_SIZE refs;
#ifdef SINGLE_THREADED
refs = agent->output->refs;
#else
__atomic_load(&agent->output->refs, &refs, __ATOMIC_RELAXED);
#endif
if (refs != 1 &&
refs != refsConstant &&
refs != refsStatic) {
fprintf(stderr, "failure in emptyAgent()\n");
abort();
}
dec_and_free((Value *)agent->output, 1);
List *l;
#ifdef SINGLE_THREADED
l = agent->input;
l->refs = refs;
#else
__atomic_load(&agent->input, &l, __ATOMIC_RELAXED);
__atomic_load(&l->refs, &refs, __ATOMIC_RELAXED);
#endif
if (refs != 1 &&
refs != refsConstant &&
refs != refsStatic) {
fprintf(stderr, "failure in emptyAgent()\n");
abort();
}
dec_and_free((Value *)l, 1);
pthread_mutex_unlock (&agent->access);
}
void freeAgent(Value *v) {
// TODO: must add loop detection. It's too easy to screw up and cause a cycle
Value *val = ((Agent *)v)->val;
REFS_SIZE refs;
#ifdef SINGLE_THREADED
refs = val->refs;
#else
__atomic_load(&val->refs, &refs, __ATOMIC_RELAXED);
#endif
emptyAgent((Agent *)v);
if (val != (Value *)0) {
dec_and_free(val, 1);
}
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
#endif
if (!cleaningUp)
free(v);
}
void freeOpaquePtr(Value *v) {
// call the destructor with the pointer
Opaque *opaque = (Opaque *)v;
if (opaque->destruct != NULL)
opaque->destruct(opaque->ptr);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
#endif
if (!cleaningUp)
free(v);
}
typedef void (*freeValFn)(Value *);
freeValFn freeJmpTbl[CoreTypeCount] = {NULL,
&freeInteger,
&freeString,
&freeFnArity,
&freeFunction,
&freeSubString,
&freeList,
&freeMaybe,
&freeVector,
&freeVectorNode,
&freeSubString,
&freeBitmapNode,
&freeArrayNode,
&freeHashCollisionNode,
NULL,
&freePromise,
&freeFuture,
&freeAgent,
&freeOpaquePtr};
void dec_and_free(Value *v, int deltaRefs) {
if (v == (Value *)0 ||
v->refs == refsStatic ||
v->refs == refsConstant ||
decRefs(v, deltaRefs) >= refsConstant)
return;
if (v->type < CoreTypeCount) {
// incTypeFree(v->type, 1);
freeJmpTbl[v->type](v);
} else {
ReifiedVal *rv = (ReifiedVal *)v;
for (int i = 0; i < rv->implCount; i++) {
dec_and_free(rv->impls[i], 1);
}
// incTypeFree(0, 1);
if (rv->implCount < 20) {
int64_t implCount = rv->implCount;
v->next = freeReified[implCount].head;
freeReified[implCount].head = v;
} else {
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
#endif
if (!cleaningUp)
free(v);
}
}
#ifdef CHECK_MEM_LEAK
// fprintf(stderr, "malloc_count: %ld free_count: %ld\r", malloc_count, free_count);
#endif
};
#ifndef FAST_INCS
Value *incRef(Value *v, int deltaRefs) {
if ((Value *)v == 0) {
fprintf(stderr, "bad incRef value: %p\n", v);
abort();
}
if (deltaRefs < 0) {
fprintf(stderr, "bad deltaRefs: %p\n", v);
abort();
} else if (deltaRefs < 1)
return(v);
#ifdef SINGLE_THREADED
if (v->refs == refsStatic || v->refs == refsConstant)
return(v);
if (v->refs < refsStatic) {
fprintf(stderr, "failure in incRef: %d %p\n", v->refs, v);
abort();
}
if (v->refs >= 0) {
v->refs += deltaRefs;;
}
#else
REFS_SIZE refs;
__atomic_load(&v->refs, &refs, __ATOMIC_RELAXED);
REFS_SIZE newRefs;
do {
if (refs == refsStatic || refs == refsConstant)
return(v);
if (refs < refsStatic) {
fprintf(stderr, "failure in incRef: %d %p\n", refs, v);
abort();
}
newRefs = refs + deltaRefs;
} while (!__atomic_compare_exchange(&v->refs, &refs, &newRefs, 1, __ATOMIC_RELAXED, __ATOMIC_RELAXED));
#endif
return(v);
}
#else
Value *simpleIncRef(Value *v, int n) {
v->refs += n;
return(v);
}
#endif
void moveFreeToCentral() {
moveToCentral(&freeLists, ¢ralFreeLists);
for (int i = 0; i < 10; i++) {
moveToCentral(&freeFunctions[i], ¢ralFreeFunctions[i]);
}
for (int i = 0; i < BMI_RECYCLE_COUNT; i++) {
moveToCentral(&freeBMINodes[i], ¢ralFreeBMINodes[i]);
}
for (int i = 0; i < 20; i++) {
moveToCentral(&freeReified[i], ¢ralFreeReified[i]);
}
moveToCentral(&freeStrings, ¢ralFreeStrings);
moveToCentral(&freeArrayNodes, ¢ralFreeArrayNodes);
moveToCentral(&freeSubStrings, ¢ralFreeSubStrings);
moveToCentral(&freeIntegers, ¢ralFreeIntegers);
moveToCentral(&freeMaybes, ¢ralFreeMaybes);
moveToCentral(&freeVectors, ¢ralFreeVectors);
moveToCentral(&freeVectorNodes, ¢ralFreeVectorNodes);
moveToCentral(&freeFnArities, ¢ralFreeFnArities);
moveToCentral(&freePromises, ¢ralFreePromises);
moveToCentral(&freeFutures, ¢ralFreeFutures);
}
void freeGlobal(Value *x) {
if (x == (Value*)0 ||
x->refs == refsError ||
x->refs == refsStatic ||
x == (Value *)&emptyBMI)
return;
x->refs = refsInit;
dec_and_free(x, 1);
x->refs = refsStatic;
}
void emptyFreeList(FreeValList *freeLinkedList) {
FreeValList listHead;
#ifdef SINGLE_THREADED
listHead = *freeLinkedList;
#else
__atomic_load((FreeValList *)freeLinkedList, (FreeValList *)&listHead, __ATOMIC_RELAXED);
#endif
for(Value *item = listHead.head;
item != (Value *)0;
item = item->next) {
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
#endif
}
}
void freeAll() {
moveFreeToCentral();
for (int i = 0; i < 10; i++) {
emptyFreeList(¢ralFreeFunctions[i]);
}
for (int i = 0; i < 20; i++) {
emptyFreeList(¢ralFreeReified[i]);
}
for (int i = 0; i < BMI_RECYCLE_COUNT; i++) {
emptyFreeList(¢ralFreeBMINodes[i]);
}
emptyFreeList(¢ralFreeFutures);
emptyFreeList(¢ralFreePromises);
emptyFreeList(¢ralFreeArrayNodes);
emptyFreeList(¢ralFreeSubStrings);
emptyFreeList(¢ralFreeFnArities);
emptyFreeList(¢ralFreeLists);
emptyFreeList(¢ralFreeMaybes);
emptyFreeList(¢ralFreeVectors);
emptyFreeList(¢ralFreeVectorNodes);
emptyFreeList(¢ralFreeStrings);
emptyFreeList(¢ralFreeIntegers);
//*
#ifdef SINGLE_THREADED
fprintf(stderr, "\nmalloc count: %" PRId64 " free count: %" PRId64 " diff: %" PRId64 "\n",
malloc_count, free_count, malloc_count - free_count);
#else
int64_t mallocs;
__atomic_load(&malloc_count, &mallocs, __ATOMIC_RELAXED);
int64_t frees;
__atomic_load(&free_count, &frees, __ATOMIC_RELAXED);
fprintf(stderr, "malloc count: %" PRId64 " free count: %" PRId64 " diff: %" PRId64 "\n",
mallocs, frees, mallocs - frees);
/*
int64_t totalMallocs = 0;
int64_t totalFrees = 0;
for (int i = 0; i < 20; i++) {
fprintf(stderr, "%d %ld %ld %ld\n", i, type_mallocs[i], type_frees[i], type_mallocs[i] - type_frees[i]);
if (i != 19) {
totalMallocs += type_mallocs[i];
totalFrees += type_frees[i];
}
}
totalMallocs = totalMallocs - type_mallocs[19];
fprintf(stderr, "\ntotalMallocs %ld\n", totalMallocs);
fprintf(stderr, "malloc diff %ld\n", mallocs - totalMallocs);
fprintf(stderr, "\ntotalFrees %ld\n", totalFrees);
fprintf(stderr, "free diff %ld\n", frees - totalFrees);
// */
#endif
// */
}
int64_t nakedSha1(Value *v1) {
Integer *hashVal;
int64_t hash;
switch (v1->type) {
case IntegerType:
hash = integerSha1(v1);
break;
case StringBufferType:
case SubStringType:
case SymbolType:
hash = strSha1(v1);
break;
case ListType:
case MaybeType:
case VectorType:
case BitmapIndexedType:
case ArrayNodeType:
case HashCollisionNodeType:
if (((HashedValue *)v1)->hashVal != 0) {
hash = ((HashedValue *)v1)->hashVal;
dec_and_free(v1, 1);
} else {
hashVal = (Integer *)sha1((FnArity *)0, v1);
hash = hashVal->numVal;
((HashedValue *)v1)->hashVal = hash;
dec_and_free((Value *)hashVal, 1);
}
break;
default:
if (v1->type > CoreTypeCount) {
if (((HashedValue *)v1)->hashVal != 0) {
hash = ((HashedValue *)v1)->hashVal;
dec_and_free(v1, 1);
} else {
hashVal = (Integer *)sha1((FnArity *)0, v1);
hash = hashVal->numVal;
((HashedValue *)v1)->hashVal = hash;
dec_and_free((Value *)hashVal, 1);
}
} else {
hashVal = (Integer *)sha1((FnArity *)0, v1);
hash = hashVal->numVal;
dec_and_free((Value *)hashVal, 1);
}
break;
}
return(hash);
}
List *reverseList(List *input) {
List *output = empty_list;
Value *item;
List *l = input;
while(l != (List *)0 && l->head != (Value *)0) {
item = l->head;
incRef(item, 1);
output = listCons(item, output);
l = l->tail;
}
dec_and_free((Value *)input, 1);
return(output);
}
void scheduleFuture(Future *fut) {
List *newList = malloc_list();
newList->head = (Value *)fut;
List *input;
#ifdef SINGLE_THREADED
input = futuresQueue.input;
newList->len = input->len + 1;
newList->tail = input;
futuresQueue.input = newList;
#else
__atomic_load(&futuresQueue.input, &input, __ATOMIC_RELAXED);
do {
newList->len = input->len + 1;
newList->tail = input;
} while (!__atomic_compare_exchange(&futuresQueue.input, &input, &newList, 1,
__ATOMIC_RELAXED, __ATOMIC_RELAXED));
#endif
// It is unusual to not hold the mutex when signalling the condition. But
// in this case it's ok. All the threads waiting on the condition are of
// equal priority, so it doesn't matter which one gets the next item in
// the queue. See this explanation for the reasoning behind this:
// https://groups.google.com/forum/?hl=ky#!msg/comp.programming.threads/wEUgPq541v8/ZByyyS8acqMJ
pthread_cond_signal(&futuresQueue.notEmpty);
}
void waitForWorkers() {
#ifdef SINGLE_THREADED
// no need to wait
#else
pthread_cond_broadcast(&futuresQueue.notEmpty);
for (int8_t i = 0; i < NUM_WORKERS; i++) {
pthread_join(workers[i], NULL);
}
pthread_mutex_lock (&futuresQueue.mutex);
List *l;
__atomic_load(&futuresQueue.output, &l, __ATOMIC_RELAXED);
dec_and_free((Value *)l, 1);
__atomic_load(&futuresQueue.input, &l, __ATOMIC_RELAXED);
dec_and_free((Value *)l, 1);
pthread_mutex_unlock (&futuresQueue.mutex);
int done = 0;
do {
pthread_mutex_lock (&lingeringAccess);
List *lingering = (List *)vals((FnArity *)0, lingeringThreads);
lingeringThreads = (Value *)&emptyBMI;
pthread_mutex_unlock (&lingeringAccess);
l = lingering;
for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {
pthread_t threadId = (pthread_t)((Integer *)x)->numVal;
pthread_join(threadId, NULL);
}
if (lingering->len == 0)
done = 1;
dec_and_free((Value *)lingering, 1);
} while(!done);
#endif
}
Value *shutDown_impl(FnArity *arity) {
Value *item;
#ifdef CHECK_MEM_LEAK
moveFreeToCentral();
#endif
pthread_exit(NULL);
return(nothing);
};
FnArity shutDown_arity = {FnArityType, -2, 0, (Vector *)0, (Value *)0, 0, shutDown_impl};
Function shutDownFn = {FunctionType, -2, "shutdown-workers", 1, {&shutDown_arity}};
Future shutDown = {FutureType, -2, (Value *)&shutDownFn, (Value *)0, (List *)0, (Value *)0, 0};
void stopWorkers() {
for (int32_t i = 0; i < NUM_WORKERS; i++)
scheduleFuture(&shutDown);
}
Value *readFuturesQueue() {
List *output;
#ifdef SINGLE_THREADED
// do nothing with futures in a single threaded system
return((Value *)0);
#else
__atomic_load(&futuresQueue.output, &output, __ATOMIC_RELAXED);
while (output != (List *)0 && output->len != 0 &&
!__atomic_compare_exchange(&futuresQueue.output,
&output,
&output->tail,
1, __ATOMIC_RELAXED, __ATOMIC_RELAXED))
;
if (output != (List *)0 && output->len != 0) {
Value *item = output->head;
output->head = (Value *)0;
output->tail = (List *)0;
REFS_SIZE refs;
__atomic_load(&output->refs, &refs, __ATOMIC_RELAXED);
if (refs != 1) {
fprintf(stderr, "error reading futures queue 1 %d\n", refs);
abort();
}
dec_and_free((Value *)output, 1);
return(item);
} else {
pthread_mutex_lock (&futuresQueue.mutex);
__atomic_load(&futuresQueue.output, &output, __ATOMIC_RELAXED);
while (output != (List *)0 && output->len != 0 &&
!__atomic_compare_exchange(&futuresQueue.output,
&output,
&output->tail,
1, __ATOMIC_RELAXED, __ATOMIC_RELAXED))
;
if (output != (List *)0 && output->len != 0) {
Value *item = output->head;
output->head = (Value *)0;
output->tail = (List *)0;
REFS_SIZE refs;
__atomic_load(&output->refs, &refs, __ATOMIC_RELAXED);
if (refs != 1) {
fprintf(stderr, "error reading futures queue 2\n");
abort();
}
dec_and_free((Value *)output, 1);
pthread_mutex_unlock (&futuresQueue.mutex);
return(item);
} else {
List *input;
__atomic_exchange((List **)&futuresQueue.input,
(List **)&empty_list,
(List **)&input,
__ATOMIC_RELAXED);
if (input == (List *)0 || input->len == 0) {
int32_t numRunning = __atomic_fetch_sub(&runningWorkers, 1, __ATOMIC_ACQ_REL);
if (numRunning <= 1 && mainThreadDone) {
stopWorkers();
} else {
#ifdef CHECK_MEM_LEAK
moveFreeToCentral();
#endif
pthread_cond_wait(&futuresQueue.notEmpty, &futuresQueue.mutex);
__atomic_fetch_add(&runningWorkers, 1, __ATOMIC_ACQ_REL);
}
pthread_mutex_unlock (&futuresQueue.mutex);
return(readFuturesQueue());
} else {
output = reverseList(input);
__atomic_store(&futuresQueue.output, &output->tail, __ATOMIC_RELAXED);
pthread_cond_signal(&futuresQueue.notEmpty);
pthread_mutex_unlock (&futuresQueue.mutex);
Value *item = output->head;
output->head = (Value *)0;
output->tail = (List *)0;
REFS_SIZE refs;
__atomic_load(&output->refs, &refs, __ATOMIC_RELAXED);
if (refs != 1) {
fprintf(stderr, "error reading futures queue 3\n");
abort();
}
dec_and_free((Value *)output, 1);
return(item);
}
}
}
#endif
}
Value *deliverFuture(Value *fut, Value *val) {
Future *future = (Future *)fut;
if (future->result == (Value *)0) {
pthread_mutex_lock (&future->access);
future->result = val;
List *l = future->actions;
List *head = l;
future->actions = (List *)0;
pthread_cond_broadcast(&future->delivered);
pthread_mutex_unlock (&future->access);
// perform actions
if (l != (List *)0 && l->len != 0) {
for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {
incRef(x, 1);
incRef(val, 1);
Value *trash = dynamicCall1Arg(x, val);
dec_and_free(trash, 1);
}
dec_and_free((Value *)head, 1);
}
} else {
dec_and_free(val, 1);
}
return fut;
}
__thread int64_t workerIndex;
void *futuresThread(void *input) {
workerIndex = (int64_t)input;
Future *future;
Value *result;
if (workerIndex >= 0)
future = (Future *)readFuturesQueue();
while(workerIndex >= 0 && future != (Future *)0) {
Value *f = future->action;
if(f->type != FunctionType) {
result = invoke0Args((FnArity *)0, incRef(f, 1));
} else {
FnArity *arity = findFnArity(f, 0);
if(arity != (FnArity *)0 && !arity->variadic) {
FnType0 *fn = (FnType0 *)arity->fn;
result = fn(arity);
} else if(arity != (FnArity *)0 && arity->variadic) {
FnType1 *fn = (FnType1 *)arity->fn;
result = fn(arity, (Value *)empty_list);
} else {
fprintf(stderr, "\n*** no arity found for '%s'.\n", ((Function *)f)->name);
abort();
}
}
deliverFuture((Value *)future, result);
dec_and_free((Value *)future, 1);
if (workerIndex >= 0) {
future = (Future *)readFuturesQueue();
}
}
#ifdef SINGLE_THREADED
runningWorkers--;
#else
__atomic_fetch_sub(&runningWorkers, 1, __ATOMIC_ACQ_REL);
#endif
Value *threadHandle = (Value *)integerValue((int64_t)pthread_self());
pthread_mutex_lock (&lingeringAccess);
lingeringThreads = baseDissoc(lingeringThreads, incRef(threadHandle, 1),
nakedSha1(threadHandle), 0);
pthread_mutex_unlock (&lingeringAccess);
#ifdef CHECK_MEM_LEAK
moveFreeToCentral();
#endif
return(NULL);
}
int32_t numWorkers = NUM_WORKERS;
void startWorkers() {
#ifdef SINGLE_THREADED
runningWorkers = numWorkers;
#else
__atomic_store(&runningWorkers, &numWorkers, __ATOMIC_RELAXED);
#endif
for (int64_t i = 0; i < NUM_WORKERS; i++)
pthread_create(&workers[i], NULL, futuresThread, (void *)i);
}
void replaceWorker() {
pthread_t me = pthread_self();
for (int64_t i = 0; i < NUM_WORKERS; i++) {
if (pthread_equal(workers[i], me)) {
pthread_create(&workers[workerIndex], NULL, futuresThread, (void *)i);
workerIndex = -1;
}
}
Value *threadHandle = (Value *)integerValue((int64_t)me);
pthread_mutex_lock (&lingeringAccess);
lingeringThreads = copyAssoc(lingeringThreads, incRef((Value *)threadHandle, 1),
incRef((Value *)threadHandle, 1),
nakedSha1(threadHandle), 0);
pthread_mutex_unlock (&lingeringAccess);
}
char *extractStr(Value *v) {
// Should only be used to print an error meessage when calling 'abort'
// Leaks a String value
if (v->type == StringBufferType)
return(((String *)v)->buffer);
else if (v->type == SubStringType) {
String *newStr = (String *)my_malloc(sizeof(String) + ((String *)v)->len + 5);
// incTypeMalloc(StringBufferType, 1);
newStr->hashVal = 0;
snprintf(newStr->buffer, ((String *)v)->len + 1, "%s", ((SubString *)v)->buffer);
return(newStr->buffer);
} else {
fprintf(stderr, "\ninvalid type for 'extractStr'\n");
abort();
}
}
FnArity *findFnArity(Value *fnVal, int64_t argCount) {
Function *fn = (Function *)fnVal;
int arityIndex = 0;
FnArity *arity = (FnArity *)fn->arities[arityIndex];
FnArity *variadic = (FnArity *)0;
while(arityIndex < fn->arityCount) {
arity = (FnArity *)fn->arities[arityIndex];
if (arity->variadic) {
variadic = arity;
arityIndex++;
} else if (arity->count != argCount) {
arityIndex++;
} else
return(arity);
}
return(variadic);
};
int8_t isNothing(Value *v, char *fileName, int lineNumber) {
return(v->type == MaybeType && ((Maybe *)v)->value == (Value *)0);
}
Value *maybe(FnArity *arity, Value *arg0, Value *arg1) {
Maybe *mVal = malloc_maybe();
mVal->value = arg1;
return((Value *)mVal);
}
Value *prSTAR(Value *str) {
int bytes;
if (str->type == StringBufferType) {
bytes = fprintf(outstream, "%-.*s", (int)((String *)str)->len, ((String *)str)->buffer);
} else if (str->type == SubStringType) {
bytes = fprintf(outstream, "%-.*s", (int)((SubString *)str)->len, ((SubString *)str)->buffer);
}
dec_and_free(str, 1);
return(integerValue(bytes));
}
Value *defaultPrErrSTAR(Value *str) {
int bytes;
if (str->type == StringBufferType) {
bytes = fprintf(stderr, "%-.*s", (int)((String *)str)->len, ((String *)str)->buffer);
} else if (str->type == SubStringType) {
bytes = fprintf(stderr, "%-.*s", (int)((SubString *)str)->len, ((SubString *)str)->buffer);
}
dec_and_free(str, 1);
return(integerValue(bytes));
}
Value *add_ints(Value *arg0, Value *arg1) {
Value *numVal = integerValue(((Integer *)arg0)->numVal + ((Integer *)arg1)->numVal);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(numVal);
}
Value *integerValue(int64_t n) {
Integer *numVal = malloc_integer();
numVal->numVal = n;
return((Value *)numVal);
};
Value *integer_str(Value *arg0) {
String *numStr = malloc_string(50);
snprintf(numStr->buffer, 40, "%" PRId64 "", ((Integer *)arg0)->numVal);
numStr->len = strlen(numStr->buffer);
dec_and_free(arg0, 1);
return((Value *)numStr);
}
Value *integer_EQ(Value *arg0, Value *arg1) {
if (IntegerType != arg0->type || IntegerType != arg1->type) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
} else if (((Integer *)arg0)->numVal != ((Integer *)arg1)->numVal) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
} else {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
}
}
Value *isInstance(Value *arg0, Value *arg1) {
TYPE_SIZE typeNum = ((Integer *)arg0)->numVal;
if (typeNum == arg1->type) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
} else if (StringBufferType == typeNum && SubStringType == arg1->type) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
// } else if (HashMapType == typeNum && (BitmapIndexedType == arg1->type ||
// ArrayNodeType == arg1->type ||
// HashCollisionNodeType == arg1->type)) {
// dec_and_free(arg1, 1);
// return(maybe((FnArity *)0, (Value *)0, arg0));
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
List *listCons(Value *x, List *l) {
List *newList = malloc_list();
newList->len = l->len + 1;
newList->head = (Value *)x;
newList->tail = l;
return(newList);
};
Vector *newVector(Value *array[], int indexToSkip) {
Vector *ret = malloc_vector();
for (int i = 0; i < VECTOR_ARRAY_LEN; i++) {
if (array[i] != (Value *)0 && i != indexToSkip) {
ret->tail[i] = array[i];
incRef(array[i], 1);
}
}
return(ret);
}
VectorNode *newVectorNode(Value *array[], int indexToSkip) {
VectorNode *ret = malloc_vectorNode();
for (int i = 0; i < VECTOR_ARRAY_LEN; i++) {
if (array[i] != (Value *)0 && i != indexToSkip) {
ret->array[i] = array[i];
incRef(array[i], 1);
}
}
return(ret);
}
Value **arrayFor(Vector *v, unsigned index) {
if (index < v->count) {
if (index >= v->tailOffset) {
return(v->tail);
} else {
VectorNode *node = v->root;
for (int level = v->shift; level > 0; level -= 5) {
node = (VectorNode *)node->array[(index >> level) & 0x1f];
}
return(node->array);
}
} else {
fprintf(stderr, "Vector index out of bounds\n");
abort();
return((Value **)0);
}
}
VectorNode *newPath(int level, VectorNode *node) {
if (level == 0) {
return(node);
} else {
VectorNode *ret = malloc_vectorNode();
ret->array[0] = (Value *)newPath(level - 5, node);
return(ret);
}
}
VectorNode *pushTail(unsigned count, int level, VectorNode *parent, VectorNode *tailNode) {
int subidx = ((count - 1) >> level) & 0x1f;
VectorNode *ret;
if (parent != (VectorNode *)0) {
ret = newVectorNode(parent->array, subidx);
} else {
ret = malloc_vectorNode();
}
VectorNode *nodeToInsert;
if (level == 5) {
nodeToInsert = tailNode;
} else {
VectorNode *child = (VectorNode *)parent->array[subidx];
if (child != (VectorNode *)0) {
nodeToInsert = pushTail(count, level - 5, child, tailNode);
} else {
nodeToInsert = newPath(level - 5, tailNode);
}
}
ret->array[subidx] = (Value *)nodeToInsert;
return(ret);
}
Vector *vectConj(Vector *vect, Value *val) {
if (vect->refs == 1) {
return(mutateVectConj((Vector *)incRef((Value *)vect, 1), val));
// if there's room in the tail
} else if (vect->count - vect->tailOffset < VECTOR_ARRAY_LEN) {
// make a new vector and copy info over
Vector *newVect = newVector(vect->tail, VECTOR_ARRAY_LEN);
newVect->shift = vect->shift;
newVect->count = vect->count + 1;
if (newVect->count < VECTOR_ARRAY_LEN) {
newVect->tailOffset = 0;
} else {
newVect->tailOffset = (newVect->count - 1) & ~0x1f;
}
newVect->root = vect->root;
if (newVect->root != (VectorNode *)0) {
incRef((Value *)newVect->root, 1);
}
// add value to tail of new vector
newVect->tail[vect->count & 0x1F] = val;
return(newVect);
} else {
// since tail is full, make a new node from the tail of 'vect'
VectorNode *newRoot;
VectorNode *tailNode = newVectorNode(vect->tail, VECTOR_ARRAY_LEN);
int newShift = vect->shift;
// if the root of 'vect' is completely full
if ((vect->count >> 5) > (1 << vect->shift)) {
// make new vector one level deeper
newRoot = malloc_vectorNode();
newRoot->array[0] = (Value *)vect->root;
incRef(newRoot->array[0], 1);
// and make a new path that includes that node
newRoot->array[1] = (Value *)newPath(vect->shift, tailNode);
newShift += 5;
} else {
// otherwise, push the tail node down, creating a new root
newRoot = pushTail(vect->count, vect->shift, vect->root, tailNode);
}
Vector *newVect = malloc_vector();
newVect->count = vect->count + 1;
newVect->tailOffset = (newVect->count - 1) & ~0x1f;
newVect->shift = newShift;
newVect->root = newRoot;
newVect->tail[0] = val;
return(newVect);
}
}
Vector *mutateVectConj(Vector *vect, Value *val) {
// if 'vect' is a static vector
if (vect->refs <= refsConstant) {
Vector *result = vectConj(vect, val);
return(result);
} else if (vect->count - vect->tailOffset < VECTOR_ARRAY_LEN) {
// if there's room in the tail, add value to tail of vector
vect->tail[vect->count & 0x1F] = val;
vect->count += 1;
return(vect);
} else {
// since tail is full, make a new node from the tail of 'vect'
VectorNode *newRoot;
VectorNode *tailNode = newVectorNode(vect->tail, VECTOR_ARRAY_LEN);
for (unsigned i = 0; i < VECTOR_ARRAY_LEN; i++) {
dec_and_free(vect->tail[i], 1);
vect->tail[i] = (Value *)0;
}
int newShift = vect->shift;
// if the root of 'vect' is completely full
if ((vect->count >> 5) > (1 << vect->shift)) {
// make new vector one level deeper
newRoot = malloc_vectorNode();
newRoot->array[0] = (Value *)vect->root;
// and make a new path that includes that node
newRoot->array[1] = (Value *)newPath(vect->shift, tailNode);
newShift += 5;
} else {
// make new vector one level deeper
// otherwise, push the tail node down, creating a new root
newRoot = pushTail(vect->count, vect->shift, vect->root, tailNode);
if (vect->root != (VectorNode *)0)
dec_and_free((Value *)vect->root, 1);
}
vect->count += 1;
vect->tailOffset = (vect->count - 1) & ~0x1f;
vect->shift = newShift;
vect->root = newRoot;
vect->tail[0] = val;
return(vect);
}
}
VectorNode *copyVectStore(int level, VectorNode *node, unsigned index, Value *val) {
if (level == 0) {
int arrayIndex = index & 0x1f;
VectorNode *newNode = newVectorNode(node->array, arrayIndex);
newNode->array[arrayIndex] = val;
return(newNode);
} else {
int arrayIndex = (index >> level) & 0x1f;
VectorNode *newNode = newVectorNode(node->array, arrayIndex);
newNode->array[arrayIndex] = (Value *)copyVectStore(level - 5, (VectorNode *)node->array[arrayIndex],
index, val);
return(newNode);
}
}
Value *vectStore(Vector *vect, unsigned index, Value *val) {
// TODO: check the refs count and mutate if equal 1
// but only if all nodes 'above' this one are mutate-able
// and if you do mutate this vect, clear the cached hash value (once that's implemented)
if (index < vect->count) {
if (index >= vect->tailOffset) {
unsigned newIndex = index & 0x1f;
Vector *ret = newVector(vect->tail, newIndex);
ret->tail[newIndex] = val;
ret->count = vect->count;
ret->tailOffset = vect->tailOffset;
ret->shift = vect->shift;
ret->root = vect->root;
if (ret->root != (VectorNode *)0) {
incRef((Value *)ret->root, 1);
}
Value *mval = maybe((FnArity *)0, (Value *)0, (Value *)ret);
return(mval);
} else {
Vector *ret = newVector(vect->tail, VECTOR_ARRAY_LEN);
ret->count = vect->count;
ret->tailOffset = vect->tailOffset;
ret->shift = vect->shift;
ret->root = copyVectStore(vect->shift, vect->root, index, val);
Value *mval = maybe((FnArity *)0, (Value *)0, (Value *)ret);
return(mval);
}
} else if (index == vect->count) {
Value *ret = (Value *)vectConj(vect, val);
Value *mval = maybe((FnArity *)0, (Value *)0, (Value *)ret);
return(mval);
} else {
dec_and_free(val, 1);
return(nothing);
}
}
Value *fastVectStore(Vector *vect, unsigned index, Value *val) {
if (index < vect->count &&
index >= vect->tailOffset &&
vect->refs == 1) {
unsigned newIndex = index & 0x1f;
dec_and_free(vect->tail[newIndex], 1);
vect->tail[newIndex] = val;
return((Value *)vect);
} else {
Value *result = vectStore(vect, index, val);
if (isNothing(result, "", 0)) {
fprintf(stderr, "*** Improper use of fastVectStore\n");
abort();
} else {
Value *inner = ((Maybe *)result)->value;
incRef(inner, 1);
dec_and_free(result, 1);
dec_and_free((Value *)vect, 1);
return(inner);
}
}
}
Value *updateField(Value *rval, Value *field, int64_t idx) {
ReifiedVal *template = (ReifiedVal *)rval;
if (idx >= template->implCount) {
fprintf(stderr, "Field index for type '%s' out of bounds: %" PRId64 ". Max: %" PRId64 "\n",
extractStr(type_name((FnArity *)0, rval)), idx, template->implCount);
abort();
}
if (rval->refs == 1) {
dec_and_free(template->impls[idx], 1);
template->impls[idx] = field;
return(rval);
} else {
ReifiedVal *rv = malloc_reified(template->implCount);
int rvSize = sizeof(ReifiedVal) + sizeof(Function *) * template->implCount;
memcpy(rv, template, rvSize);
#ifdef SINGLE_THREADED
rv->refs = refsInit;
#else
__atomic_store(&rv->refs, &refsInit, __ATOMIC_RELAXED);
#endif
for (int i = 0; i < template->implCount; i++) {
if (i != idx) {
incRef(template->impls[i], 1);
}
}
rv->impls[idx] = field;
dec_and_free(rval, 1);
return((Value *)rv);
}
}
Value *vectGet(Vector *vect, unsigned index) {
// this fn does not dec_and_free vect on purpose
// it lets calling functions do that.
Value **array = arrayFor(vect, index);
return(array[index & 0x1f]);
}
Value *vectSeq(Vector *vect, int index) {
List *ret = empty_list;
if (vect->count > 0) {
for (int i = vect->count - 1; i >= index; i -= 1) {
Value *v = vectGet(vect, (unsigned)i);
incRef(v, 1);
ret = listCons(v, ret);
}
}
dec_and_free((Value *)vect, 1);
return((Value *)ret);
}
Value *vectorReverse(Value *arg0) {
Vector *v = (Vector *)arg0;
int i;
Vector *newVect = empty_vect;
for (i = v->count - 1; i >= 0; i--) {
Value *val = vectGet(v, i);
incRef(val, 1);
newVect = mutateVectConj(newVect, val);
}
dec_and_free(arg0, 1);
return((Value *)newVect);
}
void destructValue(char *fileName, char *lineNum, Value *val, int numArgs, Value **args[]) {
if (val->type == ListType) {
List *l = (List *)val;
if (l->len < numArgs - 1) {
fprintf(stderr, "Insufficient values in list for destructuring at %s: %s\n",
fileName, lineNum);
abort();
}
int64_t len = l->len - numArgs + 1;
for (int i = 0; i < numArgs - 1; i++) {
*args[i] = l->head; l = l->tail;
incRef(*args[i], 1);
}
l->len = len;
*args[numArgs - 1] = (Value *)l;
incRef(*args[numArgs - 1], 1);
dec_and_free(val, 1);
} else if (val->type == VectorType) {
Vector *v = (Vector *)val;
if (v->count < numArgs - 1) {
fprintf(stderr, "Insufficient values in vector for destructuring at %s: %s\n",
fileName, lineNum);
abort();
}
// unpack vector
for (int i = 0; i < numArgs - 1; i++) {
*args[i] = vectGet(v, i);
incRef(*args[i], 1);
}
*args[numArgs - 1] = vectSeq(v, numArgs - 1);
} else {
fprintf(stderr, "Could not unpack value at %s %s\n", fileName, lineNum);
abort();
}
}
Value *strEQ(Value *arg0, Value *arg1) {
char *s1, *s2;
long int len;
if (arg0->type == StringBufferType &&
arg1->type == StringBufferType &&
((String *)arg0)->len == ((String *)arg1)->len) {
s1 = ((String *)arg0)->buffer;
len = ((String *)arg0)->len;
s2 = ((String *)arg1)->buffer;
} else if (arg0->type == SubStringType &&
arg1->type == SubStringType &&
((SubString *)arg0)->len == ((SubString *)arg1)->len) {
s1 = ((SubString *)arg0)->buffer;
len = ((SubString *)arg0)->len;
s2 = ((SubString *)arg1)->buffer;
} else if (arg0->type == StringBufferType &&
arg1->type == SubStringType &&
((String *)arg0)->len == ((SubString *)arg1)->len) {
s1 = ((String *)arg0)->buffer;
len = ((String *)arg0)->len;
s2 = ((SubString *)arg1)->buffer;
} else if (arg0->type == SubStringType &&
arg1->type == StringBufferType &&
((SubString *)arg0)->len == ((String *)arg1)->len) {
s1 = ((SubString *)arg0)->buffer;
len = ((SubString *)arg0)->len;
s2 = ((String *)arg1)->buffer;
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
if (strncmp(s1, s2, len) == 0) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
Value *strLT(Value *arg0, Value *arg1) {
char *s1, *s2;
long int len, s1Len, s2Len;
if (arg0->type == StringBufferType &&
arg1->type == StringBufferType) {
s1 = ((String *)arg0)->buffer;
s1Len = ((String *)arg0)->len;
s2 = ((String *)arg1)->buffer;
s2Len = ((String *)arg1)->len;
if (s1Len < s2Len)
len = s1Len;
else
len = s2Len;
} else if (arg0->type == SubStringType &&
arg1->type == SubStringType) {
s1 = ((SubString *)arg0)->buffer;
s1Len = ((SubString *)arg0)->len;
s2 = ((SubString *)arg1)->buffer;
s2Len = ((SubString *)arg1)->len;
if (s1Len < s2Len)
len = s1Len;
else
len = s2Len;
} else if (arg0->type == StringBufferType &&
arg1->type == SubStringType) {
s1 = ((String *)arg0)->buffer;
s1Len = ((String *)arg0)->len;
s2 = ((SubString *)arg1)->buffer;
s2Len = ((SubString *)arg1)->len;
if (s1Len < s2Len)
len = s1Len;
else
len = s2Len;
} else if (arg0->type == SubStringType &&
arg1->type == StringBufferType) {
s1 = ((SubString *)arg0)->buffer;
s1Len = ((SubString *)arg0)->len;
s2 = ((String *)arg1)->buffer;
s2Len = ((String *)arg1)->len;
if (s1Len < s2Len)
len = s1Len;
else
len = s2Len;
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
int cmp = strncmp(s1, s2, len);
if (cmp < 0 || (cmp == 0 && s1Len < s2Len)) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
Value *strCount(Value *arg0) {
Value *numVal;
if (arg0->type == StringBufferType)
numVal = integerValue(((String *)arg0)->len);
else
numVal = integerValue(((SubString *)arg0)->len);
dec_and_free(arg0, 1);
return(numVal);
}
Value *strList(Value *arg0) {
List *result = empty_list;
if (arg0->type == StringBufferType) {
String *s = (String *)arg0;
for (int64_t i = s->len - 1; i >= 0; i--) {
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
subStr->len = 1;
subStr->source = arg0;
subStr->buffer = s->buffer + i;
result = listCons((Value *)subStr, result);
}
incRef(arg0, s->len);
} else if (arg0->type == SubStringType) {
SubString *s = (SubString *)arg0;
for (int64_t i = s->len - 1; i >= 0; i--) {
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
subStr->len = 1;
subStr->source = arg0;
subStr->buffer = s->buffer + i;
result = listCons((Value *)subStr, result);
}
incRef(arg0, s->len);
}
dec_and_free(arg0, 1);
return((Value *)result);
}
Value *integer_LT(Value *arg0, Value *arg1) {
if (((Integer *)arg0)->numVal < ((Integer *)arg1)->numVal) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
Value *checkInstance(TYPE_SIZE typeNum, Value *arg1) {
if (typeNum == arg1->type) {
return(maybe((FnArity *)0, (Value *)0, arg1));
} else if (StringBufferType == typeNum && SubStringType == arg1->type) {
return(maybe((FnArity *)0, (Value *)0, arg1));
} else if (HashMapType == typeNum && (BitmapIndexedType == arg1->type ||
ArrayNodeType == arg1->type ||
HashCollisionNodeType == arg1->type)) {
return(maybe((FnArity *)0, (Value *)0, arg1));
} else {
dec_and_free(arg1, 1);
return(nothing);
}
}
Value *listMap(Value *arg0, Value *f) {
// List map
List *l = (List *)arg0;
if (l->len == 0) {
dec_and_free(arg0, 1);
dec_and_free(f, 1);
return((Value *)empty_list);
} else {
List *head = empty_list;
List *tail = empty_list;
int mutate = 0;
FnArity *arity2;
if(f->type == FunctionType) {
arity2 = findFnArity(f, 1);
if(arity2 == (FnArity *)0) {
fprintf(stderr, "\n*** no arity found for '%s'.\n", ((Function *)f)->name);
abort();
}
}
REFS_SIZE refs;
__atomic_load(&arg0->refs, &refs, __ATOMIC_RELAXED);
if (refs == 1) {
mutate = 1;
head = l;
head->len = 0;
tail = l;
}
for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {
Value *y;
if (mutate && l->refs > 1) {
dec_and_free((Value *)l, 1);
mutate = 0;
}
if (!mutate)
incRef(x, 1);
if(f->type != FunctionType) {
incRef(f, 1);
y = invoke1Arg((FnArity *)0, f, x);
} else if(arity2->variadic) {
FnType1 *fn4 = (FnType1 *)arity2->fn;
List *varArgs3 = (List *)listCons(x, empty_list);
y = fn4(arity2, (Value *)varArgs3);
} else {
FnType1 *fn4 = (FnType1 *)arity2->fn;
y = fn4(arity2, x);
}
// 'y' is the value for the new list
if (mutate) {
l->head = y;
tail = l;
head->len++;
} else if (head == empty_list) {
// if we haven't started the new list yet
head = malloc_list();
head->len = 1;
head->head = y;
head->tail = empty_list;
tail = head;
} else {
// otherwise, append to tail of list
List *new_tail = malloc_list();
new_tail->len = 1;
new_tail->head = y;
new_tail->tail = empty_list;
tail->tail = new_tail;
tail = new_tail;
head->len++;
}
}
if (refs != 1)
dec_and_free(arg0, 1);
dec_and_free(f, 1);
return((Value *)head);
}
}
Value *listConcat(Value *arg0) {
// TODO: check refs count for each list and stitch them together
List *ls = (List *)arg0;
if (ls->len == 0) {
dec_and_free(arg0, 1);
return((Value *)empty_list);
}
else if (ls->len == 1) {
Value *h = ls->head;
incRef(h, 1);
dec_and_free((Value *)ls, 1);
if (h != (Value *)0 && h->type == VectorType) {
return(vectSeq((Vector *)h, 0));
} else {
return(h);
}
} else {
List *head = empty_list;
List *tail = empty_list;
for (; ls != (List *)0; ls = ls->tail) {
List *l = (List *)ls->head;
List *newL;
int discard = 0;
if (l != (List *)0 && l->type == VectorType) {
l = (List *)vectSeq((Vector *)incRef((Value *)l, 1), 0);
discard = 1;
}
Value *x;
for(; l != (List *)0 && l->head != (Value *)0; l = newL) {
x = l->head;
if (head == empty_list) {
// if we haven't started the new list yet
head = malloc_list();
head->len = 1;
head->head = x;
incRef(x, 1);
head->tail = empty_list;
tail = head;
} else {
// otherwise, append to tail of list
List *new_tail = malloc_list();
new_tail->len = 1;
new_tail->head = x;
incRef(x, 1);
new_tail->tail = empty_list;
tail->tail = new_tail;
tail = new_tail;
head->len++;
}
newL = l->tail;
if(discard) {
l->tail = (List *)0;
dec_and_free((Value *)l, 1);
}
}
}
dec_and_free(arg0, 1);
return((Value *)head);
}
}
Value *car(Value *arg0) {
List *lst = (List *)arg0;
if (lst->len == 0) {
return(nothing);
} else {
Value *h = lst->head;
incRef(h, 1);
dec_and_free(arg0, 1);
return(maybe((FnArity *)0, (Value *)0, h));
}
}
Value *cdr(Value *arg0) {
List *lst = (List *)arg0;
if (lst->len == 0) {
dec_and_free(arg0, 1);
return((Value *)empty_list);
} else {
List *tail = ((List *)arg0)->tail;
tail->len = lst->len - 1;
incRef((Value *)tail, 1);
dec_and_free(arg0, 1);
return((Value *)tail);
}
}
Value *integerLT(Value *arg0, Value *arg1) {
if (((Integer *)arg0)->numVal < ((Integer *)arg1)->numVal) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
// SHA1 implementation courtesy of: Steve Reid <sreid@sea-to-sky.net>
// and others.
// from http://waterjuice.org/c-source-code-for-sha1/
#define SHA1_HASH_SIZE ( 64 / 8 )
typedef struct
{
uint8_t bytes [SHA1_HASH_SIZE];
} SHA1_HASH;
typedef union
{
uint8_t c [64];
uint32_t l [16];
} CHAR64LONG16;
#define rol(value, bits) (((value) << (bits)) | ((value) >> (32 - (bits))))
#define blk0(i) (block->l[i] = (rol(block->l[i],24)&0xFF00FF00) |(rol(block->l[i],8)&0x00FF00FF))
#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))
#define R0(v,w,x,y,z,i) z += ((w&(x^y))^y) + blk0(i)+ 0x5A827999 + rol(v,5); w=rol(w,30);
#define R1(v,w,x,y,z,i) z += ((w&(x^y))^y) + blk(i) + 0x5A827999 + rol(v,5); w=rol(w,30);
#define R2(v,w,x,y,z,i) z += (w^x^y) + blk(i) + 0x6ED9EBA1 + rol(v,5); w=rol(w,30);
#define R3(v,w,x,y,z,i) z += (((w|x)&y)|(w&x)) + blk(i) + 0x8F1BBCDC + rol(v,5); w=rol(w,30);
#define R4(v,w,x,y,z,i) z += (w^x^y) + blk(i) + 0xCA62C1D6 + rol(v,5); w=rol(w,30);
static void TransformFunction(uint32_t state[5], const uint8_t buffer[64]) {
uint32_t a;
uint32_t b;
uint32_t c;
uint32_t d;
uint32_t e;
uint8_t workspace[64];
CHAR64LONG16* block = (CHAR64LONG16*) workspace;
memcpy( block, buffer, 64 );
// Copy context->state[] to working vars
a = state[0];
b = state[1];
c = state[2];
d = state[3];
e = state[4];
// 4 rounds of 20 operations each. Loop unrolled.
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
// Add the working vars back into context.state[]
state[0] += a;
state[1] += b;
state[2] += c;
state[3] += d;
state[4] += e;
}
void Sha1Initialise (Sha1Context* Context) {
// SHA1 initialization constants
Context->State[0] = 0x67452301;
Context->State[1] = 0xEFCDAB89;
Context->State[2] = 0x98BADCFE;
Context->State[3] = 0x10325476;
Context->State[4] = 0xC3D2E1F0;
Context->Count[0] = 0;
Context->Count[1] = 0;
}
void Sha1Update (Sha1Context* Context, void* Buffer, int64_t BufferSize) {
uint32_t i;
uint32_t j;
j = (Context->Count[0] >> 3) & 63;
if( (Context->Count[0] += BufferSize << 3) < (BufferSize << 3) )
{
Context->Count[1]++;
}
Context->Count[1] += (BufferSize >> 29);
if( (j + BufferSize) > 63 )
{
i = 64 - j;
memcpy( &Context->Buffer[j], Buffer, i );
TransformFunction(Context->State, Context->Buffer);
for( ; i + 63 < BufferSize; i += 64 )
{
TransformFunction(Context->State, (uint8_t*)Buffer + i);
}
j = 0;
}
else
{
i = 0;
}
memcpy( &Context->Buffer[j], &((uint8_t*)Buffer)[i], BufferSize - i );
}
void Sha1Finalise (Sha1Context* Context, SHA1_HASH* Digest) {
uint32_t i;
uint8_t finalcount[8];
for( i=0; i<8; i++ )
{
finalcount[i] = (unsigned char)((Context->Count[(i >= 4 ? 0 : 1)]
>> ((3-(i & 3)) * 8) ) & 255); // Endian independent
}
Sha1Update( Context, (uint8_t*)"\x80", 1 );
while( (Context->Count[0] & 504) != 448 )
{
Sha1Update( Context, (uint8_t*)"\0", 1 );
}
Sha1Update( Context, finalcount, 8 ); // Should cause a Sha1TransformFunction()
for( i=0; i<SHA1_HASH_SIZE; i++ )
{
Digest->bytes[i] = (uint8_t)((Context->State[i>>2] >> ((3-(i & 3)) * 8) ) & 255);
}
}
void free_sha1(void *ptr) {
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&free_count, 1, __ATOMIC_ACQ_REL);
// incTypeFree(IntegerType, 1);
#endif
free(ptr);
}
Value *malloc_sha1() {
Sha1Context *ctxt = (Sha1Context *)malloc(sizeof(Sha1Context));
Sha1Initialise(ctxt);
#ifdef CHECK_MEM_LEAK
__atomic_fetch_add(&malloc_count, 1, __ATOMIC_ACQ_REL);
// incTypeMalloc(IntegerType, 1);
#endif
return(opaqueValue(ctxt, free_sha1));
}
Value *finalize_sha1(Value *ctxt) {
int64_t shaVal;
Sha1Finalise(((Opaque *)ctxt)->ptr, (SHA1_HASH *)&shaVal);
dec_and_free(ctxt, 1);
return((Value *)integerValue(shaVal));
}
int64_t integerSha1(Value *arg0) {
int64_t shaVal;
Sha1Context context;
Integer *numVal = (Integer *)arg0;
Sha1Initialise(&context);
Sha1Update(&context, (void *)&numVal->type, 8);
Sha1Update(&context, (void *)&numVal->numVal, 8);
Sha1Finalise(&context, (SHA1_HASH *)&shaVal);
dec_and_free(arg0, 1);
return(shaVal);
}
Value *bitAnd(Value *arg0, Value *arg1) {
Value *result;
result = integerValue(((Integer *)arg0)->numVal & ((Integer *)arg1)->numVal);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
}
Value *bitOr(Value *arg0, Value *arg1) {
Value *result;
result = integerValue(((Integer *)arg0)->numVal | ((Integer *)arg1)->numVal);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
}
Value *bitXor(Value *arg0, Value *arg1) {
Value *result;
result = integerValue(((Integer *)arg0)->numVal ^ ((Integer *)arg1)->numVal);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
}
Value *bitShiftLeft(Value *arg0, Value *arg1) {
Value *result;
result = integerValue(((Integer *)arg0)->numVal << ((Integer *)arg1)->numVal);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
}
Value *bitShiftRight(Value *arg0, Value *arg1) {
Value *result;
result = integerValue(((Integer *)arg0)->numVal >> ((Integer *)arg1)->numVal);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
}
Value *bitNot(Value *arg0) {
Value *result;
result = integerValue(~((Integer *)arg0)->numVal);
dec_and_free(arg0, 1);
return(result);
}
Value *addIntegers(Value *arg0, Value *arg1) {
Value *numVal = integerValue(((Integer *)arg0)->numVal + ((Integer *)arg1)->numVal);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(numVal);
}
Value *listEQ(Value *arg0, Value *arg1) {
if (arg1->type != ListType ||
((List *)arg0)->len != ((List *)arg1)->len) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
} else {
List *l0 = (List *)arg0;
List *l1 = (List *)arg1;
for (;
l0 != (List *)0 && l0->head != (Value *)0 &&
l1 != (List *)0 && l1->head != (Value *)0;
l0 = l0->tail, l1 = l1->tail) {
incRef(l0->head, 1);
incRef(l1->head, 1);
if (!equal(l0->head, l1->head)) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
}
}
int8_t equal(Value *v1, Value *v2) {
Value *equals;
switch (v1->type) {
case IntegerType:
equals = integer_EQ(v1, v2);
break;
case SymbolType:
equals = symEQ(v1, v2);
break;
default:
equals = equalSTAR((FnArity *)0, v1, v2);
break;
}
int8_t notEquals = isNothing(equals, "", 0);
dec_and_free(equals, 1);
return(!notEquals);
}
Value *stringValue(char *s) {
int64_t len = strlen(s);
String *strVal = malloc_string(len);
strncpy(strVal->buffer, s, len);
strVal->buffer[len] = 0;
return((Value *)strVal);
};
Value *maybeExtract(Value *arg0) {
Maybe *mValue = (Maybe *)arg0;
if (mValue->value == (Value *)0) {
(*prErrSTAR)(stringValue("\n*** The 'nothing' value can not be passed to 'extract'.\n"));
abort();
}
incRef(mValue->value, 1);
Value *result = mValue->value;
dec_and_free(arg0, 1);
return(result);
}
Value *fnApply(Value *arg0, Value *arg1) {
List *argList = (List *)arg1;
FnArity *_arity;
if (arg0->type == FunctionType)
_arity = findFnArity(arg0, argList->len);
else
_arity = (FnArity *)arg0;
if (_arity == (FnArity *)0) {
fprintf(stderr, "\n*** no arity of '%s' found to apply to %" PRId64 " args\n",
((Function *)arg0)->name, argList->len);
abort();
} else if(_arity->variadic) {
FnType1 *_fn = (FnType1 *)_arity->fn;
Value *result = _fn(_arity, arg1);
dec_and_free(arg0, 1);
return(result);
} else if (argList->len == 0) {
FnType0 *_fn = (FnType0 *)_arity->fn;
Value *result = _fn(_arity);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 1) {
FnType1 *_fn = (FnType1 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
Value *result = _fn(_arity, appArg0);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 2) {
FnType2 *_fn = (FnType2 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
argList = argList->tail;
Value *appArg1 = argList->head; incRef(appArg1, 1);
Value *result = _fn(_arity, appArg0, appArg1);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 3) {
FnType3 *_fn = (FnType3 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
argList = argList->tail;
Value *appArg1 = argList->head; incRef(appArg1, 1);
argList = argList->tail;
Value *appArg2 = argList->head; incRef(appArg2, 1);
Value *result = _fn(_arity, appArg0, appArg1, appArg2);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 4) {
FnType4 *_fn = (FnType4 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
argList = argList->tail;
Value *appArg1 = argList->head; incRef(appArg1, 1);
argList = argList->tail;
Value *appArg2 = argList->head; incRef(appArg2, 1);
argList = argList->tail;
Value *appArg3 = argList->head; incRef(appArg3, 1);
Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 5) {
FnType5 *_fn = (FnType5 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
argList = argList->tail;
Value *appArg1 = argList->head; incRef(appArg1, 1);
argList = argList->tail;
Value *appArg2 = argList->head; incRef(appArg2, 1);
argList = argList->tail;
Value *appArg3 = argList->head; incRef(appArg3, 1);
argList = argList->tail;
Value *appArg4 = argList->head; incRef(appArg4, 1);
Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 6) {
FnType6 *_fn = (FnType6 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
argList = argList->tail;
Value *appArg1 = argList->head; incRef(appArg1, 1);
argList = argList->tail;
Value *appArg2 = argList->head; incRef(appArg2, 1);
argList = argList->tail;
Value *appArg3 = argList->head; incRef(appArg3, 1);
argList = argList->tail;
Value *appArg4 = argList->head; incRef(appArg4, 1);
argList = argList->tail;
Value *appArg5 = argList->head; incRef(appArg5, 1);
Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4, appArg5);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 7) {
FnType7 *_fn = (FnType7 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
argList = argList->tail;
Value *appArg1 = argList->head; incRef(appArg1, 1);
argList = argList->tail;
Value *appArg2 = argList->head; incRef(appArg2, 1);
argList = argList->tail;
Value *appArg3 = argList->head; incRef(appArg3, 1);
argList = argList->tail;
Value *appArg4 = argList->head; incRef(appArg4, 1);
argList = argList->tail;
Value *appArg5 = argList->head; incRef(appArg5, 1);
argList = argList->tail;
Value *appArg6 = argList->head; incRef(appArg6, 1);
Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4, appArg5, appArg6);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 8) {
FnType8 *_fn = (FnType8 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
argList = argList->tail;
Value *appArg1 = argList->head; incRef(appArg1, 1);
argList = argList->tail;
Value *appArg2 = argList->head; incRef(appArg2, 1);
argList = argList->tail;
Value *appArg3 = argList->head; incRef(appArg3, 1);
argList = argList->tail;
Value *appArg4 = argList->head; incRef(appArg4, 1);
argList = argList->tail;
Value *appArg5 = argList->head; incRef(appArg5, 1);
argList = argList->tail;
Value *appArg6 = argList->head; incRef(appArg6, 1);
argList = argList->tail;
Value *appArg7 = argList->head; incRef(appArg7, 1);
Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4, appArg5, appArg6, appArg7);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else if (argList->len == 9) {
FnType9 *_fn = (FnType9 *)_arity->fn;
Value *appArg0 = argList->head; incRef(appArg0, 1);
argList = argList->tail;
Value *appArg1 = argList->head; incRef(appArg1, 1);
argList = argList->tail;
Value *appArg2 = argList->head; incRef(appArg2, 1);
argList = argList->tail;
Value *appArg3 = argList->head; incRef(appArg3, 1);
argList = argList->tail;
Value *appArg4 = argList->head; incRef(appArg4, 1);
argList = argList->tail;
Value *appArg5 = argList->head; incRef(appArg5, 1);
argList = argList->tail;
Value *appArg6 = argList->head; incRef(appArg6, 1);
argList = argList->tail;
Value *appArg7 = argList->head; incRef(appArg7, 1);
argList = argList->tail;
Value *appArg8 = argList->head; incRef(appArg8, 1);
Value *result = _fn(_arity, appArg0, appArg1, appArg2, appArg3, appArg4, appArg5, appArg6, appArg7,
appArg8);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
} else {
fprintf(stderr, "error in 'fn-apply'\n");
abort();
}
}
Value *maybeEQ(Value *arg0, Value *arg1) {
if (arg1->type == MaybeType &&
((Maybe *)arg0)->value == ((Maybe *)arg1)->value) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
} else if (arg1->type == MaybeType &&
((Maybe *)arg0)->value != (Value *)0 &&
((Maybe *)arg1)->value != (Value *)0) {
incRef(((Maybe *)arg0)->value, 1);
incRef(((Maybe *)arg1)->value, 1);
Value *eqResult = equalSTAR((FnArity *)0, ((Maybe *)arg0)->value, ((Maybe *)arg1)->value);
if (isNothing(eqResult, "", 0)) {
dec_and_free(eqResult, 1);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
} else {
dec_and_free(eqResult, 1);
dec_and_free(arg1, 1);
Value *result = maybe((FnArity *)0, (Value *)0, arg0);
return(result);
}
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
Value *maybeMap(Value *arg0, Value *arg1) {
Value *rslt6;
Maybe *mValue = (Maybe *)arg0;
if (mValue->value == (Value *)0) {
dec_and_free(arg1, 1);
return(arg0);
} else if((arg1)->type != FunctionType) {
incRef(arg1, 1);
incRef(mValue->value, 1);
rslt6 = invoke1Arg((FnArity *)0, arg1, mValue->value);
} else {
FnArity *arity3 = findFnArity(arg1, 1);
if(arity3 != (FnArity *)0 && !arity3->variadic) {
FnType1 *fn5 = (FnType1 *)arity3->fn;
incRef(mValue->value, 1);
rslt6 = fn5(arity3, mValue->value);
} else if(arity3 != (FnArity *)0 && arity3->variadic) {
FnType1 *fn5 = (FnType1 *)arity3->fn;
List *varArgs4 = empty_list;
incRef(mValue->value, 1);
varArgs4 = (List *)listCons(mValue->value, varArgs4);
rslt6 = fn5(arity3, (Value *)varArgs4);
} else {
fprintf(stderr, "\n*** no arity found for '%s'.\n", ((Function *)arg1)->name);
abort();
}
}
Value *result = maybe((FnArity *)0, (Value *)0, rslt6);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
}
void strSha1Update(Sha1Context *ctxt, Value *arg0) {
char *buffer;
int64_t len;
if (arg0->type == StringBufferType) {
String *strVal = (String *)arg0;
buffer = strVal->buffer;
len = strVal->len;
} else if (arg0->type == SubStringType) {
SubString *strVal = (SubString *)arg0;
buffer = strVal->buffer;
len = strVal->len;
}
Sha1Update(ctxt, (void *)&arg0->type, 8);
Sha1Update(ctxt, buffer, len);
return;
}
int64_t strSha1(Value *arg0) {
int64_t hash;
char *buffer;
int64_t len;
if (arg0->type == StringBufferType) {
String *strVal = (String *)arg0;
hash = strVal->hashVal;
buffer = strVal->buffer;
len = strVal->len;
} else if (arg0->type == SubStringType ||
arg0->type == SymbolType) {
SubString *strVal = (SubString *)arg0;
hash = strVal->hashVal;
buffer = strVal->buffer;
len = strVal->len;
}
if (hash != 0) {
dec_and_free(arg0, 1);
return(hash);
} else {
int64_t shaVal;
Sha1Context context;
Sha1Initialise(&context);
Sha1Update(&context, (void *)&arg0->type, 8);
Sha1Update(&context, buffer, len);
Sha1Finalise(&context, (SHA1_HASH *)&shaVal);
((String *)arg0)->hashVal = shaVal;
dec_and_free(arg0, 1);
return(shaVal);
}
}
Value *escapeChars(Value *arg0) {
if (arg0->type == StringBufferType) {
String *s = (String *)arg0;
String *result = malloc_string(s->len * 2);
char *resultBuffer = result->buffer;
int resultIndex = 0;
for(int i = 0; i < s->len; i++) {
if (s->buffer[i] == 10) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 110;
} else if (s->buffer[i] == 34) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 34;
} else if (s->buffer[i] == 13) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 114;
} else if (s->buffer[i] == 12) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 102;
} else if (s->buffer[i] == 8) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 98;
} else if (s->buffer[i] == 9) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 116;
} else if (s->buffer[i] == 92) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 92;
} else
resultBuffer[resultIndex++] = s->buffer[i];
}
resultBuffer[resultIndex] = 0;
result->len = resultIndex;
dec_and_free(arg0, 1);
return((Value *)result);
} else if (arg0->type == SubStringType) {
SubString *s = (SubString *)arg0;
String *result = malloc_string(s->len * 2);
char *resultBuffer = result->buffer;
int resultIndex = 0;
for(int i = 0; i < s->len; i++) {
if (s->buffer[i] == 10) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 110;
} else if (s->buffer[i] == 34) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 34;
} else if (s->buffer[i] == 13) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 114;
} else if (s->buffer[i] == 12) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 102;
} else if (s->buffer[i] == 8) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 98;
} else if (s->buffer[i] == 9) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 116;
} else if (s->buffer[i] == 92) {
resultBuffer[resultIndex++] = 92;
resultBuffer[resultIndex++] = 92;
} else
resultBuffer[resultIndex++] = s->buffer[i];
}
resultBuffer[resultIndex] = 0;
result->len = resultIndex;
dec_and_free(arg0, 1);
return((Value *)result);
}
return(arg0);
}
Value *opaqueValue(void *ptr, Destructor *destruct) {
Opaque *opVal = (Opaque *)my_malloc(sizeof(Opaque));
// incTypeMalloc(OpaqueType, 1);
opVal->type = OpaqueType;
opVal->ptr = ptr;
opVal->destruct = destruct;
return((Value *)opVal);
};
Value *subs2(Value *arg0, Value *arg1) {
int64_t idx = ((Integer *)arg1)->numVal;
if (arg0->type == StringBufferType) {
String *s = (String *)arg0;
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
if (idx < s->len) {
subStr->len = s->len - idx;
subStr->source = arg0;
subStr->buffer = s->buffer + idx;
} else {
dec_and_free(arg0, 1);
subStr->len = 0;
subStr->source = (Value *)0;
subStr->buffer = (char *)0;
}
dec_and_free(arg1, 1);
return((Value *)subStr);
} else if (arg0->type == SubStringType) {
SubString *s = (SubString *)arg0;
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
if (idx < s->len) {
subStr->len = s->len - idx;
subStr->source = ((SubString *)arg0)->source;
incRef(subStr->source, 1);
subStr->buffer = s->buffer + idx;
} else {
subStr->len = 0;
subStr->source = (Value *)0;
subStr->buffer = (char *)0;
}
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return((Value *)subStr);
}
return(arg0);
}
Value *subs3(Value *arg0, Value *arg1, Value *arg2) {
int64_t idx = ((Integer *)arg1)->numVal;
int64_t len = ((Integer *)arg2)->numVal;
if (len <= 0) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
dec_and_free(arg2, 1);
return(stringValue(""));
} else if (arg0->type == StringBufferType) {
String *s = (String *)arg0;
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
if (idx + len <= s->len) {
subStr->len = len;
subStr->source = arg0;
incRef(arg0, 1);
subStr->buffer = s->buffer + idx;
} else {
subStr->len = 0;
subStr->source = (Value *)0;
subStr->buffer = (char *)0;
}
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
dec_and_free(arg2, 1);
return((Value *)subStr);
} else if (arg0->type == SubStringType) {
SubString *s = (SubString *)arg0;
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
if (idx + len <= s->len) {
subStr->len = len;
subStr->source = ((SubString *)arg0)->source;
incRef((Value *)subStr->source, 1);
subStr->buffer = s->buffer + idx;
} else {
subStr->len = 0;
subStr->source = (Value *)0;
subStr->buffer = (char *)0;
}
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
dec_and_free(arg2, 1);
return((Value *)subStr);
}
return(arg0);
}
Value *strSeq(Value *arg0) {
List *result = empty_list;
if (arg0->type == StringBufferType) {
String *s = (String *)arg0;
for (int64_t i = s->len - 1; i >= 0; i--) {
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
subStr->len = 1;
subStr->source = arg0;
subStr->buffer = s->buffer + i;
result = listCons((Value *)subStr, result);
}
incRef(arg0, s->len);
} else if (arg0->type == SubStringType) {
SubString *s = (SubString *)arg0;
for (int64_t i = s->len - 1; i >= 0; i--) {
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
subStr->len = 1;
subStr->source = arg0;
subStr->buffer = s->buffer + i;
result = listCons((Value *)subStr, result);
}
incRef(arg0, s->len);
}
dec_and_free(arg0, 1);
return((Value *)result);
}
Value *dynamicCall2Arg(Value *f, Value *arg0, Value *arg1) {
Value *rslt;
if(f->type != FunctionType) {
rslt = invoke2Args((FnArity *)0, f, arg0, arg1);
} else {
FnArity *arity = findFnArity(f, 2);
if(arity != (FnArity *)0 && !arity->variadic) {
FnType2 *fn = (FnType2 *)arity->fn;
rslt = fn(arity, arg0, arg1);
} else if(arity != (FnArity *)0 && arity->variadic) {
FnType1 *fn = (FnType1 *)arity->fn;
List *dynArgs = empty_list;
dynArgs = (List *)listCons(arg1, dynArgs);
dynArgs = (List *)listCons(arg0, dynArgs);
rslt = fn(arity, (Value *)dynArgs);
} else {
fprintf(stderr, "\n*** Invalid function for string reduction.\n");
abort();
}
dec_and_free(f, 1);
}
return(rslt);
}
Value *strReduce(Value *s0, Value *x1, Value *f2) {
int64_t len = ((String *)s0)->len;
Value *result = x1;
char *buffer;
if (s0->type == StringBufferType)
buffer = ((String *)s0)->buffer;
else if (s0->type == SubStringType)
buffer = ((SubString *)s0)->buffer;
incRef(f2, len);
incRef(s0, len);
for (int64_t i = 0; i < len; i++) {
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
subStr->len = 1;
subStr->source = s0;
subStr->buffer = buffer + i;
result = dynamicCall2Arg(f2, result, (Value *)subStr);
}
dec_and_free(f2, 1);
dec_and_free(s0, 1);
return((Value *)result);
}
Value *strVec(Value *arg0) {
Vector *result = empty_vect;
if (arg0->type == StringBufferType) {
String *s = (String *)arg0;
for (int64_t i = 0; i < s->len; i++) {
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
subStr->len = 1;
subStr->source = arg0;
subStr->buffer = s->buffer + i;
result = mutateVectConj(result, (Value *)subStr);
}
incRef(arg0, s->len);
} else if (arg0->type == SubStringType) {
SubString *s = (SubString *)arg0;
for (int64_t i = 0; i < s->len; i++) {
SubString *subStr = malloc_substring();
subStr->type = SubStringType;
subStr->len = 1;
subStr->source = arg0;
subStr->buffer = s->buffer + i;
result = mutateVectConj(result, (Value *)subStr);
}
incRef(arg0, s->len);
}
dec_and_free(arg0, 1);
return((Value *)result);
}
Value *vectorGet(Value *arg0, Value *arg1) {
Vector *vect = (Vector *)arg0;
Integer *index = (Integer *)arg1;
if (index->numVal < 0 || vect->count <= index->numVal) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
} else {
Value *val = vectGet(vect, (unsigned)index->numVal);
incRef(val, 1);
Value *result = maybe((FnArity *)0, (Value *)0, val);
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(result);
}
}
Value *symbol(Value *arg0) {
int64_t len;
char *buffer;
if (arg0->type == StringBufferType) {
String *s = (String *)arg0;
buffer = s->buffer;
len = s->len;
} else if (arg0->type == SubStringType) {
SubString *s = (SubString *)arg0;
buffer = s->buffer;
len = s->len;
} else if (arg0->type == SymbolType) {
return(arg0);
}
SubString *subStr = malloc_substring();
subStr->type = SymbolType;
subStr->len = len;
subStr->source = arg0;
subStr->hashVal = 0;
subStr->buffer = buffer;
return((Value *)subStr);
}
Value *symEQ(Value *arg0, Value *arg1) {
if (arg0->type != arg1->type) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
} else {
SubString *s1 = (SubString *)arg0;
SubString *s2 = (SubString *)arg1;
if (s1->len == s2->len &&
strncmp(s1->buffer, s2->buffer, s1->len) == 0) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
}
Value *symLT(Value *arg0, Value *arg1) {
if (arg0->type != arg1->type) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
} else {
SubString *s0 = (SubString *)arg0;
SubString *s1 = (SubString *)arg1;
int64_t len;
if (s0->len < s1->len)
len = s0->len;
else
len = s1->len;
int cmp = strncmp(s0->buffer, s1->buffer, len);
if (cmp < 0 || (cmp == 0 && s0->len < s1->len)) {
dec_and_free(arg1, 1);
return(maybe((FnArity *)0, (Value *)0, arg0));
} else {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return(nothing);
}
}
}
Value *listFilter(Value *arg0, Value *arg1) {
List *l = (List *)arg0;
if (l->len == 0) {
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return((Value *)empty_list);
} else {
List *head = empty_list;
List *tail = empty_list;
FnArity *arity2;
if(arg1->type == FunctionType) {
arity2 = findFnArity(arg1, 1);
if(arity2 == (FnArity *)0) {
fprintf(stderr, "\n*** no arity found for '%s'.\n", ((Function *)arg1)->name);
abort();
}
}
for(Value *x = l->head; x != (Value *)0; l = l->tail, x = l->head) {
Value *y;
incRef(x, 1);
if(arg1->type != FunctionType) {
incRef(arg1, 1);
y = invoke1Arg((FnArity *)0, arg1, x);
} else if(arity2->variadic) {
FnType1 *fn4 = (FnType1 *)arity2->fn;
List *varArgs3 = empty_list;
varArgs3 = (List *)listCons(x, varArgs3);
y = fn4(arity2, (Value *)varArgs3);
} else {
FnType1 *fn4 = (FnType1 *)arity2->fn;
y = fn4(arity2, x);
}
// 'y' is the filter maybe/nothing value
if (!isNothing(y, "", 0)) {
incRef(x, 1);
if (head == empty_list) {
// if we haven't started the new list yet
head = malloc_list();
head->len = 1;
head->head = x;
head->tail = empty_list;
tail = head;
} else {
// otherwise, append to tail of list
List *new_tail = malloc_list();
new_tail->len = 1;
new_tail->head = x;
new_tail->tail = empty_list;
tail->tail = new_tail;
tail = new_tail;
head->len++;
}
}
dec_and_free(y, 1);
}
dec_and_free(arg0, 1);
dec_and_free(arg1, 1);
return((Value *)head);
}
}
BitmapIndexedNode *clone_BitmapIndexedNode(BitmapIndexedNode *node, int idx,
Value *key, Value* val)
{
int itemCount = __builtin_popcount(node->bitmap);
BitmapIndexedNode *newNode = malloc_bmiNode(itemCount);
newNode->bitmap = node->bitmap;
for (int i = 0; i < itemCount; i++) {
if (i == idx) {
newNode->array[i * 2] = key;
newNode->array[i * 2 + 1] = val;
} else {
if (node->array[i * 2] != (Value *)0) {
incRef(node->array[i * 2], 1);
}
if (node->array[i * 2 + 1] != (Value *)0) {
incRef(node->array[i * 2 + 1], 1);
}
newNode->array[i * 2] = node->array[i * 2];
newNode->array[i * 2 + 1] = node->array[i * 2 + 1];
}
}
return(newNode);
}
Value *createNode(int shift,
int64_t key1hash, Value *key1, Value *val1,
int64_t key2hash, Value *key2, Value *val2)
{
if (shift > 60) {
fprintf(stderr, "Ran out of shift!!!!!!");
abort();
}
BitmapIndexedNode *newNode = malloc_bmiNode(2);
int key1bit = bitpos(key1hash, shift);
int key2bit = bitpos(key2hash, shift);
newNode->bitmap = key1bit | key2bit;
int key1idx = __builtin_popcount(newNode->bitmap & (key1bit - 1));
int key2idx = __builtin_popcount(newNode->bitmap & (key2bit - 1));
if (key1bit == key2bit) {
newNode->array[0] = (Value *)0;
newNode->array [1] = createNode(shift + 5, key1hash, key1, val1,
key2hash, key2, val2);
} else {
newNode->array[key1idx * 2] = key1;
newNode->array[key1idx * 2 + 1] = val1;
newNode->array[key2idx * 2] = key2;
newNode->array[key2idx * 2 + 1] = val2;
}
return((Value *)newNode);
}
Value *bmiHashSeq(Value *arg0, Value *arg1) {
BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;
int cnt = __builtin_popcount(node->bitmap);
List *seq = (List *)arg1;
for (int i = 0; i < cnt; i++) {
if (node->array[2 * i] == (Value *)0) {
seq = (List *)hashSeq((FnArity *)0, incRef(node->array[2 * i + 1], 1), (Value *)seq);
} else {
List *pair = listCons(node->array[2 * i], listCons(node->array[2 * i + 1], empty_list));
incRef(node->array[2 * i], 1);
incRef(node->array[2 * i + 1], 1);
seq = listCons((Value *)pair, seq);
}
}
dec_and_free(arg0, 1);
return((Value *)seq);
}
Value *bmiHashVec(Value *arg0, Value *arg1) {
BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;
int cnt = __builtin_popcount(node->bitmap);
Vector *vec = (Vector *)arg1;
for (int i = 0; i < cnt; i++) {
if (node->array[2 * i] == (Value *)0) {
vec = (Vector *)hashVec(incRef(node->array[2 * i + 1], 1), (Value *)vec);
} else {
incRef(node->array[2 * i], 1);
incRef(node->array[2 * i + 1], 1);
Vector *pair = mutateVectConj(empty_vect, node->array[2 * i]);
pair = mutateVectConj(pair, node->array[2 * i + 1]);
vec = mutateVectConj(vec, (Value *)pair);
}
}
dec_and_free(arg0, 1);
return((Value *)vec);
}
Value *bmiCount(Value *arg0) {
BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;
int cnt = __builtin_popcount(((BitmapIndexedNode *)arg0)->bitmap);
int accum = 0;
for(int i = 0; i < cnt; i++) {
if (node->array[i * 2] == (Value *)0 && node->array[i * 2 + 1] != (Value *)0) {
Integer *subCnt = (Integer *)count((FnArity *)0,
incRef(((BitmapIndexedNode *)arg0)->array[i * 2 + 1], 1));
accum += subCnt->numVal;
dec_and_free((Value *)subCnt, 1);
} else {
accum++;
}
}
dec_and_free(arg0, 1);
return(integerValue(accum));
}
Value *bmiCopyAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {
BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;
Value *key = arg1;
Value *val = arg2;
int bit = bitpos(hash, shift);
int idx = __builtin_popcount(node->bitmap & (bit - 1));
if (node->bitmap & bit) {
// if the hash position is already filled
Value *keyOrNull = node->array[2 * idx];
Value *valOrNode = node->array[2 * idx + 1];
if (keyOrNull == (Value *)0) {
// There is no key in the position, so valOrNode is
// pointer to a node.
int newShift = shift + 5;
Value *n = copyAssoc(incRef(valOrNode, 1), key, val, hash, newShift);
if (n == valOrNode) {
// the key was already associated with the value
// so do nothing
dec_and_free(n, 1);
return(arg0);
} else {
// clone node and add n to it
BitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, (Value *)0, n);
dec_and_free(arg0, 1);
return((Value *)newNode);
}
} else if (equal(incRef(key, 1), incRef(keyOrNull, 1))) {
if (equal(incRef(val, 1), incRef(valOrNode, 1))) {
dec_and_free(arg1, 1);
dec_and_free(arg2, 1);
return(arg0);
} else {
// if the keyOrNull points to a value that is equal to key
// create new hash-map with valOrNode replaced by val
// clone node and add val to it
BitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, key, val);
dec_and_free((Value *)node, 1);
return((Value *)newNode);
}
} else {
// there is already a key/val pair at the position where key
// would be placed. Extend tree a level
int64_t existingKeyHash = nakedSha1(incRef(keyOrNull, 1));
if (existingKeyHash == hash) {
// make & return HashCollisionNode
HashCollisionNode *newLeaf = malloc_hashCollisionNode(2);
newLeaf->array[0] = keyOrNull;
newLeaf->array[1] = valOrNode;
newLeaf->array[2] = key;
newLeaf->array[3] = val;
incRef((Value *)keyOrNull, 1);
incRef((Value *)valOrNode, 1);
BitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, (Value *)0,
(Value *)newLeaf);
dec_and_free((Value *)node, 1);
return((Value *)newNode);
} else {
Value *newLeaf = createNode(shift + 5,
existingKeyHash, incRef(keyOrNull, 1), incRef(valOrNode, 1),
hash, key, val);
BitmapIndexedNode *newNode = clone_BitmapIndexedNode(node, idx, (Value *)0, newLeaf);
dec_and_free((Value *)node, 1);
return((Value *)newNode);
}
}
} else {
// the position in the node is empty
int n = __builtin_popcount(node->bitmap);
if (n >= 16) {
ArrayNode *newNode = (ArrayNode *)malloc_arrayNode();
int jdx = mask(hash, shift);
int newShift = shift + 5;
newNode->array[jdx] = copyAssoc((Value *)&emptyBMI, key, val, hash, newShift);
for (int i = 0, j = 0; i < ARRAY_NODE_LEN; i++) {
if ((node->bitmap >> i) & 1) {
if (node->array[j] == (Value *)0) {
newNode->array[i] = node->array[j + 1];
incRef(newNode->array[i], 1);
} else {
incRef(node->array[j], 2);
newNode->array[i] = copyAssoc((Value *)&emptyBMI,
node->array[j],
incRef(node->array[j + 1], 1),
nakedSha1(node->array[j]),
newShift);
}
j += 2;
}
}
dec_and_free((Value *)node, 1);
return((Value *)newNode);
} else {
int itemCount = n + 1;
BitmapIndexedNode *newNode = malloc_bmiNode(itemCount);
newNode->bitmap = node->bitmap | bit;
for (int i = 0; i < idx * 2; i++) {
if (node->array[i] != (Value *)0) {
incRef(node->array[i], 1);
}
newNode->array[i] = node->array[i];
}
newNode->array[2 * idx] = key;
newNode->array[2 * idx + 1] = val;
for (int i = idx * 2; i < n * 2; i++) {
if (node->array[i] != (Value *)0) {
incRef(node->array[i], 1);
}
newNode->array[i + 2] = node->array[i];
}
dec_and_free((Value *)node, 1);
return((Value *)newNode);
}
}
}
Value *bmiMutateAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int shift) {
if (arg0->refs != 1) {
return(bmiCopyAssoc(arg0, arg1, arg2, hash, shift));
} else {
BitmapIndexedNode *node = (BitmapIndexedNode *)arg0;
Value *key = arg1;
Value *val = arg2;
int bit = bitpos(hash, shift);
int idx = __builtin_popcount(node->bitmap & (bit - 1));
if (node->bitmap & bit) {
// if the hash position is already filled
Value *keyOrNull = node->array[2 * idx];
Value *valOrNode = node->array[2 * idx + 1];
if (keyOrNull == (Value *)0) {
// There is no key in the position, so valOrNode is
// pointer to a node.
Value *n;
n = mutateAssoc(valOrNode, key, val, hash, shift + 5);
// replace key/val at 'idx' with new stuff
node->array[idx * 2] = (Value *)0;;
node->array[idx * 2 + 1] = n;
return(arg0);
} else if (equal(incRef(key, 1), incRef(keyOrNull, 1))) {
if (equal(incRef(val, 1), incRef(valOrNode, 1))) {
dec_and_free(arg1, 1);
dec_and_free(arg2, 1);
return(arg0);
} else {
// if the keyOrNull points to a value that is equal to key
// replace key/val at 'idx' with new stuff
node->array[idx * 2] = key;
node->array[idx * 2 + 1] = val;
dec_and_free(valOrNode, 1);
dec_and_free(keyOrNull, 1);
return(arg0);
}
} else {
// there is already a key/val pair at the position where key
// would be placed. Extend tree a level
int64_t existingKeyHash = nakedSha1(incRef(keyOrNull, 1));
if (existingKeyHash == hash) {
// make & return HashCollisionNode
HashCollisionNode *newLeaf = malloc_hashCollisionNode(2);
newLeaf->array[0] = keyOrNull;
newLeaf->array[1] = valOrNode;
newLeaf->array[2] = key;
newLeaf->array[3] = val;
// replace key/val at 'idx' with new stuff
node->array[idx * 2] = (Value *)0;
node->array[idx * 2 + 1] = (Value *)newLeaf;
return(arg0);
} else {
Value *newLeaf = createNode(shift + 5,
existingKeyHash, keyOrNull, valOrNode,
hash, key, val);
// replace key/val at 'idx' with new stuff
node->array[idx * 2] = (Value *)0;
node->array[idx * 2 + 1] = (Value *)newLeaf;
return(arg0);
}
}
} else {
// the position in the node is empty
int n = __builtin_popcount(node->bitmap);
if (n >= 16) {
ArrayNode *newNode = (ArrayNode *)malloc_
gitextract_85yw3pm4/ ├── .gitattributes ├── .gitignore ├── CMakeLists.txt ├── HISTORY.md ├── LICENSE ├── README.md ├── assertion-tests/ │ ├── add-items-list-1.toc │ ├── add-items-list-2.toc │ ├── and-constraints-1.toc │ ├── and-constraints-2.toc │ ├── apply-constructor.toc │ ├── bad-add.toc │ ├── bad-and-1.toc │ ├── bad-and-2.toc │ ├── bad-and-clause.toc │ ├── bad-apply-constructor.toc │ ├── bad-arity-1.toc │ ├── bad-constructor-call.toc │ ├── bad-constructor-param-1.toc │ ├── bad-constructor-param-2.toc │ ├── bad-dipatch-type.toc │ ├── bad-enum-1.toc │ ├── bad-enum-2.toc │ ├── bad-enum-3.toc │ ├── bad-enum-4.toc │ ├── bad-field-1.toc │ ├── bad-field-2.toc │ ├── bad-field-3.toc │ ├── bad-field-4.toc │ ├── bad-field-5.toc │ ├── bad-flat-map-inner.toc │ ├── bad-function-returns-1.toc │ ├── bad-function-returns-2.toc │ ├── bad-impl-arity.toc │ ├── bad-impl-return-value.toc │ ├── bad-inline-result-type.toc │ ├── bad-inner-1.toc │ ├── bad-inner-10.toc │ ├── bad-inner-11.toc │ ├── bad-inner-12.toc │ ├── bad-inner-13.toc │ ├── bad-inner-14.toc │ ├── bad-inner-15.toc │ ├── bad-inner-16.toc │ ├── bad-inner-2.toc │ ├── bad-inner-3.toc │ ├── bad-inner-4.toc │ ├── bad-inner-5.toc │ ├── bad-inner-6.toc │ ├── bad-inner-7.toc │ ├── bad-inner-8.toc │ ├── bad-inner-9.toc │ ├── bad-inner-or.toc │ ├── bad-let.toc │ ├── bad-list-of-1.toc │ ├── bad-nested-let.toc │ ├── bad-or-1.toc │ ├── bad-or-2.toc │ ├── bad-result-sum-type.toc │ ├── bad-return-value.toc │ ├── bad-setter-call-1.toc │ ├── bad-setter-call-2.toc │ ├── bad-state-maybe-value-1.toc │ ├── bad-state-maybe-value-2.toc │ ├── bad-type-comp.toc │ ├── bad-vector-of-1.toc │ ├── checked-map-1.toc │ ├── checked-map-2.toc │ ├── closure-1.toc │ ├── closure-2.toc │ ├── closure-constraint.toc │ ├── closure-param.toc │ ├── comp-bad-type-1.toc │ ├── comp-bad-type-2.toc │ ├── conj-to-getter-result-1.toc │ ├── conj-to-getter-result-2.toc │ ├── constructor-param-1.toc │ ├── constructor-param-2.toc │ ├── constructor-param-3.toc │ ├── contents-2.toc │ ├── deeply-nested-vector-1.toc │ ├── deeply-nested-vector-2.toc │ ├── destruct-variadic-tail-2.toc │ ├── dup-protocol-name.toc │ ├── dynamic-call-1.toc │ ├── dynamic-call-2.toc │ ├── dynamic-call-3.toc │ ├── dynamic-call-4.toc │ ├── dynamic-call-5.toc │ ├── dynamic-call-6.toc │ ├── dynamic-call-7.toc │ ├── dynamic-call-8.toc │ ├── dynamic-field-type-1.toc │ ├── dynamic-field-type-2.toc │ ├── dynamic-nested-value-1.toc │ ├── dynamic-proto-param-1.toc │ ├── empty-defn.toc │ ├── field-and-seq-conflict.toc │ ├── field-constraint.toc │ ├── field-shadow.toc │ ├── flat-map-param.toc │ ├── impl-violates-proto.toc │ ├── incompatible-tails.toc │ ├── init-type.toc │ ├── insufficient-static-elements-1.toc │ ├── insufficient-static-elements-2.toc │ ├── insufficient-static-elements-3.toc │ ├── insufficient-static-elements-4.toc │ ├── int-too-large.toc │ ├── items-constraints-1.toc │ ├── items-constraints-2.toc │ ├── items-constraints-3.toc │ ├── key-violation.toc │ ├── list-items-types.toc │ ├── literal-hash-map-1.toc │ ├── literal-hash-map-2.toc │ ├── min-count.toc │ ├── missing-namespaced-sym.toc │ ├── multi-constraint-violated.toc │ ├── nested-destruct-1.toc │ ├── nested-destruct-2.toc │ ├── nested-destruct.toc │ ├── nested-items-conflict.toc │ ├── or-prop.toc │ ├── param-in-and.toc │ ├── param-in-or.toc │ ├── partial-param.toc │ ├── preserve-asserts.toc │ ├── preserve-static-info-1.toc.test │ ├── preserve-static-info-2.toc.test │ ├── preserve-static-info-3.toc.test │ ├── propogate-inner-1.toc │ ├── propogate-inner-2.toc │ ├── propogate-through-let.toc │ ├── propogate-through-seq.toc │ ├── propogate-through-vec.toc │ ├── proto-fn-constraint-prop.toc │ ├── proto-fn-min-count.toc │ ├── proto-fn-param.toc │ ├── restrict-conflict.toc │ ├── restrict-nested-item.toc │ ├── restrict-param.toc │ ├── return-bad-type.toc │ ├── return-generic-1.toc │ ├── return-list-of-1.toc │ ├── return-list-of-2.toc │ ├── return-sum-type.toc │ ├── simple-conflict.toc │ ├── static-fixed-dynamic-result-type-1.toc │ ├── static-fixed-dynamic-result-type-2.toc │ ├── unkown-field.toc │ ├── update-field-1.toc │ ├── variadic-constraints.toc │ ├── variadic-count-1.toc │ ├── variadic-count-2.toc │ └── vect-len.toc ├── bin/ │ ├── build-toccata.sh │ └── toccata.sh ├── core.c ├── core.h ├── core.toc ├── ebnf.md ├── em-run ├── examples/ │ ├── apply-maybe.toc │ ├── apply-vector.toc │ ├── config-file.toc │ ├── debugging.toc │ ├── flat-map-list.toc │ ├── flat-map-maybe.toc │ ├── greeting.toc │ ├── howdy.toc │ ├── json-ebnf.toc │ ├── json-graph.toc │ ├── json-parser.toc │ ├── json.toc │ ├── map-maybe.toc │ ├── map-vector.toc │ ├── number-option.toc │ └── tictactoe.toc ├── foundry/ │ └── docker/ │ ├── Development.docker │ ├── README.md │ ├── bashrc │ ├── build-devenv │ ├── build-devenv.cmd │ ├── enter-dev │ └── enter-dev.cmd ├── interpreter-tests/ │ ├── abort-memory-leak.toc │ ├── bad-and-clause-type-1.toc │ ├── bad-apply-arg-1.toc │ ├── bad-apply-arg-2.toc │ ├── bad-constructor-arg-1.toc │ ├── bad-constructor-arg-2.toc │ ├── bad-default-proto-param.toc │ ├── bad-field-1.toc │ ├── bad-field-2.toc │ ├── bad-proto-impl-param-const.toc │ ├── bad-proto-param.toc │ ├── bad-proto-return-type.toc │ ├── bad-reify-arg-1.toc │ ├── bad-reify-arg-2.toc │ ├── bad-reify-arg-3.toc │ ├── constrain-let-expr.toc │ ├── constrain-tagged.toc │ ├── insufficient-apply-args-1.toc │ ├── insufficient-apply-args-2.toc │ └── insufficient-invoke-args-1.toc ├── par-test ├── regression-tests/ │ ├── Boomer.toc │ ├── agent-regressions.toc │ ├── and-prop.toc │ ├── boom.toc │ ├── comment-in-deftype.toc │ ├── cond-expr-1.toc │ ├── cond-expr-2.toc │ ├── cond-expr-3.toc │ ├── cond-expr-4.toc │ ├── cond-expr-5.toc │ ├── destruct-test.toc │ ├── free-static-value.toc │ ├── function-regressions.toc │ ├── future-regressions.toc │ ├── hash-map-regressions.toc │ ├── integer-regressions.toc │ ├── interpreter-test.toc │ ├── lazy-list-regressions.toc │ ├── list-regressions.toc │ ├── maybe-regressions.toc │ ├── or-and-constraints.toc │ ├── promise-regressions.toc │ ├── regression-tester.toc │ ├── string-regressions.toc │ ├── symbol-regressions.toc │ ├── tail-cond-1.toc │ ├── test-apply-constructor.toc │ ├── test-comment-in-let.toc │ ├── test-def-empty.test │ ├── test-either.toc │ ├── test-for.toc │ ├── test-gensym.toc │ ├── test-global-empty-list.toc │ ├── test-hlist-cons.toc │ ├── test-ignore-inferred.toc │ ├── test-inline-invoke.toc │ ├── test-inline-namespaced-sym.toc │ ├── test-inline-sym-literal.toc │ ├── test-inlined-result-constraint.toc │ ├── test-or-comment.toc │ ├── test-parser-efficience.toc │ ├── test-proto-def-constraints.toc │ ├── test-proto-impl-destruct.toc │ ├── test-recursive-map-fn.toc │ ├── test-regressions.toc │ ├── test-tail-recur-1.toc │ ├── test-tail-recur-2.toc │ ├── test-tail-recur-3.toc │ ├── test-threading.toc │ ├── test-trailing-comment.toc │ ├── test-type-of-tail.toc │ ├── test-underscore-inline.toc │ ├── test-uni.toc │ ├── test1.toc │ ├── test10.toc │ ├── test11.toc │ ├── test12.toc │ ├── test13.toc │ ├── test14.toc │ ├── test15.toc │ ├── test16.toc │ ├── test17.toc │ ├── test18.toc │ ├── test19.toc │ ├── test20.toc │ ├── test3.toc │ ├── test4.toc │ ├── test5.toc │ ├── test6.toc │ ├── test7.toc │ ├── test8.toc │ ├── test9.toc │ ├── types-regressions.toc │ └── vector-regressions.toc ├── run ├── runtime-tests/ │ ├── agent-loop.toc │ ├── apply-constructor.toc │ ├── bad-arity-1.toc │ ├── bad-arity-2.toc │ ├── bad-enum-1.toc │ ├── bad-field-1.toc │ ├── bad-field-2.toc │ ├── bad-maybe-flat-map.toc │ ├── bad-param.toc │ ├── bad-proto-param-1.toc │ ├── bad-proto-param-2.toc │ ├── bad-proto-param-3.toc │ ├── bad-proto-param-4.toc │ ├── bad-variadic-param.toc │ ├── check-and-1.toc │ ├── check-and-2.toc │ ├── check-and-3.toc │ ├── check-and-4.toc │ ├── check-every-time.toc │ ├── check-or-1.toc │ ├── check-or-2.toc │ ├── check-or-3.toc │ ├── check-or-4.toc │ ├── check-params-1.toc │ ├── check-params-2.toc │ ├── check-return-sum-type.toc │ ├── check-tail-either.toc │ ├── closure-param.toc │ ├── constructor-param.toc │ ├── default-impl-parameter.toc │ ├── default-proto.toc │ ├── destruct-variadic-tail-1.toc │ ├── flat-map-param.toc │ ├── higher-order-fn.toc │ ├── higher-order-variadic.toc │ ├── insufficient-elements.toc │ ├── int-too-large-1.toc │ ├── int-too-large-2.toc │ ├── int-too-large.toc │ ├── int-too-small.toc │ ├── invalid-type.toc │ ├── invoke-param.toc │ ├── list-len-1.toc │ ├── list-len-2.toc │ ├── list-len-3.toc │ ├── nested-destruct-1.toc │ ├── nested-destruct-2.toc │ ├── nested-destruct.toc │ ├── param-in-cond-2.toc │ ├── param-in-cond.toc │ ├── preserve-asserts.toc │ ├── promise-loop.toc │ ├── proto-fn-arg.toc │ ├── test-tail-and.toc │ ├── test-tail-or.toc │ ├── update-field-2.toc │ └── variadic-count-2.toc ├── test ├── test-assertion ├── test-regression ├── test-runtime-check ├── toccata.c ├── toccata.toc └── update-deps
SYMBOL INDEX (221 symbols across 2 files)
FILE: core.c
function prefs (line 23) | void prefs(char *tag, Value *v) {
function incTypeMalloc (line 36) | void incTypeMalloc(TYPE_SIZE type, int delta) {
function incTypeFree (line 51) | void incTypeFree(TYPE_SIZE type, int delta) {
function mask (line 87) | int mask(int64_t hash, int shift) {
function bitpos (line 91) | int bitpos(int64_t hash, int shift) {
function Value (line 95) | Value *my_malloc(int64_t sz) {
function cleanupMemory (line 116) | void cleanupMemory (Value *the_final_answer, Value *maybeNothing, List *...
type FreeValList (line 125) | typedef struct {Value *head; uintptr_t aba;} FreeValList;
function Value (line 127) | Value *removeFreeValue(FreeValList *freeList) {
function decRefs (line 176) | int decRefs(Value *v, int deltaRefs) {
function moveToCentral (line 219) | void moveToCentral(FreeValList *freeList, FreeValList *centralList) {
function decValuePtrRef (line 253) | void decValuePtrRef(Value **ptr) {
function Integer (line 265) | Integer *malloc_integer() {
function freeInteger (line 295) | void freeInteger(Value *v) {
function String (line 303) | String *malloc_string(int len) {
function freeString (line 328) | void freeString(Value *v) {
function SubString (line 344) | SubString *malloc_substring() {
function freeSubString (line 360) | void freeSubString(Value *v) {
function FnArity (line 372) | FnArity *malloc_fnArity() {
function freeFnArity (line 389) | void freeFnArity(Value *v) {
function Function (line 416) | Function *malloc_function(int arityCount) {
function freeFunction (line 437) | void freeFunction(Value *v) {
function List (line 457) | List *malloc_list() {
function freeList (line 492) | void freeList(Value *v) {
function Maybe (line 525) | Maybe *malloc_maybe() {
function freeMaybe (line 556) | void freeMaybe(Value *v) {
function VectorNode (line 567) | VectorNode *malloc_vectorNode() {
function freeVectorNode (line 597) | void freeVectorNode(Value *v) {
function Vector (line 609) | Vector *malloc_vector() {
function freeVector (line 643) | void freeVector(Value *v) {
function ReifiedVal (line 697) | ReifiedVal *malloc_reified(int64_t implCount) {
function BitmapIndexedNode (line 775) | BitmapIndexedNode *malloc_bmiNode(int itemCount) {
function freeBitmapNode (line 819) | void freeBitmapNode(Value *v) {
function HashCollisionNode (line 839) | HashCollisionNode *malloc_hashCollisionNode(int itemCount) {
function freeHashCollisionNode (line 856) | void freeHashCollisionNode(Value *v) {
function ArrayNode (line 872) | ArrayNode *malloc_arrayNode() {
function freeArrayNode (line 903) | void freeArrayNode(Value *v) {
function Promise (line 916) | Promise *malloc_promise() {
function freePromise (line 950) | void freePromise(Value *v) {
function Future (line 966) | Future *malloc_future(int line) {
function freeFuture (line 1001) | void freeFuture(Value *v) {
function emptyAgent (line 1015) | void emptyAgent(Agent *agent) {
function freeAgent (line 1049) | void freeAgent(Value *v) {
function freeOpaquePtr (line 1069) | void freeOpaquePtr(Value *v) {
function dec_and_free (line 1103) | void dec_and_free(Value *v, int deltaRefs) {
function Value (line 1138) | Value *incRef(Value *v, int deltaRefs) {
function Value (line 1181) | Value *simpleIncRef(Value *v, int n) {
function moveFreeToCentral (line 1187) | void moveFreeToCentral() {
function freeGlobal (line 1211) | void freeGlobal(Value *x) {
function emptyFreeList (line 1222) | void emptyFreeList(FreeValList *freeLinkedList) {
function freeAll (line 1238) | void freeAll() {
function nakedSha1 (line 1295) | int64_t nakedSha1(Value *v1) {
function List (line 1347) | List *reverseList(List *input) {
function scheduleFuture (line 1361) | void scheduleFuture(Future *fut) {
function waitForWorkers (line 1387) | void waitForWorkers() {
function Value (line 1423) | Value *shutDown_impl(FnArity *arity) {
function stopWorkers (line 1436) | void stopWorkers() {
function Value (line 1441) | Value *readFuturesQueue() {
function Value (line 1533) | Value *deliverFuture(Value *fut, Value *val) {
function startWorkers (line 1609) | void startWorkers() {
function replaceWorker (line 1619) | void replaceWorker() {
function FnArity (line 1652) | FnArity *findFnArity(Value *fnVal, int64_t argCount) {
function isNothing (line 1670) | int8_t isNothing(Value *v, char *fileName, int lineNumber) {
function Value (line 1674) | Value *maybe(FnArity *arity, Value *arg0, Value *arg1) {
function Value (line 1680) | Value *prSTAR(Value *str) {
function Value (line 1691) | Value *defaultPrErrSTAR(Value *str) {
function Value (line 1702) | Value *add_ints(Value *arg0, Value *arg1) {
function Value (line 1709) | Value *integerValue(int64_t n) {
function Value (line 1715) | Value *integer_str(Value *arg0) {
function Value (line 1723) | Value *integer_EQ(Value *arg0, Value *arg1) {
function Value (line 1738) | Value *isInstance(Value *arg0, Value *arg1) {
function List (line 1758) | List *listCons(Value *x, List *l) {
function Vector (line 1766) | Vector *newVector(Value *array[], int indexToSkip) {
function VectorNode (line 1777) | VectorNode *newVectorNode(Value *array[], int indexToSkip) {
function Value (line 1788) | Value **arrayFor(Vector *v, unsigned index) {
function VectorNode (line 1806) | VectorNode *newPath(int level, VectorNode *node) {
function VectorNode (line 1816) | VectorNode *pushTail(unsigned count, int level, VectorNode *parent, Vect...
function Vector (line 1839) | Vector *vectConj(Vector *vect, Value *val) {
function Vector (line 1891) | Vector *mutateVectConj(Vector *vect, Value *val) {
function VectorNode (line 1936) | VectorNode *copyVectStore(int level, VectorNode *node, unsigned index, V...
function Value (line 1951) | Value *vectStore(Vector *vect, unsigned index, Value *val) {
function Value (line 1988) | Value *fastVectStore(Vector *vect, unsigned index, Value *val) {
function Value (line 2012) | Value *updateField(Value *rval, Value *field, int64_t idx) {
function Value (line 2044) | Value *vectGet(Vector *vect, unsigned index) {
function Value (line 2051) | Value *vectSeq(Vector *vect, int index) {
function Value (line 2064) | Value *vectorReverse(Value *arg0) {
function destructValue (line 2077) | void destructValue(char *fileName, char *lineNum, Value *val, int numArg...
function Value (line 2113) | Value *strEQ(Value *arg0, Value *arg1) {
function Value (line 2157) | Value *strLT(Value *arg0, Value *arg1) {
function Value (line 2218) | Value *strCount(Value *arg0) {
function Value (line 2228) | Value *strList(Value *arg0) {
function Value (line 2257) | Value *integer_LT(Value *arg0, Value *arg1) {
function Value (line 2268) | Value *checkInstance(TYPE_SIZE typeNum, Value *arg1) {
function Value (line 2283) | Value *listMap(Value *arg0, Value *f) {
function Value (line 2362) | Value *listConcat(Value *arg0) {
function Value (line 2424) | Value *car(Value *arg0) {
function Value (line 2436) | Value *cdr(Value *arg0) {
function Value (line 2450) | Value *integerLT(Value *arg0, Value *arg1) {
type SHA1_HASH (line 2467) | typedef struct
type CHAR64LONG16 (line 2472) | typedef union
function TransformFunction (line 2488) | static void TransformFunction(uint32_t state[5], const uint8_t buffer[64...
function Sha1Initialise (line 2536) | void Sha1Initialise (Sha1Context* Context) {
function Sha1Update (line 2547) | void Sha1Update (Sha1Context* Context, void* Buffer, int64_t BufferSize) {
function Sha1Finalise (line 2577) | void Sha1Finalise (Sha1Context* Context, SHA1_HASH* Digest) {
function free_sha1 (line 2599) | void free_sha1(void *ptr) {
function Value (line 2607) | Value *malloc_sha1() {
function Value (line 2617) | Value *finalize_sha1(Value *ctxt) {
function integerSha1 (line 2624) | int64_t integerSha1(Value *arg0) {
function Value (line 2637) | Value *bitAnd(Value *arg0, Value *arg1) {
function Value (line 2645) | Value *bitOr(Value *arg0, Value *arg1) {
function Value (line 2653) | Value *bitXor(Value *arg0, Value *arg1) {
function Value (line 2661) | Value *bitShiftLeft(Value *arg0, Value *arg1) {
function Value (line 2669) | Value *bitShiftRight(Value *arg0, Value *arg1) {
function Value (line 2677) | Value *bitNot(Value *arg0) {
function Value (line 2684) | Value *addIntegers(Value *arg0, Value *arg1) {
function Value (line 2691) | Value *listEQ(Value *arg0, Value *arg1) {
function equal (line 2717) | int8_t equal(Value *v1, Value *v2) {
function Value (line 2735) | Value *stringValue(char *s) {
function Value (line 2743) | Value *maybeExtract(Value *arg0) {
function Value (line 2755) | Value *fnApply(Value *arg0, Value *arg1) {
function Value (line 2920) | Value *maybeEQ(Value *arg0, Value *arg1) {
function Value (line 2949) | Value *maybeMap(Value *arg0, Value *arg1) {
function strSha1Update (line 2982) | void strSha1Update(Sha1Context *ctxt, Value *arg0) {
function strSha1 (line 3000) | int64_t strSha1(Value *arg0) {
function Value (line 3036) | Value *escapeChars(Value *arg0) {
function Value (line 3109) | Value *opaqueValue(void *ptr, Destructor *destruct) {
function Value (line 3118) | Value *subs2(Value *arg0, Value *arg1) {
function Value (line 3157) | Value *subs3(Value *arg0, Value *arg1, Value *arg2) {
function Value (line 3205) | Value *strSeq(Value *arg0) {
function Value (line 3234) | Value *dynamicCall2Arg(Value *f, Value *arg0, Value *arg1) {
function Value (line 3258) | Value *strReduce(Value *s0, Value *x1, Value *f2) {
function Value (line 3283) | Value *strVec(Value *arg0) {
function Value (line 3312) | Value *vectorGet(Value *arg0, Value *arg1) {
function Value (line 3329) | Value *symbol(Value *arg0) {
function Value (line 3353) | Value *symEQ(Value *arg0, Value *arg1) {
function Value (line 3373) | Value *symLT(Value *arg0, Value *arg1) {
function Value (line 3399) | Value *listFilter(Value *arg0, Value *arg1) {
function BitmapIndexedNode (line 3461) | BitmapIndexedNode *clone_BitmapIndexedNode(BitmapIndexedNode *node, int ...
function Value (line 3485) | Value *createNode(int shift,
function Value (line 3512) | Value *bmiHashSeq(Value *arg0, Value *arg1) {
function Value (line 3530) | Value *bmiHashVec(Value *arg0, Value *arg1) {
function Value (line 3549) | Value *bmiCount(Value *arg0) {
function Value (line 3567) | Value *bmiCopyAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t hash,...
function Value (line 3684) | Value *bmiMutateAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t has...
function Value (line 3801) | Value *bmiGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash, int ...
function Value (line 3838) | Value *bmiDissoc(Value *arg0, Value* arg1, int64_t hash, int shift) {
function Value (line 3908) | Value *arrayNodeCopyAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t...
function Value (line 3947) | Value *arrayNodeMutateAssoc(Value *arg0, Value *arg1, Value *arg2, int64...
function Value (line 3968) | Value *collisionAssoc(Value *arg0, Value *arg1, Value *arg2, int64_t has...
function Value (line 4011) | Value *arrayNodeGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash,...
function Value (line 4029) | Value *arrayNodeCount(Value *arg0) {
function Value (line 4042) | Value *collisionCount(Value *arg0) {
function Value (line 4048) | Value *collisionSeq(Value *arg0, Value *arg1) {
function Value (line 4063) | Value *collisionVec(Value *arg0, Value *arg1) {
function Value (line 4081) | Value *collisionDissoc(Value *arg0, Value *arg1, int64_t hash, int shift) {
function Value (line 4121) | Value *collisionGet(Value *arg0, Value *arg1, Value *arg2, int64_t hash,...
function Value (line 4146) | Value *arrayNodeSeq(Value *arg0, Value *arg1) {
function Value (line 4159) | Value *arrayNodeVec(Value *arg0, Value *arg1) {
function Value (line 4172) | Value *arrayNodeDissoc(Value *arg0, Value *arg1, int64_t hash, int shift) {
function Value (line 4199) | Value *get(FnArity *arity, Value *node, Value *k, Value *v, int64_t hash...
function Value (line 4213) | Value *baseDissoc(Value *node, Value *k, int64_t hash, int shift) {
function Value (line 4227) | Value *hashVec(Value *node, Value *vec) {
function Value (line 4241) | Value *copyAssoc(Value *node, Value *k, Value *v, int64_t hash, int shif...
function Value (line 4255) | Value *mutateAssoc(Value *node, Value *k, Value *v, int64_t hash, int sh...
function Value (line 4270) | Value *hashMapGet(Value *arg0, Value *arg1) {
function Value (line 4281) | Value *hashMapAssoc(Value *arg0, Value *arg1, Value *arg2) {
function Value (line 4286) | Value *dynamicCall1Arg(Value *f, Value *arg) {
function Value (line 4309) | Value *addPromiseAction(Promise *p, Value *action) {
function Value (line 4343) | Value *deliverPromise(Value *arg0, Value *arg1) {
function Value (line 4372) | Value *extractPromise(Value *arg0) {
function Value (line 4399) | Value *promiseDelivered(Value *arg0) {
function Value (line 4412) | Value *extractFuture(Value *arg0) {
function Value (line 4438) | Value *makeFuture(Value *arg0) {
function Value (line 4448) | Value *addFutureAction(Future *p, Value *action) {
function Value (line 4487) | Value *makeAgent(Value *arg0) {
function Value (line 4503) | Value *extractAgent(Value *arg0) {
function List (line 4512) | List *readAgentQueue(Agent *agent) {
function Value (line 4558) | Value *updateAgent_impl(FnArity *arity) {
function scheduleAgent (line 4575) | void scheduleAgent(Agent *agent, List *action) {
function freeExtractCache (line 4611) | void freeExtractCache(void *cachePtr) {
function freeIntGenerator (line 4624) | void freeIntGenerator(void *ptr) {
function String (line 4635) | String *nullTerm(Value *s) {
function show (line 4645) | void show(Value *v) {
function countSeq (line 4667) | int64_t countSeq(Value *seq) {
function Value (line 4674) | Value *reifiedTypeArgs(Value *x) {
function Vector (line 4691) | Vector *listVec(Value *list) {
function Value (line 4701) | Value *newTypeValue(int typeNum, Vector *fields) {
FILE: core.h
type Sha1Context (line 29) | typedef struct
type Value (line 38) | typedef struct Value {TYPE_SIZE type; REFS_SIZE refs; struct Value* next...
type Integer (line 39) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t numVal;} Integer;
type HashedValue (line 40) | typedef struct HashedValue {TYPE_SIZE type; REFS_SIZE refs; int64_t hash...
type String (line 41) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int64_t...
type SubString (line 42) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int64_t...
type List (line 43) | typedef struct List {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal;
type VectorNode (line 45) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; Value *array[VECTOR_ARRA...
type Vector (line 46) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int32_t...
type FnArity (line 48) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int count; Vector *closu...
type Function (line 50) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; char *name; int64_t arit...
type Maybe (line 51) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; Value* ...
type BitmapIndexedNode (line 52) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int32_t...
type ArrayNode (line 53) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; Value *...
type HashCollisionNode (line 54) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int16_t...
type Promise (line 55) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; Value *result; List *act...
type Future (line 57) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; Value *action; Value* er...
type Agent (line 59) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; Value *val; List* input;...
type ReifiedVal (line 61) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; int64_t hashVal; int64_t...
type Opaque (line 62) | typedef struct {TYPE_SIZE type; REFS_SIZE refs; void *ptr; Destructor *d...
type ProtoImpl (line 67) | typedef struct {TYPE_SIZE type; Value *implFn;} ProtoImpl;
type ProtoImpls (line 68) | typedef struct {int64_t implCount; ProtoImpl impls[];} ProtoImpls;
type Value (line 70) | typedef Value *(FnType0)(FnArity *);
type Value (line 71) | typedef Value *(FnType1)(FnArity *, Value *);
type Value (line 72) | typedef Value *(FnType2)(FnArity *, Value *, Value *);
type Value (line 73) | typedef Value *(FnType3)(FnArity *, Value *, Value *, Value *);
type Value (line 74) | typedef Value *(FnType4)(FnArity *, Value *, Value *, Value *, Value *);
type Value (line 75) | typedef Value *(FnType5)(FnArity *, Value *, Value *, Value *, Value *, ...
type Value (line 76) | typedef Value *(FnType6)(FnArity *, Value *, Value *, Value *, Value *, ...
type Value (line 77) | typedef Value *(FnType7)(FnArity *, Value *, Value *, Value *, Value *, ...
type Value (line 78) | typedef Value *(FnType8)(FnArity *, Value *, Value *, Value *, Value *, ...
type Value (line 79) | typedef Value *(FnType9)(FnArity *, Value *, Value *, Value *, Value *, ...
type extractCache (line 81) | typedef struct {
type intGenerator (line 85) | typedef struct {
Condensed preview — 346 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (904K chars).
[
{
"path": ".gitattributes",
"chars": 32,
"preview": "*.toc linguist-language=Clojure\n"
},
{
"path": ".gitignore",
"chars": 46,
"preview": "\n*.DS_Store\ndependencies\n*.dSYM\nbuild\ntoccata\n"
},
{
"path": "CMakeLists.txt",
"chars": 193,
"preview": "cmake_minimum_required(VERSION 3.9.4)\n\nproject(toccata)\n\nadd_definitions(-std=c99)\n\nset (CORE_LIBS pthread)\n\nadd_executa"
},
{
"path": "HISTORY.md",
"chars": 10956,
"preview": "# Rationale\n\nThe first (almost) usuable version of Toccata is finally nearing completion. By reading\nthrough the commits"
},
{
"path": "LICENSE",
"chars": 16725,
"preview": "Mozilla Public License Version 2.0\n==================================\n\n1. Definitions\n--------------\n\n1.1. \"Contributor\""
},
{
"path": "README.md",
"chars": 3459,
"preview": "Toccata\n=======\n\n> \"Pithy quote.\"\n> - Unknown\n\nAn incomplete, buggy, undocumented, Clojure-inspired Lisp dialect that c"
},
{
"path": "assertion-tests/add-items-list-1.toc",
"chars": 265,
"preview": "\n(def CrazyType (any-of List\n Vector\n Integer))\n\n(defn f [x]\n (assert (inst"
},
{
"path": "assertion-tests/add-items-list-2.toc",
"chars": 265,
"preview": "\n(def CrazyType (any-of List\n Vector\n Integer))\n\n(defn f [x]\n (assert (inst"
},
{
"path": "assertion-tests/and-constraints-1.toc",
"chars": 182,
"preview": "\n(defn foo [zs p]\n (let [mv (maybe zs)]\n (and (let [t (extract mv)]\n (maybe (inc p)))\n mv)))\n\n(mai"
},
{
"path": "assertion-tests/and-constraints-2.toc",
"chars": 227,
"preview": "\n(defn foo [zs p]\n (let [mv (maybe zs)\n p (str p)]\n (and mv\n (let [t (extract mv)]\n (maybe "
},
{
"path": "assertion-tests/apply-constructor.toc",
"chars": 164,
"preview": "\n\n(deftype Popper [x y]\n (assert (instance? Symbol x))\n (assert (instance? Integer y)))\n\n(defn g [& vs]\n (apply Poppe"
},
{
"path": "assertion-tests/bad-add.toc",
"chars": 48,
"preview": "\n(def a \"z\")\n(def b 's)\n\n(main [_]\n (+ 8 b a))\n"
},
{
"path": "assertion-tests/bad-and-1.toc",
"chars": 80,
"preview": "\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",
"chars": 84,
"preview": "\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",
"chars": 592,
"preview": "(defn add-commas [x-str]\n (assert (instance? String x-str))\n (assert-result l (instance? List l))\n\n (let [prefix-len "
},
{
"path": "assertion-tests/bad-apply-constructor.toc",
"chars": 146,
"preview": "\n(deftype Bogus [a b c]\n Stringable\n (string-list [_]\n (list \"<BC \" (str a) \" \" (str b) \" \" (str c) \">\")))\n\n(main ["
},
{
"path": "assertion-tests/bad-arity-1.toc",
"chars": 51,
"preview": "\n\n(defn bad [a b]\n a)\n\n(main [_]\n (bad \"Bogus\"))\n"
},
{
"path": "assertion-tests/bad-constructor-call.toc",
"chars": 166,
"preview": "\n(deftype AnotherType [x z]\n Stringable\n (string-list [_] (list \"<AnotherType \" (str z) \">\")))\n\n(def boomer (AnotherTy"
},
{
"path": "assertion-tests/bad-constructor-param-1.toc",
"chars": 182,
"preview": "\n(deftype Boogie [xs]\n (assert (instance? (vector-of Integer) xs))\n\n Stringable\n (string-list [_]\n (list \"Boogie \""
},
{
"path": "assertion-tests/bad-constructor-param-2.toc",
"chars": 402,
"preview": "\n(defprotocol Pookie\n (pook [_]\n (assert-result r (instance? (list-of (any-of StringBuffer\n "
},
{
"path": "assertion-tests/bad-dipatch-type.toc",
"chars": 168,
"preview": "\n(defprotocol BogusProto\n (bogus [x]\n (assert (instance? String x))))\n\n(deftype BogusType [y]\n BogusProto\n (bogus "
},
{
"path": "assertion-tests/bad-enum-1.toc",
"chars": 115,
"preview": "\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",
"chars": 121,
"preview": "\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))"
},
{
"path": "assertion-tests/bad-enum-3.toc",
"chars": 139,
"preview": "\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"
},
{
"path": "assertion-tests/bad-enum-4.toc",
"chars": 121,
"preview": "\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))"
},
{
"path": "assertion-tests/bad-field-1.toc",
"chars": 94,
"preview": "\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",
"chars": 208,
"preview": "\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?"
},
{
"path": "assertion-tests/bad-field-3.toc",
"chars": 208,
"preview": "\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?"
},
{
"path": "assertion-tests/bad-field-4.toc",
"chars": 123,
"preview": "\n(deftype Ooops [not-there])\n\n(deftype Bogus [x-field])\n\n(main [_]\n (-> (Bogus 99)\n (.x-field 3)\n .not-there"
},
{
"path": "assertion-tests/bad-field-5.toc",
"chars": 137,
"preview": "\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 "
},
{
"path": "assertion-tests/bad-flat-map-inner.toc",
"chars": 151,
"preview": "\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)"
},
{
"path": "assertion-tests/bad-function-returns-1.toc",
"chars": 453,
"preview": "\n\n(deftype Failure [])\n\n(deftype new-se [invoke-fn]\n ;; (assert (instance? Fn invoke-fn))\n (assert (instance? (functio"
},
{
"path": "assertion-tests/bad-function-returns-2.toc",
"chars": 1042,
"preview": "\n(deftype Failure [])\n\n(deftype new-se [invoke-fn]\n ;; (assert (instance? Fn invoke-fn))\n (assert (instance? (function"
},
{
"path": "assertion-tests/bad-impl-arity.toc",
"chars": 30,
"preview": "\n\n(main [_]\n (take \"Bogus\"))\n"
},
{
"path": "assertion-tests/bad-impl-return-value.toc",
"chars": 267,
"preview": "\n(defprotocol Proto\n (some-getter [tc]\n (assert-result r (instance? (maybe-of Symbol) r))\n\n nothing))\n\n(deftype K"
},
{
"path": "assertion-tests/bad-inline-result-type.toc",
"chars": 98,
"preview": "\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",
"chars": 86,
"preview": "\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",
"chars": 143,
"preview": "\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 "
},
{
"path": "assertion-tests/bad-inner-11.toc",
"chars": 102,
"preview": "\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",
"chars": 100,
"preview": "\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",
"chars": 88,
"preview": "\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",
"chars": 99,
"preview": "\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",
"chars": 55,
"preview": "\n(main [_]\n (-> (maybe \"1\")\n extract\n inc))\n"
},
{
"path": "assertion-tests/bad-inner-16.toc",
"chars": 309,
"preview": "\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"
},
{
"path": "assertion-tests/bad-inner-2.toc",
"chars": 100,
"preview": "\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",
"chars": 135,
"preview": "\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 (prin"
},
{
"path": "assertion-tests/bad-inner-4.toc",
"chars": 130,
"preview": "\n(main [_]\n (-> [1 2 3]\n (map inc)\n (drop-while (fn [n]\n (= \"\" (subs n 1)))))\n (print-err"
},
{
"path": "assertion-tests/bad-inner-5.toc",
"chars": 132,
"preview": "\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-e"
},
{
"path": "assertion-tests/bad-inner-6.toc",
"chars": 117,
"preview": "\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",
"chars": 141,
"preview": "\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 \"bo"
},
{
"path": "assertion-tests/bad-inner-8.toc",
"chars": 112,
"preview": "\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",
"chars": 115,
"preview": "\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",
"chars": 146,
"preview": "\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 [_"
},
{
"path": "assertion-tests/bad-let.toc",
"chars": 125,
"preview": "\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 'do"
},
{
"path": "assertion-tests/bad-list-of-1.toc",
"chars": 326,
"preview": "\n(defprotocol TestListOf\n (returns-list-of-string [x]\n (assert-result x (instance? (list-of String) x))))\n\n(deftype "
},
{
"path": "assertion-tests/bad-nested-let.toc",
"chars": 181,
"preview": "\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"
},
{
"path": "assertion-tests/bad-or-1.toc",
"chars": 148,
"preview": "\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 "
},
{
"path": "assertion-tests/bad-or-2.toc",
"chars": 101,
"preview": "\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",
"chars": 244,
"preview": "\n(defprotocol Proto\n (proto-fn [_]\n (assert-result r (instance? (maybe-of Integer) r))))\n\n(deftype IC [x]\n Proto\n "
},
{
"path": "assertion-tests/bad-return-value.toc",
"chars": 497,
"preview": "\n;; TODO: the path on the error generated is incomplete\n\n(defprotocol C\n (eic [_]\n (assert-result r (instance? Vecto"
},
{
"path": "assertion-tests/bad-setter-call-1.toc",
"chars": 257,
"preview": "\n(deftype Bogus [x]\n Stringable\n (string-list [_]\n (list \"Bogus\" x)))\n\n(deftype Boogie [xs]\n (assert (instance? (v"
},
{
"path": "assertion-tests/bad-setter-call-2.toc",
"chars": 403,
"preview": "\n(defprotocol Pookie\n (pook [_]\n (assert-result r (instance? (list-of (any-of StringBuffer\n "
},
{
"path": "assertion-tests/bad-state-maybe-value-1.toc",
"chars": 1193,
"preview": "\n(deftype new-sm [invoke-fn]\n Stringable\n (string-list [x]\n (comp (list \"<new-sm \")\n (string-list (.invoke"
},
{
"path": "assertion-tests/bad-state-maybe-value-2.toc",
"chars": 1129,
"preview": "\n(deftype new-sm [invoke-fn]\n Stringable\n (string-list [x]\n (comp (list \"<new-sm \")\n (string-list (.invoke"
},
{
"path": "assertion-tests/bad-type-comp.toc",
"chars": 293,
"preview": "\n(deftype Type1 [int]\n Stringable\n (string-list [_] (list (str int))))\n\n(deftype Type2 [int]\n Stringable\n (string-li"
},
{
"path": "assertion-tests/bad-vector-of-1.toc",
"chars": 137,
"preview": "\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"
},
{
"path": "assertion-tests/checked-map-1.toc",
"chars": 127,
"preview": "\n(main [_]\n (let [m {}]\n (assert (instance? (map-of String Integer) m))\n (assoc m \"bogus\" 'bogus)\n (println 'd"
},
{
"path": "assertion-tests/checked-map-2.toc",
"chars": 127,
"preview": "\n(main [_]\n (let [m {}]\n (assert (instance? (map-of Integer Symbol) m))\n (assoc m \"bogus\" 'bogus)\n (println 'd"
},
{
"path": "assertion-tests/closure-1.toc",
"chars": 235,
"preview": "\n(defn foo [zs p]\n (flat-map (list zs)\n (fn [t]\n (list (subs p 1))))\n (flat-map (list zs)\n "
},
{
"path": "assertion-tests/closure-2.toc",
"chars": 159,
"preview": "\n(defn foo [zs p]\n (flat-map (list zs)\n (fn [t]\n (list (inc p)))))\n\n(main [_]\n (println (f"
},
{
"path": "assertion-tests/closure-constraint.toc",
"chars": 345,
"preview": "\n(defprotocol Boomer\n (boom [_ y]\n (print-err 'booooom)\n (abort)))\n\n(deftype Dummy [nope])\n\n(deftype Slider []\n "
},
{
"path": "assertion-tests/closure-param.toc",
"chars": 127,
"preview": "\n(main [_]\n (let [x 8\n f (fn [z]\n (+ x z))]\n (println (f \"100\")))\n (println '"
},
{
"path": "assertion-tests/comp-bad-type-1.toc",
"chars": 95,
"preview": "\n(def BadType (any-of NoType\n List))\n\n(main [_]\n (println \"FAIL!!!\"))\n"
},
{
"path": "assertion-tests/comp-bad-type-2.toc",
"chars": 95,
"preview": "\n(def BadType (any-of List\n NoType))\n\n(main [_]\n (println \"FAIL!!!\"))\n"
},
{
"path": "assertion-tests/conj-to-getter-result-1.toc",
"chars": 194,
"preview": "\n(deftype Boogie [xs]\n (assert (instance? (vector-of Integer) xs))\n\n Stringable\n (string-list [_]\n (list \"Boogie \""
},
{
"path": "assertion-tests/conj-to-getter-result-2.toc",
"chars": 458,
"preview": "\n(defprotocol Pookie\n (pook [_]\n (assert-result r (instance? (list-of (any-of StringBuffer\n "
},
{
"path": "assertion-tests/constructor-param-1.toc",
"chars": 133,
"preview": "\n(deftype SomeType [a b]\n (assert (instance? Symbol a))\n (assert (instance? String b)))\n\n(main [_]\n (SomeType (str 's"
},
{
"path": "assertion-tests/constructor-param-2.toc",
"chars": 155,
"preview": "\n(deftype SomeType [a b]\n (assert (instance? Symbol a))\n (assert (instance? String b)))\n\n(defn f [x]\n (SomeType x \"9\""
},
{
"path": "assertion-tests/constructor-param-3.toc",
"chars": 153,
"preview": "\n(deftype SomeType [a b]\n (assert (instance? (min-count 1) a))\n (assert (instance? String b)))\n\n(defn f [xs]\n (SomeTy"
},
{
"path": "assertion-tests/contents-2.toc",
"chars": 94,
"preview": "\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",
"chars": 200,
"preview": "\n(defn g []\n [\"str\"])\n\n(defn f [x]\n (assert (instance? Integer x))\n (assert-result r (instance? (vector-of String) r)"
},
{
"path": "assertion-tests/deeply-nested-vector-2.toc",
"chars": 226,
"preview": "\n(defn f [x]\n (assert (instance? Integer x))\n (assert-result r (instance? (vector-of String) r))\n\n TODO: this test ne"
},
{
"path": "assertion-tests/destruct-variadic-tail-2.toc",
"chars": 228,
"preview": "\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"
},
{
"path": "assertion-tests/dup-protocol-name.toc",
"chars": 154,
"preview": "\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("
},
{
"path": "assertion-tests/dynamic-call-1.toc",
"chars": 515,
"preview": "\n(deftype nougie [invoke-fn]\n (assert (instance? Fn invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"<noug"
},
{
"path": "assertion-tests/dynamic-call-2.toc",
"chars": 103,
"preview": "\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",
"chars": 142,
"preview": "\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(ma"
},
{
"path": "assertion-tests/dynamic-call-4.toc",
"chars": 516,
"preview": "\n(deftype nougie [invoke-fn]\n (assert (instance? Fn invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"<noug"
},
{
"path": "assertion-tests/dynamic-call-5.toc",
"chars": 229,
"preview": "\nTODO: Detecting this error will require a much different technique\nProbably build a function to be executed at the call"
},
{
"path": "assertion-tests/dynamic-call-6.toc",
"chars": 239,
"preview": "\nTODO: Detecting this error will require a much different technique\nProbably build a function to be executed at the call"
},
{
"path": "assertion-tests/dynamic-call-7.toc",
"chars": 155,
"preview": "\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)"
},
{
"path": "assertion-tests/dynamic-call-8.toc",
"chars": 514,
"preview": "\n(deftype nougie [invoke-fn]\n (assert (instance? Fn invoke-fn))\n\n Stringable\n (string-list [x]\n (comp (list \"<noug"
},
{
"path": "assertion-tests/dynamic-field-type-1.toc",
"chars": 77,
"preview": "\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",
"chars": 122,
"preview": "\n(deftype AType [x])\n\nTODO: re-enable this test eventually\n(main [_]\n (-> (AType 9)\n (.x 'x)\n .x\n (inc))"
},
{
"path": "assertion-tests/dynamic-nested-value-1.toc",
"chars": 194,
"preview": "\n\n(defn g [_ x]\n (maybe [x]))\n\n(main [_]\n (map (either (g 'nope 'bogus)\n ;; TODO: this should cause an a"
},
{
"path": "assertion-tests/dynamic-proto-param-1.toc",
"chars": 132,
"preview": "\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 9"
},
{
"path": "assertion-tests/empty-defn.toc",
"chars": 51,
"preview": "\n(defn f []\n )\n\n(main [_]\n (println \"FAIL\"))\n"
},
{
"path": "assertion-tests/field-and-seq-conflict.toc",
"chars": 135,
"preview": "\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 (prin"
},
{
"path": "assertion-tests/field-constraint.toc",
"chars": 163,
"preview": "\n(defprotocol Proto\n (proto-f [_]))\n\n(deftype Bogus [x]\n (assert (instance? Integer x))\n\n Proto\n (proto-f [_]\n (s"
},
{
"path": "assertion-tests/field-shadow.toc",
"chars": 291,
"preview": "\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 (pri"
},
{
"path": "assertion-tests/flat-map-param.toc",
"chars": 694,
"preview": "\n(deftype and-ast [clauses]\n (assert (instance? Vector clauses))\n\n Stringable\n (string-list [_]\n (comp (list \"<And"
},
{
"path": "assertion-tests/impl-violates-proto.toc",
"chars": 313,
"preview": "\n(deftype FirstType [x y])\n\n(deftype SecondType [x])\n\n(defprotocol Proto\n (proto-fn [a b]\n (assert (instance? Second"
},
{
"path": "assertion-tests/incompatible-tails.toc",
"chars": 301,
"preview": "\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"
},
{
"path": "assertion-tests/init-type.toc",
"chars": 163,
"preview": "\n(def ints [1 2 3])\n\n(def ints (-> ints\n (reverse)\n (take 2)\n (map inc)))\n\n(defn "
},
{
"path": "assertion-tests/insufficient-static-elements-1.toc",
"chars": 50,
"preview": "\n(defn f [[a b]]\n (inc a))\n\n(main [_]\n (f [9]))\n"
},
{
"path": "assertion-tests/insufficient-static-elements-2.toc",
"chars": 80,
"preview": "\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",
"chars": 85,
"preview": "\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",
"chars": 89,
"preview": "\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",
"chars": 123,
"preview": "\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"
},
{
"path": "assertion-tests/items-constraints-1.toc",
"chars": 66,
"preview": "\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",
"chars": 69,
"preview": "\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",
"chars": 87,
"preview": "\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",
"chars": 130,
"preview": "\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 {} "
},
{
"path": "assertion-tests/list-items-types.toc",
"chars": 61,
"preview": "\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",
"chars": 128,
"preview": "\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-er"
},
{
"path": "assertion-tests/literal-hash-map-2.toc",
"chars": 129,
"preview": "\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-e"
},
{
"path": "assertion-tests/min-count.toc",
"chars": 73,
"preview": "\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",
"chars": 61,
"preview": "\n(def puke \"puke\")\n\n(main [_]\n (println 'puke ll/puke))\n"
},
{
"path": "assertion-tests/multi-constraint-violated.toc",
"chars": 224,
"preview": "\n(def Bands (all-of Integer\n (min 4)\n (max 8)))\n\n(defn pr-bands [n]\n (assert (insta"
},
{
"path": "assertion-tests/nested-destruct-1.toc",
"chars": 157,
"preview": "\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 "
},
{
"path": "assertion-tests/nested-destruct-2.toc",
"chars": 170,
"preview": "\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"
},
{
"path": "assertion-tests/nested-destruct.toc",
"chars": 128,
"preview": "\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]"
},
{
"path": "assertion-tests/nested-items-conflict.toc",
"chars": 122,
"preview": "\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)"
},
{
"path": "assertion-tests/or-prop.toc",
"chars": 446,
"preview": "\n(def SomeVal (any-of Integer\n String))\n\n(defn f [x y]\n (assert (instance? SomeVal x))\n (or (and ("
},
{
"path": "assertion-tests/param-in-and.toc",
"chars": 72,
"preview": "\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",
"chars": 70,
"preview": "\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",
"chars": 31,
"preview": "\n(main [_]\n (partial subs 8))\n"
},
{
"path": "assertion-tests/preserve-asserts.toc",
"chars": 276,
"preview": "\n(deftype Checked [m]\n (assert (instance? HashMap m))\n\n Associative\n (assoc [_ k v]\n (assert (instance? HashSet v)"
},
{
"path": "assertion-tests/preserve-static-info-1.toc.test",
"chars": 183,
"preview": "\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"
},
{
"path": "assertion-tests/preserve-static-info-2.toc.test",
"chars": 236,
"preview": "\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 "
},
{
"path": "assertion-tests/preserve-static-info-3.toc.test",
"chars": 261,
"preview": "\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 "
},
{
"path": "assertion-tests/propogate-inner-1.toc",
"chars": 112,
"preview": "\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",
"chars": 129,
"preview": "\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}"
},
{
"path": "assertion-tests/propogate-through-let.toc",
"chars": 68,
"preview": "\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",
"chars": 47,
"preview": "\n(main [_]\n (map (seq (vector 'a 'b 2)) inc))\n"
},
{
"path": "assertion-tests/propogate-through-vec.toc",
"chars": 45,
"preview": "\n(main [_]\n (map (vec (list 'a 'b 2)) inc))\n"
},
{
"path": "assertion-tests/proto-fn-constraint-prop.toc",
"chars": 154,
"preview": "\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 [_"
},
{
"path": "assertion-tests/proto-fn-min-count.toc",
"chars": 183,
"preview": "\n(defprotocol TempProto\n (bogus [z u]\n (assert (instance? (min-count 2) u))))\n\n(deftype Bogus [s]\n TempProto\n (bog"
},
{
"path": "assertion-tests/proto-fn-param.toc",
"chars": 32,
"preview": "\n(main [_]\n (nth [1 2 3] \"2\"))\n"
},
{
"path": "assertion-tests/restrict-conflict.toc",
"chars": 552,
"preview": "\n(deftype OneType [x]\n Stringable\n (string-list [_] (list \"<OneType \" (str x) \">\")))\n\n(deftype AnotherType [x z]\n Str"
},
{
"path": "assertion-tests/restrict-nested-item.toc",
"chars": 485,
"preview": "\n(deftype OneType [x]\n Stringable\n (string-list [_] (list \"<OneType \" (str x) \">\")))\n\n(deftype AnotherType [x z]\n Str"
},
{
"path": "assertion-tests/restrict-param.toc",
"chars": 440,
"preview": "\n(deftype OneType [x]\n Stringable\n (string-list [_] (list \"<OneType \" (str x) \">\")))\n\n(deftype AnotherType [x z]\n Str"
},
{
"path": "assertion-tests/return-bad-type.toc",
"chars": 208,
"preview": "\n(defprotocol SomeProto\n (f [x]\n (assert-result l (instance? List l))))\n\n(deftype SomeType [x]\n SomeProto\n (f [y]\n"
},
{
"path": "assertion-tests/return-generic-1.toc",
"chars": 117,
"preview": "\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",
"chars": 205,
"preview": "\n(defprotocol BProt\n (bloop [_ z]\n (assert-result r (instance? (list-of Integer) r))))\n\n(deftype Bogus [x]\n BProt\n "
},
{
"path": "assertion-tests/return-list-of-2.toc",
"chars": 241,
"preview": "\n(defprotocol BProt\n (bloop [_]\n (assert-result r (instance? (list-of Integer) r))))\n\n(deftype Bogus [x]\n Stringabl"
},
{
"path": "assertion-tests/return-sum-type.toc",
"chars": 105,
"preview": "\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",
"chars": 94,
"preview": "\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",
"chars": 75,
"preview": "\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",
"chars": 160,
"preview": "\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"
},
{
"path": "assertion-tests/unkown-field.toc",
"chars": 147,
"preview": "\n(deftype Bogus [int]\n (assert (instance? Integer string))\n\n Stringable\n (string-list [_] (list (str int))))\n\n(main ["
},
{
"path": "assertion-tests/update-field-1.toc",
"chars": 254,
"preview": "\n(deftype SomeType [x y]\n (assert (instance? String x))\n (assert (instance? Integer y))\n \n Stringable\n (string-list"
},
{
"path": "assertion-tests/variadic-constraints.toc",
"chars": 57,
"preview": "\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",
"chars": 62,
"preview": "\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",
"chars": 166,
"preview": "\n(main [_]\n (let [a 'bogus\n f (fn [x y & t]\n (println a x))]\n (print-err \"Line num"
},
{
"path": "assertion-tests/vect-len.toc",
"chars": 142,
"preview": "\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 "
},
{
"path": "bin/build-toccata.sh",
"chars": 223,
"preview": "#! /bin/sh\n\nTOCCATA_DIR=\"$(cd -P -- $(dirname -- $0)/../ && pwd)\"\n\nclang -g \\\n -v \\\n -fno-objc-arc \\\n -o toccata \\\n "
},
{
"path": "bin/toccata.sh",
"chars": 229,
"preview": "#! /bin/sh\n\nexport TOCCATA_DIR=\"$(cd -P -- $(dirname -- $0)/../ && pwd)\"\nPATH=$PATH:$TOCCATA_DIR\n\nusage() {\n echo \"Us"
},
{
"path": "core.c",
"chars": 144074,
"preview": "\n#include <stdlib.h>\n#include <stdatomic.h>\n#include \"core.h\"\n\nREFS_SIZE refsInit = 1;\nREFS_SIZE refsError = -10;\nREFS_S"
},
{
"path": "core.h",
"chars": 12679,
"preview": "\n#include <sys/types.h>\n#include <stdio.h>\n#include <string.h>\n#include <pthread.h>\n#include <stdint.h>\n#include <inttyp"
},
{
"path": "core.toc",
"chars": 73909,
"preview": "\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 sym"
},
{
"path": "ebnf.md",
"chars": 6850,
"preview": "\nlinear-whitespace = ',' | ' ' | '\\t';\n\nnewline = '\\n';\n\nwhitespace = linear-whitespace | '\\r' | newline;\n\nopen-paren = "
},
{
"path": "em-run",
"chars": 607,
"preview": "#!/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\"; "
},
{
"path": "examples/apply-maybe.toc",
"chars": 215,
"preview": "\n(main [_]\n (println \"apply '+':\" (apply (maybe +) (maybe 3) (maybe 4)))\n (let [x 3]\n (println \"apply-to '+':\" (app"
},
{
"path": "examples/apply-vector.toc",
"chars": 295,
"preview": "\n(main [_]\n (println \"apply-to []:\" (apply-to inc []))\n (println \"map [1 2 3]:\" (map [1 2 3] inc))\n (println \"apply-t"
},
{
"path": "examples/config-file.toc",
"chars": 2431,
"preview": "\n(add-ns rd (git-dependency \"https://github.com/Toccata-Lang/recursive-descent.git\"\n \"recursiv"
},
{
"path": "examples/debugging.toc",
"chars": 130,
"preview": "\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"
},
{
"path": "examples/flat-map-list.toc",
"chars": 659,
"preview": "\n(main [_]\n (println (map (list 15 99 24)\n (fn [x]\n (list (inc x)))))\n (println \"flat-"
},
{
"path": "examples/flat-map-maybe.toc",
"chars": 689,
"preview": "\n(main [_]\n (println (first (list 15 99 24)))\n (println (map (first (list 15 99 24))\n (fn [x]\n "
},
{
"path": "examples/greeting.toc",
"chars": 574,
"preview": "\n(def greetings {\"Jim\" \"Howdy\"\n \"Frank\" \"Hello\"\n \"Maria\" \"Bonjour\"\n \"Tina\" "
},
{
"path": "examples/howdy.toc",
"chars": 103,
"preview": "\n(main [args]\n (println \"Howdy,\" (either (second args)\n \"Folks\")))\n"
},
{
"path": "examples/json-ebnf.toc",
"chars": 303,
"preview": "\n;; A simple (and not quite complete) JSON parser\n\n(add-ns ebnf (git-dependency \"https://github.com/Toccata-Lang/ebnf.gi"
},
{
"path": "examples/json-graph.toc",
"chars": 254,
"preview": "\n(add-ns gg (git-dependency \"https://github.com/Toccata-Lang/grammar-graph.git\"\n \"grammar-grap"
},
{
"path": "examples/json-parser.toc",
"chars": 932,
"preview": "\n(add-ns rd (git-dependency \"https://github.com/Toccata-Lang/recursive-descent.git\"\n \"recursiv"
},
{
"path": "examples/json.toc",
"chars": 4786,
"preview": "\n;; A simple (and not quite complete) JSON parser\n\n(add-ns grmr (git-dependency \"https://github.com/Toccata-Lang/grammar"
},
{
"path": "examples/map-maybe.toc",
"chars": 116,
"preview": "\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",
"chars": 56,
"preview": "\n(main [_]\n (println \"map vector:\" (map [1 2 3] inc)))\n"
},
{
"path": "examples/number-option.toc",
"chars": 1150,
"preview": "(add-ns rd (git-dependency \"https://github.com/Toccata-Lang/recursive-descent.git\"\n \"recursive"
},
{
"path": "examples/tictactoe.toc",
"chars": 8756,
"preview": "\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:"
},
{
"path": "foundry/docker/Development.docker",
"chars": 1416,
"preview": "FROM debian:stretch\n\nRUN apt-get update \\\n && apt-get install -y --no-install-recommends \\\n ca-certificates \\\n"
},
{
"path": "foundry/docker/README.md",
"chars": 1401,
"preview": "# Docker Build\n\nThis folder allows you to build Toccata in a container. The Dockerfile contains instructions to set up a"
},
{
"path": "foundry/docker/bashrc",
"chars": 105,
"preview": "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",
"chars": 71,
"preview": "#! /bin/bash\ndocker build -t toccata-devenv -f Development.docker ../.."
},
{
"path": "foundry/docker/build-devenv.cmd",
"chars": 58,
"preview": "docker build -t toccata-devenv -f Development.docker ../.."
},
{
"path": "foundry/docker/enter-dev",
"chars": 67,
"preview": "#! /bin/bash\ndocker run -it --rm --name toccata-dev toccata-devenv\n"
},
{
"path": "foundry/docker/enter-dev.cmd",
"chars": 54,
"preview": "docker run -it --rm --name toccata-dev toccata-devenv\n"
},
{
"path": "interpreter-tests/abort-memory-leak.toc",
"chars": 23,
"preview": "\n(defn f []\n (abort))\n"
},
{
"path": "interpreter-tests/bad-and-clause-type-1.toc",
"chars": 24,
"preview": "\n(and (maybe 3)\n 3)\n"
},
{
"path": "interpreter-tests/bad-apply-arg-1.toc",
"chars": 32,
"preview": "\n(main [_]\n (ev/test-apply 'x))"
},
{
"path": "interpreter-tests/bad-apply-arg-2.toc",
"chars": 34,
"preview": "\n(defn f [_]\n (ev/test-apply 'x))"
},
{
"path": "interpreter-tests/bad-constructor-arg-1.toc",
"chars": 33,
"preview": "\n(defn f2 []\n (HashSet 'bogus))\n"
},
{
"path": "interpreter-tests/bad-constructor-arg-2.toc",
"chars": 30,
"preview": "\n(main []\n (HashSet 'bogus))\n"
},
{
"path": "interpreter-tests/bad-default-proto-param.toc",
"chars": 23,
"preview": "\n\n(ev/test-proto 9 10)\n"
},
{
"path": "interpreter-tests/bad-field-1.toc",
"chars": 44,
"preview": "\n(main [_]\n (print-err (.k (HashSet {}))))\n"
},
{
"path": "interpreter-tests/bad-field-2.toc",
"chars": 46,
"preview": "\n(defn f [_]\n (print-err (.k (HashSet {}))))\n"
},
{
"path": "interpreter-tests/bad-proto-impl-param-const.toc",
"chars": 122,
"preview": "\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!!!!!\")"
},
{
"path": "interpreter-tests/bad-proto-param.toc",
"chars": 25,
"preview": "\n(test-proto {'a 1} \"8\")\n"
},
{
"path": "interpreter-tests/bad-proto-return-type.toc",
"chars": 155,
"preview": "\n\n(deftype Bogus [x]\n Stringable\n (string-list [_]\n (subs x 1)))\n\n(main [_]\n (print-err 'bo (string-list (Bogus \"b"
},
{
"path": "interpreter-tests/bad-reify-arg-1.toc",
"chars": 33,
"preview": "\n(main [_]\n (ev/test-invoke 'x))"
},
{
"path": "interpreter-tests/bad-reify-arg-2.toc",
"chars": 35,
"preview": "\n(defn f [_]\n (ev/test-invoke 'x))"
}
]
// ... and 146 more files (download for full content)
About this extraction
This page contains the full source code of the Toccata-Lang/toccata GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 346 files (26.4 MB), approximately 227.2k tokens, and a symbol index with 221 extracted functions, classes, methods, constants, and types. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.