├── .gitattributes ├── .github └── workflows │ ├── test-debian-clang.yml │ ├── test-debian-gcc.yml │ ├── test-debian-tcc.yml │ └── test-macos-clang.yml ├── LICENSE ├── Makefile ├── README.md ├── examples ├── fib.cog ├── fizzbuzz.cog ├── hanoi.cog ├── hello.cog └── prime.cog ├── screenshots ├── fizzbuzz.png ├── hanoi.png ├── prime.png └── square.png ├── src ├── builtins.c ├── cognac.c ├── cognac.h ├── lexer.l ├── parser.y ├── prelude.cog └── runtime.h └── tests ├── ack.cog ├── begin.cog ├── block.cog ├── booleans.cog ├── box.cog ├── dispatch.cog ├── fib.cog ├── filter.cog ├── fizzbuzz.cog ├── for.cog ├── functions.cog ├── hanoi.cog ├── if.cog ├── io.cog ├── io.txt ├── lists.cog ├── map.cog ├── maths.cog ├── other-math.cog ├── overloading.cog ├── parsing.cog ├── prime.cog ├── prime2.cog ├── regex.cog ├── stack.cog ├── stop-begin.cog ├── stop.cog ├── strings.cog ├── symbols.cog ├── table.cog ├── trig.cog └── variables.cog /.gitattributes: -------------------------------------------------------------------------------- 1 | lexer.c linguist-generated 2 | lexer.l linguist-language=Flex 3 | parser.h linguist-generated 4 | parser.c linguist-generated 5 | parser.y linguist-language=Bison 6 | -------------------------------------------------------------------------------- /.github/workflows/test-debian-clang.yml: -------------------------------------------------------------------------------- 1 | name: Debian (clang) 2 | on: 3 | push: 4 | branches: 5 | - "**" 6 | pull_request: 7 | branches: 8 | - "**" 9 | workflow_dispatch: 10 | jobs: 11 | tests: 12 | runs-on: ubuntu-24.04 13 | if: "!contains(github.event.head_commit.message, '[skip ci]')" 14 | steps: 15 | - uses: actions/checkout@v2 16 | - name: Aquire dependencies and compile 17 | shell: bash 18 | run: | 19 | sudo apt install clang -y 20 | cd $GITHUB_WORKSPACE 21 | make CC=clang 22 | - name: Run test script 23 | shell: bash 24 | run: | 25 | cd $GITHUB_WORKSPACE 26 | make test -j8 27 | - name: Upload test output 28 | if: failure() 29 | uses: actions/upload-artifact@v4 30 | with: 31 | name: tests-debian-clang 32 | path: tests/*.* 33 | -------------------------------------------------------------------------------- /.github/workflows/test-debian-gcc.yml: -------------------------------------------------------------------------------- 1 | name: Debian (gcc) 2 | on: 3 | push: 4 | branches: 5 | - "**" 6 | pull_request: 7 | branches: 8 | - "**" 9 | workflow_dispatch: 10 | jobs: 11 | tests: 12 | runs-on: ubuntu-24.04 13 | if: "!contains(github.event.head_commit.message, '[skip ci]')" 14 | steps: 15 | - uses: actions/checkout@v2 16 | - name: Aquire dependencies and compile 17 | shell: bash 18 | run: | 19 | cd $GITHUB_WORKSPACE 20 | make CC=gcc 21 | - name: Run test script 22 | shell: bash 23 | run: | 24 | cd $GITHUB_WORKSPACE 25 | make test -j8 26 | - name: Upload test output 27 | if: failure() 28 | uses: actions/upload-artifact@v4 29 | with: 30 | name: tests-debian-gcc 31 | path: tests/*.* 32 | -------------------------------------------------------------------------------- /.github/workflows/test-debian-tcc.yml: -------------------------------------------------------------------------------- 1 | name: Debian (tcc) 2 | on: 3 | push: 4 | branches: 5 | - "**" 6 | pull_request: 7 | branches: 8 | - "**" 9 | workflow_dispatch: 10 | jobs: 11 | tests: 12 | runs-on: ubuntu-latest 13 | if: "!contains(github.event.head_commit.message, '[skip ci]')" 14 | steps: 15 | - uses: actions/checkout@v2 16 | - name: Aquire dependencies and compile 17 | shell: bash 18 | run: | 19 | sudo apt install tcc -y 20 | cd $GITHUB_WORKSPACE 21 | make CC=tcc 22 | - name: Run test script 23 | shell: bash 24 | run: | 25 | cd $GITHUB_WORKSPACE 26 | make test -j8 27 | - name: Upload test output 28 | if: failure() 29 | uses: actions/upload-artifact@v4 30 | with: 31 | name: tests-debian-tcc 32 | path: tests/*.* 33 | -------------------------------------------------------------------------------- /.github/workflows/test-macos-clang.yml: -------------------------------------------------------------------------------- 1 | name: MacOS (clang) 2 | on: 3 | push: 4 | branches: 5 | - "**" 6 | pull_request: 7 | branches: 8 | - "**" 9 | workflow_dispatch: 10 | jobs: 11 | tests: 12 | runs-on: macOS-latest 13 | if: "!contains(github.event.head_commit.message, '[skip ci]')" 14 | steps: 15 | - uses: actions/checkout@v2 16 | - name: Aquire dependencies and compile 17 | shell: bash 18 | run: | 19 | cd $GITHUB_WORKSPACE 20 | brew install llvm@16 21 | export PATH="/opt/homebrew/opt/llvm@16/bin:$PATH" 22 | export LDFLAGS="-L/opt/homebrew/opt/llvm@16/lib" 23 | export CPPFLAGS="-I/opt/homebrew/opt/llvm@16/include" 24 | clang --version 25 | make CC=clang 26 | - name: Run test script 27 | shell: bash 28 | run: | 29 | cd $GITHUB_WORKSPACE 30 | export PATH="/opt/homebrew/opt/llvm@16/bin:$PATH" 31 | export LDFLAGS="-L/opt/homebrew/opt/llvm@16/lib" 32 | export CPPFLAGS="-I/opt/homebrew/opt/llvm@16/include" 33 | clang --version 34 | make test -j8 35 | - name: Upload test output 36 | if: failure() 37 | uses: actions/upload-artifact@v4 38 | with: 39 | name: tests-macOS-clang 40 | path: tests/*.* 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2020, Finn Barber 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | CC=cc 2 | CFLAGS=-Og -ggdb3 -g -rdynamic -Wall -Wpedantic 3 | PREFIX=`echo ~`/.local 4 | BINDIR=$(PREFIX)/bin 5 | TESTS=$(basename $(wildcard tests/*.cog)) 6 | 7 | cognac: src/cognac.h src/cognac.c src/parser.c src/parser.h src/lexer.c src/runtime_bytes.h src/prelude.h src/builtins.c 8 | $(CC) $(CFLAGS) src/lexer.c src/parser.c src/cognac.c -o cognac -DCC=$(CC) 9 | 10 | install: cognac 11 | mkdir -p $(BINDIR) 12 | cp cognac $(BINDIR)/cognac 13 | 14 | uninstall: 15 | rm -rf $(BINDIR)/cognac 16 | 17 | src/runtime_bytes.h: src/runtime.h 18 | xxd -i src/runtime.h > src/runtime_bytes.h 19 | 20 | src/prelude.h: src/prelude.cog 21 | xxd -i src/prelude.cog > src/prelude.h 22 | 23 | src/lexer.c: src/lexer.l 24 | flex -o src/lexer.c src/lexer.l 25 | 26 | src/parser.c src/parser.h: src/parser.y 27 | bison src/parser.y --defines=src/parser.h -o src/parser.c 28 | 29 | clean: 30 | rm src/lexer.c src/parser.c src/parser.h cognac src/runtime_bytes.h 31 | 32 | test: $(TESTS) 33 | 34 | $(TESTS): cognac 35 | @rm -f $@.log $@.c $@ 36 | ./cognac $@.cog > $@.log 37 | ./$@ >> $@.log 38 | ./cognac $@.cog -debug > $@-debug.log 39 | ./$@ >> $@-debug.log 40 | ./cognac $@.cog -GCTEST > $@-GCTEST.log 41 | ./$@ >> $@-GCTEST.log 42 | ./cognac $@.cog -NOINLINE > $@-NOINLINE.log 43 | ./$@ >> $@-NOINLINE.log 44 | ./cognac $@.cog -GCTEST -NOINLINE > $@-BOTH.log 45 | ./$@ >> $@-BOTH.log 46 | @! grep "^FAIL" $@.log --color 47 | @! grep "^FAIL" $@-debug.log --color 48 | @! grep "^FAIL" $@-GCTEST.log --color 49 | @! grep "^FAIL" $@-NOINLINE.log --color 50 | @! grep "^FAIL" $@-BOTH.log --color 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |

Cognate

2 |

Readable and concise concatenative programming

3 |

4 | 5 | 6 | 7 | 8 | 9 |

10 | 11 | 12 | 13 | Cognate is a project aiming to create a human readable programming language with as little syntax as possible. Where natural language programming usually uses many complex syntax rules, instead Cognate takes them away. What it adds is simple, a way to embed comments into statements. 14 | 15 | 16 | 17 | As you can see, Cognate ignores words starting with lowercase letters, allowing them to be used to describe functionality and enhance readability. This makes Cognate codebases intuitive and maintainable. 18 | 19 | 20 | 21 | Cognate is a stack-oriented programming language similar to Forth or Factor, except statements are evaluated right to left. This gives the expressiveness of concatenative programming as well as the readability of prefix notation. Statements can be delimited at arbitrary points, allowing them to read as sentences would in English. 22 | 23 | 24 | 25 | Cognate borrows from other concatenative languages, but also adds unique features of its own. 26 | 27 | - Point-free functions 28 | - Operation chaining 29 | - Multiple return values 30 | - Combinator oriented programming 31 | - Predicate pattern matching 32 | - Natural language programming 33 | 34 | Interested? Read the [tutorial](/learn/), and check out one of Cognate's implementations: 35 | 36 | - CognaC (this repository) is the original compiler -- it performs type inference and produces efficient binaries. 37 | - [Cognate Playground](https://cognate-playground.hedy.dev/) (developed by [hedyhli](https://github.com/hedyhli)) runs Cognate programs in a web browser. 38 | - [Cogni](https://github.com/dragoncoder047/cogni) (developed by [dragoncoder047](https://github.com/dragoncoder047)) interprets Cognate programs and is optimised to run on microcontrollers. 39 | 40 | ## Cognac 41 | 42 | CognaC is the original Cognate compiler, it compiles Cognate programs into efficient C, which is then compiled into a small executable. As well as all language features, CognaC... 43 | 44 | - Performs type inference (for optimisation and error reporting at compile time) 45 | - Features a generational garbage collector 46 | - Prints pretty error messages and backtraces (in debug mode) 47 | - Approaches the speed of C for some small programs 48 | 49 | ### Building Cognate 50 | Currently, Cognate will run on Linux and MacOS systems. If you use Windows, then you can install Cognate on the Windows Subsystem for Linux. To build Cognate, you will need `make`, `flex`, `bison`, and a C compiler (currently supported are GCC, Clang, and TCC). After installing these, simply run: 51 | ``` 52 | make 53 | ``` 54 | If that succeeds, install the compiler with: 55 | ``` 56 | make install 57 | ``` 58 | This installs cognate to the `.local` prefix. To install to a different directory: 59 | ``` 60 | make PREFIX=/my/prefix/dir install 61 | ``` 62 | You should then run the test script to test Cognate's functionality. This should work regardless of operating system. 63 | ``` 64 | make test -j 65 | ``` 66 | If the tests all pass (they should!), you can then try running some of the included demo programs: 67 | ``` 68 | cognac examples/fizzbuzz.cog 69 | ./examples/fizzbuzz 70 | ``` 71 | 72 | [Here](https://cognate-lang.github.io/learn.html) is an work-in-progress introduction to the language. 73 | -------------------------------------------------------------------------------- /examples/fib.cog: -------------------------------------------------------------------------------- 1 | Def Fib 2 | Case (< 3) then (1 Drop) 3 | else (Let N ; Fib of - 1 N ; + Fib of - 2 N); 4 | 5 | Put "The 40th fibonacci number is... "; 6 | Print the Fib of 40; 7 | 8 | -------------------------------------------------------------------------------- /examples/fizzbuzz.cog: -------------------------------------------------------------------------------- 1 | Def Fizzbuzz ( 2 | Let N be Of (Integer?); 3 | Def Multiple as (Zero? Modulo Swap N); 4 | Print 5 | If Multiple of 15 then "fizzbuzz" 6 | If Multiple of 3 then "fizz" 7 | If Multiple of 5 then "buzz" 8 | else N 9 | ); 10 | 11 | 12 | For each in Range 1 to 100 ( Fizzbuzz ) 13 | -------------------------------------------------------------------------------- /examples/hanoi.cog: -------------------------------------------------------------------------------- 1 | ~~ Towers of Hanoi in Cognate 2 | 3 | Def Move discs as ( 4 | 5 | Let N be number of discs; 6 | Let A be first rod; 7 | Let B be second rod; 8 | Let C be third rod; 9 | 10 | Unless Zero? N ( 11 | Move - 1 N discs from A via C to B; 12 | Prints ("Move disc " N " from " A " to " C); 13 | Move - 1 N discs from B via A to C; 14 | ) 15 | ); 16 | 17 | Move 5 discs from \a via \b to \c 18 | -------------------------------------------------------------------------------- /examples/hello.cog: -------------------------------------------------------------------------------- 1 | Print "Hello world!" 2 | -------------------------------------------------------------------------------- /examples/prime.cog: -------------------------------------------------------------------------------- 1 | ~~ Prime numbers in Cognate 2 | 3 | Def Factor (Zero? Modulo Swap); 4 | 5 | Def Primes ( 6 | Fold ( 7 | Let I be our potential prime; 8 | Let Primes are the found primes; 9 | Let To-check be Take-while (<= Sqrt I) Primes; 10 | When None (Factor of I) To-check 11 | (Append List (I)) to Primes; 12 | ) from List () over Range from 2 13 | ); 14 | 15 | Print Primes up to 1000; 16 | -------------------------------------------------------------------------------- /screenshots/fizzbuzz.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cognate-lang/cognate/6bdd7b9ca16a3e9a6b124b52359153b1e94fd5ea/screenshots/fizzbuzz.png -------------------------------------------------------------------------------- /screenshots/hanoi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cognate-lang/cognate/6bdd7b9ca16a3e9a6b124b52359153b1e94fd5ea/screenshots/hanoi.png -------------------------------------------------------------------------------- /screenshots/prime.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cognate-lang/cognate/6bdd7b9ca16a3e9a6b124b52359153b1e94fd5ea/screenshots/prime.png -------------------------------------------------------------------------------- /screenshots/square.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cognate-lang/cognate/6bdd7b9ca16a3e9a6b124b52359153b1e94fd5ea/screenshots/square.png -------------------------------------------------------------------------------- /src/builtins.c: -------------------------------------------------------------------------------- 1 | /* Builtin functions */ 2 | {.name="empty", .calltype=call, .argc=0, .returns=true, .rettype=list}, 3 | {.name="true", .calltype=call, .argc=0, .returns=true, .rettype=boolean}, 4 | {.name="false", .calltype=call, .argc=0, .returns=true, .rettype=boolean}, 5 | {.name="+", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=number}, 6 | {.name="-", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=number}, 7 | {.name="*", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=number}, 8 | {.name="/", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=number}, 9 | {.name=">", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=boolean}, 10 | {.name=">=", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=boolean}, 11 | {.name="<", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=boolean}, 12 | {.name="<=", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=boolean}, 13 | {.name="==", .calltype=call, .argc=2, .args={any, any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 14 | {.name="^", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=number}, 15 | {.name="match", .calltype=call, .argc=2, .args={any, any}, .returns=true, .rettype=boolean}, 16 | {.name="if", .calltype=branch, .argc=3, .args={boolean, any, any}, .returns=true, .rettype=any}, 17 | {.name="print", .calltype=call, .argc=1, .args={any}, .returns=false, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL} }, 18 | {.name="put", .calltype=call, .argc=1, .args={any}, .returns=false, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL} }, 19 | {.name="do", .calltype=call, .argc=1, .args={block}, .stack=true}, 20 | {.name="random", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=number}, 21 | {.name="modulo", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=number}, 22 | {.name="sqrt", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 23 | {.name="or", .calltype=call, .argc=2, .args={boolean, boolean}, .returns=true, .rettype=boolean}, 24 | {.name="and", .calltype=call, .argc=2, .args={boolean, boolean}, .returns=true, .rettype=boolean}, 25 | {.name="xor", .calltype=call, .argc=2, .args={boolean, boolean}, .returns=true, .rettype=boolean}, 26 | {.name="not", .calltype=call, .argc=1, .args={boolean}, .returns=true, .rettype=boolean}, 27 | {.name="number?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 28 | {.name="io?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 29 | {.name="symbol?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 30 | {.name="integer?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean}, 31 | {.name="zero?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean}, 32 | {.name="any?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean}, 33 | {.name="list?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 34 | {.name="string?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 35 | {.name="block?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 36 | {.name="boolean?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 37 | {.name="table?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL}}, 38 | {.name="number!", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 39 | {.name="symbol!", .calltype=call, .argc=1, .args={symbol}, .returns=true, .rettype=symbol}, 40 | {.name="io!", .calltype=call, .argc=1, .args={io}, .returns=true, .rettype=io}, 41 | {.name="any!", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=any}, 42 | {.name="list!", .calltype=call, .argc=1, .args={list}, .returns=true, .rettype=list}, 43 | {.name="string!", .calltype=call, .argc=1, .args={string}, .returns=true, .rettype=string}, 44 | {.name="block!", .calltype=call, .argc=1, .args={block}, .returns=true, .rettype=block}, 45 | {.name="boolean!", .calltype=call, .argc=1, .args={boolean},.returns=true, .rettype=boolean}, 46 | {.name="table!", .calltype=call, .argc=1, .args={table}, .returns=true, .rettype=table}, 47 | 48 | {.name="first", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=any, .overload=true, .overloads={list,string,NIL}, .overload_returns={any, string, NIL}}, 49 | {.name="rest", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=any, .overload=true, .overloads={list,string,NIL}, .overload_returns={list, string, NIL}}, 50 | {.name="push", .calltype=call, .argc=2, .args={any, list}, .returns=true, .rettype=list}, 51 | {.name="empty?", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=boolean, .overload=true, .overloads={list, string, table, NIL}}, 52 | {.name="append", .calltype=call, .argc=2, .args={any, any}, .returns=true, .rettype=any, .overload=true, .overloads={string, list, NIL}, .overload_returns={string, list, NIL}}, 53 | {.name="substring", .calltype=call, .argc=3, .args={number, number, string}, .returns=true, .rettype=string}, 54 | {.name="regex", .calltype=call, .argc=2, .args={string, string}, .returns=true, .rettype=boolean}, 55 | {.name="regex-match", .calltype=call, .argc=2, .args={string, string}, .returns=true, .rettype=boolean, .stack=true}, 56 | {.name="ordinal", .calltype=call, .argc=1, .args={string}, .returns=true, .rettype=number}, 57 | {.name="character", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=string}, 58 | {.name="split", .calltype=call, .argc=2, .args={string, string}, .returns=true, .rettype=list}, 59 | {.name="uppercase", .calltype=call, .argc=1, .args={string}, .returns=true, .rettype=string}, 60 | {.name="lowercase", .calltype=call, .argc=1, .args={string}, .returns=true, .rettype=string}, 61 | {.name="floor", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 62 | {.name="round", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 63 | {.name="ceiling", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 64 | {.name="abs", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 65 | {.name="error", .calltype=call, .argc=1, .args={string}}, 66 | {.name="list", .calltype=call, .argc=1, .args={block}, .returns=true, .rettype=list}, 67 | {.name="number", .calltype=call, .argc=1, .args={string}, .returns=true, .rettype=number}, 68 | //{.name="precompute", .calltype=call, .argc=1, .args={block}, .returns=true, .rettype=block}, 69 | {.name="wait", .calltype=call, .argc=1, .args={number}, .returns=false}, 70 | {.name="stop", .calltype=call, .argc=0, .returns=false}, 71 | {.name="show", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=string, .overload=true, .overloads={number, symbol, table, string, boolean, block, list, box, io, NIL} }, 72 | {.name="stack", .calltype=call, .returns=true, .rettype=list, .stack=true}, 73 | {.name="clear", .calltype=call, .argc=0, .stack=true}, 74 | //{.name="remember", .calltype=call, .argc=1, .args={block}, .returns=true, .rettype=block}, 75 | //{.name="pure", .calltype=call, .argc=1, .args={block}, .returns=true, .rettype=block}, 76 | {.name="box", .calltype=call, .argc=1, .args={any}, .returns=true, .rettype=box}, 77 | {.name="unbox", .calltype=call, .argc=1, .args={box}, .returns=true, .rettype=any}, 78 | {.name="set", .calltype=call, .argc=2, .args={box, any}, .returns=false}, 79 | //{.name="debug", .calltype=call, .argc=0, .returns=false}, 80 | {.name="begin", .calltype=call, .argc=1, .args={block}, .stack=true}, 81 | 82 | /* math */ 83 | {.name="sind", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 84 | {.name="cosd", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 85 | {.name="tand", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 86 | 87 | {.name="sin", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 88 | {.name="cos", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 89 | {.name="tan", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 90 | 91 | {.name="exp", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 92 | {.name="log", .calltype=call, .argc=2, .args={number, number}, .returns=true, .rettype=number}, 93 | {.name="ln", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 94 | 95 | {.name="asind", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 96 | {.name="acosd", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 97 | {.name="atand", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 98 | 99 | {.name="asin", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 100 | {.name="acos", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 101 | {.name="atan", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 102 | 103 | {.name="sinhd", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 104 | {.name="coshd", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 105 | {.name="tanhd", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 106 | 107 | {.name="sinh", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 108 | {.name="cosh", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 109 | {.name="tanh", .calltype=call, .argc=1, .args={number}, .returns=true, .rettype=number}, 110 | 111 | {.name="table", .calltype=call, .argc=1, .args={block}, .returns=true, .rettype=table}, 112 | {.name="insert", .calltype=call, .argc=3, .args={any, any, table}, .returns=true, .rettype=table}, 113 | {.name="remove", .calltype=call, .argc=2, .args={any, table}, .returns=true, .rettype=table}, 114 | {.name=".", .calltype=call, .argc=2, .args={any, table}, .returns=true, .rettype=any}, 115 | {.name="has", .calltype=call, .argc=2, .args={any, table}, .returns=true, .rettype=boolean}, 116 | {.name="values", .calltype=call, .argc=1, .args={table}, .returns=true, .rettype=list}, 117 | {.name="keys", .calltype=call, .argc=1, .args={table}, .returns=true, .rettype=list}, 118 | 119 | {.name="length", .calltype=call, .argc=1, .args={any}, .overload=true, .overloads={list, table, string, NIL}, .returns=true, .rettype=number}, 120 | 121 | /* Builtin stack operations */ 122 | //{.name="drop", .calltype=stack_op, .stack_shuffle=&drop_register}, 123 | //{.name="twin", .calltype=stack_op, .stack_shuffle=&twin_register}, 124 | //{.name="triplet", .calltype=stack_op, .stack_shuffle=&triplet_register}, 125 | //{.name="swap", .calltype=stack_op, .stack_shuffle=&swap_register}, 126 | 127 | /* Builtin IO */ 128 | 129 | #ifndef DISABLEIO 130 | {.name="parameters", .calltype=call, .returns=true, .rettype=list}, 131 | {.name="input", .calltype=call, .returns=true, .rettype=string}, 132 | {.name="open", .calltype=call, .argc=2, .args={symbol, string}, .returns=true, .rettype=io}, 133 | {.name="read-file", .calltype=call, .argc=1, .args={io}, .returns=true, .rettype=string}, 134 | {.name="read-line", .calltype=call, .argc=1, .args={io}, .returns=true, .rettype=string}, 135 | {.name="close", .calltype=call, .argc=1, .args={io}}, 136 | {.name="path", .calltype=call, .returns=true, .rettype=string}, 137 | {.name="seek", .calltype=call, .argc=3, .args={symbol, number, io}, .returns=false}, 138 | #endif 139 | 140 | {.name=NULL}, 141 | -------------------------------------------------------------------------------- /src/cognac.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | 3 | #include 4 | #include 5 | 6 | typedef struct _ptr_assoc_t ptr_assoc_t; 7 | typedef struct _func_t func_t; 8 | typedef struct _module_t module_t; 9 | typedef struct _ast_t ast_t; 10 | typedef struct _word_t word_t; 11 | typedef struct _builtin_t builtin_t; 12 | typedef struct _word_list_t word_list_t; 13 | typedef struct _func_list_t func_list_t; 14 | typedef struct _symbol_list_t symbol_list_t; 15 | typedef struct _ast_list_t ast_list_t; 16 | typedef struct _lit_t lit_t; 17 | typedef struct _reg_dequeue_t reg_dequeue_t; 18 | typedef struct _val_t val_t; 19 | typedef struct _val_list_t val_list_t; 20 | typedef struct _reg_t reg_t; 21 | typedef struct _where_t where_t; 22 | typedef struct _where_list_t where_list_t; 23 | typedef struct _module_list_t module_list_t; 24 | 25 | typedef enum _type_t 26 | { 27 | none = 0, 28 | // original AST only 29 | let, // STRING 30 | def, // STRING 31 | use, // STRING 32 | braces, // CHILD 33 | identifier, // STRING 34 | module_identifier, // STRING 35 | // Both 36 | literal, 37 | // IR specific 38 | closure, // FUNC 39 | var, // WORD 40 | call, // WORD 41 | define, // WORD 42 | bind, // WORD 43 | to_any, // VAL_TYPE 44 | from_any, // VAL_TYPE 45 | pop, // none 46 | push, // none 47 | pick, // none 48 | unpick, // none 49 | branch, // none 50 | fn_branch, // FUNCS 51 | load, // none 52 | ret, // none 53 | static_call, // FUNC 54 | drop, // none 55 | backtrace_push, // WORD 56 | backtrace_pop, 57 | } type_t; 58 | 59 | typedef enum _val_type_t 60 | { 61 | NIL=0, 62 | number, 63 | symbol, 64 | table, 65 | string, 66 | boolean, 67 | block, 68 | list, 69 | box, 70 | io, 71 | any, 72 | strong_any, 73 | } val_type_t; 74 | 75 | struct _ptr_assoc_t 76 | { 77 | void* from; 78 | void* to; 79 | ptr_assoc_t* next; 80 | }; 81 | 82 | struct _reg_dequeue_t 83 | { 84 | reg_t* front; 85 | reg_t* rear; 86 | size_t len; 87 | }; 88 | 89 | struct _reg_t 90 | { 91 | reg_t* next; 92 | reg_t* prev; 93 | ast_list_t* source; 94 | size_t id; 95 | val_type_t type; 96 | // registers and values should be the same thing 97 | // just make values dequeue-able 98 | // and add an id field for C generation 99 | }; 100 | 101 | struct _lit_t 102 | { 103 | const char* string; 104 | val_type_t type; 105 | }; 106 | 107 | struct _word_list_t 108 | { 109 | word_t* word; 110 | word_list_t* next; 111 | }; 112 | 113 | struct _builtin_t 114 | { 115 | char* name; 116 | char argc; 117 | val_type_t args[3]; 118 | bool stack; 119 | bool returns; 120 | type_t calltype; 121 | val_type_t storagetype; 122 | val_type_t rettype; 123 | val_type_t overloads[10]; 124 | val_type_t overload_returns[10]; 125 | bool overload; 126 | //val_type_t checks; 127 | }; 128 | 129 | struct _val_list_t 130 | { 131 | val_t* val; 132 | val_list_t* next; 133 | }; 134 | 135 | struct _val_t 136 | { 137 | val_type_t type; 138 | ast_list_t* source; 139 | }; 140 | 141 | struct _word_t 142 | { 143 | char* name; 144 | size_t shadow_id; 145 | module_t* mod; 146 | type_t calltype; 147 | val_t* val; 148 | bool used_early; 149 | bool used; 150 | // See decl_list from old compiler 151 | }; 152 | 153 | struct _ast_list_t 154 | { 155 | ast_t* op; 156 | ast_list_t* next; 157 | ast_list_t* prev; 158 | }; 159 | 160 | struct _ast_t 161 | { 162 | union 163 | { 164 | void* data; 165 | char* string; 166 | func_t* func; 167 | func_list_t* funcs; 168 | word_t* word; 169 | lit_t* literal; 170 | ast_list_t* child; 171 | module_t* mod; 172 | val_type_t val_type; 173 | }; 174 | where_t* where; 175 | size_t sqnum; 176 | type_t type; 177 | }; 178 | 179 | struct _func_list_t 180 | { 181 | func_t* func; 182 | func_list_t* next; 183 | }; 184 | 185 | struct _func_t 186 | { 187 | func_t* generic_variant; 188 | ast_list_t* ops; 189 | word_list_t* captures; 190 | word_list_t* locals; 191 | func_list_t* calls; 192 | val_list_t* args; 193 | val_type_t rettype; 194 | val_type_t checks; 195 | val_type_t tentative_rettype; 196 | char* unmangled_name; 197 | size_t argc; 198 | char* name; 199 | val_type_t overloads[10]; 200 | val_type_t overload_returns[10]; 201 | val_type_t overloaded_to; 202 | bool overload; 203 | bool returns; 204 | bool stack; 205 | bool used; 206 | bool entry; 207 | bool has_args; 208 | bool has_regs; 209 | bool has_stack; 210 | bool generic; 211 | bool branch; 212 | bool unique; 213 | bool builtin; 214 | }; 215 | 216 | struct _symbol_list_t 217 | { 218 | char* text; 219 | struct _symbol_list_t* next; 220 | }; 221 | 222 | struct _module_t 223 | { 224 | char* path; 225 | char* prefix; 226 | char* dir; 227 | FILE* file; 228 | ast_list_t* tree; 229 | func_list_t* funcs; 230 | func_t* entry; 231 | symbol_list_t* symbols; 232 | module_list_t* uses; 233 | where_t* first_ref; 234 | size_t num_lines; 235 | char** lines; 236 | }; 237 | 238 | struct _module_list_t 239 | { 240 | module_t* mod; 241 | module_list_t* next; 242 | }; 243 | 244 | struct _where_t 245 | { 246 | module_t* mod; 247 | size_t line; 248 | size_t col; 249 | char* symbol; 250 | char* line_str; 251 | }; 252 | 253 | struct _where_list_t 254 | { 255 | where_t* where; 256 | where_list_t* next; 257 | }; 258 | 259 | ast_list_t* join_ast(ast_list_t*, ast_list_t*); 260 | ast_list_t* push_ast(ast_t*, ast_list_t*); 261 | ast_list_t* ast_single(type_t, void*, where_t*); 262 | char* lowercase(const char*); 263 | int main(int, char**); 264 | void print_funcs (module_t*); 265 | void print_ast(ast_list_t*, int); 266 | void flatten_ast(module_t*); 267 | void add_captures(module_t*); 268 | void resolve_scope(module_t*); 269 | void module_parse(module_t*); 270 | module_t* create_module(char*); 271 | void fold_defs(module_t*); 272 | lit_t* mk_lit(val_type_t, const char*); 273 | word_list_t* builtins(void); 274 | const char* c_val_type(val_type_t); 275 | const char* print_val_type(val_type_t); 276 | _Noreturn void throw_error(char*, where_t*); 277 | void load_preludes(void); 278 | 279 | extern FILE* yyin; 280 | extern ast_list_t* full_ast; 281 | extern where_t* parse_pos(char*); 282 | int yylex(void); 283 | int yyparse (void); 284 | void yyerror(char*); 285 | char* lc(char*); 286 | -------------------------------------------------------------------------------- /src/lexer.l: -------------------------------------------------------------------------------- 1 | %option noyywrap noinput nounput nodefault 2 | %{ 3 | #define YY_USER_ACTION yylloc.first_column += yyleng; yylloc.last_column += yyleng; 4 | 5 | #include "cognac.h" 6 | #include "parser.h" 7 | #include 8 | #include 9 | #include 10 | 11 | char* lc(char* s) 12 | { 13 | for (int i = 0; s[i] != '\0'; ++i) s[i] = tolower(s[i]); 14 | return s; 15 | } 16 | 17 | void yyerror(char* str) 18 | { 19 | throw_error(str, parse_pos(NULL)); 20 | } 21 | 22 | int brace_depth = 0; 23 | int last_openbrace_line; 24 | int last_openbrace_col; 25 | %} 26 | 27 | %x BLOCK_COMMENT 28 | 29 | ALLOWCHAR [A-Za-z0-9\-\?\!\'\+\/\*\>\=\<\^\.] 30 | FORMAL [A-Z\-\?\!\+\/\*\>\<\=\^\.] 31 | END [;\(\)$^\~[:space:]] 32 | ESCAPES [abfnrtv\\\"] 33 | 34 | %% 35 | D[eE][fF]/{END} return DEF; 36 | L[eE][tT]/{END} return LET; 37 | 38 | \-?([1-9][0-9]*|[0-9])(\.[0-9]+)?(e\-?[0-9]+)?/{END} yylval.text=strdup(yytext); return NUMBER; 39 | {FORMAL}{ALLOWCHAR}*/{END} yylval.text=lc(strdup(yytext)); return IDENTIFIER; 40 | {ALLOWCHAR}+:{FORMAL}{ALLOWCHAR}*/{END} yylval.text=lc(strdup(yytext)); return MODULE_IDENTIFIER; 41 | \\{ALLOWCHAR}+/{END} yylval.text=lc(strdup(yytext+1)); return SYMBOL; 42 | \"(\\{ESCAPES}|[^\n"\\])*\"/{END} yylval.text=strdup(yytext); return STRING; 43 | \"(\\.|[^\n"\\])*\"/{END} yyerror("invalid escape sequence"); 44 | \" yyerror("unterminated string"); // TODO error message is printing with wrong column. 45 | 46 | ; return ';'; 47 | \( brace_depth++; last_openbrace_line = yylloc.first_line; last_openbrace_col = yylloc.first_column; return '('; 48 | 49 | \) if (brace_depth--) return ')'; yyerror("unbalanced brace"); 50 | 51 | <> if (brace_depth) { yylloc.first_line = last_openbrace_line; 52 | yylloc.first_column = last_openbrace_col; 53 | yyerror("unbalanced brace"); } else yyterminate(); 54 | 55 | \n yylloc.first_line++; yylloc.first_column = 1; 56 | 57 | [a-z][a-z0-9\'\-\?\!\.]* /* Ignore informal syntax */ 58 | [[:space:]] /* Ignore whitespace */ 59 | \~\~.* /* Ignore line comments */ 60 | 61 | \~ BEGIN(BLOCK_COMMENT); 62 | \~ BEGIN(INITIAL); 63 | \n yylloc.first_line++; yylloc.first_column = 1; 64 | . 65 | 66 | . yyerror("invalid token"); 67 | %% 68 | -------------------------------------------------------------------------------- /src/parser.y: -------------------------------------------------------------------------------- 1 | %{ 2 | #include "cognac.h" 3 | %} 4 | 5 | %locations 6 | 7 | %union { 8 | char* text; 9 | ast_list_t* tree; 10 | } 11 | 12 | %token 13 | NUMBER 14 | IDENTIFIER 15 | MODULE_IDENTIFIER 16 | STRING 17 | SYMBOL 18 | DEF 19 | LET 20 | ';' 21 | '(' 22 | ')' 23 | ; 24 | 25 | %type STATEMENT; 26 | %type EXPRESSION; 27 | %type TOKEN; 28 | 29 | %start ENTRY; 30 | %% 31 | 32 | ENTRY: 33 | EXPRESSION { full_ast = $1; } 34 | ; 35 | 36 | EXPRESSION: 37 | STATEMENT ';' EXPRESSION { $$ = join_ast($1, $3); } 38 | | STATEMENT { $$ = $1; } 39 | ; 40 | 41 | STATEMENT: 42 | TOKEN STATEMENT { $$ = join_ast($2, $1); } 43 | | /* Empty */ { $$ = NULL; } 44 | ; 45 | 46 | TOKEN: 47 | IDENTIFIER { $$ = ast_single(identifier, (void*)lowercase($1), parse_pos($1)); } 48 | | MODULE_IDENTIFIER { $$ = ast_single(module_identifier, (void*)lowercase($1), parse_pos($1)); } 49 | | '(' EXPRESSION ')' { $$ = ast_single(braces, (void*)$2, parse_pos($1)); } 50 | | NUMBER { $$ = ast_single(literal, mk_lit(number, $1), parse_pos($1)); } 51 | | STRING { $$ = ast_single(literal, mk_lit(string, $1), parse_pos($1)); } 52 | | SYMBOL { $$ = ast_single(literal, mk_lit(symbol, $1), parse_pos($1)); } 53 | | DEF IDENTIFIER { $$ = ast_single(def, (void*)lowercase($2), parse_pos($2)); } 54 | | LET IDENTIFIER { $$ = ast_single(let, (void*)lowercase($2), parse_pos($2)); } 55 | ; 56 | 57 | %% 58 | -------------------------------------------------------------------------------- /src/prelude.cog: -------------------------------------------------------------------------------- 1 | ~ 2 | Compares two values and returns True if they differ. 3 | 4 | ``` 5 | Print != 1 2; 6 | Print != 1 1; 7 | ``` 8 | ~ 9 | Def != as ( Not == ); 10 | 11 | ~ 12 | Discard the top stack item. 13 | 14 | ``` 15 | Print Drop "foo" "bar"; 16 | ``` 17 | ~ 18 | Def Drop as ( Let X ); 19 | 20 | ~ 21 | Swaps the top two stack items. 22 | 23 | ``` 24 | Print Swap 1 2; 25 | ``` 26 | ~ 27 | Def Swap as ( Let X ; Let Y ; Y X ); 28 | 29 | ~ 30 | Execute a block. 31 | 32 | ``` 33 | Do ( Print "hello world!" ); 34 | ``` 35 | ~ 36 | Def Do as ( Def F ; F ); 37 | 38 | ~ 39 | Takes a parameter of any type and returns True 40 | 41 | ``` 42 | Print Any? 12; 43 | Print Any? "hello"; 44 | Print Any? List (1 2 3); 45 | ``` 46 | ~ 47 | Def Any? ( True Drop ); 48 | 49 | 50 | ~ 51 | Duplicate the top stack item. 52 | 53 | ``` 54 | Def Square as (* Twin); 55 | Print Square 8; 56 | ``` 57 | ~ 58 | Def Twin as (Let X ; X X); 59 | 60 | ~ 61 | Triplicates the top stack item 62 | 63 | ``` 64 | Def Cube as (* * Triplet); 65 | Print Cube 8; 66 | ``` 67 | ~ 68 | Def Triplet as (Twin ; Twin); 69 | 70 | ~ 71 | Takes a boolean (`Cond`) and a block (`F`) as parameters. Executes `F`, given `Cond` is True. 72 | 73 | ``` 74 | When True ( Print "hello!" ); 75 | When False ( Print "bye!" ); 76 | ``` 77 | ~ 78 | Def When as ( 79 | Let Cond; 80 | Def F; 81 | Do If Cond then ( F ) else (); 82 | ); 83 | 84 | ~ 85 | Opposite of `When`. Takes a boolean (`Cond`) and a block (`F`) as parameters. Executes `F`, given `Cond` is False. 86 | 87 | ``` 88 | Unless True ( Print "hello!" ); 89 | Unless False ( Print "bye!" ); 90 | ``` 91 | ~ 92 | Def Unless as ( 93 | Let Cond; 94 | Def F; 95 | Do If Cond then ( ) else ( F ); 96 | ); 97 | 98 | ~ 99 | Takes two block parameters (`Cond` and `F`). Continually execute `F` while `Cond` evaluates to True. 100 | 101 | ``` 102 | While (True) ( Print "This will print forever..." ); 103 | While (False) ( Print "This won't print at all..." ); 104 | ``` 105 | ~ 106 | Def While ( 107 | Def Cond; 108 | Def F; 109 | Let Result be Cond; 110 | When Result then ( F ; While (Cond) (F) ) 111 | ); 112 | 113 | ~ 114 | Opposite of While. Takes two block parameters (`Cond` and `F`). Continually execute `F` until `Cond` evaluates to True. 115 | 116 | ``` 117 | Until (False) ( Print "This will print forever..." ); 118 | Until (True) ( Print "This won't print at all..." ); 119 | ``` 120 | ~ 121 | Def Until ( 122 | Def Cond; 123 | Def F; 124 | Let Result be Cond; 125 | Unless Result then ( F ; Until (Cond) (F) ); 126 | ); 127 | 128 | ~ 129 | Takes a number (`N`) and a block (`F`) as parameters. Evaluates `F` `N` times. 130 | 131 | ``` 132 | Times 3 ( Print "Hip Hip Hooray!" ); 133 | ``` 134 | ~ 135 | Def Times ( 136 | Let N be Of (Integer?); 137 | Def F; 138 | Unless Zero? N ( F ; Times - 1 N (F) ); 139 | ); 140 | 141 | 142 | ~ 143 | Takes symbol parameter `Mode`, string parameter `Filename` and block parameter `Body`. Opens the file `Filename` in mode `Mode`. Evaluates `Body`, passing it a reference to the file. 144 | 145 | ``` 146 | With \read "foo.txt" ( 147 | Let F be the file handle; 148 | Print Read-file F; 149 | ); 150 | ``` 151 | ~ 152 | Def With ( 153 | Let Mode be Of (Symbol?); 154 | Let Filename be Of (String?); 155 | Def Body; 156 | Let Fp be Open as Mode Filename; 157 | Body Fp; 158 | Close Fp 159 | ); 160 | 161 | ~ 162 | Returns the list parameter reversed. 163 | 164 | ``` 165 | Print Reverse List (1 2 3); 166 | ``` 167 | ~ 168 | Def Reverse ( 169 | Def Reverse-helper ( 170 | Let L1 be List!; 171 | Let L2 be List!; 172 | Do If Empty? L2 ( L1 ) else ( Reverse-helper Push First L2 to L1 and Rest L2 ) 173 | ); 174 | 175 | Reverse-helper Empty; 176 | ) 177 | 178 | ~ 179 | Takes a block (`F`) and a list (`L`) as parameters. Applies a block to each element in a list 180 | 181 | ``` 182 | For each in Range 1 to 100 ( Print ); 183 | ``` 184 | ~ 185 | Def For ( 186 | ~~ Tail recursive; 187 | Let L be Of (List?); 188 | Def F; 189 | When Not Empty? L ( 190 | F First L; 191 | For each in Rest L do (F); 192 | ) 193 | ); 194 | 195 | ~ 196 | Takes a block (`F`), initial value (`I`), and list (`L`) as parameters. Applies `F` to each element in `L`, pushing `I` to the stack first. 197 | 198 | ``` 199 | Fold (*) from 1 over Range 1 to 10; 200 | Print; 201 | ``` 202 | ~ 203 | Def Fold ( 204 | Def F; 205 | Let I; 206 | Let L be Of (List?); 207 | I ; For each in L do (F); 208 | ); 209 | 210 | ~ 211 | Builds a string from a block parameter and prints it to standard output, without a newline. 212 | 213 | ``` 214 | Puts ( "The square of 10 is " * Twin 10 "\n"); 215 | ``` 216 | ~ 217 | Def Puts ( Put Fold ( Prepend Show ) from "" over Reverse List); 218 | 219 | ~ 220 | Builds a string from a block parameter and prints it to standard output, with a newline. 221 | 222 | ``` 223 | Puts ( "The square of 10 is " * Twin 10); 224 | ``` 225 | ~ 226 | Def Prints ( Print Fold ( Prepend Show ) from "" over Reverse List); 227 | 228 | ~ 229 | Takes a block parameter `Predicate` and a list `L`. Applies `Predicate` to each element in `L`. Returns a list containing only the elements where `Predicate` evaluated to True. 230 | 231 | ``` 232 | Def Even? as (Zero? Modulo 2); 233 | Filter (Even?) over Range 1 to 100; 234 | Print; 235 | ``` 236 | ~ 237 | Def Filter ( 238 | Def Predicate; 239 | 240 | Def Filter-helper ( 241 | Let Acc be List!; 242 | Let L be List!; 243 | Do If Empty? L ( Acc ) 244 | else ( 245 | Let R be Boolean! Predicate First L; 246 | Do If R ( Filter-helper Push First L to Acc and Rest L ) 247 | else ( Filter-helper Acc and Rest L ); 248 | ) 249 | ); 250 | 251 | Reverse Filter-helper Empty; 252 | ); 253 | 254 | ~ 255 | Takes two number parameters and returns the smaller one. 256 | 257 | ``` 258 | Print Min 3 10; 259 | ``` 260 | ~ 261 | Def Min as ( 262 | Let A be Of (Number?); 263 | Let B be Of (Number?); 264 | If < A B then B else A; 265 | ); 266 | 267 | ~ 268 | Takes two number parameters and returns the larger one. 269 | 270 | ``` 271 | Print Max 3 10; 272 | ``` 273 | ~ 274 | Def Max as ( 275 | Let A be Of (Number?); 276 | Let B be Of (Number?); 277 | If < A B then A else B; 278 | ); 279 | 280 | ~ 281 | Takes a predicate block (`F`) and a list (`L`) as parameters. Builds a new list by taking elements one by one from `L` and evaluating `F` on them. Stops building the list when the `F` first evaluates to False. 282 | 283 | ``` 284 | Print Take-while (< 10) Range 1 to 100; 285 | ``` 286 | ~ 287 | Def Take-while ( 288 | Def F; 289 | Let L be Of (List?); 290 | Def H as ( 291 | Let L; 292 | Unless Empty? L ( 293 | Let I be First L; 294 | Let R be F of I; 295 | When R then ( 296 | Push I; 297 | H Rest L 298 | ) 299 | ) 300 | ); 301 | Reverse H L Empty; 302 | ); 303 | 304 | ~ 305 | Takes a predicate block (`F`) and list (`L`) as parameters. Applies `F` to each element of `L`, returning True if `F` returned True every time, else returning False. 306 | 307 | ``` 308 | Print All (< 100) Range 1 to 10; 309 | Print All (< 10) Range 1 to 100; 310 | ``` 311 | ~ 312 | Def All ( 313 | Def F; 314 | Let L be Of (List?); 315 | Do If Empty? L then ( True ) 316 | else ( 317 | Do If F on First L 318 | then ( All (F) of Rest of L ) 319 | else ( False ) 320 | ) 321 | ); 322 | 323 | ~ 324 | Takes a predicate block and list as parameters. Returns True if evaluating the predicate on all of the list elements gives False, else returns False. 325 | 326 | ``` 327 | Print None (> 100) Range 1 to 10; 328 | Print None (> 10) Range 1 to 100; 329 | ``` 330 | ~ 331 | Def None ( 332 | Def P; 333 | Let L; 334 | All ( Not P ) of L; 335 | ); 336 | 337 | ~ 338 | Takes two list or string parameters and returns a new list/string created by joining the second list/string onto the end of the first list/string. 339 | 340 | ``` 341 | Print Prepend List (1 2 3) to List (4 5 6); 342 | Print Prepend "hello" to "world"; 343 | ``` 344 | ~ 345 | Def Prepend ( Swap ; Append ); 346 | 347 | ~ 348 | Takes a predicate block `Pred` and two other blocks `If-true` and `If-false`. Returns a block that takes one parameter (`X`) and applies the predicate to it. If this gives True then `If-true` is evaluated with `X` as a parameter. If not `If-false` is evaluated with `X` as a parameter. 349 | 350 | ``` 351 | Def Multiple as ( Zero? Modulo ); 352 | 353 | Def Fizzbuzz 354 | Case (Multiple of 15) then ( "Fizzbuzz" Drop ) 355 | Case (Multiple of 3) then ( "Fizz" Drop ) 356 | Case (Multiple of 5) then ( "Buzz" Drop ) 357 | else ( just return the number ); 358 | ``` 359 | 360 | For each in Range 1 to 100 ( Print Fizzbuzz ) 361 | ~ 362 | Def Case as ( 363 | Def Pred; 364 | Def If-true; 365 | Def If-false; 366 | ( 367 | Let X; 368 | Let B be Pred X; 369 | Do If B then (If-true X) else (If-false X) 370 | ); 371 | ); 372 | 373 | ~ 374 | Takes a list of numbers as a parameter and returns a list containing the same numbers in ascending order. 375 | 376 | ``` 377 | Print Sort List ( 9 6 2 5 7 4 1 3 8); 378 | ``` 379 | ~ 380 | Def Sort 381 | Case (Empty?) () 382 | else ( 383 | Let L; 384 | Let Pivot be First of L; 385 | Sort Filter (< Pivot) L; 386 | Sort Filter (>= Pivot) Rest of L; 387 | Push Pivot; 388 | Append 389 | ); 390 | 391 | ~ 392 | Takes a block (`F`) and a list (`L`) as parameters. Creates a new list where each element is the result of applying `F` to the corresponding element in `L`. 393 | 394 | ``` 395 | Def Square as (* Twin); 396 | Map (Square) over the Range from 1 to 10; 397 | Print 398 | ``` 399 | ~ 400 | Def Map ( 401 | Def F; 402 | 403 | Def Map-helper ( 404 | Let Acc be List!; 405 | Let L be List!; 406 | Do If Empty? L ( Acc ) 407 | else ( 408 | Let R be F of First L; 409 | Map-helper Push R to Acc and Rest L 410 | ) 411 | ); 412 | 413 | Reverse Map-helper Empty; 414 | ); 415 | 416 | ~ 417 | Takes an integer (`N`) and a list (`L`) as parameters. Returns a list created by removing the first `N` elements of `L`. 418 | 419 | ``` 420 | Print Discard 4 from Range 1 to 10; 421 | ``` 422 | ~ 423 | Def Discard ( 424 | Let N be Of (Integer?); 425 | Let L be Of (List?); 426 | Do If Zero? N ( L ) else ( 427 | When Empty? L ( Error "Cannot Discard more elements than in list" ); 428 | Discard - 1 N from Rest L 429 | ); 430 | ); 431 | 432 | ~ 433 | Takes an integer (`N`) and a list (`L`) as parameters. Returns a list containing only the first `N` elements of `L`. 434 | 435 | ``` 436 | Print Take 4 from Range 1 to 10; 437 | ``` 438 | ~ 439 | Def Take ( 440 | Def Take-helper ( 441 | Let Acc be List!; 442 | Let N be Number!; 443 | Let L be List!; 444 | Do If Zero? N ( Acc ) 445 | else ( 446 | When Empty? L ( Error "Cannot Take more elements than in list" ); 447 | Take-helper Push First L to Acc taking - 1 N from Rest L; 448 | ) 449 | ); 450 | 451 | Reverse Take-helper Empty; 452 | ); 453 | 454 | ~ 455 | Takes an integer (`N`) and a list or string (`L`) as parameters. Returns the `N`th element (indexed from zero) of `L`. 456 | 457 | ``` 458 | Print Index 4 of Range 0 to 100; 459 | ``` 460 | ~ 461 | Def Index ( 462 | Let N be Of (Integer?); 463 | Let L; 464 | 465 | When < 0 N ( Error Prepend "Invalid index " Show N ); 466 | When Empty? L ( Error "Index is beyond the end" ); 467 | 468 | Do If Zero? N ( return First element of L ) 469 | else ( Index - 1 N of Rest of L ) 470 | ); 471 | 472 | ~ 473 | Takes two number parameters (`Start` and `End`). Returns a list of numbers ranging from `Start` to `End` inclusive of `Start` but not `End` with a step of 1. 474 | 475 | ``` 476 | Print Range 1 to 100; 477 | ``` 478 | ~ 479 | Def Range ( 480 | Let Start be Number!; 481 | Let End be Number!; 482 | 483 | When > End Start ~~ TODO? maybe we could have this create a reverse range. 484 | ( 485 | Error Prepend Prepend Prepend "Invalid range " Show Start "..." Show End; 486 | ); 487 | 488 | Def Range-helper ( 489 | Let Start be Number!; 490 | Let End be Number!; 491 | Let L be List!; 492 | 493 | Do If < End Start ( Range-helper from + 1 Start to End with Push Start to L ) else ( L ); 494 | ); 495 | 496 | Reverse Range-helper from Start to End with Empty; 497 | ); 498 | 499 | ~ 500 | Takes a string (`Assertion`) and a boolean (`Result`). If `Result` is not True then throws an error, with the text of `Assertion` in the error message. 501 | 502 | ``` 503 | Assert "This assertion will pass" True; 504 | Assert "This assertion will fail" False; 505 | ``` 506 | ~ 507 | Def Assert ( 508 | Let Assertion be String!; 509 | Let Result be Boolean!; 510 | 511 | Unless Result ( Error Prepend Prepend "Failed assertion: '" Assertion "'" ); 512 | ); 513 | 514 | ~ 515 | Takes a block `Predicate` and a value `X`. Applies `Predicate` to `X`. If this returns False throw an error. If it returns True then return `X`; 516 | 517 | Def Print-integer ( 518 | Let I be Of (Integer?); 519 | Print I; 520 | ); 521 | 522 | ``` 523 | Print-integer 5; 524 | Print-integer 2.3; 525 | ``` 526 | ~ 527 | Def Of as ( 528 | Def Predicate; 529 | Let X; 530 | Let Result be Predicate X; 531 | Unless Result ( Error "Predicate failed" ); 532 | X; 533 | ); 534 | 535 | ~ 536 | Takes a single block parameter - this block should take one parameter and return one value deterministically. Returns a block that performs the same computation but has an internal cache (which persists between calls) to avoid recomputing inputs that it's already seen. This cache has a logarithmic lookup time. If the provided block performs IO, then that IO will not be performed in the case of an input it's seen before. 537 | 538 | ``` 539 | Def Fib as Cache 540 | Case (< 3) then (1 Drop) 541 | else (Let N ; Fib of - 1 N ; + Fib of - 2 N); 542 | 543 | Put "The 100th fibonacci number is... "; 544 | Print the Fib of 100; 545 | ``` 546 | ~ 547 | Def Cache as ( 548 | Def F; 549 | Let BT be Box Table (); 550 | 551 | ( 552 | Let X; 553 | Let T be Unbox BT; 554 | Do If Has X T 555 | then ( . X T ) 556 | else ( 557 | Let Y be F X; 558 | Unbox BT; 559 | Insert X is Y; 560 | Set BT; 561 | Y 562 | ) 563 | ) 564 | ); 565 | 566 | -------------------------------------------------------------------------------- /src/runtime.h: -------------------------------------------------------------------------------- 1 | // ---------- RUNTIME HEADER ---------- 2 | #define _GNU_SOURCE 3 | 4 | #ifndef __TINYC__ 5 | #define _FORTIFY_SOURCE 2 6 | #endif 7 | 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | #include 29 | #include 30 | 31 | #ifdef __TINYC__ 32 | #define __nmatch 33 | #endif 34 | 35 | #include 36 | 37 | #define KILOBYTE 1024l 38 | #define MEGABYTE 1024l*KILOBYTE 39 | #define GIGABYTE 1024l*MEGABYTE 40 | #define TERABYTE 1024l*GIGABYTE 41 | #define ALLOC_SIZE 100l*GIGABYTE 42 | #define ALLOC_START (void*)(42l * TERABYTE) 43 | 44 | #ifdef GCTEST 45 | #define GC_FIRST_THRESHOLD 16 46 | #define GC_MUTABLE_THRESHOLD 16 47 | #define GC_THRESHOLD_RATIO 2 48 | #define GC_MAX_HEAPS 300 49 | #else 50 | #define GC_FIRST_THRESHOLD MEGABYTE 51 | #define GC_MUTABLE_THRESHOLD MEGABYTE 52 | #define GC_THRESHOLD_RATIO 8 53 | #define GC_MAX_HEAPS 8 54 | #endif 55 | 56 | #define NIL ((uint64_t)0x7ffc000000000000) // NaN 57 | #define PTR_MASK ((uint64_t)0x0000fffffffffff8) // 48 bit aligned pointers 58 | #define TYPE_MASK ((uint64_t)0xffff000000000007) // Everything left 59 | 60 | #define UNALIGNED_PTR_MASK ((uint64_t)0x0000ffffffffffff) // 48 bit unaligned pointers 61 | 62 | #define MEM_PROT PROT_READ|PROT_WRITE 63 | #define MEM_FLAGS MAP_ANONYMOUS|MAP_PRIVATE|MAP_NORESERVE 64 | 65 | typedef uint64_t ANY; 66 | typedef uint64_t cognate_type; 67 | typedef ANY* ANYPTR; 68 | typedef ANY* BOX; 69 | typedef struct cognate_block* BLOCK; 70 | typedef char BOOLEAN; 71 | typedef double NUMBER; 72 | typedef const char* STRING; 73 | typedef const struct cognate_list* LIST; 74 | typedef const char* SYMBOL; 75 | typedef struct cognate_file* IO; 76 | typedef struct cognate_table* TABLE; 77 | 78 | typedef struct cognate_block 79 | { 80 | void (*fn)(ANY*); 81 | ANY env[0]; 82 | } cognate_block; 83 | 84 | #define NUMBER_TYPE ( NIL | 0x0000000000000008 ) // Use NaN boxing, so the value here is irrelevant. 85 | #define STRING_TYPE ( NIL | 0x0002000000000000 ) // Use a higher bit to signify strings, since they're not necessarily aligned. 86 | #define SYMBOL_TYPE ( NIL | 0x0001000000000000 ) // Same with symbols. 87 | #define BOOLEAN_TYPE ( NIL | 0x0000000000000001 ) 88 | #define BOX_TYPE ( NIL | 0x0000000000000002 ) 89 | #define LIST_TYPE ( NIL | 0x0000000000000003 ) 90 | #define TABLE_TYPE ( NIL | 0x0000000000000004 ) 91 | #define IO_TYPE ( NIL | 0x0000000000000005 ) 92 | #define BLOCK_TYPE ( NIL | 0x0000000000000006 ) 93 | 94 | typedef struct cognate_object 95 | { 96 | union 97 | { 98 | BOX box; 99 | BOOLEAN boolean; 100 | STRING string; 101 | LIST list; 102 | BLOCK block; 103 | SYMBOL symbol; 104 | NUMBER number; 105 | IO io; 106 | TABLE table; 107 | void* ptr; 108 | }; 109 | cognate_type type; 110 | } cognate_object; 111 | 112 | typedef struct cognate_table 113 | { 114 | ANY key; 115 | ANY value; 116 | TABLE left; 117 | TABLE right; 118 | size_t level; 119 | } cognate_table; 120 | 121 | typedef struct cognate_list 122 | { 123 | LIST next; 124 | ANY object; 125 | } cognate_list; 126 | 127 | typedef struct cognate_file 128 | { 129 | STRING path; 130 | STRING mode; 131 | FILE* file; 132 | } cognate_file; 133 | 134 | typedef struct cognate_stack 135 | { 136 | ANYPTR start; // Pointer to start. 137 | ANYPTR top; // Pointer to top. 138 | ANYPTR absolute_start; // For the garbage collector 139 | } cognate_stack; 140 | 141 | #ifdef DEBUG 142 | 143 | typedef struct backtrace 144 | { 145 | const struct backtrace* next; 146 | const char* name; 147 | const size_t line; 148 | const size_t col; 149 | const char* file; 150 | const char* line_str; 151 | } backtrace; 152 | 153 | typedef struct var_info 154 | { 155 | const struct var_info* next; 156 | const char* name; 157 | const ANY value; 158 | } var_info; 159 | 160 | #endif 161 | 162 | #define unlikely(expr) (__builtin_expect((_Bool)(expr), 0)) 163 | #define likely(expr) (__builtin_expect((_Bool)(expr), 1)) 164 | 165 | typedef struct gc_heap { 166 | uintptr_t* start; 167 | uint8_t* bitmap; 168 | size_t alloc; 169 | } gc_heap; 170 | 171 | static gc_heap mutable_space[2]; 172 | static gc_heap space[GC_MAX_HEAPS]; 173 | static int gc_num_heaps = 1; 174 | 175 | static bool mz = 0; 176 | 177 | static _Bool pure = 0; 178 | 179 | // Global variables 180 | static cognate_stack stack; 181 | static LIST cmdline_parameters = NULL; 182 | static void* general_purpose_buffer = NULL; 183 | #ifdef DEBUG 184 | static const backtrace* trace = NULL; 185 | static const var_info* vars = NULL; 186 | #endif 187 | 188 | extern int main(int, char**); 189 | 190 | static const char* function_stack_start; 191 | 192 | static TABLE memoized_regexes = NULL; 193 | 194 | const SYMBOL SYMstart = "start"; 195 | const SYMBOL SYMend = "end"; 196 | const SYMBOL SYMcurrent = "current"; 197 | const SYMBOL SYMread = "read"; 198 | const SYMBOL SYMwrite = "write"; 199 | const SYMBOL SYMappend = "append"; 200 | const SYMBOL SYMreadHwrite = "read-write"; 201 | const SYMBOL SYMreadHappend = "read-append"; 202 | const SYMBOL SYMreadHwriteHexisting = "read-write-existing"; 203 | 204 | // Variables and needed by functions.c defined in runtime.c 205 | static void init_stack(void); 206 | static void init_general_purpose_buffer(void); 207 | static STRING show_object(const ANY object, char*, LIST); 208 | static void _Noreturn __attribute__((format(printf, 1, 2))) throw_error_fmt(const char* const, ...); 209 | static void _Noreturn throw_error(const char* const); 210 | static ptrdiff_t compare_objects(ANY, ANY); 211 | //static _Bool match_objects(ANY, ANY); 212 | static void destructure_lists(LIST, LIST); 213 | static void destructure_objects(ANY, ANY); 214 | #ifdef DEBUG 215 | static void print_backtrace(int, const backtrace*, int); 216 | #endif 217 | 218 | static void* gc_malloc(size_t); 219 | static void* gc_malloc_mutable(size_t); 220 | static void* gc_malloc_on(gc_heap*, size_t); 221 | static void maybe_gc_collect(void); 222 | static void gc_collect(gc_heap*, gc_heap*); 223 | static void gc_collect_cascade(int); 224 | static void gc_collect_mutable(void); 225 | static void gc_init(void); 226 | static char* gc_strdup(char*); 227 | static char* gc_strndup(char*, size_t); 228 | static void gc_mark_ptr(void*); 229 | static void gc_mark_any(ANY*); 230 | static bool any_is_ptr(ANY); 231 | static void gc_bitmap_or(gc_heap*, size_t, uint8_t); 232 | static void gc_bitmap_set(gc_heap*, size_t, uint8_t); 233 | static uint8_t gc_bitmap_get(gc_heap*, size_t); 234 | 235 | // Variables and functions needed by compiled source file defined in runtime.c 236 | static NUMBER unbox_NUMBER(ANY); 237 | static BOX unbox_BOX(ANY); 238 | static ANY box_BOX(BOX); 239 | static ANY box_NUMBER(NUMBER); 240 | static BOOLEAN unbox_BOOLEAN(ANY); 241 | static ANY box_BOOLEAN(BOOLEAN); 242 | static STRING unbox_STRING(ANY); 243 | static ANY box_STRING(STRING); 244 | static LIST unbox_LIST(ANY); 245 | static ANY box_LIST(LIST); 246 | static SYMBOL unbox_SYMBOL(ANY); 247 | static ANY box_SYMBOL(SYMBOL); 248 | static BLOCK unbox_BLOCK(ANY); 249 | static ANY box_BLOCK(BLOCK); 250 | static IO unbox_IO(ANY); 251 | static ANY box_IO(IO); 252 | static TABLE unbox_TABLE(ANY); 253 | static ANY box_TABLE(TABLE); 254 | 255 | static NUMBER early_NUMBER(BOX); 256 | static BOX early_BOX(BOX); 257 | static BOOLEAN early_BOOLEAN(BOX); 258 | static STRING early_STRING(BOX); 259 | static LIST early_LIST(BOX); 260 | static SYMBOL early_SYMBOL(BOX); 261 | static BLOCK early_BLOCK(BOX); 262 | static IO early_IO(BOX); 263 | static TABLE early_TABLE(BOX); 264 | static ANY early_ANY(BOX); 265 | 266 | static NUMBER radians_to_degrees(NUMBER); 267 | static NUMBER degrees_to_radians(NUMBER); 268 | 269 | static void cleanup(void); 270 | static void push(ANY); 271 | static ANY pop(void); 272 | static ANY peek(void); 273 | static int stack_length(void); 274 | 275 | static TABLE mktable(ANY, ANY, TABLE, TABLE, size_t); 276 | 277 | // Builtin functions needed by compiled source file defined in functions.c 278 | static TABLE ___insert(ANY, ANY, TABLE); 279 | static LIST ___empty(void); 280 | static ANY ___if(BOOLEAN, ANY, ANY); 281 | static void ___put(ANY); 282 | static void ___print(ANY); 283 | static NUMBER ___P(NUMBER, NUMBER); 284 | static NUMBER ___M(NUMBER, NUMBER); 285 | static NUMBER ___H(NUMBER, NUMBER); 286 | static NUMBER ___S(NUMBER, NUMBER); 287 | static NUMBER ___C(NUMBER, NUMBER); 288 | static NUMBER ___modulo(NUMBER, NUMBER); 289 | static NUMBER ___sqrt(NUMBER); 290 | static NUMBER ___random(NUMBER, NUMBER); 291 | static void ___clear(void); 292 | static BOOLEAN ___true(void); 293 | static BOOLEAN ___false(void); 294 | static BOOLEAN ___or(BOOLEAN, BOOLEAN); 295 | static BOOLEAN ___and(BOOLEAN, BOOLEAN); 296 | static BOOLEAN ___xor(BOOLEAN, BOOLEAN); 297 | static BOOLEAN ___not(BOOLEAN); 298 | static BOOLEAN ___EE(ANY, ANY); 299 | static BOOLEAN ___L(NUMBER, NUMBER); 300 | static BOOLEAN ___G(NUMBER, NUMBER); 301 | static BOOLEAN ___LE(NUMBER, NUMBER); 302 | static BOOLEAN ___GE(NUMBER, NUMBER); 303 | //static BOOLEAN ___match(ANY, ANY); 304 | static BOOLEAN ___numberQ(ANY); 305 | static BOOLEAN ___symbolQ(ANY); 306 | static BOOLEAN ___listQ(ANY); 307 | static BOOLEAN ___stringQ(ANY); 308 | static BOOLEAN ___blockQ(ANY); 309 | static BOOLEAN ___booleanQ(ANY); 310 | static BOOLEAN ___integerQ(ANY); 311 | static BOOLEAN ___ioQ(ANY); 312 | static BOOLEAN ___zeroQ(ANY); 313 | static BOOLEAN ___tableQ(ANY); 314 | static ANY ___first(ANY); 315 | static ANY ___rest(ANY); 316 | static STRING ___first_STRING(STRING); 317 | static STRING ___rest_STRING(STRING); 318 | static ANY ___first_LIST(LIST); 319 | static LIST ___rest_LIST(LIST); 320 | static STRING ___head(STRING); 321 | static STRING ___tail(STRING); 322 | static LIST ___push(ANY, LIST); 323 | static BOOLEAN ___emptyQ(ANY); 324 | static LIST ___list(BLOCK); 325 | static STRING ___join(STRING, STRING); 326 | static STRING ___substring(NUMBER, NUMBER, STRING); 327 | static STRING ___input(void); 328 | static IO ___open(SYMBOL, STRING); 329 | static void ___close(IO); 330 | static NUMBER ___number(STRING); 331 | static STRING ___path(void); 332 | static LIST ___stack(void); 333 | static LIST ___parameters(void); 334 | static void ___stop(void); 335 | static STRING ___show(ANY); 336 | static STRING ___show_NUMBER(NUMBER); 337 | static STRING ___show_LIST(LIST); 338 | static STRING ___show_BLOCK(BLOCK); 339 | static STRING ___show_TABLE(TABLE); 340 | static STRING ___show_IO(IO); 341 | static STRING ___show_STRING(STRING); 342 | static STRING ___show_SYMBOL(SYMBOL); 343 | static STRING ___show_BOOLEAN(BOOLEAN); 344 | static STRING ___show_BOX(BOX); 345 | 346 | static BOOLEAN ___regex(STRING, STRING); 347 | static BOOLEAN ___regexHmatch(STRING, STRING); 348 | static NUMBER ___ordinal(STRING); 349 | static STRING ___character(NUMBER); 350 | static NUMBER ___floor(NUMBER); 351 | static NUMBER ___round(NUMBER); 352 | static NUMBER ___ceiling(NUMBER); 353 | static NUMBER ___abs(NUMBER); 354 | static void ___error(STRING); 355 | //static BLOCK ___precompute(BLOCK); 356 | static void ___wait(NUMBER); 357 | static LIST ___split(STRING, STRING); 358 | //static BLOCK ___remember(BLOCK); 359 | 360 | static NUMBER ___sind(NUMBER); 361 | static NUMBER ___cosd(NUMBER); 362 | static NUMBER ___tand(NUMBER); 363 | static NUMBER ___sin(NUMBER); 364 | static NUMBER ___cos(NUMBER); 365 | static NUMBER ___tan(NUMBER); 366 | 367 | static NUMBER ___exp(NUMBER); 368 | static NUMBER ___log(NUMBER, NUMBER); 369 | static NUMBER ___ln(NUMBER); 370 | 371 | static NUMBER ___asind(NUMBER); 372 | static NUMBER ___acosd(NUMBER); 373 | static NUMBER ___atand(NUMBER); 374 | static NUMBER ___asin(NUMBER); 375 | static NUMBER ___acos(NUMBER); 376 | static NUMBER ___atan(NUMBER); 377 | 378 | static NUMBER ___sinhd(NUMBER); 379 | static NUMBER ___coshd(NUMBER); 380 | static NUMBER ___tanhd(NUMBER); 381 | static NUMBER ___sinh(NUMBER); 382 | static NUMBER ___cosh(NUMBER); 383 | static NUMBER ___tanh(NUMBER); 384 | 385 | static const char *lookup_type(cognate_type); 386 | static ptrdiff_t compare_lists(LIST, LIST); 387 | static ptrdiff_t compare_tables(TABLE, TABLE); 388 | static _Bool match_lists(LIST, LIST); 389 | static void handle_error_signal(int, siginfo_t*, void *); 390 | static void assert_impure(void); 391 | 392 | #ifdef DEBUG 393 | static _Bool debug = 0; 394 | static size_t next_count = 0; 395 | static size_t debug_lineno = 0; 396 | #endif 397 | 398 | static int _argc; 399 | static char** _argv; 400 | 401 | static void fn0(void); 402 | 403 | int main(int argc, char** argv) 404 | { 405 | function_stack_start = __builtin_frame_address(0); 406 | _argc = argc; 407 | _argv = argv; 408 | // Set locale for strings. 409 | if unlikely(setlocale(LC_ALL, "") == NULL) 410 | { 411 | throw_error("Cannot set locale"); 412 | } 413 | // Init GC 414 | gc_init(); 415 | // Seed the random number generator properly. 416 | struct timespec ts; 417 | if unlikely(clock_gettime(CLOCK_REALTIME, &ts) == -1) 418 | { 419 | throw_error("Cannot get system time"); 420 | } 421 | srand(ts.tv_nsec ^ ts.tv_sec); // TODO make random more random. 422 | // Load parameters 423 | while (argc --> 1) cmdline_parameters = ___push(box_STRING(argv[argc]), cmdline_parameters); 424 | // Bind error signals. 425 | struct sigaction error_signal_action; 426 | error_signal_action.sa_sigaction = handle_error_signal; 427 | sigemptyset(&error_signal_action.sa_mask); 428 | error_signal_action.sa_flags = SA_SIGINFO; 429 | char signals[] = { SIGHUP, SIGINT, SIGQUIT, SIGILL, SIGABRT, SIGBUS, SIGFPE, SIGPIPE, SIGTERM, SIGCHLD, SIGSEGV }; 430 | for (size_t i = 0; i < sizeof(signals); ++i) 431 | if (sigaction(signals[i], &error_signal_action, NULL) == -1) throw_error("couldn't install signal handler"); 432 | // Allocate buffer for object printing 433 | init_general_purpose_buffer(); 434 | // Initialize the stack. 435 | init_stack(); 436 | #ifdef DEBUG 437 | if (getenv("COG_DEBUG")) debug=1; 438 | #endif 439 | fn0(); 440 | cleanup(); 441 | } 442 | 443 | static void cleanup(void) 444 | { 445 | if unlikely(stack.top != stack.start) 446 | throw_error_fmt("Exiting with %ti object(s) on the stack", stack.top - stack.start); 447 | } 448 | 449 | #ifdef DEBUG 450 | 451 | #define BACKTRACE_PUSH(NAME, LINE, COL, FILE, LINE_STR, ID) \ 452 | const backtrace _trace_##LINE##_##COL##_##ID = (backtrace) {.name = NAME, .line = (LINE), .col = (COL), .file = (FILE), .line_str=(LINE_STR), .next=trace}; \ 453 | trace = &_trace_##LINE##_##COL##_##ID; 454 | 455 | #define BACKTRACE_POP() \ 456 | trace = trace->next; 457 | 458 | /* 459 | #define VARS_PUSH(NAME, CNAME, VALUE) \ 460 | const var_info _varinfo_##CNAME = (var_info) {.name = NAME, .value = VALUE, .next=vars}; \ 461 | vars = &_varinfo_##CNAME; 462 | 463 | #define VARS_POP() \ 464 | vars = vars->next; 465 | 466 | static void debugger_step() 467 | { 468 | if likely(!debug) return; 469 | if (next_count > 0) 470 | { 471 | next_count--; 472 | return; 473 | } 474 | print_backtrace(1, trace); 475 | ask: 476 | fputs("\033[0;33m\033[0m ", stderr); 477 | char buf[257] = {0}; 478 | fgets(buf, 256, stdin); 479 | if (feof(stdin)) exit(EXIT_SUCCESS); 480 | if (*buf == '\n') goto ask; 481 | char op[65] = "\0"; 482 | unsigned long int_arg = 0; 483 | char str_arg[129] = {0}; 484 | sscanf(buf, "%64s %lu", op, &int_arg); 485 | sscanf(buf, "%64s %128s", op, str_arg); 486 | switch (*op) 487 | { 488 | case 'h': case 'H': 489 | // Help 490 | fputs("Usage:\n" 491 | "\tq \t\033[0;1mquit\033[0m the debugger\n" 492 | "\th \tshow this \033[0;1mhelp\033[0m message\n" 493 | "\ts [n] \tshow (n items of) the \033[0;1mstack\033[0m\n" 494 | "\tc \t\033[0;1mcontinue\033[0m execution\n" 495 | "\tr \t\033[0;1mrestart\033[0m the program\n" 496 | "\tn [n] \tgo to \033[0;1mnext\033[0m (n) tokens\n" 497 | "\tt [n] \tprint (n items of) a back\033[0;1mtrace\033[0m\n" 498 | "\tl \t\033[0;1mlist\033[0m the source program\n" 499 | "\tb [n] \tset \033[0;1mbreakpoint\033[0m on line n\n" 500 | "\td [n] \t\033[0;1mdelete\033[0m breakpoint on line n\n" 501 | "\tv [name]\tshow \033[0;1mvariable\033[0m of name\n", stderr); 502 | break; 503 | case 'r': case 'R': 504 | // Restart 505 | debug = 0; 506 | trace = NULL; 507 | vars = NULL; 508 | fn0(NULL); 509 | exit(EXIT_SUCCESS); 510 | case 's': case 'S': 511 | // Stack 512 | for (ANY* a = stack.top - 1; a >= stack.start; --a) 513 | { 514 | fputs(show_object(*a, 0, NULL), stderr); 515 | fputc('\n', stderr); 516 | } 517 | break; 518 | case 'c': case 'C': 519 | // Continue 520 | debug = 0; 521 | return; 522 | case 'n': case 'N': 523 | // Next 524 | if (int_arg) 525 | next_count = int_arg - 1; 526 | return; 527 | case 't': case 'T': 528 | // Trace 529 | if (int_arg) 530 | print_backtrace(int_arg, trace); 531 | else print_backtrace(5, trace); 532 | break; 533 | case 'l': case 'L': 534 | // List TODO handle argument 535 | // TODO highlight current identifier like in traces 536 | for (size_t i = 0; source_file_lines[i]; ++i) 537 | { 538 | int broken = breakpoints[i]; 539 | fprintf(stderr, "\033[0;2m[%3zi] %s\033[0m ", i+1, broken?"\033[0;33m*":" "); 540 | if (trace->line == i+1) 541 | { 542 | size_t len = strlen(trace->name); 543 | char* ln = source_file_lines[i]; 544 | fprintf(stderr, "%.*s\033[0;1m%.*s\033[0;0m%s", 545 | (int)(trace->col - len - 1), ln, 546 | (int)len, ln + trace->col - len - 1, 547 | ln + trace->col - 1); 548 | } 549 | else fputs(source_file_lines[i], stderr); 550 | fputc('\n', stderr); 551 | } 552 | break; 553 | case 'q': case 'Q': 554 | // Quit 555 | fputs("Exiting...\n", stderr); 556 | exit (EXIT_SUCCESS); 557 | case 'b': case 'B': 558 | //if (int_arg > source_line_num) // TODO 559 | // fprintf(stderr, "Line %zi is beyond end of file.\n", int_arg); 560 | if (int_arg) breakpoints[int_arg-1] = 1; 561 | else breakpoints[trace->line-1] = 1; 562 | break; 563 | case 'v': case 'V':; 564 | char* s = str_arg; 565 | for (size_t i = 0; i < strlen(s); ++i) 566 | s[i] = tolower(s[i]); 567 | if (!*s) 568 | { 569 | fputs("Usage: v [NAME]\n", stderr); 570 | break; 571 | } 572 | for (const var_info* v = vars; v; v = v->next) 573 | { 574 | if (!strcmp(v->name, str_arg)) 575 | { 576 | fprintf(stderr, "%c%s = %s\n", toupper(*s), s+1, show_object(v->value, 0, NULL)); 577 | goto ask; 578 | } 579 | } 580 | fprintf(stderr, "No variable '%c%s' found\nNote: debug variables are dynamically scoped\n", toupper(*s), s+1); 581 | break; 582 | case 'd': case 'D': 583 | // Delete breakpoint 584 | if (!int_arg) fputs("Usage: d [LINE]\n", stderr); 585 | else breakpoints[int_arg-1] = 0; 586 | break; 587 | default: 588 | fprintf(stderr, "Invalid command '%s'\n", op); 589 | break; 590 | } 591 | goto ask; 592 | } 593 | 594 | static void check_breakpoint(size_t line) 595 | { 596 | debug |= unlikely(breakpoints[line-1]); 597 | } 598 | 599 | */ 600 | 601 | static void print_backtrace(int n, const backtrace* b, int last_spaces) 602 | { 603 | if (!b || !n || !b->name || !b->line_str) return; 604 | int len = strlen(b->name); 605 | char* ln = strdup(b->line_str); 606 | char* tabs = ln; 607 | ssize_t col = b->col; 608 | while (*ln) 609 | { 610 | if (*ln != ' ' && *ln != '\t') break; 611 | ln++; 612 | col--; 613 | } 614 | for ( ; *tabs ; tabs++) if (*tabs == '\t') *tabs = ' '; 615 | char pos[128]; 616 | sprintf(pos, "[%s %zi:%zi]", b->file, b->line, b->col); 617 | int spaces = (strlen(pos)) + col - len/2 - 1; 618 | if (last_spaces) 619 | { 620 | fputs("\033[31;1m", stderr); 621 | if (last_spaces + 2 < spaces) 622 | { 623 | for (int i = 0 ; i < last_spaces+1 ; ++i) fputs(" ", stderr); 624 | fputs("\\", stderr); 625 | for (int i = last_spaces+1 ; i < spaces-2 ; ++i) fputs("_", stderr); 626 | fputs("\n", stderr); 627 | for (int i = 0 ; i < spaces-1 ; ++i) fputs(" ", stderr); 628 | fputs("\\\n", stderr); 629 | } 630 | else if (last_spaces > spaces + 2) 631 | { 632 | for (int i = 0 ; i < spaces+2 ; ++i) fputs(" ", stderr); 633 | for (int i = spaces+2 ; i < last_spaces-1 ; ++i) fputs("_", stderr); 634 | fputs("/\n", stderr); 635 | for (int i = 0 ; i < spaces+1 ; ++i) fputs(" ", stderr); 636 | fputs("/\n", stderr); 637 | } 638 | else 639 | { 640 | for (int i = 0 ; i < spaces-1 ; ++i) fputs(" ", stderr); 641 | if (last_spaces < spaces) fputs("\\\n", stderr); 642 | else if (last_spaces > spaces) fputs(" /\n", stderr); 643 | else fputs(" |\n", stderr); 644 | } 645 | fputs("\033[0m", stderr); 646 | } 647 | fprintf(stderr, "\033[0;2m%s\033[0m %.*s\033[31;1m%.*s\033[0m%s\n", 648 | pos, 649 | (int)(col - len - 1), ln, 650 | len, ln + col - len - 1, 651 | ln + col - 1); 652 | if (n <= 1) 653 | { 654 | for (int i = 0 ; i < spaces ; ++i) fputs(" ", stderr); 655 | fputs("\033[31;1m^\033[0m\n", stderr); 656 | } 657 | else print_backtrace(n - 1, b->next, spaces); 658 | } 659 | #endif 660 | 661 | static _Noreturn __attribute__((format(printf, 1, 2))) void throw_error_fmt(const char* const fmt, ...) 662 | { 663 | char buf[1024]; 664 | fputs("\n\n\033[31;1m ", stderr); 665 | va_list args; 666 | va_start(args, fmt); 667 | vsprintf(buf, fmt, args); 668 | va_end(args); 669 | fputs(buf, stderr); 670 | fputs("\n", stderr); 671 | #ifndef DEBUG 672 | fputs("\n\033[0m", stderr); 673 | #else 674 | print_backtrace(10, trace, strlen(buf)/2 + 4); 675 | /* 676 | if (isatty(fileno(stdin))) 677 | { 678 | debug = 1; 679 | debugger_step(); 680 | } else print_backtrace(5, trace); 681 | */ 682 | #endif 683 | exit(EXIT_FAILURE); 684 | } 685 | 686 | static _Noreturn void throw_error(const char* const msg) 687 | { 688 | throw_error_fmt("%s", msg); 689 | } 690 | 691 | static void handle_error_signal(int sig, siginfo_t *info, void *ucontext) 692 | { 693 | if (sig == SIGSEGV) 694 | { 695 | char* addr = (char*)info->si_addr; 696 | if (addr >= (char*)stack.absolute_start && addr <= (char*)stack.absolute_start + ALLOC_SIZE) 697 | throw_error_fmt("Stack overflow (%zu items on the stack)", stack.top - stack.absolute_start); 698 | else 699 | throw_error("Memory error"); 700 | } 701 | else throw_error_fmt("Received signal %i (%s)", sig, strsignal(sig)); 702 | } 703 | 704 | static cognate_type type_of(ANY a) 705 | { 706 | if ((NIL & a) != NIL) return NUMBER_TYPE; 707 | if ((STRING_TYPE & a) == STRING_TYPE) return STRING_TYPE; 708 | if ((SYMBOL_TYPE & a) == SYMBOL_TYPE) return SYMBOL_TYPE; 709 | return (cognate_type)(a & TYPE_MASK); 710 | } 711 | 712 | static void assert_impure(void) 713 | { 714 | if unlikely(pure) throw_error("Invalid operation for pure function"); 715 | } 716 | 717 | TABLE table_skew(TABLE T) 718 | { 719 | // input: T, a node representing an AA tree that needs to be rebalanced. 720 | // output: Another node representing the rebalanced AA tree. 721 | if (!T) return NULL; 722 | else if (!T->left) return T; 723 | else if (T->left->level == T->level) 724 | return 725 | mktable(T->left->key, T->left->value, T->left->left, 726 | mktable(T->key, T->value, T->left->right, T->right, T->level), 727 | T->left->level); 728 | /* 729 | else if (T->right && T->right->left && T->right && T->right->left->level == T->right->level) 730 | { 731 | TABLE c = (TABLE)T->right; 732 | T->right = table_skew(c); 733 | } 734 | */ 735 | return T; 736 | } 737 | 738 | TABLE table_split(TABLE T) 739 | { 740 | // input: T, a node representing an AA tree that needs to be rebalanced. 741 | // output: Another node representing the rebalanced AA tree. 742 | if (!T) return NULL; 743 | else if (!T->right || !T->right->right) return T; 744 | else if (T->level == T->right->right->level) 745 | return 746 | mktable(T->right->key, T->right->value, 747 | mktable(T->key, T->value, T->left, T->right->left, T->level), 748 | T->right->right, T->right->level); 749 | else return T; 750 | } 751 | 752 | static char* show_table_helper(TABLE d, char* buffer, LIST checked) 753 | { 754 | if (!d) return buffer; 755 | 756 | buffer = show_table_helper(d->left, buffer, checked); 757 | 758 | buffer = (char*)show_object(d->key, buffer, checked); 759 | *buffer++ = ':'; 760 | buffer = (char*)show_object(d->value, buffer, checked); 761 | *buffer++ = ' '; 762 | 763 | buffer = show_table_helper(d->right, buffer, checked); 764 | 765 | return buffer; 766 | } 767 | 768 | static char* show_table(TABLE d, char* buffer, LIST checked) 769 | { 770 | *buffer++ = '{'; 771 | *buffer++ = ' '; 772 | buffer = show_table_helper(d, buffer, checked); 773 | *buffer++ = '}'; 774 | *buffer = '\0'; 775 | return buffer; 776 | } 777 | 778 | static char* show_io(IO i, char* buffer) 779 | { 780 | if (i->file != NULL) 781 | return buffer + sprintf(buffer, "{ %s OPEN mode '%s' }", i->path, i->mode); 782 | else 783 | return buffer + sprintf(buffer, "{ %s CLOSED }", i->path); 784 | } 785 | 786 | static char* show_string(STRING s, char* buffer) 787 | { 788 | *buffer++ = '"'; 789 | for (const char* str = s ; *str ; ++str) 790 | { 791 | char c = *str; 792 | if unlikely(c >= '\a' && c <= '\r') 793 | { 794 | *buffer++ = '\\'; 795 | *buffer++ = "abtnvfr"[c-'\a']; 796 | } 797 | else if (c == '\\') { *buffer++ = '\\'; *buffer++ = '\\'; } 798 | else if (c == '"') { *buffer++ = '\\'; *buffer++ = '"'; } 799 | else *buffer++ = c; 800 | } 801 | *buffer++ = '"'; 802 | *buffer = '\0'; 803 | return buffer; 804 | } 805 | 806 | static char* show_number(NUMBER n, char* buffer) 807 | { 808 | return buffer + sprintf(buffer, "%.14g", n); 809 | } 810 | 811 | static char* show_list(LIST l, char* buffer, LIST checked) 812 | { 813 | *buffer++ = '('; 814 | for ( ; l ; l = l->next) 815 | { 816 | buffer = (char*)show_object(l->object, buffer, checked); 817 | if (!l->next) break; 818 | //*buffer++ = ','; 819 | *buffer++ = ' '; 820 | } 821 | *buffer++ = ')'; 822 | *buffer = '\0'; 823 | return buffer; 824 | } 825 | 826 | static char* show_boolean(BOOLEAN b, char* buffer) 827 | { 828 | return buffer + sprintf(buffer, "%s", b ? "True" : "False"); 829 | } 830 | 831 | static char* show_symbol(SYMBOL s, char* buffer) 832 | { 833 | return buffer + sprintf(buffer, "%s", s); 834 | } 835 | 836 | static char* show_block(BLOCK b, char* buffer) 837 | { 838 | void (*fn)(ANY*) = b->fn; 839 | return buffer + sprintf(buffer, "", *(void**)&fn); 840 | } 841 | 842 | static char* show_box(BOX b, char* buffer, LIST checked) 843 | { 844 | bool found = false; 845 | for (LIST l = checked ; l ; l = l->next) 846 | if ((BOX)(l->object & PTR_MASK) == b) 847 | { 848 | *buffer++ = '.'; 849 | *buffer++ = '.'; 850 | *buffer++ = '.'; 851 | goto end; 852 | } 853 | checked = (cognate_list*)___push(box_BOX(b), checked); 854 | *buffer++ = '['; 855 | buffer = (char*)show_object(*b, buffer, checked); 856 | *buffer++ = ']'; 857 | checked = (cognate_list*)___rest_LIST(checked); 858 | end: 859 | *buffer = '\0'; 860 | return buffer; 861 | } 862 | 863 | static STRING show_object (const ANY object, char* buffer, LIST checked) 864 | { 865 | switch (type_of(object)) 866 | { 867 | case NIL: throw_error("This shouldn't happen"); break; 868 | case NUMBER_TYPE: buffer = show_number (*(NUMBER*)&object, buffer); break; 869 | case IO_TYPE: buffer = show_io ((IO) (object & PTR_MASK), buffer); break; 870 | case BOOLEAN_TYPE: buffer = show_boolean((BOOLEAN) (object & PTR_MASK), buffer); break; 871 | case STRING_TYPE: buffer = show_string ((STRING) (object & UNALIGNED_PTR_MASK), buffer); break; 872 | case SYMBOL_TYPE: buffer = show_symbol ((SYMBOL) (object & UNALIGNED_PTR_MASK), buffer); break; 873 | case BLOCK_TYPE: buffer = show_block ((BLOCK) (object & PTR_MASK), buffer); break; 874 | case TABLE_TYPE: buffer = show_table ((TABLE) (object & PTR_MASK), buffer, checked); break; 875 | case LIST_TYPE: buffer = show_list ((LIST) (object & PTR_MASK), buffer, checked); break; 876 | case BOX_TYPE: buffer = show_box ((BOX) (object & PTR_MASK), buffer, checked); break; 877 | } 878 | return buffer; 879 | } 880 | 881 | static void init_general_purpose_buffer(void) 882 | { 883 | general_purpose_buffer = mmap(ALLOC_START, ALLOC_SIZE, MEM_PROT, MEM_FLAGS, -1, 0); 884 | } 885 | 886 | static void init_stack(void) 887 | { 888 | stack.absolute_start = stack.top = stack.start 889 | = mmap(ALLOC_START, ALLOC_SIZE, MEM_PROT, MEM_FLAGS, -1, 0); 890 | } 891 | 892 | __attribute__((hot)) 893 | static void push(ANY object) 894 | { 895 | *stack.top++ = object; 896 | } 897 | 898 | __attribute__((hot)) 899 | static ANY pop(void) 900 | { 901 | if unlikely(stack.top == stack.start) throw_error("Stack underflow"); 902 | return *--stack.top; 903 | } 904 | 905 | __attribute__((hot)) 906 | static ANY peek(void) 907 | { 908 | if unlikely(stack.top == stack.start) throw_error("Stack underflow"); 909 | return *(stack.top - 1); 910 | } 911 | 912 | static int stack_length(void) 913 | { 914 | return stack.top - stack.start; 915 | } 916 | 917 | static const char* lookup_type(cognate_type type) 918 | { 919 | switch(type) 920 | { 921 | case NIL: return "nil"; 922 | case BOX_TYPE: return "box"; 923 | case STRING_TYPE: return "string"; 924 | case NUMBER_TYPE: return "number"; 925 | case LIST_TYPE: return "list"; 926 | case BLOCK_TYPE: return "block"; 927 | case SYMBOL_TYPE: return "symbol"; 928 | case BOOLEAN_TYPE: return "boolean"; 929 | default: return NULL; 930 | } 931 | } 932 | 933 | static ptrdiff_t compare_lists(LIST lst1, LIST lst2) 934 | { 935 | if (lst1 == lst2) return 0; 936 | if (!lst1) return -!!lst2; 937 | if (!lst2) return 1; 938 | ptrdiff_t diff; 939 | while (!(diff = compare_objects(lst1->object, lst2->object))) 940 | { 941 | if (!lst1->next) return -!!lst2->next; 942 | if (!lst2->next) return 1; 943 | lst1 = lst1 -> next; 944 | lst2 = lst2 -> next; 945 | } 946 | return diff; 947 | } 948 | 949 | static ptrdiff_t compare_tables(TABLE t1, TABLE t2) 950 | { 951 | if (!t1) return -!!t2; 952 | if (!t2) return 1; 953 | 954 | ptrdiff_t diff; 955 | 956 | if ((diff = compare_objects(t1->key, t2->key))) return diff; 957 | if ((diff = compare_objects(t1->value, t2->value))) return diff; 958 | if ((diff = compare_tables(t1->left, t2->left))) return diff; 959 | 960 | return compare_tables(t1->right, t2->right); 961 | } 962 | 963 | static ptrdiff_t compare_blocks(BLOCK b1, BLOCK b2) 964 | { 965 | return b1 - b2; 966 | } 967 | 968 | #define FLOAT_MAX_ULPS 4 // Arbitrarily chosen - higher is more tolerant 969 | 970 | static ptrdiff_t compare_numbers(NUMBER n1, NUMBER n2) 971 | { 972 | // Floating point maths is rather difficult. 973 | // This solution is usually better than the naive comparison that most languages use. 974 | // But if correctness is important one should implement their own comparison operator. 975 | // Def Exact== as ( Let N1 ; Let N2 ; Both <= N1 N2 and <= N2 N1 ); 976 | ptrdiff_t diff = *(uint64_t*)&n1 - *(uint64_t*)&n2; 977 | return diff / (FLOAT_MAX_ULPS + 1); 978 | } 979 | 980 | static ptrdiff_t compare_strings(STRING s1, STRING s2) 981 | { 982 | return strcmp(s1, s2); 983 | } 984 | 985 | static ptrdiff_t compare_io(IO i1, IO i2) 986 | { 987 | return i1->file - i2->file; 988 | } 989 | 990 | static ptrdiff_t compare_booleans(BOOLEAN b1, BOOLEAN b2) 991 | { 992 | return (ptrdiff_t)b1 - (ptrdiff_t)b2; 993 | } 994 | 995 | static ptrdiff_t compare_boxes(BOX b1, BOX b2) 996 | { 997 | return b1 - b2; 998 | } 999 | 1000 | static ptrdiff_t compare_symbols(SYMBOL s1, SYMBOL s2) 1001 | { 1002 | return s1 - s2; 1003 | } 1004 | 1005 | static ptrdiff_t compare_objects(ANY ob1, ANY ob2) 1006 | { 1007 | // TODO this function should be overloaded 1008 | cognate_type t1 = type_of(ob1); 1009 | cognate_type t2 = type_of(ob2); 1010 | if (t1 != t2) return (ptrdiff_t)t1 - (ptrdiff_t)t2; 1011 | //if (memcmp(&ob1, &ob2, sizeof ob1) == 0) return 0; 1012 | switch (t1) 1013 | { 1014 | case NUMBER_TYPE: return compare_numbers(*(NUMBER*)&ob1, *(NUMBER*)&ob2); 1015 | case STRING_TYPE: return compare_strings((STRING)(ob1 & UNALIGNED_PTR_MASK), (STRING)(ob2 & UNALIGNED_PTR_MASK)); 1016 | case LIST_TYPE: return compare_lists((LIST)(ob1 & PTR_MASK), (LIST)(ob2 & PTR_MASK)); 1017 | case BLOCK_TYPE: return compare_blocks((BLOCK)(ob1 & PTR_MASK), (BLOCK)(ob2 & PTR_MASK)); 1018 | case TABLE_TYPE: return compare_tables((TABLE)(ob1 & PTR_MASK), (TABLE)(ob2 & PTR_MASK)); 1019 | case IO_TYPE: return compare_io((IO)(ob1 & PTR_MASK), ((IO)(ob2 & PTR_MASK))); 1020 | case BOOLEAN_TYPE: return compare_booleans((BOOLEAN)(ob1 & PTR_MASK), (BOOLEAN)(ob2 & PTR_MASK)); 1021 | case BOX_TYPE: return compare_boxes((BOX)(ob1 & PTR_MASK), (BOX)(ob2 & PTR_MASK)); 1022 | case SYMBOL_TYPE: return compare_symbols((SYMBOL)(ob1 & UNALIGNED_PTR_MASK), (SYMBOL)(ob2 & UNALIGNED_PTR_MASK)); 1023 | default: return 0; // really shouldn't happen 1024 | /* NOTE 1025 | * The garbage collector *will* reorder objects in memory, 1026 | * which means that the relative addresses of blocks and boxes 1027 | * *will* change - which is why these can't be used to index tables 1028 | * for example. 1029 | */ 1030 | } 1031 | } 1032 | 1033 | static void call_block(BLOCK b) 1034 | { 1035 | b->fn((ANY*)&b->env); 1036 | } 1037 | 1038 | 1039 | 1040 | /* 1041 | static _Bool match_lists(LIST lst1, LIST lst2) 1042 | { 1043 | if (!lst1) return !lst2; 1044 | if (!lst2) return 0; 1045 | while (match_objects(lst1->object, lst2->object)) 1046 | { 1047 | if (!lst1->next) return !lst2->next; 1048 | if (!lst2->next) return 0; 1049 | lst1 = lst1 -> next; 1050 | lst2 = lst2 -> next; 1051 | } 1052 | return 0; 1053 | } 1054 | 1055 | static _Bool match_objects(ANY patt, ANY obj) 1056 | { 1057 | cognate_type T = patt.type; 1058 | if (T == block) 1059 | { 1060 | push (obj); 1061 | call_block(unbox_BLOCK(patt)); 1062 | return unbox_BOOLEAN(pop()); 1063 | } 1064 | else if (T != obj.type) return 0; 1065 | switch (T) 1066 | { 1067 | case number: 1068 | return fabs(unbox_NUMBER(patt) - unbox_NUMBER(obj)) 1069 | <= 0.5e-14 * fabs(unbox_NUMBER(patt)); 1070 | case boolean: return unbox_BOOLEAN(patt) == unbox_BOOLEAN(obj); 1071 | case string: return !strcmp(unbox_STRING(patt), unbox_STRING(obj)); 1072 | case symbol: return unbox_SYMBOL(patt) == unbox_SYMBOL(obj); 1073 | case list: return match_lists(unbox_LIST(patt), unbox_LIST(obj)); 1074 | case box: return match_objects(*unbox_BOX(patt), *unbox_BOX(obj)); 1075 | default: return 0; // really shouldn't happen 1076 | } 1077 | } 1078 | 1079 | 1080 | static void destructure_lists(LIST patt, LIST obj) 1081 | { 1082 | if (!patt) return; 1083 | destructure_lists(patt->next, obj->next); 1084 | destructure_objects(patt->object, obj->object); 1085 | } 1086 | 1087 | static void destructure_objects(ANY patt, ANY obj) 1088 | { 1089 | if (patt.type == block) 1090 | { 1091 | push(obj); 1092 | return; 1093 | } 1094 | switch (patt.type) 1095 | { 1096 | case list: destructure_lists(unbox_LIST(patt), unbox_LIST(obj)); break; 1097 | case box: destructure_objects(*unbox_BOX(patt), *unbox_BOX(obj)); break; 1098 | default:; 1099 | } 1100 | 1101 | } 1102 | */ 1103 | 1104 | static _Noreturn void type_error(char* expected, ANY got) 1105 | { 1106 | char* s = "a"; 1107 | switch (expected[0]) 1108 | case 'a': case 'e': case 'i': case 'o': case 'u': case 'h': 1109 | s = "an"; 1110 | throw_error_fmt("Expected %s %s but got %.64s", s, expected, ___show(got)); 1111 | } 1112 | 1113 | __attribute__((hot)) 1114 | static NUMBER unbox_NUMBER(ANY b) 1115 | { 1116 | if likely((b & NIL) != NIL) 1117 | return *(NUMBER*)&b; 1118 | type_error("number", b); 1119 | #ifdef __TINYC__ 1120 | return 0.0; 1121 | #endif 1122 | } 1123 | 1124 | __attribute__((hot)) 1125 | static ANY box_NUMBER(NUMBER num) 1126 | { 1127 | return *(ANY*)# 1128 | } 1129 | 1130 | __attribute__((hot)) 1131 | static BOX unbox_BOX(ANY b) 1132 | { 1133 | if likely((b & TYPE_MASK) == BOX_TYPE) 1134 | return (BOX)(b & PTR_MASK); 1135 | type_error("box", b); 1136 | #ifdef __TINYC__ 1137 | return NULL; 1138 | #endif 1139 | } 1140 | 1141 | __attribute__((hot)) 1142 | static ANY box_BOX(BOX b) 1143 | { 1144 | return BOX_TYPE | (ANY)b; 1145 | } 1146 | 1147 | __attribute__((hot)) 1148 | static BOOLEAN unbox_BOOLEAN(ANY b) 1149 | { 1150 | if likely((b & TYPE_MASK) == BOOLEAN_TYPE) 1151 | return (BOOLEAN)(b & PTR_MASK); 1152 | type_error("boolean", b); 1153 | #ifdef __TINYC__ 1154 | return 0; 1155 | #endif 1156 | } 1157 | 1158 | __attribute__((hot)) 1159 | static ANY box_BOOLEAN(BOOLEAN b) 1160 | { 1161 | return BOOLEAN_TYPE | (ANY)(0x8 * (b != false)); 1162 | } 1163 | 1164 | __attribute__((hot)) 1165 | static STRING unbox_STRING(ANY b) 1166 | { 1167 | if likely((b & STRING_TYPE) == STRING_TYPE) 1168 | return (STRING)(b & UNALIGNED_PTR_MASK); 1169 | type_error("string", b); 1170 | #ifdef __TINYC__ 1171 | return NULL; 1172 | #endif 1173 | } 1174 | 1175 | __attribute__((hot)) 1176 | static ANY box_STRING(STRING s) 1177 | { 1178 | return STRING_TYPE | (ANY)s; 1179 | } 1180 | 1181 | __attribute__((hot)) 1182 | static LIST unbox_LIST(ANY b) 1183 | { 1184 | if likely((b & TYPE_MASK) == LIST_TYPE) 1185 | return (LIST)(b & PTR_MASK); 1186 | type_error("list", b); 1187 | #ifdef __TINYC__ 1188 | return NULL; 1189 | #endif 1190 | } 1191 | 1192 | __attribute__((hot)) 1193 | static ANY box_LIST(LIST l) 1194 | { 1195 | return LIST_TYPE | (ANY)l; 1196 | } 1197 | 1198 | __attribute__((hot)) 1199 | static SYMBOL unbox_SYMBOL(ANY b) 1200 | { 1201 | if likely((b & SYMBOL_TYPE) == SYMBOL_TYPE) 1202 | return (SYMBOL)(b & UNALIGNED_PTR_MASK); 1203 | type_error("list", b); 1204 | #ifdef __TINYC__ 1205 | return NULL; 1206 | #endif 1207 | } 1208 | 1209 | __attribute__((hot)) 1210 | static ANY box_SYMBOL(SYMBOL s) 1211 | { 1212 | return SYMBOL_TYPE | (ANY)s; 1213 | } 1214 | 1215 | __attribute__((hot)) 1216 | static BLOCK unbox_BLOCK(ANY b) 1217 | { 1218 | if likely((b & TYPE_MASK) == BLOCK_TYPE) 1219 | return (BLOCK)(b & PTR_MASK); 1220 | type_error("block", b); 1221 | #ifdef __TINYC__ 1222 | return NULL; 1223 | #endif 1224 | } 1225 | 1226 | /* 1227 | BLOCK block_copy(BLOCK b) 1228 | { 1229 | size_t i = 0; 1230 | for (; b->env[i] ; ++i); 1231 | BLOCK B = gc_malloc(sizeof(b->fn) + (i + 1) * (sizeof b->env[0]) + i * sizeof(ANY)); 1232 | uint64_t* buf = (uint64_t*)B + i + 2; 1233 | for (size_t i = 0; b->env[i] ; ++i) 1234 | { 1235 | B->env[i] = buf++; 1236 | *(uint64_t*)(B->env[i]) = *(uint64_t*)(b->env[i]); 1237 | } 1238 | B->env[i] = NULL; 1239 | B->fn = b->fn; 1240 | return B; 1241 | } 1242 | */ 1243 | __attribute__((hot)) 1244 | static ANY box_BLOCK(BLOCK b) 1245 | { 1246 | return BLOCK_TYPE | (ANY)b; 1247 | } 1248 | 1249 | __attribute__((hot)) 1250 | static ANY box_IO(IO i) 1251 | { 1252 | return IO_TYPE | (ANY)i; 1253 | } 1254 | 1255 | 1256 | __attribute__((hot)) 1257 | static IO unbox_IO(ANY b) 1258 | { 1259 | if likely((b & TYPE_MASK) == IO_TYPE) 1260 | return (IO)(b & PTR_MASK); 1261 | type_error("io", b); 1262 | #ifdef __TINYC__ 1263 | return NULL; 1264 | #endif 1265 | } 1266 | 1267 | __attribute__((hot)) 1268 | static ANY box_TABLE(TABLE d) 1269 | { 1270 | return TABLE_TYPE | (ANY)d; 1271 | } 1272 | 1273 | __attribute__((hot)) 1274 | static TABLE unbox_TABLE(ANY b) 1275 | { 1276 | if likely((b & TYPE_MASK) == TABLE_TYPE) 1277 | return (TABLE)(b & PTR_MASK); 1278 | type_error("table", b); 1279 | #ifdef __TINYC__ 1280 | return NULL; 1281 | #endif 1282 | } 1283 | 1284 | __attribute__((hot)) 1285 | static TABLE early_TABLE(BOX box) 1286 | { 1287 | ANY a = *box; 1288 | if likely (a != NIL) return (TABLE) (a & PTR_MASK); 1289 | throw_error("Used before definition"); 1290 | #ifdef __TINYC__ 1291 | return NULL; 1292 | #endif 1293 | } 1294 | 1295 | __attribute__((hot)) 1296 | static LIST early_LIST(BOX box) 1297 | { 1298 | ANY a = *box; 1299 | if likely (a != NIL) return (LIST) (a & PTR_MASK); 1300 | throw_error("Used before definition"); 1301 | #ifdef __TINYC__ 1302 | return NULL; 1303 | #endif 1304 | } 1305 | 1306 | __attribute__((hot)) 1307 | static NUMBER early_NUMBER(BOX box) 1308 | { 1309 | ANY a = *box; 1310 | if likely (a != NIL) return *(NUMBER*)&a; 1311 | throw_error("Used before definition"); 1312 | #ifdef __TINYC__ 1313 | return 0; 1314 | #endif 1315 | } 1316 | 1317 | __attribute__((hot)) 1318 | static BOOLEAN early_BOOLEAN(BOX box) 1319 | { 1320 | ANY a = *box; 1321 | if likely (a != NIL) return (BOOLEAN) (a & PTR_MASK); 1322 | throw_error("Used before definition"); 1323 | #ifdef __TINYC__ 1324 | return 0; 1325 | #endif 1326 | } 1327 | 1328 | __attribute__((hot)) 1329 | static SYMBOL early_SYMBOL(BOX box) 1330 | { 1331 | ANY a = *box; 1332 | if likely (a != NIL) return (SYMBOL) (a & PTR_MASK); 1333 | throw_error("Used before definition"); 1334 | #ifdef __TINYC__ 1335 | return NULL; 1336 | #endif 1337 | } 1338 | 1339 | __attribute__((hot)) 1340 | static STRING early_STRING(BOX box) 1341 | { 1342 | ANY a = *box; 1343 | if likely (a != NIL) return (STRING) (a & UNALIGNED_PTR_MASK); 1344 | throw_error("Used before definition"); 1345 | #ifdef __TINYC__ 1346 | return NULL; 1347 | #endif 1348 | } 1349 | 1350 | __attribute__((hot)) 1351 | static BLOCK early_BLOCK(BOX box) 1352 | { 1353 | ANY a = *box; 1354 | if likely (a != NIL) return (BLOCK) (a & PTR_MASK); 1355 | throw_error("Used before definition"); 1356 | #ifdef __TINYC__ 1357 | return NULL; 1358 | #endif 1359 | } 1360 | 1361 | __attribute__((hot)) 1362 | static IO early_IO(BOX box) 1363 | { 1364 | ANY a = *box; 1365 | if likely (a != NIL) return (IO) (a & PTR_MASK); 1366 | throw_error("Used before definition"); 1367 | #ifdef __TINYC__ 1368 | return NULL; 1369 | #endif 1370 | } 1371 | 1372 | __attribute__((hot)) 1373 | static BOX early_BOX(BOX box) 1374 | { 1375 | ANY a = *box; 1376 | if likely (a != NIL) return (BOX) (a & PTR_MASK); 1377 | throw_error("Used before definition"); 1378 | #ifdef __TINYC__ 1379 | return NULL; 1380 | #endif 1381 | } 1382 | 1383 | __attribute__((hot)) 1384 | static ANY early_ANY(BOX box) 1385 | { 1386 | ANY a = *box; 1387 | if likely (a != NIL) return a; 1388 | throw_error("Used before definition"); 1389 | #ifdef __TINYC__ 1390 | return NIL; 1391 | #endif 1392 | } 1393 | 1394 | #define EMPTY 0x0 // 0000 1395 | #define ALLOC 0x1 // 0001 1396 | #define PTR 0x2 // 0010 1397 | #define ALLOCPTR 0x3 // 0011 1398 | #define FORWARD 0x7 // 0111 1399 | 1400 | static void gc_mark_ptr(void* ptr) 1401 | { 1402 | //printf("OR[%i] %i -> ", (uintptr_t*)ptr - space[0].start, gc_bitmap_get(&space[0], (uintptr_t*)ptr - space[0].start)); 1403 | gc_bitmap_or(&space[0], (uintptr_t*)ptr - space[0].start, PTR); 1404 | //printf("%i\n", gc_bitmap_get(&space[0], (uintptr_t*)ptr - space[0].start)); 1405 | } 1406 | 1407 | static void gc_mark_mutable_ptr(void* ptr) 1408 | { 1409 | gc_bitmap_or(&mutable_space[mz], (uintptr_t*)ptr - mutable_space[mz].start, PTR); 1410 | } 1411 | 1412 | static void gc_mark_mutable_any(ANY* a) 1413 | { 1414 | if (any_is_ptr(*a)) gc_mark_mutable_ptr(a); 1415 | } 1416 | 1417 | static void gc_mark_any(ANY* a) 1418 | { 1419 | if (any_is_ptr(*a)) gc_mark_ptr(a); 1420 | } 1421 | 1422 | static void gc_bitmap_or(gc_heap* heap, size_t index, uint8_t value) 1423 | { 1424 | //printf("bitmap at %p\n", heap->bitmap); 1425 | heap->bitmap[index / 2] |= (uint8_t)(value << (4 * (index & 0x1))); // set to value 1426 | } 1427 | 1428 | static void gc_bitmap_set(gc_heap* heap, size_t index, uint8_t value) 1429 | { 1430 | //printf("bitmap at %p\n", heap->bitmap); 1431 | heap->bitmap[index / 2] &= (uint8_t)(~(0xf << (4 * (index & 0x1)))); // set to 00 1432 | heap->bitmap[index / 2] |= (uint8_t)(value << (4 * (index & 0x1))); // set to value 1433 | } 1434 | 1435 | static uint8_t gc_bitmap_get(gc_heap* heap, size_t index) 1436 | { 1437 | return (heap->bitmap[index / 2] >> (4 * (index & 0x1))) & 0xf; 1438 | } 1439 | 1440 | static void gc_init_heap(gc_heap* heap) 1441 | { 1442 | heap->bitmap = mmap(ALLOC_START, ALLOC_SIZE/16, MEM_PROT, MEM_FLAGS, -1, 0); 1443 | heap->start = mmap(ALLOC_START, ALLOC_SIZE, MEM_PROT, MEM_FLAGS, -1, 0); 1444 | heap->alloc = 0; 1445 | gc_bitmap_set(heap, 0, ALLOC); 1446 | } 1447 | 1448 | static void gc_init(void) 1449 | { 1450 | gc_init_heap(&mutable_space[0]); 1451 | gc_init_heap(&mutable_space[1]); 1452 | gc_init_heap(&space[0]); 1453 | } 1454 | 1455 | 1456 | __attribute__((assume_aligned(sizeof(uint64_t)), returns_nonnull)) 1457 | static void* gc_malloc_on(gc_heap* heap, size_t sz) 1458 | { 1459 | void* buf = heap->start + heap->alloc; 1460 | heap->alloc += (sz + 7) / 8; 1461 | gc_bitmap_set(heap, heap->alloc, ALLOC); 1462 | return buf; 1463 | } 1464 | 1465 | static void* __attribute__((noinline)) gc_malloc_mutable(size_t sz) 1466 | { 1467 | asm(""); 1468 | maybe_gc_collect(); 1469 | return gc_malloc_on(&mutable_space[mz], sz); 1470 | } 1471 | 1472 | static void* __attribute__((noinline)) gc_malloc(size_t sz) 1473 | { 1474 | asm(""); 1475 | maybe_gc_collect(); 1476 | return gc_malloc_on(&space[0], sz); 1477 | } 1478 | 1479 | static bool is_gc_ptr(gc_heap* heap, uintptr_t object) 1480 | { 1481 | uintptr_t diff = (uintptr_t*)(object & PTR_MASK) - heap->start; 1482 | return diff < heap->alloc; 1483 | } 1484 | 1485 | static void gc_collect_root(uintptr_t* addr, gc_heap* source, gc_heap* dest) 1486 | { 1487 | if (!is_gc_ptr(source, *addr)) return; 1488 | struct action { 1489 | uintptr_t from; 1490 | uintptr_t* to; 1491 | }; 1492 | struct action* act_stk_start = (struct action*)source->start + source->alloc; 1493 | struct action* act_stk_top = act_stk_start; 1494 | *act_stk_top++ = (struct action) { .from=*addr, .to=addr }; 1495 | while (act_stk_top-- != act_stk_start) 1496 | { 1497 | uintptr_t from = act_stk_top->from; 1498 | uintptr_t* to = act_stk_top->to; 1499 | const uintptr_t extra_bits = from & ~PTR_MASK; 1500 | uintptr_t index = (uintptr_t*)(from & PTR_MASK) - source->start; 1501 | ptrdiff_t offset = 0; 1502 | while (!(gc_bitmap_get(source, index) & ALLOC)) index--, offset++; // Ptr to middle of object 1503 | uint8_t alloc_mode = gc_bitmap_get(source, index); 1504 | if (alloc_mode == FORWARD && is_gc_ptr(dest, source->start[index])) 1505 | *to = extra_bits | (uintptr_t)((uintptr_t*)source->start[index] + offset); 1506 | else 1507 | { 1508 | uintptr_t* buf = dest->start + dest->alloc; // Buffer in newspace 1509 | size_t sz = 0; 1510 | uint8_t bits = alloc_mode; 1511 | for ( ; (sz==0) || !((bits = gc_bitmap_get(source, index + sz)) & ALLOC) ; sz++ ) 1512 | { 1513 | gc_bitmap_set(dest, dest->alloc + sz, bits); 1514 | uintptr_t from = source->start[index + sz]; 1515 | if ((bits & PTR) && is_gc_ptr(source, from)) 1516 | *act_stk_top++ = (struct action) { .from=from, .to=buf+sz }; 1517 | else buf[sz] = from; 1518 | } 1519 | dest->alloc += sz; 1520 | source->start[index] = (uintptr_t)buf; // Set forwarding address 1521 | gc_bitmap_set(source, index, FORWARD); 1522 | *to = extra_bits | (uintptr_t)(buf + offset); 1523 | } 1524 | } 1525 | } 1526 | 1527 | static void gc_clear_heap(gc_heap* heap) 1528 | { 1529 | memset(heap->bitmap, 0x0, heap->alloc / 2 + 1); 1530 | heap->alloc = 0; 1531 | gc_bitmap_set(heap, 0, ALLOC); 1532 | } 1533 | 1534 | static void gc_collect_from_heap(gc_heap* roots, gc_heap* source, gc_heap* dest) 1535 | { 1536 | asm(""); 1537 | for (size_t i = 0 ; i < roots->alloc; ++i) 1538 | if (gc_bitmap_get(roots, i) & PTR) gc_collect_root(roots->start + i, source, dest); 1539 | 1540 | gc_bitmap_set(dest, dest->alloc, ALLOC); 1541 | } 1542 | 1543 | static bool any_is_ptr(ANY a) 1544 | { 1545 | switch (type_of(a)) 1546 | { 1547 | case NIL: case NUMBER_TYPE: case BOOLEAN_TYPE: case SYMBOL_TYPE: return false; 1548 | default: return true; 1549 | } 1550 | } 1551 | 1552 | __attribute__((noinline)) 1553 | static void gc_collect_from_stacks(gc_heap* source, gc_heap* dest) 1554 | { 1555 | asm(""); 1556 | for (ANY* root = stack.absolute_start; root < stack.top; ++root) 1557 | if (any_is_ptr(*root)) gc_collect_root((uintptr_t*)root, source, dest); 1558 | 1559 | jmp_buf a; 1560 | if (setjmp(a)) return; 1561 | 1562 | for (uintptr_t* root = (uintptr_t*)&a; root < (uintptr_t*)function_stack_start; ++root) 1563 | gc_collect_root(root, source, dest); // Watch me destructively modify the call stack 1564 | 1565 | gc_collect_root((uintptr_t*)&memoized_regexes, source, dest); 1566 | 1567 | gc_bitmap_set(dest, dest->alloc, ALLOC); 1568 | 1569 | longjmp(a, 1); 1570 | } 1571 | 1572 | static void maybe_gc_collect(void) 1573 | { 1574 | size_t threshold = GC_FIRST_THRESHOLD; 1575 | for (int i = 0 ; space[i].alloc > threshold ; ++i, threshold *= GC_THRESHOLD_RATIO) 1576 | gc_collect_cascade(i); 1577 | 1578 | static size_t mutable_space_alloc = 0; 1579 | if (mutable_space[mz].alloc - mutable_space_alloc > GC_MUTABLE_THRESHOLD) 1580 | { 1581 | gc_collect_mutable(); 1582 | mutable_space_alloc = mutable_space[mz].alloc; 1583 | } 1584 | } 1585 | 1586 | static size_t gc_heap_usage(void) 1587 | { 1588 | size_t n = 0; 1589 | for (int i = 0 ; i < gc_num_heaps ; ++i) n += space[i].alloc; 1590 | return n + mutable_space[mz].alloc + mutable_space[!mz].alloc; 1591 | } 1592 | 1593 | __attribute__((noinline)) 1594 | static void gc_collect_cascade(int n) 1595 | { 1596 | asm(""); 1597 | /* 1598 | clock_t start = clock(); 1599 | size_t original_heap = gc_heap_usage(); 1600 | */ 1601 | 1602 | if unlikely(n + 1 == gc_num_heaps) 1603 | { 1604 | if unlikely(gc_num_heaps == GC_MAX_HEAPS) throw_error("GC heap exhausted"); 1605 | gc_init_heap(&space[n+1]); 1606 | gc_num_heaps++; 1607 | } 1608 | gc_collect_from_heap(&mutable_space[mz], &space[n], &space[n+1]); 1609 | gc_collect_from_stacks(&space[n], &space[n+1]); 1610 | gc_clear_heap(&space[n]); 1611 | /* 1612 | clock_t end = clock(); 1613 | float mseconds = (float)(end - start) * 1000 / CLOCKS_PER_SEC; 1614 | printf("cascade %i->%i took %lfms (%zu -> %zu)\n", n, n+1, mseconds, original_heap, gc_heap_usage()); 1615 | */ 1616 | } 1617 | 1618 | static void gc_collect_mutable(void) 1619 | { 1620 | gc_collect_from_stacks(&mutable_space[mz], &mutable_space[!mz]); // Mutable memory gc 1621 | for (int i = 0 ; i < gc_num_heaps ; ++i) 1622 | gc_collect_from_heap(&space[i], &mutable_space[mz], &mutable_space[!mz]); // Mutable memory can be referenced by main memory. TODO combine this with main memory gc 1623 | gc_clear_heap(&mutable_space[mz]); 1624 | mz = !mz; 1625 | } 1626 | 1627 | static char* gc_strdup(char* src) 1628 | { 1629 | const size_t len = strlen(src); 1630 | return memcpy(gc_malloc(len + 1), src, len + 1); 1631 | } 1632 | 1633 | static char* gc_strndup(char* src, size_t bytes) 1634 | { 1635 | const size_t len = strlen(src); 1636 | if (len < bytes) bytes = len; 1637 | char* dest = gc_malloc(bytes + 1); 1638 | dest[bytes] = '\0'; 1639 | return memcpy(dest, src, bytes); 1640 | } 1641 | 1642 | static ANY ___if(BOOLEAN cond, ANY a, ANY b) 1643 | { 1644 | return cond ? a : b; 1645 | } 1646 | 1647 | static void ___put(ANY a) { assert_impure(); fputs(___show(a), stdout); fflush(stdout); } 1648 | static void ___put_NUMBER(NUMBER a) { assert_impure(); fputs(___show_NUMBER(a), stdout); fflush(stdout); } 1649 | static void ___put_LIST(LIST a) { assert_impure(); fputs(___show_LIST(a), stdout); fflush(stdout); } 1650 | static void ___put_TABLE(TABLE a) { assert_impure(); fputs(___show_TABLE(a), stdout); fflush(stdout); } 1651 | static void ___put_IO(IO a) { assert_impure(); fputs(___show_IO(a), stdout); fflush(stdout); } 1652 | static void ___put_BLOCK(BLOCK a) { assert_impure(); fputs(___show_BLOCK(a), stdout); fflush(stdout); } 1653 | static void ___put_STRING(STRING a) { assert_impure(); fputs(___show_STRING(a), stdout); fflush(stdout); } 1654 | static void ___put_SYMBOL(SYMBOL a) { assert_impure(); fputs(___show_SYMBOL(a), stdout); fflush(stdout); } 1655 | static void ___put_BOOLEAN(BOOLEAN a) { assert_impure(); fputs(___show_BOOLEAN(a), stdout); fflush(stdout); } 1656 | static void ___put_BOX(BOX a) { assert_impure(); fputs(___show_BOX(a), stdout); } 1657 | 1658 | static void ___print(ANY a) { assert_impure(); puts(___show(a)); } 1659 | static void ___print_NUMBER(NUMBER a) { assert_impure(); puts(___show_NUMBER(a)); } 1660 | static void ___print_LIST(LIST a) { assert_impure(); puts(___show_LIST(a)); } 1661 | static void ___print_TABLE(TABLE a) { assert_impure(); puts(___show_TABLE(a)); } 1662 | static void ___print_IO(IO a) { assert_impure(); puts(___show_IO(a)); } 1663 | static void ___print_BLOCK(BLOCK a) { assert_impure(); puts(___show_BLOCK(a)); } 1664 | static void ___print_STRING(STRING a) { assert_impure(); puts(___show_STRING(a)); } 1665 | static void ___print_SYMBOL(SYMBOL a) { assert_impure(); puts(___show_SYMBOL(a)); } 1666 | static void ___print_BOOLEAN(BOOLEAN a) { assert_impure(); puts(___show_BOOLEAN(a)); } 1667 | static void ___print_BOX(BOX a) { assert_impure(); puts(___show_BOX(a)); } 1668 | 1669 | static NUMBER ___P(NUMBER a, NUMBER b) { return a + b; } // Add cannot produce NaN. 1670 | static NUMBER ___M(NUMBER a, NUMBER b) { return a * b; } 1671 | static NUMBER ___H(NUMBER a, NUMBER b) { return b - a; } 1672 | static NUMBER ___S(NUMBER a, NUMBER b) { return b / a; } 1673 | static NUMBER ___C(NUMBER a, NUMBER b) { return pow(b, a); } 1674 | static NUMBER ___modulo(NUMBER a, NUMBER b) { return b - a * floor(b / a); } 1675 | static NUMBER ___sqrt(NUMBER a) { return sqrt(a); } 1676 | static NUMBER ___random(NUMBER low, NUMBER high) 1677 | { 1678 | if unlikely((high - low) < 0) goto invalid_range; 1679 | else if (high - low < 1) return low; 1680 | // This is not cryptographically secure btw. 1681 | // Since RAND_MAX may only be 2^15, we need to do this: 1682 | const long num 1683 | = ((long)(short)rand()) 1684 | | ((long)(short)rand() << 15) 1685 | | ((long)(short)rand() << 30) 1686 | | ((long)(short)rand() << 45) 1687 | | ((long) rand() << 60); 1688 | const double r = low + (NUMBER)(num % (unsigned long)(high - low)); 1689 | return r; 1690 | invalid_range: 1691 | throw_error_fmt("Invalid range %.14g..%.14g", low, high); 1692 | #ifdef __TINYC__ 1693 | return 0; 1694 | #endif 1695 | } 1696 | 1697 | static void ___clear(void) { stack.top=stack.start; } 1698 | 1699 | static BOOLEAN ___true(void) { return true; } 1700 | static BOOLEAN ___false(void) { return false; } 1701 | static BOOLEAN ___or(BOOLEAN a, BOOLEAN b) { return a || b; } 1702 | static BOOLEAN ___and(BOOLEAN a, BOOLEAN b) { return a && b; } 1703 | static BOOLEAN ___xor(BOOLEAN a, BOOLEAN b) { return a ^ b; } 1704 | static BOOLEAN ___not(BOOLEAN a) { return a ? false : true; } 1705 | static BOOLEAN ___EE(ANY a, ANY b) { return 0 == compare_objects(a,b); } 1706 | static BOOLEAN ___G(NUMBER a, NUMBER b) { return a < b; } 1707 | static BOOLEAN ___L(NUMBER a, NUMBER b) { return a > b; } 1708 | static BOOLEAN ___GE(NUMBER a, NUMBER b) { return a <= b; } 1709 | static BOOLEAN ___LE(NUMBER a, NUMBER b) { return a >= b; } 1710 | static BOOLEAN ___numberQ(ANY a) { return (a & NIL) != NIL; } 1711 | static BOOLEAN ___listQ(ANY a) { return (a & TYPE_MASK) == LIST_TYPE; } 1712 | static BOOLEAN ___stringQ(ANY a) { return (a & STRING_TYPE) == STRING_TYPE; } 1713 | static BOOLEAN ___blockQ(ANY a) { return (a & TYPE_MASK) == BLOCK_TYPE; } 1714 | static BOOLEAN ___booleanQ(ANY a) { return (a & TYPE_MASK) == BOOLEAN_TYPE; } 1715 | static BOOLEAN ___symbolQ(ANY a) { return (a & SYMBOL_TYPE) == SYMBOL_TYPE; } 1716 | static BOOLEAN ___ioQ(ANY a) { return (a & TYPE_MASK) == IO_TYPE; } 1717 | static BOOLEAN ___tableQ(ANY a) { return (a & TYPE_MASK) == TABLE_TYPE; } 1718 | static BOOLEAN ___integerQ(ANY a) { return ___numberQ(a) && unbox_NUMBER(a) == floor(unbox_NUMBER(a)); } 1719 | static BOOLEAN ___zeroQ(ANY a) { return ___numberQ(a) && unbox_NUMBER(a) == 0; } 1720 | 1721 | static NUMBER ___numberX(NUMBER a) { return a; } 1722 | static LIST ___listX(LIST a) { return a; } 1723 | static STRING ___stringX(STRING a) { return a; } 1724 | static ANY ___anyX(ANY a) { return a; } 1725 | static BLOCK ___blockX(BLOCK a) { return a; } 1726 | static BOOLEAN ___booleanX(BOOLEAN a){ return a; } 1727 | static SYMBOL ___symbolX(SYMBOL a) { return a; } 1728 | static IO ___ioX(IO a) { return a; } 1729 | static TABLE ___tableX(TABLE a) { return a; } 1730 | 1731 | //static BOOLEAN ___match(ANY patt, ANY obj) { return match_objects(patt,obj); } 1732 | 1733 | static ANY ___first_LIST(LIST lst) 1734 | { 1735 | // Returns the first element of a list. O(1). 1736 | if unlikely(!lst) throw_error("empty list is invalid"); 1737 | return lst->object; 1738 | } 1739 | 1740 | static LIST ___rest_LIST(LIST lst) 1741 | { 1742 | // Returns the tail portion of a list. O(1). 1743 | if unlikely(!lst) throw_error("empty list is invalid"); 1744 | return lst->next; 1745 | } 1746 | 1747 | static STRING ___first_STRING(STRING str) 1748 | { 1749 | if unlikely(!*str) throw_error("empty string is invalid"); 1750 | return gc_strndup((char*)str, mblen(str, MB_CUR_MAX)); 1751 | } 1752 | 1753 | static STRING ___rest_STRING(STRING str) 1754 | { 1755 | if unlikely(!*str) throw_error("empty string is invalid"); 1756 | return str + mblen(str, MB_CUR_MAX); 1757 | } 1758 | 1759 | static ANY ___first(ANY a) 1760 | { 1761 | switch(type_of(a)) 1762 | { 1763 | case LIST_TYPE: return ___first_LIST((LIST)(a & PTR_MASK)); 1764 | case STRING_TYPE: return box_STRING(___first_STRING((STRING)(a & UNALIGNED_PTR_MASK))); 1765 | default: type_error("string or list", a); 1766 | } 1767 | #ifdef __TINYC__ 1768 | return NIL; 1769 | #endif 1770 | } 1771 | 1772 | static ANY ___rest(ANY a) 1773 | { 1774 | switch(type_of(a)) 1775 | { 1776 | case LIST_TYPE: return box_LIST(___rest_LIST((LIST)(a & PTR_MASK))); 1777 | case STRING_TYPE: return box_STRING(___rest_STRING((STRING)(a & UNALIGNED_PTR_MASK))); 1778 | default: type_error("string or list", a); 1779 | } 1780 | #ifdef __TINYC__ 1781 | return NIL; 1782 | #endif 1783 | } 1784 | 1785 | static LIST ___push(ANY a, LIST b) 1786 | { 1787 | // Pushes an object from the stack onto the list's first element. O(1). 1788 | // TODO: Better name? Inconsistent with List where pushing to the stack adds to the END. 1789 | cognate_list* lst = gc_malloc (sizeof *lst); 1790 | *lst = (cognate_list) {.object = a, .next = b}; 1791 | gc_mark_ptr((void*)&lst->next); 1792 | gc_mark_any(&lst->object); 1793 | return lst; 1794 | } 1795 | 1796 | static BOOLEAN ___emptyQ_LIST(LIST l) 1797 | { 1798 | return !l; 1799 | } 1800 | 1801 | static BOOLEAN ___emptyQ_STRING(STRING s) 1802 | { 1803 | return !*s; 1804 | } 1805 | 1806 | static BOOLEAN ___emptyQ_TABLE(TABLE t) 1807 | { 1808 | return !t; 1809 | } 1810 | 1811 | static BOOLEAN ___emptyQ(ANY a) 1812 | { 1813 | // Returns true is a list or string is empty. O(1). 1814 | // Can be used to to write a Length function. 1815 | switch (type_of(a)) 1816 | { 1817 | case LIST_TYPE: return ___emptyQ_LIST(unbox_LIST(a)); 1818 | case STRING_TYPE: return ___emptyQ_STRING(unbox_STRING(a)); 1819 | case TABLE_TYPE: return ___emptyQ_TABLE(unbox_TABLE(a)); 1820 | default: type_error("List or String or Table", a); 1821 | } 1822 | #ifdef __TINYC__ 1823 | return 0; 1824 | #endif 1825 | } 1826 | 1827 | static LIST ___list(BLOCK expr) 1828 | { 1829 | ANYPTR tmp_stack_start = stack.start; 1830 | stack.start = stack.top; 1831 | // Eval expr 1832 | call_block(expr); 1833 | // Move to a list. 1834 | LIST lst = NULL; 1835 | size_t len = stack_length(); 1836 | for (size_t i = 0; i < len; ++i) 1837 | lst = ___push(stack.start[i], lst); 1838 | stack.top = stack.start; 1839 | stack.start = tmp_stack_start; 1840 | return lst; 1841 | } 1842 | 1843 | static STRING ___substring(NUMBER startf, NUMBER endf, STRING str) 1844 | { 1845 | // O(end). 1846 | // Only allocates a new string if it has to. 1847 | /* TODO: Would it be better to have a simpler and more minimalist set of string functions, like lists do? 1848 | * The only real difference between NULL terminated strings and linked lists is that appending to strings is harder. 1849 | * Maybe also a 'Join N Str1 Str2 Str3 ... StrN' function. 1850 | */ 1851 | size_t start = startf; 1852 | size_t end = endf; 1853 | if unlikely(start != startf || end != endf || start > end) goto invalid_range; 1854 | size_t str_size = 0; 1855 | end -= start; 1856 | for (;start != 0; --start) 1857 | { 1858 | if unlikely(!*str) goto invalid_range; 1859 | str += mblen(str, MB_CUR_MAX); 1860 | } 1861 | for (;end != 0; --end) 1862 | { 1863 | if unlikely(str[str_size] == '\0') goto invalid_range; 1864 | str_size += mblen(str+str_size, MB_CUR_MAX); 1865 | } 1866 | if unlikely(str[str_size] == '\0') 1867 | { 1868 | // We don't need to make a new string here. 1869 | return str; 1870 | } 1871 | return gc_strndup((char*)str, str_size + 1); 1872 | invalid_range: 1873 | throw_error_fmt("Invalid range %.14g..%.14g", startf, endf); 1874 | #ifdef __TINYC__ 1875 | return NULL; 1876 | #endif 1877 | } 1878 | 1879 | 1880 | static STRING ___input(void) 1881 | { 1882 | // Read user input to a string. 1883 | assert_impure(); 1884 | size_t size = 0; 1885 | char* buf; 1886 | size_t chars = getline(&buf, &size, stdin); 1887 | char* ret = gc_strndup(buf, chars-1); // Don't copy trailing newline. 1888 | free(buf); 1889 | return ret; 1890 | } 1891 | 1892 | static NUMBER ___number(STRING str) 1893 | { 1894 | // casts string to number. 1895 | char* end; 1896 | NUMBER num = strtod(str, &end); 1897 | if (end == str || *end != '\0') goto cannot_parse; 1898 | return num; 1899 | cannot_parse: 1900 | throw_error_fmt("Cannot parse '%.32s' to a number", str); 1901 | #ifdef __TINYC__ 1902 | return 0; 1903 | #endif 1904 | } 1905 | 1906 | static STRING ___path(void) 1907 | { 1908 | assert_impure(); 1909 | char buf[FILENAME_MAX]; 1910 | if (!getcwd(buf, FILENAME_MAX)) 1911 | throw_error("cannot get working directory"); 1912 | char* ret = gc_strdup(buf); 1913 | return ret; 1914 | } 1915 | 1916 | static LIST ___stack(void) 1917 | { 1918 | LIST lst = NULL; 1919 | for (size_t i = 0; i + stack.start < stack.top; ++i) 1920 | { 1921 | cognate_list* tmp = gc_malloc (sizeof *tmp); 1922 | tmp -> object = stack.start[i]; 1923 | tmp -> next = lst; 1924 | lst = tmp; 1925 | gc_mark_ptr((void*)&tmp->next); 1926 | gc_mark_any((void*)&tmp->object); 1927 | } 1928 | return lst; 1929 | } 1930 | 1931 | static LIST ___parameters(void) 1932 | { 1933 | return cmdline_parameters; // TODO should be a variable, and allow mutation and stuff 1934 | } 1935 | 1936 | static void ___stop(void) 1937 | { 1938 | assert_impure(); 1939 | // Don't check stack length, because it probably wont be empty. 1940 | exit(EXIT_SUCCESS); 1941 | } 1942 | 1943 | 1944 | static NUMBER ___ordinal(STRING str) 1945 | { 1946 | if unlikely(!str[0] || strlen(str) > (size_t)mblen(str, MB_CUR_MAX)) 1947 | throw_error_fmt("Invalid string '%.32s' (should be length 1)", str); 1948 | wchar_t chr = 0; 1949 | mbtowc(&chr, str, MB_CUR_MAX); 1950 | return chr; 1951 | } 1952 | 1953 | static STRING ___character(NUMBER d) 1954 | { 1955 | const wchar_t i = d; 1956 | char* const str = gc_malloc (MB_CUR_MAX + 1); 1957 | if unlikely(i != d || wctomb(str, i) == -1) 1958 | throw_error_fmt("Cannot convert %.14g to UTF8 character", d); 1959 | str[mblen(str, MB_CUR_MAX)] = '\0'; 1960 | return str; 1961 | } 1962 | 1963 | static NUMBER ___floor(NUMBER a) 1964 | { 1965 | return floor(a); 1966 | } 1967 | 1968 | static NUMBER ___round(NUMBER a) 1969 | { 1970 | return round(a); 1971 | } 1972 | 1973 | static NUMBER ___ceiling(NUMBER a) 1974 | { 1975 | return ceil(a); 1976 | } 1977 | 1978 | static NUMBER ___abs(NUMBER a) 1979 | { 1980 | return fabs(a); 1981 | } 1982 | 1983 | static void ___error(STRING str) 1984 | { 1985 | throw_error(str); 1986 | } 1987 | 1988 | static void ___wait(NUMBER seconds) 1989 | { 1990 | assert_impure(); 1991 | sleep(seconds); 1992 | } 1993 | 1994 | /* 1995 | static BLOCK ___precompute(BLOCK blk) 1996 | { 1997 | ANYPTR tmp_stack_start = stack.start; 1998 | stack.start = stack.top; 1999 | blk(); 2000 | const size_t len = stack_length(); 2001 | if (!len) return Block_copy(^{}); 2002 | ANYPTR ret_data = gc_malloc(len * sizeof *ret_data); 2003 | for (size_t i = 0; i < len; ++i) 2004 | ret_data[len] = stack.start[i]; 2005 | stack.top = stack.start; 2006 | stack.start = tmp_stack_start; 2007 | return Block_copy(^{ 2008 | for (size_t i = 0; i < len; ++i) 2009 | push(ret_data[i]); 2010 | }); 2011 | } 2012 | */ 2013 | 2014 | static STRING ___show(ANY o) 2015 | { 2016 | if ((o & STRING_TYPE) == STRING_TYPE || (o & SYMBOL_TYPE) == SYMBOL_TYPE) 2017 | return (STRING)(o & UNALIGNED_PTR_MASK); 2018 | show_object(o, general_purpose_buffer, NULL); 2019 | return general_purpose_buffer; 2020 | } 2021 | 2022 | static LIST ___split(STRING sep, STRING str) 2023 | { 2024 | if (!*sep) throw_error("Seperator cannot be empty"); 2025 | LIST lst1 = NULL; 2026 | size_t len = strlen(sep); 2027 | char* found; 2028 | while ((found = strstr(str, sep))) 2029 | { 2030 | found = strstr(str, sep); 2031 | if (found != str) 2032 | { 2033 | char* item = gc_malloc(found - str + 1); 2034 | memcpy(item, str, found - str); 2035 | item[found - str] = '\0'; 2036 | lst1 = ___push(box_STRING(item), lst1); 2037 | } 2038 | str = found + len; 2039 | } 2040 | if (*str) lst1 = ___push(box_STRING(str), lst1); 2041 | LIST lst = NULL; 2042 | for (; lst1 ; lst1 = lst1->next) lst = ___push(lst1->object, lst); 2043 | return lst; 2044 | } 2045 | 2046 | static STRING ___uppercase(STRING str) 2047 | { 2048 | char* converted = gc_strdup((char*)str); 2049 | int len = 0; 2050 | for (char* c = converted; *c; c += len) 2051 | { 2052 | wchar_t chr = 0; 2053 | len = mblen(c, MB_CUR_MAX); 2054 | mbtowc(&chr, c, len); 2055 | chr = towupper(chr); 2056 | wctomb(c, chr); 2057 | } 2058 | return converted; 2059 | } 2060 | 2061 | static STRING ___lowercase(STRING str) 2062 | { 2063 | char* converted = gc_strdup((char*)str); 2064 | int len = 0; 2065 | for (char* c = converted; *c; c += len) 2066 | { 2067 | wchar_t chr = 0; 2068 | len = mblen(c, MB_CUR_MAX); 2069 | mbtowc(&chr, c, len); 2070 | chr = towlower(chr); 2071 | wctomb(c, chr); 2072 | } 2073 | return converted; 2074 | } 2075 | 2076 | /* 2077 | static BLOCK ___remember(BLOCK b) 2078 | { 2079 | // Only works for 1 -> 1 functions 2080 | struct memolist { 2081 | struct memolist* next; 2082 | ANY input; 2083 | ANY output; 2084 | }; 2085 | __block struct memolist* memo = NULL; 2086 | return Block_copy(^{ 2087 | ANY a = pop(); 2088 | for (struct memolist* l = memo ; l ; l = l->next) 2089 | if (l->input == a) 2090 | { 2091 | push(l->output); 2092 | return; 2093 | } 2094 | ANY* temp = stack.start; 2095 | stack.start = stack.top; 2096 | push(a); 2097 | b(); 2098 | stack.start = temp; 2099 | struct memolist* new = gc_malloc(sizeof *new); 2100 | new->input = a; 2101 | new->output = peek(); 2102 | new->next = memo; 2103 | memo = new; 2104 | }); 2105 | } 2106 | */ 2107 | 2108 | /* 2109 | static BLOCK ___pure(BLOCK b) 2110 | { 2111 | return Block_copy(^{ 2112 | pure = 1; 2113 | b(); 2114 | pure = 0; 2115 | }); 2116 | } 2117 | */ 2118 | 2119 | 2120 | static BOX ___box(ANY a) // boxes seem to break the GC sometimes TODO 2121 | { 2122 | ANY* b = gc_malloc_mutable(sizeof *b); 2123 | *b = a; 2124 | gc_mark_mutable_any(b); 2125 | return b; 2126 | } 2127 | 2128 | static ANY ___unbox(BOX b) 2129 | { 2130 | return *b; 2131 | } 2132 | 2133 | static void ___set(BOX b, ANY a) 2134 | { 2135 | *b = a; 2136 | gc_mark_mutable_any(b); 2137 | } 2138 | 2139 | /* math */ 2140 | 2141 | #ifndef M_PI 2142 | #define M_PI 3.14159265358979323846 2143 | #endif 2144 | 2145 | // helper for math functions 2146 | static inline NUMBER radians_to_degrees(NUMBER a) 2147 | { 2148 | return a * (180 / M_PI); 2149 | } 2150 | 2151 | static inline NUMBER degrees_to_radians(NUMBER a) 2152 | { 2153 | return a * (M_PI / 180); 2154 | } 2155 | 2156 | static NUMBER ___sind(NUMBER a) 2157 | { 2158 | double rad = degrees_to_radians(a); 2159 | double sinrad = sin(rad); 2160 | return sinrad; 2161 | } 2162 | 2163 | static NUMBER ___cosd(NUMBER a) 2164 | { 2165 | double rad = degrees_to_radians(a); 2166 | double cosrad = cos(rad); 2167 | return cosrad; 2168 | } 2169 | 2170 | static NUMBER ___tand(NUMBER a) 2171 | { 2172 | double rad = degrees_to_radians(a); 2173 | double tanrad = tan(rad); 2174 | return tanrad; 2175 | } 2176 | 2177 | static NUMBER ___sin(NUMBER a) 2178 | { 2179 | return sin(a); 2180 | } 2181 | 2182 | static NUMBER ___cos(NUMBER a) 2183 | { 2184 | return cos(a); 2185 | } 2186 | 2187 | static NUMBER ___tan(NUMBER a) 2188 | { 2189 | return tan(a); 2190 | } 2191 | 2192 | static NUMBER ___exp(NUMBER a) 2193 | { 2194 | return exp(a); 2195 | } 2196 | 2197 | static NUMBER ___log(NUMBER a, NUMBER b) 2198 | { 2199 | /* This uses the following formula: 2200 | log_x(y) = 2201 | log_e(y) / log_e(x) 2202 | */ 2203 | const double top = log(b); 2204 | const double bottom = log(a); 2205 | return top / bottom; 2206 | } 2207 | 2208 | static NUMBER ___ln(NUMBER a) 2209 | { 2210 | return log(a); 2211 | } 2212 | 2213 | 2214 | static NUMBER ___asind(NUMBER a) 2215 | { 2216 | return radians_to_degrees(asin(a)); 2217 | } 2218 | 2219 | static NUMBER ___acosd(NUMBER a) 2220 | { 2221 | return radians_to_degrees(acos(a)); 2222 | } 2223 | 2224 | static NUMBER ___atand(NUMBER a) 2225 | { 2226 | return radians_to_degrees(atan(a)); 2227 | } 2228 | 2229 | static NUMBER ___asin(NUMBER a) 2230 | { 2231 | return asin(a); 2232 | } 2233 | 2234 | static NUMBER ___acos(NUMBER a) 2235 | { 2236 | return acos(a); 2237 | } 2238 | 2239 | static NUMBER ___atan(NUMBER a) 2240 | { 2241 | return atan(a); 2242 | } 2243 | 2244 | static NUMBER ___sinhd(NUMBER a) 2245 | { 2246 | return sinh(degrees_to_radians(a)); 2247 | } 2248 | 2249 | static NUMBER ___coshd(NUMBER a) 2250 | { 2251 | return cosh(degrees_to_radians(a)); 2252 | } 2253 | 2254 | static NUMBER ___tanhd(NUMBER a) 2255 | { 2256 | return tanh(degrees_to_radians(a)); 2257 | } 2258 | 2259 | static NUMBER ___sinh(NUMBER a) 2260 | { 2261 | return sinh(a); 2262 | } 2263 | 2264 | static NUMBER ___cosh(NUMBER a) 2265 | { 2266 | return cosh(a); 2267 | } 2268 | 2269 | static NUMBER ___tanh(NUMBER a) 2270 | { 2271 | return tanh(a); 2272 | } 2273 | 2274 | static IO ___open(SYMBOL m, STRING path) 2275 | { 2276 | assert_impure(); 2277 | char* mode; 2278 | if (m == SYMread) mode = "r"; 2279 | else if (m == SYMwrite) mode = "w"; 2280 | else if (m == SYMappend) mode = "a"; 2281 | else if (m == SYMreadHappend) mode = "a+"; 2282 | else if (m == SYMreadHwrite) mode = "w+"; 2283 | else if (m == SYMreadHwriteHexisting) mode = "r+"; 2284 | else throw_error("Expected one of \\read, \\write, \\append, \\read-write, \\read-append, \\read-write-existing"); 2285 | FILE* fp = fopen(path, mode); 2286 | if unlikely(!fp) throw_error_fmt("Cannot open file '%s'", path); 2287 | IO io = gc_malloc(sizeof *io); 2288 | io->path = path; 2289 | io->mode = mode; 2290 | io->file = fp; 2291 | gc_mark_ptr((void*)&io->path); 2292 | //gc_mark_ptr((void*)&io->mode); 2293 | //gc_mark_ptr((void*)&io->file); 2294 | return io; 2295 | } 2296 | 2297 | static STRING ___readHfile(IO io) 2298 | { 2299 | assert_impure(); 2300 | // Read a file to a string. 2301 | FILE *fp = io->file; 2302 | fseek(fp, 0, SEEK_SET); // seek to beginning 2303 | if unlikely(!io->mode) throw_error_fmt("File '%s' is not open", io->path); 2304 | if unlikely(fp == NULL) throw_error_fmt("Cannot open file '%s'", io->path); 2305 | struct stat st; 2306 | fstat(fileno(fp), &st); 2307 | char* const text = gc_malloc (st.st_size + 1); 2308 | if (fread(text, sizeof(char), st.st_size, fp) != (unsigned long)st.st_size) 2309 | throw_error_fmt("Error reading file '%s'", io->path); 2310 | text[st.st_size] = '\0'; // Remove trailing eof. 2311 | return text; 2312 | } 2313 | 2314 | static STRING ___readHline(IO io) 2315 | { 2316 | assert_impure(); 2317 | char* buf = (char*)general_purpose_buffer; 2318 | fgets(buf, INT_MAX, io->file); 2319 | return gc_strdup(buf); // this can only GC once so won't overwrite the buffer. 2320 | } 2321 | 2322 | static void ___close(IO io) 2323 | { 2324 | assert_impure(); 2325 | fclose(io->file); 2326 | io->file = NULL; 2327 | } 2328 | 2329 | static BOOLEAN ___openQ(IO io) 2330 | { 2331 | return io->file ? true : false; 2332 | } 2333 | 2334 | static STRING ___fileHname(IO io) 2335 | { 2336 | return io->path; 2337 | } 2338 | 2339 | static STRING ___fileHmode(IO io) 2340 | { 2341 | return io->mode; // TODO symbol 2342 | } 2343 | 2344 | static void ___write(STRING s, IO io) 2345 | { 2346 | fputs(s, io->file); 2347 | } 2348 | 2349 | static void ___seek(SYMBOL ref, NUMBER n, IO io) 2350 | { 2351 | int pos; 2352 | if (ref == SYMstart) pos = SEEK_SET; 2353 | else if (ref == SYMend) pos = SEEK_END; 2354 | else if (ref == SYMcurrent) pos = SEEK_CUR; 2355 | else throw_error_fmt("Expected one of \\start, \\end, \\current"); 2356 | long offset = n; 2357 | if unlikely(offset != n || fseek(io->file, offset, pos)) 2358 | throw_error_fmt("Can't seek to position %.14g relative to %s", n, ref); 2359 | } 2360 | 2361 | static void invalid_jump(ANY* env) 2362 | { 2363 | throw_error("Cannot resume expired continuation"); 2364 | } 2365 | 2366 | static void oh_no(ANY* env) 2367 | { 2368 | #ifdef DEBUG 2369 | // Remove all the now-invalid backtraces. 2370 | while ((char*)trace < *(char**)(1 + (jmp_buf*)env)) trace = trace->next; 2371 | #endif 2372 | longjmp(*(jmp_buf*)env, 1); 2373 | } 2374 | 2375 | __attribute__((returns_twice)) 2376 | static void ___begin(BLOCK f) 2377 | { 2378 | #ifdef DEBUG 2379 | BLOCK a = gc_malloc(sizeof *a + sizeof(jmp_buf) + sizeof(char*)); 2380 | // Add the address of the stack pointer so we know which backtraces to pop. 2381 | char c; 2382 | *(char**)(1 + (jmp_buf*)&a->env) = &c; 2383 | #else 2384 | BLOCK a = gc_malloc(sizeof *a + sizeof(jmp_buf)); 2385 | #endif 2386 | for (uintptr_t* p = (uintptr_t*)&a->env ; (char*)p < (char*)&a->env + sizeof(jmp_buf) ; ++p) 2387 | gc_mark_ptr(p); 2388 | if (!setjmp(*(jmp_buf*)&a->env)) 2389 | { 2390 | a->fn = oh_no; 2391 | push(box_BLOCK(a)); 2392 | call_block(f); 2393 | a->fn = invalid_jump; 2394 | } 2395 | } 2396 | 2397 | static LIST ___empty (void) 2398 | { 2399 | return NULL; 2400 | } 2401 | 2402 | static TABLE ___table (BLOCK expr) 2403 | { 2404 | ANYPTR tmp_stack_start = stack.start; 2405 | stack.start = stack.top; 2406 | // Eval expr 2407 | call_block(expr); 2408 | // Move to a table. 2409 | TABLE d = NULL; 2410 | size_t len = stack_length(); 2411 | if unlikely(len & 1) throw_error("Table initialiser must be key-value pairs"); 2412 | for (size_t i = 0; i < len; i += 2) 2413 | { 2414 | ANY key = stack.start[i+1]; 2415 | ANY value = stack.start[i]; 2416 | d = ___insert(key, value, d); 2417 | } 2418 | stack.top = stack.start; 2419 | stack.start = tmp_stack_start; 2420 | return d; 2421 | } 2422 | 2423 | static TABLE mktable(ANY key, ANY value, TABLE left, TABLE right, size_t level) 2424 | { 2425 | TABLE t = gc_malloc(sizeof *t); 2426 | t->key = key; 2427 | t->value = value; 2428 | t->left = left; 2429 | t->right = right; 2430 | t->level = level; 2431 | gc_mark_ptr((void*)&t->left); 2432 | gc_mark_ptr((void*)&t->right); 2433 | gc_mark_any(&t->key); 2434 | gc_mark_any(&t->value); 2435 | return t; 2436 | } 2437 | 2438 | static TABLE ___insert(ANY key, ANY value, TABLE d) 2439 | { 2440 | cognate_type t = TYPE_MASK & key; 2441 | if unlikely(t == IO_TYPE || t == BLOCK_TYPE || t == BOX_TYPE) throw_error_fmt("Can't index a table with %s", ___show(key)); 2442 | if (!d) return mktable(key, value, NULL, NULL, 1); 2443 | ptrdiff_t diff = compare_objects(d->key, key); 2444 | if (diff == 0) return mktable(key, value, d->left, d->right, d->level); 2445 | if (diff > 0) 2446 | return 2447 | table_split(table_skew( 2448 | mktable(d->key, d->value, ___insert(key, value, d->left), d->right, d->level))); 2449 | else //if (diff < 0) 2450 | return 2451 | table_split(table_skew( 2452 | mktable(d->key, d->value, d->left, ___insert(key, value, d->right), d->level))); 2453 | } 2454 | 2455 | static ANY ___D(ANY key, TABLE d) 2456 | { 2457 | cognate_type t = TYPE_MASK & key; 2458 | if unlikely(t == IO_TYPE || t == BLOCK_TYPE || t == BOX_TYPE) throw_error_fmt("Can't index a table with %s", ___show(key)); 2459 | while (d) 2460 | { 2461 | ptrdiff_t diff = compare_objects(d->key, key); 2462 | if (diff == 0) return d->value; 2463 | else if (diff > 0) d = d->left; 2464 | else d = d->right; 2465 | } 2466 | 2467 | throw_error_fmt("%s is not in table", ___show(key)); 2468 | #ifdef __TINYC__ 2469 | return NIL; 2470 | #endif 2471 | } 2472 | 2473 | static BOOLEAN ___has(ANY key, TABLE d) 2474 | { 2475 | cognate_type t = TYPE_MASK & key; 2476 | if unlikely(t == IO_TYPE || t == BLOCK_TYPE || t == BOX_TYPE) throw_error_fmt("Can't index a table with %s", ___show(key)); 2477 | while (d) 2478 | { 2479 | ptrdiff_t diff = compare_objects(d->key, key); 2480 | if (diff == 0) return true; 2481 | else if (diff > 0) d = d->left; 2482 | else d = d->right; 2483 | } 2484 | 2485 | return false; 2486 | } 2487 | 2488 | static TABLE ___remove(ANY key, TABLE T) 2489 | { 2490 | // input: X, the key to delete, and T, the root of the tree from which it should be deleted. 2491 | // output: T, balanced, without the value X. 2492 | cognate_type t = TYPE_MASK & key; 2493 | if unlikely(t == IO_TYPE || t == BLOCK_TYPE || t == BOX_TYPE) throw_error_fmt("Can't index a table with %s", ___show(key)); 2494 | if (!T) throw_error_fmt("Key %s not in table", ___show(key)); 2495 | ptrdiff_t diff = compare_objects(T->key, key); 2496 | TABLE T2 = NULL; 2497 | // This part is fairly intuitive - if this breaks it's probably not here: 2498 | if (diff < 0) 2499 | T2 = mktable(T->key, T->value, T->left, ___remove(key, T->right), T->level); 2500 | else if (diff > 0) 2501 | T2 = mktable(T->key, T->value, ___remove(key, T->left), T->right, T->level); 2502 | else if (!T->left && !T->right) return NULL; 2503 | else if (!T->left) // T->right not null 2504 | { 2505 | TABLE L = T->right; 2506 | while (L->left) L = L->left; // successor 2507 | T2 = mktable(L->key, L->value, T->left, ___remove(L->key, T->right), L->level); 2508 | } 2509 | else // left and right not null 2510 | { 2511 | TABLE L = T->left; 2512 | while (L->right) L = L->right; // predecessor 2513 | T2 = mktable(L->key, L->value, ___remove(L->key, T->left), T->right, L->level); 2514 | } 2515 | 2516 | // below here idk really what's going on, but it seems to work: 2517 | 2518 | if (T2->left && T2->right) 2519 | { 2520 | long llevel = T2->left->level; 2521 | long rlevel = T2->right->level; 2522 | long should_be = 1 + (llevel < rlevel ? llevel : rlevel); 2523 | 2524 | if (should_be < T2->level) 2525 | { 2526 | T2->level = should_be; 2527 | if (should_be < T2->right->level) 2528 | T2->right->level = should_be; 2529 | } 2530 | } 2531 | 2532 | // This part makes at least vague sense: 2533 | 2534 | /* Commented these bits out because the GC can't handle them 2535 | * Probably worth implementing a recursive skew and split at some point. 2536 | * IDK how balanced the table is gonna be after this 2537 | if (T2->right) 2538 | { 2539 | T2->right->right = table_skew(T2->right->right); 2540 | T2->right = table_skew(T2->right); 2541 | } 2542 | */ 2543 | T2 = table_skew(T2); 2544 | //if (T2->right) T2->right = table_split(T2->right); 2545 | T2 = table_split(T2); 2546 | 2547 | return T2; 2548 | } 2549 | 2550 | static LIST values_helper(TABLE T, LIST L) 2551 | { 2552 | if (!T) return L; 2553 | return values_helper(T->left, ___push(T->value, values_helper(T->right, L))); 2554 | } 2555 | 2556 | static LIST ___values(TABLE T) 2557 | { 2558 | return values_helper(T, NULL); 2559 | } 2560 | 2561 | static LIST keys_helper(TABLE T, LIST L) 2562 | { 2563 | if (!T) return L; 2564 | return keys_helper(T->left, ___push(T->key, keys_helper(T->right, L))); 2565 | } 2566 | 2567 | static LIST ___keys(TABLE T) 2568 | { 2569 | return keys_helper(T, NULL); 2570 | } 2571 | 2572 | static NUMBER ___length_TABLE(TABLE T) 2573 | { 2574 | if (!T) return 0; 2575 | return 1 + ___length_TABLE(T->left) + ___length_TABLE(T->right); 2576 | } 2577 | 2578 | static NUMBER ___length_LIST(LIST l) 2579 | { 2580 | size_t len = 0; 2581 | while (l) 2582 | { 2583 | len++; 2584 | l = l->next; 2585 | } 2586 | return (NUMBER)len; 2587 | } 2588 | 2589 | static NUMBER ___length_STRING(STRING str) 2590 | { 2591 | size_t len = 0; 2592 | for (; *str ; str += mblen(str, MB_CUR_MAX), ++len); 2593 | return len; 2594 | } 2595 | 2596 | static NUMBER ___length(ANY a) 2597 | { 2598 | switch(type_of(a)) 2599 | { 2600 | case LIST_TYPE: return ___length_LIST(unbox_LIST(a)); 2601 | case STRING_TYPE: return ___length_STRING(unbox_STRING(a)); 2602 | case TABLE_TYPE: return ___length_TABLE(unbox_TABLE(a)); 2603 | default: type_error("list or string or table", a); 2604 | } 2605 | #ifdef __TINYC__ 2606 | return 0; 2607 | #endif 2608 | } 2609 | 2610 | static STRING ___show_NUMBER(NUMBER a) 2611 | { 2612 | show_number(a, (char*)general_purpose_buffer); 2613 | return gc_strdup((char*)general_purpose_buffer); 2614 | } 2615 | 2616 | static STRING ___show_TABLE(TABLE a) 2617 | { 2618 | show_table(a, (char*)general_purpose_buffer, NULL); 2619 | return gc_strdup((char*)general_purpose_buffer); 2620 | } 2621 | 2622 | static STRING ___show_IO(IO a) 2623 | { 2624 | show_io(a, (char*)general_purpose_buffer); 2625 | return gc_strdup((char*)general_purpose_buffer); 2626 | } 2627 | 2628 | static STRING ___show_STRING(STRING s) 2629 | { 2630 | return s; 2631 | } 2632 | 2633 | static STRING ___show_BOOLEAN(BOOLEAN b) 2634 | { 2635 | return b ? "True" : "False"; 2636 | } 2637 | 2638 | static STRING ___show_SYMBOL(SYMBOL s) 2639 | { 2640 | return s; 2641 | } 2642 | 2643 | static STRING ___show_BLOCK(BLOCK b) 2644 | { 2645 | show_block(b, (char*)general_purpose_buffer); 2646 | return gc_strdup((char*)general_purpose_buffer); 2647 | } 2648 | 2649 | static STRING ___show_BOX(BOX b) 2650 | { 2651 | show_box(b, (char*)general_purpose_buffer, NULL); 2652 | return gc_strdup((char*)general_purpose_buffer); 2653 | } 2654 | 2655 | static STRING ___show_LIST(LIST l) 2656 | { 2657 | show_list(l, (char*)general_purpose_buffer, NULL); 2658 | return gc_strdup((char*)general_purpose_buffer); 2659 | } 2660 | 2661 | 2662 | 2663 | static regex_t* memoized_regcomp(STRING reg_str) 2664 | { 2665 | regex_t* reg; 2666 | if (___has(box_STRING(reg_str), memoized_regexes)) reg = (regex_t*)unbox_STRING(___D(box_STRING(reg_str), memoized_regexes)); 2667 | else 2668 | { 2669 | reg = gc_malloc(sizeof *reg); 2670 | const int status = regcomp(reg, reg_str, REG_EXTENDED | REG_NEWLINE); 2671 | errno = 0; // Hmmm 2672 | if unlikely(status) 2673 | { 2674 | char reg_err[256]; 2675 | regerror(status, reg, reg_err, 256); 2676 | throw_error_fmt("Compile error (%s) in regex '%.32s'", reg_err, reg_str); 2677 | } 2678 | memoized_regexes = ___insert(box_STRING(reg_str), box_STRING((char*)reg), memoized_regexes); 2679 | } 2680 | 2681 | return reg; 2682 | } 2683 | 2684 | static BOOLEAN ___regex(STRING reg_str, STRING str) 2685 | { 2686 | regex_t* reg = memoized_regcomp(reg_str); 2687 | const int found = regexec(reg, str, 0, NULL, 0); 2688 | if unlikely(found != 0 && found != REG_NOMATCH) 2689 | throw_error_fmt("Regex failed matching string '%.32s'", str); 2690 | 2691 | return found != REG_NOMATCH; 2692 | } 2693 | 2694 | static BOOLEAN ___regexHmatch(STRING reg_str, STRING str) 2695 | { 2696 | regex_t* reg = memoized_regcomp(reg_str); 2697 | 2698 | size_t groups = reg->re_nsub + 1; 2699 | regmatch_t matches[groups]; 2700 | const int found = regexec(reg, str, groups, matches, 0); 2701 | if unlikely(found != 0 && found != REG_NOMATCH) throw_error_fmt("Regex failed matching string '%.32s'", str); 2702 | 2703 | if (found == 0) { 2704 | for (unsigned int g = 1; g < groups ; g++) 2705 | { 2706 | size_t from = matches[g].rm_so; 2707 | if (from == (size_t)-1) 2708 | { 2709 | groups = g; 2710 | break; 2711 | } 2712 | } 2713 | 2714 | for (unsigned int g = groups-1; g > 0; g--) 2715 | { 2716 | size_t from = matches[g].rm_so; 2717 | size_t to = matches[g].rm_eo; 2718 | char* item = gc_strndup((char*)str, to); 2719 | push(box_STRING(item + from)); 2720 | } 2721 | } 2722 | return found != REG_NOMATCH; 2723 | } 2724 | 2725 | static LIST ___append_LIST(LIST l1, LIST l2) 2726 | { 2727 | if (!l2) return l1; 2728 | else return ___push(___first_LIST(l2), ___append_LIST(l1, ___rest_LIST(l2))); 2729 | } 2730 | 2731 | static STRING ___append_STRING(STRING s1, STRING s2) 2732 | { 2733 | size_t len1 = strlen(s1); 2734 | size_t len2 = strlen(s2); 2735 | char* output = gc_malloc(len1 + len2 + 1); 2736 | strcpy(output, s2); 2737 | strcpy(output+len2, s1); 2738 | output[len1+len2] = '\0'; 2739 | return (STRING)output; 2740 | } 2741 | 2742 | static ANY ___append(ANY a1, ANY a2) 2743 | { 2744 | cognate_type t = type_of(a1); 2745 | switch (t) 2746 | { 2747 | case LIST_TYPE: 2748 | return box_LIST(___append_LIST(unbox_LIST(a1), unbox_LIST(a2))); 2749 | case STRING_TYPE: 2750 | return box_STRING(___append_STRING(unbox_STRING(a1), unbox_STRING(a2))); 2751 | default: type_error("List or String", a1); 2752 | } 2753 | #ifdef __TINYC__ 2754 | return NIL; 2755 | #endif 2756 | } 2757 | 2758 | static BOOLEAN ___numberQ_NUMBER(NUMBER _) { return true; } 2759 | static BOOLEAN ___numberQ_LIST(LIST _) { return false; } 2760 | static BOOLEAN ___numberQ_BOX(BOX _) { return false; } 2761 | static BOOLEAN ___numberQ_TABLE(TABLE _) { return false; } 2762 | static BOOLEAN ___numberQ_IO(IO _) { return false; } 2763 | static BOOLEAN ___numberQ_BOOLEAN(BOOLEAN _) { return false; } 2764 | static BOOLEAN ___numberQ_STRING(STRING _) { return false; } 2765 | static BOOLEAN ___numberQ_SYMBOL(SYMBOL _) { return false; } 2766 | static BOOLEAN ___numberQ_BLOCK(BLOCK _) { return false; } 2767 | 2768 | static BOOLEAN ___listQ_NUMBER(NUMBER _) { return false; } 2769 | static BOOLEAN ___listQ_LIST(LIST _) { return true; } 2770 | static BOOLEAN ___listQ_BOX(BOX _) { return false; } 2771 | static BOOLEAN ___listQ_TABLE(TABLE _) { return false; } 2772 | static BOOLEAN ___listQ_IO(IO _) { return false; } 2773 | static BOOLEAN ___listQ_BOOLEAN(BOOLEAN _) { return false; } 2774 | static BOOLEAN ___listQ_STRING(STRING _) { return false; } 2775 | static BOOLEAN ___listQ_SYMBOL(SYMBOL _) { return false; } 2776 | static BOOLEAN ___listQ_BLOCK(BLOCK _) { return false; } 2777 | 2778 | static BOOLEAN ___boxQ_NUMBER(NUMBER _) { return false; } 2779 | static BOOLEAN ___boxQ_LIST(LIST _) { return false; } 2780 | static BOOLEAN ___boxQ_BOX(BOX _) { return true; } 2781 | static BOOLEAN ___boxQ_TABLE(TABLE _) { return false; } 2782 | static BOOLEAN ___boxQ_IO(IO _) { return false; } 2783 | static BOOLEAN ___boxQ_BOOLEAN(BOOLEAN _) { return false; } 2784 | static BOOLEAN ___boxQ_STRING(STRING _) { return false; } 2785 | static BOOLEAN ___boxQ_SYMBOL(SYMBOL _) { return false; } 2786 | static BOOLEAN ___boxQ_BLOCK(BLOCK _) { return false; } 2787 | 2788 | static BOOLEAN ___tableQ_NUMBER(NUMBER _) { return false; } 2789 | static BOOLEAN ___tableQ_LIST(LIST _) { return false; } 2790 | static BOOLEAN ___tableQ_BOX(BOX _) { return false; } 2791 | static BOOLEAN ___tableQ_TABLE(TABLE _) { return true; } 2792 | static BOOLEAN ___tableQ_IO(IO _) { return false; } 2793 | static BOOLEAN ___tableQ_BOOLEAN(BOOLEAN _) { return false; } 2794 | static BOOLEAN ___tableQ_STRING(STRING _) { return false; } 2795 | static BOOLEAN ___tableQ_SYMBOL(SYMBOL _) { return false; } 2796 | static BOOLEAN ___tableQ_BLOCK(BLOCK _) { return false; } 2797 | 2798 | static BOOLEAN ___ioQ_NUMBER(NUMBER _) { return false; } 2799 | static BOOLEAN ___ioQ_LIST(LIST _) { return false; } 2800 | static BOOLEAN ___ioQ_BOX(BOX _) { return false; } 2801 | static BOOLEAN ___ioQ_TABLE(TABLE _) { return false; } 2802 | static BOOLEAN ___ioQ_IO(IO _) { return true; } 2803 | static BOOLEAN ___ioQ_BOOLEAN(BOOLEAN _) { return false; } 2804 | static BOOLEAN ___ioQ_STRING(STRING _) { return false; } 2805 | static BOOLEAN ___ioQ_SYMBOL(SYMBOL _) { return false; } 2806 | static BOOLEAN ___ioQ_BLOCK(BLOCK _) { return false; } 2807 | 2808 | static BOOLEAN ___booleanQ_NUMBER(NUMBER _) { return false; } 2809 | static BOOLEAN ___booleanQ_LIST(LIST _) { return false; } 2810 | static BOOLEAN ___booleanQ_BOX(BOX _) { return false; } 2811 | static BOOLEAN ___booleanQ_TABLE(TABLE _) { return false; } 2812 | static BOOLEAN ___booleanQ_IO(IO _) { return false; } 2813 | static BOOLEAN ___booleanQ_BOOLEAN(BOOLEAN _) { return true; } 2814 | static BOOLEAN ___booleanQ_STRING(STRING _) { return false; } 2815 | static BOOLEAN ___booleanQ_SYMBOL(SYMBOL _) { return false; } 2816 | static BOOLEAN ___booleanQ_BLOCK(BLOCK _) { return false; } 2817 | 2818 | static BOOLEAN ___stringQ_NUMBER(NUMBER _) { return false; } 2819 | static BOOLEAN ___stringQ_LIST(LIST _) { return false; } 2820 | static BOOLEAN ___stringQ_BOX(BOX _) { return false; } 2821 | static BOOLEAN ___stringQ_TABLE(TABLE _) { return false; } 2822 | static BOOLEAN ___stringQ_IO(IO _) { return false; } 2823 | static BOOLEAN ___stringQ_BOOLEAN(BOOLEAN _) { return false; } 2824 | static BOOLEAN ___stringQ_STRING(STRING _) { return true; } 2825 | static BOOLEAN ___stringQ_SYMBOL(SYMBOL _) { return false; } 2826 | static BOOLEAN ___stringQ_BLOCK(BLOCK _) { return false; } 2827 | 2828 | static BOOLEAN ___symbolQ_NUMBER(NUMBER _) { return false; } 2829 | static BOOLEAN ___symbolQ_LIST(LIST _) { return false; } 2830 | static BOOLEAN ___symbolQ_BOX(BOX _) { return false; } 2831 | static BOOLEAN ___symbolQ_TABLE(TABLE _) { return false; } 2832 | static BOOLEAN ___symbolQ_IO(IO _) { return false; } 2833 | static BOOLEAN ___symbolQ_BOOLEAN(BOOLEAN _) { return false; } 2834 | static BOOLEAN ___symbolQ_STRING(STRING _) { return false; } 2835 | static BOOLEAN ___symbolQ_SYMBOL(SYMBOL _) { return true; } 2836 | static BOOLEAN ___symbolQ_BLOCK(BLOCK _) { return false; } 2837 | 2838 | static BOOLEAN ___blockQ_NUMBER(NUMBER _) { return false; } 2839 | static BOOLEAN ___blockQ_LIST(LIST _) { return false; } 2840 | static BOOLEAN ___blockQ_BOX(BOX _) { return false; } 2841 | static BOOLEAN ___blockQ_TABLE(TABLE _) { return false; } 2842 | static BOOLEAN ___blockQ_IO(IO _) { return false; } 2843 | static BOOLEAN ___blockQ_BOOLEAN(BOOLEAN _) { return false; } 2844 | static BOOLEAN ___blockQ_STRING(STRING _) { return false; } 2845 | static BOOLEAN ___blockQ_SYMBOL(SYMBOL _) { return false; } 2846 | static BOOLEAN ___blockQ_BLOCK(BLOCK _) { return true; } 2847 | 2848 | static BOOLEAN ___EE_NUMBER(NUMBER n1, NUMBER n2) { return !compare_numbers(n1, n2); } 2849 | static BOOLEAN ___EE_LIST(LIST l1, LIST l2) { return !compare_lists(l1, l2); } 2850 | static BOOLEAN ___EE_BOX(BOX b1, BOX b2) { return !compare_boxes(b1, b2); } 2851 | static BOOLEAN ___EE_TABLE(TABLE t1, TABLE t2) { return !compare_tables(t1, t2); } 2852 | static BOOLEAN ___EE_IO(IO i1, IO i2) { return !compare_io(i1, i2); } 2853 | static BOOLEAN ___EE_BOOLEAN(BOOLEAN b1, BOOLEAN b2) { return !compare_booleans(b1, b2); } 2854 | static BOOLEAN ___EE_STRING(STRING s1, STRING s2) { return !compare_strings(s1, s2); } 2855 | static BOOLEAN ___EE_SYMBOL(SYMBOL s1, SYMBOL s2) { return !compare_symbols(s1, s2); } 2856 | static BOOLEAN ___EE_BLOCK(BLOCK b1, BLOCK b2) { return !compare_blocks(b1, b2); } 2857 | 2858 | // ---------- ACTUAL PROGRAM ---------- 2859 | -------------------------------------------------------------------------------- /tests/ack.cog: -------------------------------------------------------------------------------- 1 | Def Ack ( 2 | Let X; 3 | Let Y; 4 | 5 | Do 6 | If Zero? X ( + 1 Y ) 7 | If Zero? Y ( Ack of - 1 X and 1 ) 8 | else ( Ack of - 1 X and Ack X and - 1 Y ) 9 | ); 10 | 11 | Print If == 253 Ack 3 5 12 | "PASS: Ackermann function" 13 | else 14 | "FAIL: Ackermann function"; 15 | 16 | -------------------------------------------------------------------------------- /tests/begin.cog: -------------------------------------------------------------------------------- 1 | Let reached UnreachableCode Box False; 2 | Let reached ReachableCode Box False; 3 | 4 | Begin ( 5 | Def Exit; 6 | Set reached ReachableCode to True; 7 | Exit; 8 | Set reached UnreachableCode to True; 9 | ); 10 | 11 | Print If And reached Unbox ReachableCode and Not reached Unbox UnreachableCode 12 | "PASS: Begin" 13 | else 14 | "FAIL: Begin"; 15 | 16 | 17 | Let UnreachableList be Map (Box) over List (False False False); 18 | Let ReachableList be Map (Box) over List (False False False); 19 | 20 | Begin ( 21 | Def Level1; 22 | Set Index 0 ReachableList to True; 23 | Begin ( 24 | Def Level2; 25 | Set Index 1 ReachableList to True; 26 | Begin ( 27 | Def Level3; 28 | Set Index 2 ReachableList to True; 29 | exit from Level1; 30 | Set First UnreachableList to True; 31 | ) 32 | Set Index 1 UnreachableList to True; 33 | ) 34 | Set Index 2 UnreachableList to True; 35 | ); 36 | 37 | Print If And All are (Not reached from Unbox) in UnreachableList and 38 | All are reached from (Unbox) in ReachableList then 39 | "PASS: Exit from nested Begin 1" 40 | else 41 | "PASS: Exit from nested Begin 1"; 42 | 43 | 44 | For item in UnreachableList (Let I; Set I Not Unbox I); 45 | For item in ReachableList (Let I; Set I Not Unbox I); 46 | 47 | Begin ( 48 | Def Level1; 49 | Set Index 0 ReachableList to True; 50 | Begin ( 51 | Def Level2; 52 | Set Index 1 ReachableList to True; 53 | Begin ( 54 | Def Level3; 55 | Set Index 2 ReachableList to True; 56 | Do ( 57 | exit Level1; 58 | ); 59 | Set First UnreachableList to True; 60 | ) 61 | Set Index 1 UnreachableList to True; 62 | ) 63 | Set Index 2 UnreachableList to True; 64 | ); 65 | 66 | Print If And All are (Not reached from Unbox) in UnreachableList and 67 | All are reached from (Unbox) in ReachableList then 68 | "PASS: Exit from nested Begin 2" 69 | else 70 | "PASS: Exit from nested Begin 2"; 71 | -------------------------------------------------------------------------------- /tests/block.cog: -------------------------------------------------------------------------------- 1 | Def Drop as (Let X); 2 | 3 | Def Baz as ( 4 | Let Z; 5 | (Do Z); 6 | ); 7 | 8 | 9 | Def Bar as ( 10 | Let Y; 11 | Baz (Do Y); 12 | ); 13 | 14 | Def Foo as ( 15 | Let X; 16 | Bar (Print X); 17 | ); 18 | 19 | 20 | Foo "PASS: Implicit block copying"; 21 | Foo "FAIL: Implicit block copying"; 22 | Drop; Do; 23 | 24 | 25 | Let Y be Box (); 26 | 27 | Def Foo2 as ( 28 | Let X; 29 | Set Y to (Print X); 30 | ); 31 | 32 | 33 | Foo2 "PASS: Implicit block copying with mutation"; Let Z be Unbox Y; 34 | Foo2 "FAIL: Implicit block copying with mutation"; Let W be Unbox Y; 35 | Do Z; 36 | Drop W; 37 | 38 | Def A as ( 39 | Let B; 40 | Let Foo as (Print B); 41 | return (Do Foo); 42 | ); 43 | 44 | Do A "PASS: Another block copying test"; 45 | 46 | Def B as ( 47 | Let B; 48 | Def Foo as (Print B); 49 | return (Foo); 50 | ); 51 | 52 | Do B "PASS: Another block copying test again"; 53 | 54 | "PASS: Closure loading 2"; 55 | "PASS: Closure loading 1"; 56 | 57 | Do ( 58 | Let X; 59 | Let Y; 60 | Do If True 61 | then ( Print X ; Print Y ) 62 | else ( ) 63 | ); 64 | 65 | Let H be 5; 66 | Let B1 be ( Print H ); 67 | Let B2 be ( Print H ); 68 | 69 | Print If != B1 B2 70 | "PASS: Comparing different blocks" 71 | else 72 | "FAIL: Comparing different blocks"; 73 | 74 | Print If == B1 B1 75 | "PASS: Comparing the same block" 76 | else 77 | "FAIL: Comparing the same block"; 78 | -------------------------------------------------------------------------------- /tests/booleans.cog: -------------------------------------------------------------------------------- 1 | Print If == True True then "PASS: True == True" else "FAIL: True == True"; 2 | Print If == False False then "PASS: False == False" else "FAIL: False == False"; 3 | Print If == True False then "Fail: True == False" else "PASS: True == False"; 4 | Print If == False True then "Fail: False == True" else "PASS: False == True"; 5 | 6 | 7 | Print If And True True then "PASS: True AND True" else "FAIL: True AND True"; 8 | Print If And True False then "FAIL: True AND False" else "PASS: True AND False"; 9 | Print If And False True then "FAIL: False AND True" else "PASS: False AND True"; 10 | Print If And False False then "FAIL: False AND False" else "PASS: False AND False"; 11 | 12 | Print If Or True True then "PASS: True OR True" else "FAIL: True OR True"; 13 | Print If Or True False then "PASS: True OR False" else "FAIL: True OR False"; 14 | Print If Or False True then "PASS: False OR True" else "FAIL: False OR True"; 15 | Print If Or False False then "FAIL: False OR False" else "PASS: False OR False"; 16 | 17 | Print If Xor True True then "FAIL: True XOR True" else "PASS: True XOR True"; 18 | Print If Xor True False then "PASS: True XOR False" else "FAIL: True XOR False"; 19 | Print If Xor False True then "PASS: False XOR True" else "FAIL: False XOR True"; 20 | Print If Xor False False then "FAIL: False XOR False" else "PASS: False XOR False"; 21 | 22 | Print If Not True then "FAIL: NOT True" else "PASS: NOT True"; 23 | Print If Not False then "PASS: NOT False" else "PASS: NOT False"; 24 | -------------------------------------------------------------------------------- /tests/box.cog: -------------------------------------------------------------------------------- 1 | Let X be Box 10; 2 | 3 | Print If == 10 Unbox X 4 | "PASS: Boxing and unboxing" 5 | else 6 | "FAIL: Boxing and unboxing"; 7 | 8 | Set X to 11; 9 | 10 | Print If == 11 Unbox X 11 | "PASS: Setting box to different value" 12 | else 13 | "FAIL: Setting box to different value"; 14 | 15 | Let L be Map (Box) over Range 1 to 100; 16 | 17 | For each in L ( Let X ; Set X to + 1 Unbox X ); 18 | 19 | Print If == 49 Unbox Index 47 L 20 | "PASS: Setting each element in list of boxes" 21 | else 22 | "FAIL: Setting each element in list of boxes"; 23 | 24 | Print If == "[11]" Show X 25 | "PASS: Printing simple box to string" 26 | else 27 | "FAIL: Printing simple box to string"; 28 | 29 | 30 | Let C be Box \waow; 31 | Set C to C; 32 | 33 | Print If == "[[...]]" Show Box C 34 | "PASS: Printing cyclic box" 35 | else 36 | "FAIL: Printing cyclic box"; 37 | 38 | Let B1 be Box 0; 39 | Let B2 be Box 1; 40 | Let B3 be Box 2; 41 | 42 | Set B1 to B2; 43 | Set B2 to B3; 44 | Set B3 to B1; 45 | 46 | Print If == "[[[...]]]" Show B1 47 | "PASS: Printing doubly cyclic box" 48 | else 49 | "FAIL: Printing doubly cyclic box"; 50 | 51 | 52 | Let D be a List (0 Box 1 2 Box 3); 53 | Set Index 1 D to be D; 54 | 55 | Print If == "(0 [(0 ... 2 [3])] 2 [3])" Show D 56 | "PASS: Printing cyclic box within list" 57 | else 58 | "FAIL: Printing cyclic box within list"; 59 | 60 | Let E be a List (Box 1 Box 2 Box 3 Box 4); 61 | Set Index 0 E be Index 1 E; 62 | Set Index 1 E be Index 2 E; 63 | Set Index 2 E be Index 3 E; 64 | Set Index 3 E be Index 0 E; 65 | 66 | Print If == "([[[[...]]]] [[[[...]]]] [[[[...]]]] [[[[...]]]])" Show E 67 | "PASS: Printing cyclic box within list 2" 68 | else 69 | "FAIL: Printing cyclic box within list 2"; 70 | -------------------------------------------------------------------------------- /tests/dispatch.cog: -------------------------------------------------------------------------------- 1 | Let N be "PASS: dynamic dispatch"; 2 | 3 | Do If Number? N (Print + 1 N) 4 | else (Print N); 5 | -------------------------------------------------------------------------------- /tests/fib.cog: -------------------------------------------------------------------------------- 1 | Def Fib 2 | Case (< 3) then (1 Drop) 3 | else (Let N ; Fib of - 1 N ; + Fib of - 2 N); 4 | 5 | Print If == 55 Fib 10 6 | then "PASS: Fibonacci numbers" 7 | else "FAIL: Fibonacci numbers"; 8 | -------------------------------------------------------------------------------- /tests/filter.cog: -------------------------------------------------------------------------------- 1 | Def Drop as (Let X); 2 | Def Twin as (Let X ; X X); 3 | Let Evens be Filter (Modulo 2 ; == 0) over the List (1 2 3 4 5); 4 | Let Empty be Filter (Modulo 2 ; == 0) over the List (); 5 | Let X be Box True; 6 | Let Odds be Filter (Drop ; Twin Unbox X ; Set X to Not) 7 | over the List (1 2 3 4 5); 8 | 9 | Print If == Evens List (2 4) 10 | then "PASS: Filtering a list" 11 | else "FAIL: Filtering a list"; 12 | 13 | Print If == Empty List () 14 | then "PASS: Filtering an empty list" 15 | else "FAIL: Filtering an empty list"; 16 | 17 | Print If == Odds List (1 3 5) 18 | then "PASS: Filtering a list in order" 19 | else "FAIL: Filtering a list in order"; 20 | -------------------------------------------------------------------------------- /tests/fizzbuzz.cog: -------------------------------------------------------------------------------- 1 | Def Fizzbuzz ( 2 | Let N; 3 | Def Multiple as ( Zero? Modulo Swap N ); 4 | If Multiple of 15 then "fizzbuzz" 5 | If Multiple of 3 then "fizz" 6 | If Multiple of 5 then "buzz" 7 | else N 8 | ); 9 | 10 | 11 | Let L be Map (Fizzbuzz) over Range 1 to 100; 12 | 13 | Print If == "fizz" Index 5 of L 14 | then "PASS: Fizzbuzz 1" 15 | else "FAIL: Fizzbuzz 1"; 16 | 17 | Print If == "fizzbuzz" Index 14 of L 18 | then "PASS: Fizzbuzz 2" 19 | else "FAIL: Fizzbuzz 2"; 20 | 21 | Print If == 16 Index 15 of L 22 | then "PASS: Fizzbuzz 3" 23 | else "FAIL: Fizzbuzz 3"; 24 | -------------------------------------------------------------------------------- /tests/for.cog: -------------------------------------------------------------------------------- 1 | Let R be For each in List (1 2 3 4 5) (*) from 1; 2 | 3 | Print If == 120 R 4 | then "PASS: Computing 5! using for loop" 5 | else "FAIL: Computing 5! using for loop"; 6 | 7 | Let X be Box 0; 8 | For each in List (1 2 3 4 5) (Set X); 9 | 10 | Print If == 5 Unbox X 11 | then "PASS: For loop executes in order" 12 | else "FAIL: For loop executes in order"; 13 | -------------------------------------------------------------------------------- /tests/functions.cog: -------------------------------------------------------------------------------- 1 | Def Foo as (+ 1); 2 | 3 | Print If == 5 Foo 4 4 | "PASS: Function call and return" 5 | else 6 | "FAIL: Function call and return"; 7 | 8 | Do ( 9 | Def Foo as (+ 3); 10 | 11 | Print If == 8 Foo 5 12 | "PASS: Function shadowing 1" 13 | else 14 | "FAIL: Function shadowing 1"; 15 | ); 16 | 17 | Print If == 8 Foo 7 18 | "PASS: Function shadowing 2" 19 | else 20 | "FAIL: Function shadowing 2"; 21 | 22 | Let Recurred be Box False; 23 | Def Bar as 24 | ( 25 | Let N; 26 | Do If == 0 N then ( 27 | Set Recurred to True; 28 | ) else ( 29 | Bar with 0; 30 | ); 31 | ); 32 | 33 | call Bar with 10; 34 | Print If Unbox Recurred 35 | "PASS: Recursion" 36 | else 37 | "FAIL: Recursion"; 38 | 39 | Def Binrec1 40 | ( Let X; 41 | Do If > 1000 X 42 | then (Print "PASS: Binary recursion") 43 | else (Binrec2 with + 1 X); 44 | ); 45 | 46 | Def Binrec2 47 | ( 48 | Binrec1 with + 1; 49 | ); 50 | 51 | Binrec1 1; 52 | 53 | -------------------------------------------------------------------------------- /tests/hanoi.cog: -------------------------------------------------------------------------------- 1 | Def Concatenate as ( Fold ( Prepend Show ) from "" over Reverse List ); 2 | 3 | Def Move discs as ( 4 | 5 | Let N be number of discs; 6 | Let A be first rod; 7 | Let B be second rod; 8 | Let C be third rod; 9 | 10 | Unless Zero? N ( 11 | Move - 1 N discs from A via C to B; 12 | Concatenate ("Move disc " N " from " A " to " C); 13 | Move - 1 N discs from B via A to C; 14 | ) 15 | ); 16 | 17 | Let L be List ( Move 5 discs from \a via \b to \c ); 18 | 19 | Print If == "Move disc 2 from a to b" Index 5 L 20 | then "PASS: Towers of Hanoi" 21 | else "FAIL: Towers of Hanoi"; 22 | -------------------------------------------------------------------------------- /tests/if.cog: -------------------------------------------------------------------------------- 1 | Print If True 2 | "PASS: If True" 3 | else 4 | "FAIL: If True"; 5 | 6 | Print If False 7 | "FAIL: If False" 8 | else 9 | "PASS: If False"; 10 | -------------------------------------------------------------------------------- /tests/io.cog: -------------------------------------------------------------------------------- 1 | With \read "tests/io.txt" ( 2 | 3 | Let F be the file; 4 | 5 | 6 | Let S be Read-file F; 7 | 8 | Print If == "foo\nbar\n" S 9 | "PASS: Reading multi-line file to string" 10 | else 11 | "FAIL: Reading multi-line file to string"; 12 | 13 | Seek from \start to position 0 in F; 14 | 15 | Let L be Read-line F; 16 | 17 | Print If == "foo\n" L 18 | "PASS: Reading first line of file to string" 19 | else 20 | "FAIL: Reading first line of file to string"; 21 | 22 | 23 | ); 24 | -------------------------------------------------------------------------------- /tests/io.txt: -------------------------------------------------------------------------------- 1 | foo 2 | bar 3 | -------------------------------------------------------------------------------- /tests/lists.cog: -------------------------------------------------------------------------------- 1 | Let Foo be List (1 2 3); 2 | 3 | Print If == Foo Foo 4 | "PASS: Comparing equal lists" 5 | else 6 | "FAIL: Comparing equal lists"; 7 | 8 | Print If != Foo List (5 6 7) 9 | "PASS: Comparing unequal lists" 10 | else 11 | "FAIL: Comparing unequal lists"; 12 | 13 | Print If == List () List () 14 | "PASS: Comparing two empty lists" 15 | else 16 | "FAIL: Comparing two empty lists"; 17 | 18 | Print If != List () Foo 19 | "PASS: An empty list to a non-empty list" 20 | else 21 | "FAIL: An empty list to a non-empty list"; 22 | 23 | Print If == Push 42 to Foo is List (42 1 2 3) 24 | "PASS: Pushing object to list" 25 | else 26 | "FAIL: Pushing object to list"; 27 | 28 | Print If == 1 First element in Foo 29 | "PASS: Getting First element in list" 30 | else 31 | "FAIL: Getting First element in list"; 32 | 33 | Print If == 1 First element in List (1) 34 | "PASS: Getting First element in single-element list" 35 | else 36 | "FAIL: Getting First element in single-element list"; 37 | 38 | Print If == Rest of Foo List (2 3) 39 | "PASS: Getting Rest of list" 40 | else 41 | "FAIL: Getting Rest of list"; 42 | 43 | Print If == List () Rest of List (1) 44 | "PASS: Getting Rest of single-element list" 45 | else 46 | "FAIL: Getting Rest of single-element list"; 47 | 48 | Print If == 4 Index 3 of List (1 2 3 4 5) 49 | "PASS: Getting index of list" 50 | "FAIL: Getting index of list"; 51 | 52 | Print If == 3 Length of List (1 2 3) 53 | "PASS: Getting length of list" 54 | "FAIL: Getting length of list"; 55 | 56 | Print If == "(1 2 3)" Show List (1 2 3) 57 | "PASS: Printing list to string" 58 | "FAIL: Printing list to string"; 59 | -------------------------------------------------------------------------------- /tests/map.cog: -------------------------------------------------------------------------------- 1 | Print If == List (2 3 4) Map (+ 1) over the List (1 2 3) 2 | then "PASS: Mapping over a list" 3 | else "FAIL: Mapping over a list"; 4 | 5 | Print If == List () Map (+ 1) over the List () 6 | then "PASS: Mapping over an empty list" 7 | else "FAIL: Mapping over a list"; 8 | 9 | Let X be Box 0; 10 | Print If == List (1 3 6) Map (+ Unbox X; Set X; Unbox X) over List (1 2 3) 11 | then "PASS: Mapping in order" 12 | else "FAIL: Mapping in order"; 13 | -------------------------------------------------------------------------------- /tests/maths.cog: -------------------------------------------------------------------------------- 1 | Print If == 11 + 5 6 2 | "PASS: Addition" 3 | else 4 | "FAIL: Addition"; 5 | 6 | Print If == 9 - 10 19 7 | "PASS: Subtraction" 8 | else 9 | "FAIL: Subtraction"; 10 | 11 | Print If == 72 * 9 8 12 | "PASS: Multiplication" 13 | else 14 | "FAIL: Multiplication"; 15 | 16 | Print If == 6 / 7 42 17 | "PASS: Division" 18 | else 19 | "FAIL: Division"; 20 | 21 | Print If == 1 Modulo by 3 of 10 22 | "PASS: Modulus" 23 | else 24 | "FAIL: Modulus"; 25 | 26 | Print If == 4 Floor 4.7 27 | "PASS: Floor" 28 | else 29 | "FAIL: Floor"; 30 | 31 | Print If == 5 Ceiling 4.3 32 | "PASS: Ceiling" 33 | else 34 | "FAIL: Ceiling"; 35 | 36 | Print If == 5 Round 4.7 37 | "PASS: Round" 38 | else 39 | "FAIL: Round"; 40 | 41 | Print If And == 5 Abs -5 == 2.17 Abs Abs -2.17 42 | "PASS: Abs" 43 | else 44 | "FAIL: Abs"; 45 | 46 | Print If == 0.3 + 0.1 0.2 47 | "PASS: Floating point error" 48 | else 49 | "FAIL: Floating point error"; 50 | 51 | Print If == 1 + 0.1 * 3 0.3 52 | "PASS: Floating point error 2" 53 | else 54 | "FAIL: Floating point error 2"; 55 | -------------------------------------------------------------------------------- /tests/other-math.cog: -------------------------------------------------------------------------------- 1 | Print If == 1 Exp 0 2 | "PASS: exp" 3 | else 4 | "FAIL: exp"; 5 | 6 | Print If == 0 Ln 1 7 | "PASS: Log base e" 8 | else 9 | "FAIL: Log base e"; 10 | 11 | Print If == 2 Log 10 100 12 | "PASS: Log" 13 | else 14 | "FAIL: Log"; 15 | -------------------------------------------------------------------------------- /tests/overloading.cog: -------------------------------------------------------------------------------- 1 | Def Q ( 2 | Let A be Of (Any?); 3 | Do If Number? A 4 | (Do If > 0 A (Print "PASS: Overloading 1") (Print "PASS: Overloading 2")) 5 | (Print "PASS: Overloading 3"); 6 | ); 7 | 8 | Q -1; 9 | Q 1; 10 | Q ""; 11 | -------------------------------------------------------------------------------- /tests/parsing.cog: -------------------------------------------------------------------------------- 1 | ~ Let A be 4; ~ ~~ Let A be 4; 2 | Let A be 5; ~~ Let A be 4; ~ Let A be 4; ~ 3 | ~ Let A be 4; ~ ~~ Let A be 4; 4 | 5 | Print If == 5 A 6 | "PASS: Comments" 7 | else 8 | "FAIL: Comments"; 9 | 10 | ~~ The syntax highlighter can"t handle this next bit. 11 | 12 | Let X be Box 0; 13 | 14 | Def Inc as ( Set X to + 1 Unbox X ); 15 | 16 | " \" Inc; \" " " " Inc; " " 17 | Inc; "" "Inc;" 18 | " Inc; \" Inc "; 19 | Clear; 20 | 21 | Print If == 2 Unbox X 22 | "PASS: Strings" 23 | else 24 | "FAIL: Strings"; 25 | 26 | Print If == 1.5 / 2 3 27 | "PASS: Floating point numbers" 28 | else 29 | "FAIL: Floating point numbers"; 30 | -------------------------------------------------------------------------------- /tests/prime.cog: -------------------------------------------------------------------------------- 1 | Def Factor (Zero? Modulo Swap); 2 | 3 | Def Primes ( 4 | Let U is upper bound; 5 | initially Empty; 6 | For Range 2 to U ( 7 | Let I be our potential prime; 8 | Let Primes are the found primes; 9 | Let To-check be Take-while (<= Sqrt I) Primes; 10 | When None (Factor of I) To-check 11 | (Append List (I)) to Primes; 12 | ) 13 | ); 14 | 15 | Let L be Primes up to 100; 16 | 17 | Print If == 73 Index 20 of L 18 | then "PASS: Prime numbers" 19 | else "FAIL: Prime numbers" 20 | -------------------------------------------------------------------------------- /tests/prime2.cog: -------------------------------------------------------------------------------- 1 | Def Factor (Zero? Modulo Swap); 2 | 3 | Def Primes ( 4 | Let U is upper bound; 5 | initially Table (); 6 | For Range 2 to U ( 7 | Let I be our potential prime; 8 | Let To-check be Range 2 to Floor + 1 Sqrt I; 9 | Insert I None (Factor of I) To-check; 10 | ) 11 | ); 12 | 13 | Let P be Primes up to 100; 14 | 15 | Print If And Not . 50 P . 37 P 16 | "PASS: Prime numbers using a table" 17 | else 18 | "FAIL: Prime numbers using a table"; 19 | -------------------------------------------------------------------------------- /tests/regex.cog: -------------------------------------------------------------------------------- 1 | ~~ This simple regex matches hexadecimal integers. 2 | ~~ ^ and $ are needed else it will only match part of the string. 3 | 4 | Let R1 be "^[0-9A-Fa-f]*$"; 5 | Print If And Regex R1 "12EFab" and Not Regex R1 "foo123" 6 | "PASS: Simple regex to identify hex integers" 7 | else 8 | "FAIL: Simple regex to identify hex integers"; 9 | 10 | ~~ Same regex as before; but with POSIX character classes 11 | Let R2 be "^[[:xdigit:]]*$"; 12 | Print If And Regex R2 "12EFab" and Not Regex R2 "foo123" 13 | "PASS: Regex to identify hex integers (character class)" 14 | else 15 | "FAIL: Regex to identify hex integers (character class)"; 16 | 17 | ~~ This regex matches decimal numbers (d.p can be dot or comma) 18 | Let R3 be "^(-)?([0-9]+)((;|.)([0-9]+))?$"; 19 | Print If And Regex R3 "1.234" and Not Regex R3 "Hello world" 20 | "PASS: Extended regex to identify decimal numbers" 21 | else 22 | "FAIL: Extended regex to identify decimal numbers"; 23 | 24 | Let R4 be "-?([0-9]+)(.[0-9]+)?"; 25 | Print If == List (Regex-match R4 "13.37") List (True "13" ".37") 26 | "PASS: Capture sub-expressions for integer and fractional parts" 27 | else 28 | "FAIL: Capture sub-expressions for integer and fractional parts"; 29 | 30 | Let R5 be "([[:alnum:]]+)"; 31 | Let B Regex-match R5 "[->+<]"; 32 | Print If B 33 | "FAIL: Empty sub-expressions match list to identify alphanumeric characters" 34 | else 35 | "PASS: Empty sub-expressions match list to identify alphanumeric characters" 36 | -------------------------------------------------------------------------------- /tests/stack.cog: -------------------------------------------------------------------------------- 1 | Print If == 2 Drop 3 2 2 | "PASS: Drop" 3 | else 4 | "FAIL: Drop"; 5 | 6 | Print If == 6 Drop Swap 6 5 7 | "PASS: Swap" 8 | else 9 | "FAIL: Swap"; 10 | 11 | Print If == 4 Drop Twin 4 12 | "PASS: Twin" 13 | else 14 | "FAIL: Twin"; 15 | 16 | Print If == 7 Drop Drop Triplet 7 17 | "PASS: Triplet" 18 | else 19 | "FAIL: Triplet"; 20 | 21 | Print If == 2 Do (Drop) 3 2 22 | "PASS: Drop (runtime stack)" 23 | else 24 | "FAIL: Drop (runtime stack)"; 25 | 26 | Print If == 6 Drop Do (Swap) 6 5 27 | "PASS: Swap (runtime stack)" 28 | else 29 | "FAIL: Swap (runtime stack)"; 30 | 31 | Print If == 4 Drop Do (Twin) 4 32 | "PASS: Twin (runtime stack)" 33 | else 34 | "FAIL: Twin (runtime stack)"; 35 | 36 | Print If == 7 Drop Drop Do (Triplet) 7 37 | "PASS: Triplet (runtime stack)" 38 | else 39 | "FAIL: Triplet (runtime stack)"; 40 | 41 | Let X be == List (1 2 3) Stack 1 2 3; 42 | Drop Drop Drop; 43 | 44 | Print If X 45 | "PASS: Stack as list" 46 | else 47 | "FAIL: Stack as list"; 48 | 49 | 1 2 3 4 5; 50 | 51 | Let Y be == List() Stack Clear; 52 | 53 | Print If Y 54 | "PASS: Clearing the stack" 55 | else 56 | "FAIL: Clearing the stack"; 57 | 58 | -------------------------------------------------------------------------------- /tests/stop-begin.cog: -------------------------------------------------------------------------------- 1 | Begin ( 2 | Def Exit; 3 | Do ( 4 | Print "PASS: Stop in begin"; 5 | Stop; 6 | ); 7 | Print "FAIL: Stop in begin"; 8 | ); 9 | -------------------------------------------------------------------------------- /tests/stop.cog: -------------------------------------------------------------------------------- 1 | Def F ( 2 | Print "PASS: Stop"; 3 | Stop; 4 | Print "FAIL: Stop"; 5 | ); 6 | 7 | F; 8 | -------------------------------------------------------------------------------- /tests/strings.cog: -------------------------------------------------------------------------------- 1 | Print If == "Hello world ☺" Prepend Prepend the strings "Hello" " world" " ☺" 2 | "PASS: Converting list of strings to combined string" 3 | else 4 | "FAIL: Converting list of characters to combined string"; 5 | 6 | Print If == 9786 Ordinal of "☺" 7 | "PASS: Converting string to UTF8 value with Ordinal" 8 | else 9 | "PASS: Converting string to UTF8 value with Ordinal"; 10 | 11 | Print If == "☺" Character with value 9786 12 | "PASS: Converting UTF8 value to string" 13 | else 14 | "FAIL: Converting UTF8 value to string"; 15 | 16 | Print If == 123.4 Number "123.4" 17 | "PASS: Casting strings to numbers" 18 | else 19 | "PASS: Casting strings to numbers"; 20 | 21 | Print If == "H" First of "Hello" 22 | "PASS: Getting First of string" 23 | else 24 | "FAIL: Getting First of string"; 25 | 26 | Print If == "e" First of "e" 27 | "PASS: Getting First of single-character string" 28 | else 29 | "FAIL: Getting First of single-character string"; 30 | 31 | Print If == "ello" Rest of "Hello" 32 | "PASS: Getting Rest of string" 33 | else 34 | "FAIL: Getting Rest of string"; 35 | 36 | Print If == "" Rest of "e" 37 | "PASS: Getting Rest of single-character string" 38 | else 39 | "FAIL: Getting Rest of single-character string"; 40 | 41 | Print If == List ("Hello" "world!") Split on " " with "Hello world!" 42 | "PASS: Splitting a string" 43 | else 44 | "FAIL: Splitting a string"; 45 | 46 | ~~ TODO: Only ASCII conversions are supported right now. 47 | Print If == "123 áæćde" Lowercase "123 ÁÆĆdE" 48 | ~~Print If == "123 ♥ æabcde" Lowercase "123 ♥ æAbCdE" 49 | "PASS: Converting a string to lowercase" 50 | else 51 | "FAIL: Converting a string to lowercase"; 52 | 53 | Print If == "123 ♥ ÆABCDE" Uppercase "123 ♥ ÆaBcde" 54 | "PASS: Converting a string to uppercase" 55 | else 56 | "FAIL: Converting a string to uppercase"; 57 | -------------------------------------------------------------------------------- /tests/symbols.cog: -------------------------------------------------------------------------------- 1 | Print If != \foo \bar 2 | "PASS: Comparing different symbols" 3 | "FAIL: Comparing different symbols"; 4 | 5 | Print If == \foo \foo 6 | "PASS: Comparing the same symbol" 7 | "FAIL: Comparing the same symbol"; 8 | 9 | Print If == "foo" Show \foo 10 | "PASS: Printing a symbol" 11 | "FAIL: Printing a symbol"; 12 | -------------------------------------------------------------------------------- /tests/table.cog: -------------------------------------------------------------------------------- 1 | Let T be Table ( 2 | \foo is "bar"; 3 | "bar" is \foo; 4 | 12 is 13; 5 | List (0 1) is 1; 6 | Table (\A "b") is "Ab"; 7 | ); 8 | 9 | Print If == "bar" . \foo T 10 | "PASS: Table lookup with string" 11 | else 12 | "FAIL: Table lookup with string"; 13 | 14 | Print If == \foo . "bar" T 15 | "PASS: Table lookup with symbol" 16 | else 17 | "FAIL: Table lookup with symbol"; 18 | 19 | Print If == 13 . 12 T 20 | "PASS: Table lookup with number" 21 | else 22 | "FAIL: Table lookup with number"; 23 | 24 | Print If == 1 . List (0 1) T 25 | "PASS: Table lookup with list" 26 | else 27 | "FAIL: Table lookup with list"; 28 | 29 | Print If == "Ab" . Table (\A "b") T 30 | "PASS: Table lookup with table" 31 | else 32 | "FAIL: Table lookup with table"; 33 | 34 | Let T2 be Insert \foo is "baz" into T; 35 | 36 | Print If And == "baz" . \foo T2 and == "bar" . \foo T 37 | "PASS: Table insertion" 38 | else 39 | "FAIL: Table insertion"; 40 | 41 | Print If == "{ foo:\"bar\" \"foo\":bar }" Show Table ( \foo "bar" and "foo" \bar ) 42 | "PASS: Printing a table" 43 | else 44 | "FAIL: Printing a table"; 45 | 46 | Print If And Has \foo T Not Has \bar T 47 | "PASS: Has" 48 | else 49 | "FAIL: Has"; 50 | 51 | Let T3 be Remove \foo from T; 52 | 53 | Print If Not Has \foo T3 54 | "PASS: Removing keys" 55 | else 56 | "FAIL: Removing keys"; 57 | 58 | Print If == List (List (0 1) Table (\A "b") 12 \foo "bar") Keys T 59 | "PASS: Getting list of keys in table" 60 | else 61 | "FAIL: Getting list of keys in table"; 62 | 63 | Print If == List (1 "Ab" 13 "bar" \foo) Values T 64 | "PASS: Getting list of values in table" 65 | else 66 | "FAIL: Getting list of values in table"; 67 | 68 | 69 | Print If == Table () Table () 70 | "PASS: Table comparison 1" 71 | else 72 | "FAIL: Table comparison 1"; 73 | 74 | Print If == Table (\A 1) Table (\A 1) 75 | "PASS: Table comparison 2" 76 | else 77 | "FAIL: Table comparison 2"; 78 | 79 | Print If != Table (\A 2) Table (\A 1) 80 | "PASS: Table comparison 3" 81 | else 82 | "FAIL: Table comparison 3"; 83 | 84 | Print If != Table (\A 1) Table (\B 1) 85 | "PASS: Table comparison 4" 86 | else 87 | "FAIL: Table compariso 4"; 88 | 89 | Print If == Table (\C 1 \B 2 \A 3) Table (\C 1 \B 2 \A 3) 90 | "PASS: Table comparison 5" 91 | else 92 | "FAIL: Table comparison 5"; 93 | -------------------------------------------------------------------------------- /tests/trig.cog: -------------------------------------------------------------------------------- 1 | Def Almost== as ( Let N ; Let M ; < 0.0000000000001 Abs - N M ); 2 | 3 | Print If Almost== 1 Sind 90 4 | "PASS: Degree sin" 5 | else 6 | "FAIL: Degree sin"; 7 | 8 | Print If Almost== 1 Cosd 360 9 | "PASS: Degree cos" 10 | else 11 | "FAIL: Degree cos"; 12 | 13 | Print If Almost== / Cosd 90 Sind 90 Tand 90 14 | "PASS: Degree tan" 15 | else 16 | "FAIL: Degree tan"; 17 | 18 | Print If Almost== 1 Sin / 2 3.14159265358979323846 19 | "PASS: Radian sin" 20 | else 21 | "FAIL: Radian sin"; 22 | 23 | Print If Almost== 1 Cos 0 24 | "PASS: Radian cos" 25 | else 26 | "FAIL: Radian cos"; 27 | 28 | Print If Almost== / Cos 90 Sin 90 Tan 90 29 | "PASS: Radian tan" 30 | else 31 | "FAIL: Radian tan"; 32 | 33 | Print If Almost== 30 Asind 0.5 34 | "PASS: Degree arcsin" 35 | else 36 | "FAIL: Degree arcsin"; 37 | 38 | Print If Almost== 60 Acosd 0.5 39 | "PASS: Degree arccos" 40 | else 41 | "FAIL: Degree arccos"; 42 | 43 | Print If Almost== 26.565051177078 Atand 0.5 44 | "PASS: Degree arctan" 45 | else 46 | "FAIL: Degree arctan"; 47 | 48 | Print If Almost== 0.5235987755983 Asin 0.5 49 | "PASS: Radian arcsin" 50 | else 51 | "FAIL: Radian arcsin"; 52 | 53 | Print If Almost== 1.0471975511966 Acos 0.5 54 | "PASS: Radian arccos" 55 | else 56 | "FAIL: Radian arccos"; 57 | 58 | Print If Almost== 10 Tan Atan 10 59 | "PASS: Radian arctan" 60 | else 61 | "FAIL: Radian arctan"; 62 | 63 | Print If Almost== 0.17542037193601015 Sinhd 10 64 | "PASS: Degree hyperbolic sin" 65 | else 66 | "FAIL: Degree hyperbolic sin"; 67 | 68 | Print If Almost== 1.0001523125762564 Coshd 1 69 | "PASS: Degree hyperbolic cos" 70 | else 71 | "FAIL: Degree hyperbolic cos"; 72 | 73 | Print If Almost== 0.17278206351636377 Tanhd 10 74 | "PASS: Degree hyperbolic tan" 75 | else 76 | "FAIL: Degree hyperbolic tan"; 77 | 78 | Print If Almost== 74.20321057778875 Sinh 5 79 | "PASS: Radian hyperbolic sin" 80 | else 81 | "FAIL: Radian hyperbolic sin"; 82 | 83 | Print If Almost== 74.20994852478785 Cosh 5 84 | "PASS: Radian hyperbolic cos" 85 | else 86 | "FAIL: Radian hyperbolic cos"; 87 | 88 | Print If Almost== Tanh 8 / Cosh 8 Sinh 8 89 | "PASS: Radian hyperbolic tan" 90 | else 91 | "FAIL: Radian hyperbolic tan"; 92 | -------------------------------------------------------------------------------- /tests/variables.cog: -------------------------------------------------------------------------------- 1 | Let X be 1; 2 | Print If == 1 X 3 | "PASS: Variable assignment" 4 | else 5 | "FAIL: Variable assignment"; 6 | 7 | Do ( 8 | Let X be 2; 9 | Print If == 2 X 10 | "PASS: Variable shadowing" 11 | else 12 | "FAIL: Variable shadowing"; 13 | ); 14 | 15 | Print If == 1 X 16 | "PASS: Variable shadowing in block" 17 | else 18 | "FAIL: Variable shadowing in block"; 19 | --------------------------------------------------------------------------------