├── .clang-format ├── .gitmodules ├── .vimrc ├── CMakeLists.txt ├── Doxyfile ├── LICENSE ├── Makefile ├── README.md ├── b ├── ms.eth └── unsorted.txt ├── dope.eth ├── env.sh ├── ether-logo.1280x640.png ├── ether-logo.55px.png ├── ether.pc ├── include └── ether │ ├── ether-code.h │ ├── ether.h │ ├── ether.hpp │ └── sandbox.hpp ├── libs ├── CMakeLists.txt ├── __builtins.eth ├── cmdarg.eth ├── ctype │ ├── lib.c │ └── lib.eth ├── io │ ├── lib.c │ └── lib.eth ├── json │ └── lib.c ├── list │ ├── lib.c │ └── lib.eth ├── math │ └── lib.c ├── os │ ├── lib.c │ └── lib.eth ├── ref │ └── lib.c ├── regexp │ ├── lib.c │ └── lib.eth ├── std.eth ├── string │ ├── lib.c │ └── lib.eth └── vector │ ├── lib.c │ └── lib.eth ├── main.c ├── mainpage.md ├── samples ├── basics.eth ├── mergesort.eth └── test-samples.eth ├── src ├── alloc.c ├── ast-var.c ├── ast.c ├── attr.c ├── bit-array.h ├── boolean.c ├── builtins.c ├── bytecode.c ├── c++ │ ├── ether.cpp │ ├── sandbox.cpp │ └── value.cpp ├── environment.c ├── errno.c ├── error-codes.h ├── ether.c ├── exception.c ├── exit.c ├── file.c ├── format.c ├── function.c ├── hash-table.c ├── insn.c ├── ir-builder.c ├── ir-node.c ├── ir-spec.c ├── ir.c ├── lazy.c ├── location.c ├── log.c ├── methods.c ├── module.c ├── mtree.c ├── nil.c ├── number.c ├── pair.c ├── printf.c ├── range.c ├── rbtree.c ├── records.c ├── ref.c ├── regexp.c ├── repl.c ├── root.c ├── scanner-data.h ├── scanner.c ├── scp.c ├── ssa-builder.c ├── ssa-tape.c ├── state.c ├── string.c ├── symbol.c ├── syntax │ ├── parser.y │ └── scanner.l ├── type.c ├── vector.c └── vm.c └── t ├── Seq.eth ├── bench.eth ├── builtins.eth ├── cmdarg.eth ├── foo ├── foo.eth └── install.eth ├── iter.eth ├── list.txt ├── mergesort.eth ├── mergesort.py ├── test-dope.eth ├── test.eth └── test.py /.clang-format: -------------------------------------------------------------------------------- 1 | BreakBeforeBraces: Custom 2 | BraceWrapping: 3 | AfterFunction: true 4 | BeforeElse: true 5 | IndentBraces: false 6 | AfterControlStatement: true 7 | 8 | AlwaysBreakAfterReturnType: All 9 | 10 | ReflowComments: false 11 | 12 | IndentWidth: 2 13 | TabWidth: 2 14 | UseTab: Never 15 | ColumnLimit: 80 16 | 17 | IndentCaseLabels: true 18 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "codeine"] 2 | path = codeine 3 | url = https://github.com/pidhii/codeine.git 4 | [submodule "eco"] 5 | path = eco 6 | url = https://github.com/pidhii/eco.git 7 | -------------------------------------------------------------------------------- /.vimrc: -------------------------------------------------------------------------------- 1 | let g:ale_c_gcc_options = "-I codeine/include -I eco/include -std=gnu99 -Wall -Wextra -Wno-unused" 2 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean cleanall Release Debug test fuzzy 2 | 3 | ifeq ($(CMAKE),) 4 | $(info Set CMAKE-variable to change CMake version.) 5 | CMAKE=cmake 6 | endif 7 | $(info Using cmake ($(shell cmake --version))) 8 | 9 | all: 10 | @echo -e "\e[1mBuilding Debug configuration\e[0m" 11 | @mkdir -p Debug/build 12 | @$(CMAKE) -D CMAKE_BUILD_TYPE=Debug \ 13 | -D CMAKE_INSTALL_PREFIX=`pwd`/Debug/install \ 14 | -D ENABLE_ARB=NO \ 15 | -B Debug/build \ 16 | -S . 17 | @$(MAKE) -C Debug/build install 18 | @echo -e "\n\e[1mBuilding Release configuration\e[0m" 19 | @mkdir -p Release/build 20 | @$(CMAKE) -D CMAKE_BUILD_TYPE=Release \ 21 | -D CMAKE_INSTALL_PREFIX=`pwd`/Release/install \ 22 | -D BUILD_SHARED_LIBRARY=ON \ 23 | -D ENABLE_ARB=NO \ 24 | -B Release/build \ 25 | -S . 26 | @$(MAKE) -C Release/build install 27 | 28 | Release: 29 | @mkdir -p Release/build 30 | @$(CMAKE) -D CMAKE_BUILD_TYPE=Release \ 31 | -D CMAKE_INSTALL_PREFIX=`pwd`/Release/install \ 32 | -D BUILD_SHARED_LIBRARY=ON \ 33 | -D ENABLE_ARB=NO \ 34 | -B Release/build \ 35 | -S . 36 | @$(MAKE) -C Release/build install 37 | 38 | Debug: 39 | @mkdir -p Debug/build 40 | @$(CMAKE) -D CMAKE_BUILD_TYPE=Debug \ 41 | -D CMAKE_INSTALL_PREFIX=`pwd`/Debug/install \ 42 | -D ENABLE_ARB=NO \ 43 | -B Debug/build \ 44 | -S . 45 | @$(MAKE) -C Debug/build install 46 | 47 | clean: 48 | @rm -rfv Release/build Debug/build 49 | 50 | cleanall: 51 | @rm -rfv Release Debug 52 | 53 | test: test_Debug test_Release 54 | .ONESHELL: 55 | test_%: 56 | source ./env.sh $*/install 57 | test -d $* 58 | $(MAKE) -C $*/build test CTEST_OUTPUT_ON_FAILURE=1 59 | 60 | fuzzy: t/test.eth 61 | valgrind --leak-check=full ./Debug/install/bin/ether --log=debug -Lt t/builtins.eth 62 | valgrind --leak-check=full ./Debug/install/bin/ether --log=debug -Lt t/test.eth <<<$(shell echo -e "1\n2\n") 63 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 |

3 | 4 |

5 | 6 | !!! **IMPORTANT** !!!
7 | Documentation of the language on my [wiki](https://github.com/pidhii/ether/wiki) is outdated. 8 | I hope to update it. But developement is still quite rapid so I dont know if it would make sence.
9 | 10 | # [Contents](#contents) 11 | - [Examples](#examples) 12 | - [Build and installation](#build-and-installation) 13 | - [Running in interactive mode](#repl) 14 | - [Syntax higlighting](#syntax-higlighting) 15 | - [Ether Wiki](https://github.com/pidhii/ether/wiki) 16 | - [Where to get help](#where-to-get-help) 17 | - [FAQ](#faq) 18 | 19 | # [Check-list](#check-list) 20 | General: 21 | - [x] REPL 22 | - [x] Packet manager (*dope*) 23 | 24 | Features: 25 | - [x] Pattern matching 26 | - [x] Closures 27 | - [x] Variant-types 28 | - [x] Lightweight record-types 29 | - [ ] Persistent tables *...some more flexible dictionary-like thing* 30 | - [x] Classes *...for the sake of inheritance* 31 | - [x] Named classes 32 | - [x] Objects of unnamed classes 33 | - [x] Tuples 34 | - [x] Persistent vectors 35 | - [x] Regular expressions 36 | - [ ] Macros
*I want it to be something derived from Lisp.* 37 | - [x] User-defined operators 38 | - [x] redefinition of builtin operators 39 | - [x] allow definition of new operators 40 | - [ ] precedence for user-defined operators 41 | - [ ] Named arguments
*Can try to exploit records as reading multiple values is quite efficient with them.* 42 | - [x] Exceptions 43 | - [x] Modules 44 | - [ ] Coroutines 45 | - [ ] Multiple return-values (like in Lua) 46 | - [ ] Ability to enter REPL at break-points (for debug) 47 | - [ ] Type constrains *...whatever it means.*
*Need a tool to check signatures (arity + return-value) of functions.*
*Easy to implement via language itself but it should have some dedicated syntax + care about performance.* 48 | 49 | Syntax: 50 | - [x] simplyfied syntax for loops 51 | - [ ] `match` like in Caml 52 | - [ ] *"*`do`*-natation" for monads?* 53 | 54 | ### 55 | - [ ] Fuck Python, I'm the queen 56 | 57 | # [Optimization](#optimizations) 58 | - [x] Smart reference counting 59 | - [ ] Capture unpacked fields if available 60 | - [ ] Unpack structs outside closure (if applicable) 61 | - [ ] Inline small functions at first pass 62 | - [ ] Dynamic optimization 63 | - [ ] inline captures 64 | - [ ] *branch prediction?* 65 | - [ ] Detect fixed values in loops 66 | - [ ] JIT compilation 67 | - [ ] Propagate type information when possible 68 | - [x] intrinsic operators 69 | - [x] constructors 70 | - [ ] functions 71 | - [ ] C functions 72 | - [ ] closures 73 | - [ ] Merge sequential unpacks (if applicable) 74 | - [ ] Smaller instructions 75 | - [ ] Delay lambda constructors (when used conditionaly) 76 | 77 | 78 | 79 | # [Examples](#examples) 80 | - [basics](./samples/basics.eth) 81 | - [merge-sort](./samples/mergesort.eth) 82 | 83 | 84 | 85 | # [Build and installation](#build-and-installation) 86 | Build and install with [CMake](https://cmake.org/runningcmake/). 87 | *Debug* and *Release* build types are supported. 88 | 89 | To build *Release* configuration do 90 | - create directory for temporary files: 91 | ```sh 92 | $ mkdir build 93 | ``` 94 | - run CMake to generate build-scripts: 95 | ```sh 96 | $ cmake -D CMAKE_BUILD_TYPE=Release \ # we want Release-configuration 97 | -D CMAKE_INSTALL_PREFIX= \ 98 | -B build \ # temporary directory for a build 99 | -S . # path to Ether sources 100 | ``` 101 | - build and install (we are using GNU Make here): 102 | ```sh 103 | $ make -C build install 104 | ``` 105 | - additionaly you can run some tests: 106 | ```sh 107 | $ make -C build test 108 | ``` 109 | - now you can add Ether to your system environment: 110 | ```sh 111 | $ prefix= 112 | $ export PATH=$prefix/bin:path 113 | $ export PKG_CONFIG_PATH=${PKG_CONFIG_PATH:+${PKG_CONFIG_PATH}:}$prefix/lib/pkgconfig 114 | ``` 115 | or you can use [env.sh](./env.sh) to setup environment in current shell: 116 | ```sh 117 | $ source env.sh 118 | ``` 119 | 120 | 121 | 122 | # [REPL](#repl) 123 | To run Ether in interactive mode just run it straightaway: 124 | ``` 125 | $ ether 126 | Ether REPL 127 | version: 0.2.0 128 | build: Release 129 | build flags: -Wall -Werror -Wextra -Wno-unused -Wno-error=cpp -rdynamic -O3 -DNDEBUG 130 | prefix: /home/pidhii/sandbox/create/ether/Release/install 131 | 132 | Enter (EOF) to exit 133 | Commands: 134 | '.' to reset input buffer (cancel current expression) 135 | '.help' show help and available commands 136 | '.help ' show help for given identifier 137 | '.complete-empty' display all available identifiers when completing empty word 138 | '.no-complete-empty' disable effect of the previous command 139 | 140 | > 141 | ``` 142 | 143 | **Note** that some syntacticly valid expressions will not work for REPL. It is 144 | due to "machanisms" of REPL are different to those applied to script processing. 145 | 146 | 147 | 148 | # [Syntax higlighting](#syntax-higlighting) 149 | As you may have noticed, ether syntax is wery similar to ML's one, so generaly 150 | you can just set your editor to treat it like OCaml for examle. However there 151 | are differences, and some of ether-only expressions tend to appear very often 152 | in the code (e.g. `if let `). 153 | 154 | ## Vim 155 | I'm maintaining native syntax configuration only for Vim (not familiar with other 156 | editors). See [ether-vim](https://github.com/pidhii/ether-vim) for the plugin. 157 | You can install with [pathogen](https://github.com/tpope/vim-pathogen). 158 | 159 | To make Vim recognise ether scripts you can add following line to your .vimrc: 160 | ```vim 161 | autocmd BufRead,BufNewFile *.eth set filetype=ether syntax=ether 162 | ``` 163 | 164 | If you use [NERDCommenter](https://www.vim.org/scripts/script.php?script_id=1218) 165 | you can also add: 166 | ```vim 167 | let g:NERDCustomDelimiters = { 168 | \ 'ether': { 'left': '--', 'leftAlt': '--[[', 'rightAlt': ']]', 'nested': 1 } 169 | \ } 170 | ``` 171 | 172 | 173 | 174 | # [Where to get help](#where-to-get-help) 175 | This world is cruel. 176 | 177 | 178 | 179 | # [FAQ](#faq) 180 | Just joking =) 181 | -------------------------------------------------------------------------------- /b/ms.eth: -------------------------------------------------------------------------------- 1 | #!/bin/env ether 2 | 3 | open 'std' 4 | import 'io' 5 | import 'cmdarg' 6 | 7 | 8 | let print_help() { 9 | let argv0 = car(command_line) 10 | print("usage: {argv0} -g [] [-n ] (1)") 11 | print(" {argv0} [-n ] [ ...] (2)") 12 | print("") 13 | print("1. Generate a list of \e[4mn\e[0m numbers and write it to \e[4mopath\e[0m.") 14 | print("") 15 | print("2. Read \e[4mn\e[0m numbers from \e[4mipath1\e[0m and sort them. Repeat for each supplied input file.") 16 | print("") 17 | } 18 | 19 | 20 | let #(opts, args) = { 21 | let options = 22 | [ 23 | #{ name = ["h"], val = `h, has_arg = false }, 24 | #{ name = ["g"], val = `g, has_arg = false }, 25 | #{ name = ["o"], val = `o, has_arg = true }, 26 | #{ name = ["n"], val = `n, has_arg = true, arg_pat = /[[:digit:]]+/ }, 27 | ] 28 | cmdarg.get(options, cdr(command_line)) 29 | } 30 | 31 | if {opts is [] && args is []} || assq_opt(`h, opts) then 32 | print_help() 33 | 34 | else if assq_opt(`g, opts) then { 35 | let ofile = open_out(assq(`o, opts)) or stdout 36 | let n = {assq(`n, opts) |> to_number} or 1_000_000 37 | range(1..n) |> iter (fn _ -> print_to(ofile, rand())) 38 | close(ofile) 39 | } 40 | 41 | else { 42 | let n = `some(assq(`n, opts) |> to_number) or false 43 | args |> iter(fn input_path -> { 44 | let l = 45 | open_in(input_path) 46 | |> io.read_file 47 | |> chomp 48 | |> split( /\n/) 49 | |> map(to_number) 50 | let l = if let `some(n) = n then take(n, l) else l 51 | sort((<), l) 52 | }) 53 | } 54 | 55 | -------------------------------------------------------------------------------- /env.sh: -------------------------------------------------------------------------------- 1 | p=`realpath ${1:?installation path not specified}` 2 | 3 | export PATH=$p/bin:$PATH 4 | export ETHER_ROOT=$p 5 | export ETHER_PATH=$p/lib/ether 6 | export LD_LIBRARY_PATH=$p/lib${LD_LIBRARY_PATH+:${LD_LIBRARY_PATH}} 7 | export PKG_CONFIG_PATH=$p/lib/pkgconfig${PKG_CONFIG_PATH+:${PKG_CONFIG_PATH}} 8 | -------------------------------------------------------------------------------- /ether-logo.1280x640.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pidhii/ether/b08392dadb6b0468b9e436e4a9c6b0aef04c529e/ether-logo.1280x640.png -------------------------------------------------------------------------------- /ether-logo.55px.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pidhii/ether/b08392dadb6b0468b9e436e4a9c6b0aef04c529e/ether-logo.55px.png -------------------------------------------------------------------------------- /ether.pc: -------------------------------------------------------------------------------- 1 | prefix=@ETHER_PREFIX@ 2 | includedir=${prefix}/include 3 | libdir=${prefix}/lib 4 | 5 | Name: ether 6 | Description: Interpreter for Ether language 7 | URL: https://github.com/pidhii/ether 8 | Version: @CMAKE_PROJECT_VERSION@ 9 | Cflags: -I${includedir} 10 | Libs: -L${libdir} -lether -lpcre -lm -ldl 11 | -------------------------------------------------------------------------------- /include/ether/ether-code.h: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pidhii/ether/b08392dadb6b0468b9e436e4a9c6b0aef04c529e/include/ether/ether-code.h -------------------------------------------------------------------------------- /include/ether/sandbox.hpp: -------------------------------------------------------------------------------- 1 | #ifndef ETHER_SANDBOX_HPP 2 | #define ETHER_SANDBOX_HPP 3 | 4 | #include "ether/ether.hpp" 5 | 6 | 7 | namespace eth { 8 | 9 | class sandbox { 10 | public: 11 | sandbox(); 12 | sandbox(const std::string &pathroot); 13 | sandbox(const sandbox &other) = delete; 14 | sandbox(sandbox &&other) = delete; 15 | 16 | sandbox& operator = (const sandbox &other) = delete; 17 | sandbox& operator = (sandbox &&other) = delete; 18 | 19 | ~sandbox(); 20 | 21 | std::string 22 | resolve_path(const std::string &path); 23 | 24 | void 25 | add_module_path(const std::string &path); 26 | 27 | value 28 | eval(const std::string &str); 29 | 30 | value 31 | operator () (const std::string &str) 32 | { return eval(str); } 33 | 34 | value 35 | operator [] (const std::string &var_name) const; 36 | 37 | void 38 | define(const std::string &var_name, const value &val); 39 | 40 | value 41 | source(const std::string &path); 42 | 43 | private: 44 | eth_root *m_root; 45 | eth_module *m_module; 46 | }; // class eth::sandbox 47 | 48 | } // namespace eth 49 | 50 | #endif 51 | -------------------------------------------------------------------------------- /libs/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # single-file-modules 2 | file (GLOB STD_LIBS ${CMAKE_SOURCE_DIR}/libs/*.eth) 3 | install (FILES ${STD_LIBS} DESTINATION lib/ether) 4 | 5 | # Ref 6 | set (REF_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/ref) 7 | set (REF_DST_DIR lib/ether/ref) 8 | add_library (ref SHARED ${REF_SRC_DIR}/lib.c) 9 | set_target_properties (ref 10 | PROPERTIES 11 | POSITION_INDEPENDENT_CODE ON 12 | PREFIX "" 13 | OUTPUT_NAME "ref") 14 | install (TARGETS ref DESTINATION ${REF_DST_DIR}) 15 | 16 | # Math 17 | set (MATH_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/math) 18 | set (MATH_DST_DIR lib/ether/math) 19 | add_library (math SHARED ${MATH_SRC_DIR}/lib.c) 20 | set_target_properties (math 21 | PROPERTIES 22 | POSITION_INDEPENDENT_CODE ON 23 | PREFIX "" 24 | OUTPUT_NAME "math") 25 | install (TARGETS math DESTINATION ${MATH_DST_DIR}) 26 | 27 | # Vector 28 | set (VECTOR_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/vector) 29 | set (VECTOR_DST_DIR lib/ether/vector) 30 | add_library (vector SHARED ${VECTOR_SRC_DIR}/lib.c) 31 | set_target_properties (vector 32 | PROPERTIES 33 | POSITION_INDEPENDENT_CODE ON 34 | PREFIX "" 35 | OUTPUT_NAME "vector") 36 | install (TARGETS vector DESTINATION ${VECTOR_DST_DIR}) 37 | install (FILES ${VECTOR_SRC_DIR}/lib.eth DESTINATION ${VECTOR_DST_DIR}) 38 | 39 | # JSON 40 | function(build_json_module include_dirs library_dirs libraries) 41 | set (JSON_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/json) 42 | set (JSON_DST_DIR lib/ether/json) 43 | add_library (json SHARED ${JSON_SRC_DIR}/lib.c) 44 | set_target_properties (json 45 | PROPERTIES 46 | POSITION_INDEPENDENT_CODE ON 47 | PREFIX "" 48 | OUTPUT_NAME "json") 49 | target_include_directories (json PRIVATE ${include_dirs}) 50 | target_link_directories (json PRIVATE ${library_dirs}) 51 | target_link_libraries (json PRIVATE ${libraries} -lbsd) 52 | install (TARGETS json DESTINATION ${JSON_DST_DIR}) 53 | endfunction() 54 | # -- 55 | if (ENABLE_JSON) 56 | pkg_check_modules (JSON json-c) 57 | if (JSON_FOUND) 58 | build_json_module("${JSON_INCLUDE_DIRS}" "${JSON_LIBRARY_DIRS}" "${JSON_LIBRARIES}") 59 | elseif (NOT "${ExternalProject_FOUND}" STREQUAL "NOTFOUND") 60 | message (STATUS "Library json-c will be built manually") 61 | set (THIRD "${CMAKE_BINARY_DIR}/3rd") 62 | set (JSON_C_INSTALL "${THIRD}/json-c-install") 63 | ExternalProject_Add(json-c 64 | PREFIX "${THIRD}" 65 | INSTALL_DIR "${JSON_C_INSTALL}" 66 | GIT_REPOSITORY "https://github.com/json-c/json-c.git" 67 | GIT_PROGRESS TRUE 68 | CONFIGURE_COMMAND 69 | ${CMAKE_COMMAND} -DCMAKE_INSTALL_PREFIX=${JSON_C_INSTALL} 70 | -DCMAKE_INSTALL_LIBDIR=${JSON_C_INSTALL}/lib 71 | -DCMAKE_BUILD_TYPE=${CMAKE_BUILD_TYPE} 72 | -DBUILD_TESTING=0 73 | -DHAVE_ARC4RANDOM=0 74 | -S${THIRD}/src/json-c 75 | -B${THIRD}/src/json-c-build 76 | BUILD_COMMAND make -C ${THIRD}/src/json-c-build install) 77 | add_library (json-c-lib STATIC IMPORTED GLOBAL) 78 | file (MAKE_DIRECTORY "${JSON_C_INSTALL}") 79 | file (MAKE_DIRECTORY "${JSON_C_INSTALL}/lib") 80 | file (MAKE_DIRECTORY "${JSON_C_INSTALL}/include") 81 | set_target_properties (json-c-lib 82 | PROPERTIES 83 | IMPORTED_LOCATION "${JSON_C_INSTALL}/lib/libjson-c.a" 84 | INTERFACE_INCLUDE_DIRECTORIES "${JSON_C_INSTALL}/include") 85 | add_dependencies(json-c-lib json-c) 86 | build_json_module("${JSON_C_INSTALL}/include" "${JSON_C_INSTALL}/lib" "json-c-lib") 87 | else () 88 | message (WARNING "Can't build Json-module.") 89 | endif () 90 | endif (ENABLE_JSON) 91 | 92 | # List 93 | set (LIST_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/list) 94 | set (LIST_DST_DIR lib/ether/list) 95 | add_library (list SHARED ${LIST_SRC_DIR}/lib.c) 96 | set_target_properties (list 97 | PROPERTIES 98 | POSITION_INDEPENDENT_CODE ON 99 | PREFIX "" 100 | OUTPUT_NAME "list") 101 | install (TARGETS list DESTINATION ${LIST_DST_DIR}) 102 | install (FILES ${LIST_SRC_DIR}/lib.eth DESTINATION ${LIST_DST_DIR}) 103 | 104 | # String 105 | set (STRING_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/string) 106 | set (STRING_DST_DIR lib/ether/string) 107 | add_library (string SHARED ${STRING_SRC_DIR}/lib.c) 108 | set_target_properties (string 109 | PROPERTIES 110 | POSITION_INDEPENDENT_CODE ON 111 | PREFIX "" 112 | OUTPUT_NAME "string") 113 | install (TARGETS string DESTINATION ${STRING_DST_DIR}) 114 | install (FILES ${STRING_SRC_DIR}/lib.eth DESTINATION ${STRING_DST_DIR}) 115 | 116 | # I/O 117 | set (IO_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/io) 118 | set (IO_DST_DIR lib/ether/io) 119 | add_library (io SHARED ${IO_SRC_DIR}/lib.c) 120 | set_target_properties (io 121 | PROPERTIES 122 | POSITION_INDEPENDENT_CODE ON 123 | PREFIX "" 124 | OUTPUT_NAME "io") 125 | install (TARGETS io DESTINATION ${IO_DST_DIR}) 126 | install (FILES ${IO_SRC_DIR}/lib.eth DESTINATION ${IO_DST_DIR}) 127 | 128 | # RegExp 129 | set (REGEXP_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/regexp) 130 | set (REGEXP_DST_DIR lib/ether/regexp) 131 | add_library (regexp SHARED ${REGEXP_SRC_DIR}/lib.c) 132 | set_target_properties (regexp 133 | PROPERTIES 134 | POSITION_INDEPENDENT_CODE ON 135 | PREFIX "" 136 | OUTPUT_NAME "regexp") 137 | install (TARGETS regexp DESTINATION ${REGEXP_DST_DIR}) 138 | install (FILES ${REGEXP_SRC_DIR}/lib.eth DESTINATION ${REGEXP_DST_DIR}) 139 | 140 | # OS 141 | set (OS_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/os) 142 | set (OS_DST_DIR lib/ether/os) 143 | add_library (os SHARED ${OS_SRC_DIR}/lib.c) 144 | set_target_properties (os 145 | PROPERTIES 146 | POSITION_INDEPENDENT_CODE ON 147 | PREFIX "" 148 | OUTPUT_NAME "os") 149 | install (TARGETS os DESTINATION ${OS_DST_DIR}) 150 | install (FILES ${OS_SRC_DIR}/lib.eth DESTINATION ${OS_DST_DIR}) 151 | 152 | # ctype 153 | set (CTYPE_SRC_DIR ${CMAKE_SOURCE_DIR}/libs/ctype) 154 | set (CTYPE_DST_DIR lib/ether/ctype) 155 | add_library (ctype SHARED ${CTYPE_SRC_DIR}/lib.c) 156 | set_target_properties (ctype 157 | PROPERTIES 158 | POSITION_INDEPENDENT_CODE ON 159 | PREFIX "" 160 | OUTPUT_NAME "ctype") 161 | install (TARGETS ctype DESTINATION ${CTYPE_DST_DIR}) 162 | install (FILES ${CTYPE_SRC_DIR}/lib.eth DESTINATION ${CTYPE_DST_DIR}) 163 | 164 | -------------------------------------------------------------------------------- /libs/__builtins.eth: -------------------------------------------------------------------------------- 1 | let pub __builtin fn (+) x y = x + y in 2 | let pub __builtin fn (-) x y = x - y in 3 | let pub __builtin fn (*) x y = x * y in 4 | let pub __builtin fn (/) x y = x / y in 5 | let pub __builtin fn (mod) x y = x mod y in 6 | let pub __builtin fn (^) x y = x ^ y in 7 | 8 | let pub __builtin fn (land) x y = x land y in 9 | let pub __builtin fn (lor) x y = x lor y in 10 | let pub __builtin fn (lxor) x y = x lxor y in 11 | let pub __builtin fn (lshl) x y = x lshl y in 12 | let pub __builtin fn (lshr) x y = x lshr y in 13 | let pub __builtin fn (ashl) x y = x ashl y in 14 | let pub __builtin fn (ashr) x y = x ashr y in 15 | let pub __builtin fn (lnot) x = lnot x in 16 | 17 | let pub __builtin fn (<) x y = x < y in 18 | let pub __builtin fn (>) x y = x > y in 19 | let pub __builtin fn (<=) x y = x <= y in 20 | let pub __builtin fn (>=) x y = x >= y in 21 | let pub __builtin fn (==) x y = x == y in 22 | let pub __builtin fn (!=) x y = x != y in 23 | 24 | let pub __builtin fn (is) x y = x is y in 25 | 26 | let pub fn (++) x y = x ++ y in 27 | 28 | let pub __builtin fn (::) x y = x :: y in 29 | 30 | let pub fn (,) a b = (a, b) in 31 | let pub fn (,,) a b c = (a, b, c) in 32 | let pub fn (,,,) a b c d = (a, b, c, d) in 33 | let pub fn (,,,,) a b c d e = (a, b, c, d, e) in 34 | 35 | let pub __builtin fn (not) x = not x in 36 | 37 | 38 | --let pub (∘) f g x = f (g x) 39 | let pub fn (>>) f g x = g (f x) in 40 | 41 | let pub fn list x = 42 | if x is of (_ :: _) then 43 | let rec fn unwrap xs acc = 44 | if let x :: xs = xs then 45 | unwrap xs (x :: acc) 46 | else 47 | __rev_list acc 48 | in 49 | unwrap x nil 50 | else 51 | __list x 52 | in 53 | 54 | 55 | -- Application 56 | let pub fn ($) f x = f x in 57 | let pub fn (|>) x f = f x in 58 | 59 | -- Pairs 60 | let pub fn car (x :: _) = x in 61 | let pub fn cdr (_ :: x) = x in 62 | 63 | -- Tuples 64 | let pub fn first {_1 = x} = x in 65 | let pub fn second {_2 = x} = x in 66 | let pub fn third {_3 = x} = x in 67 | 68 | -- Functions 69 | let pub fn id x = x in 70 | 71 | let pub fn flip f x y = f y x in 72 | let pub fn const x = fn _ -> x in 73 | let pub fn curry f = fn x y -> f (x, y) in 74 | let pub fn uncurry f = fn (x, y) -> f x y in 75 | 76 | -- Sequences 77 | --let pub index seq idx = 78 | --if let {__methods={index}} = seq then index seq idx 79 | --else __index seq idx 80 | 81 | -- Math 82 | let pub fn even? x = x mod 2 == 0 in 83 | let pub fn odd? x = x mod 2 == 1 in 84 | 85 | let fn compose_va f g = 86 | let rec fn aux x = 87 | if function? x then 88 | fn y -> aux (x y) 89 | else f x 90 | in aux g 91 | in 92 | 93 | let pub fn die msg = 94 | __print_to stderr msg; 95 | exit 1; 96 | in 97 | 98 | let pub require = __require in 99 | 100 | --let fn load_with_defs defs path = __load path defs in 101 | --let fn load_stream_with_defs defs file = __load_stream file (list defs) in 102 | --let fn load_string_with_defs defs str = __load_stream (__open_string str) (list defs) in 103 | let pub fn load x = 104 | if record? x then 105 | fn path -> __load path (list x) 106 | else __load x [] 107 | in 108 | let pub fn load_stream x = 109 | if record? x then 110 | fn stream -> __load_stream stream (list x) 111 | else __load_stream x [] 112 | in 113 | let pub fn load_string x = 114 | if record? x then 115 | fn str -> __load_stream (__open_string str) (list x) 116 | else __load_stream (__open_string x) [] 117 | in 118 | 119 | let pub fn __fmt l = 120 | let rec fn loop l acc = 121 | if let x :: xs = l then 122 | let x = if string? x then x else format "%d" x in 123 | loop xs (x ++ acc) 124 | else acc 125 | in loop l "" 126 | in 127 | 128 | 129 | let pub record = lazy 130 | let {strcmp} = require 'string' in 131 | let {sort, mapi, map} = require 'list' in 132 | fn pairs -> 133 | -- sort pairs 134 | let sortedPairs = 135 | pairs 136 | |> mapi (,) 137 | |> sort (fn (i, (a, _)) (j, (b, _)) -> 138 | let cmp = strcmp a b in 139 | if cmp < 0 then true 140 | else if cmp == 0 then i < j 141 | else false 142 | ) 143 | |> map second 144 | in 145 | 146 | -- remove duplicate keys (leave the latest one) and construct a record 147 | let rec fn loop l acc = 148 | if let x :: xs = l then 149 | if acc is [] then 150 | -- accumulate first kv-pair 151 | loop xs [x] 152 | else if first x eq first (car acc) then 153 | -- replace previous kv-pair with the current one (collision of keys) 154 | loop xs (x :: cdr acc) 155 | else 156 | -- accumulate kv-pair 157 | loop xs (x :: acc) 158 | else 159 | __record acc 160 | in loop sortedPairs [] 161 | in 162 | 163 | -------------------------------------------------------------------------------- 164 | -- IO 165 | -- 166 | -- * open_in 167 | -- * open_out 168 | -- * open_append 169 | -- * open_pipe_in 170 | -- * open_pipe_out 171 | -- * close (C) 172 | -- 173 | -- Input: 174 | -- * input (C) 175 | -- 176 | -- Output: 177 | -- * print 178 | -- * eprint 179 | -- 180 | let pub fn open_in path = __open path "r" in 181 | let pub fn open_out path = __open path "w" in 182 | let pub fn open_append path = __open path "a" in 183 | let pub fn open_pipe_in cmd = __popen cmd "r" in 184 | let pub fn open_pipe_out cmd = __popen cmd "w" in 185 | let pub open_string_in = __open_string in 186 | 187 | let pub print_to = __print_to in 188 | let pub print = print_to stdout in 189 | let pub eprint = print_to stderr in 190 | 191 | -------------------------------------------------------------------------------- 192 | -- System 193 | let pub system = __system in 194 | 195 | -------------------------------------------------------------------------------- 196 | -- Random 197 | let pub rand = __rand in 198 | let pub srand = __srand in 199 | 200 | -------------------------------------------------------------------------------- 201 | -- Errors 202 | -- 203 | let struct __invalid_argument = 204 | val what = nil 205 | 206 | impl apply self what = self with {what} 207 | 208 | impl write self os = 209 | let {fprintf} = require 'io' in 210 | fprintf os "invalid_argument %w" self.what 211 | 212 | impl display self os = 213 | let {fprintf} = require 'io' in 214 | fprintf os "invalid argument: %d" self.what 215 | in 216 | let pub fn invalid_argument what = raise $ __invalid_argument what in 217 | 218 | let pub fn failure nil = raise `failure in 219 | let pub fn type_error nil = raise `type_error in 220 | 221 | 222 | 223 | let pub fn some x = {some = x} in 224 | let pub fn system_error x = {system_error = x} in 225 | 226 | nil 227 | 228 | -------------------------------------------------------------------------------- /libs/cmdarg.eth: -------------------------------------------------------------------------------- 1 | let {*} = import 'list' in 2 | let {*} = import 'string' in 3 | 4 | let pub fn invalid_option_argument x = {invalid_option_argument = x} in 5 | 6 | let fn get_options cfg os = 7 | cfg |> iter (fn opt -> 8 | if not (opt is of {name, value, has_arg}) then 9 | raise $ invalid_argument 10 | "options must be of type \{name, value, has_arg}, got `{opt}`" 11 | ); 12 | 13 | let cfg = cfg |> flat_map $ fn optcfg -> 14 | if pair? optcfg.name 15 | then map (fn name -> optcfg with {name}) optcfg.name 16 | else [optcfg] 17 | in 18 | 19 | let cfg = cfg |> map $ fn optcfg -> 20 | if optcfg is of {arg_pat} then optcfg 21 | else record $ ('arg_pat', /.*/) :: list optcfg 22 | in 23 | 24 | let fn get_rules opt = 25 | try find (fn {name} -> name eq opt) cfg 26 | except `failure -> raise `undefined_option 27 | in 28 | 29 | let rec fn mainLoop os kws pos = 30 | if let o::os = os then 31 | if o eq "--" then (kws, rev_append pos os) 32 | else if o =~ /^--/ then handle_long_option o os kws pos 33 | else if o =~ /^-/ then handle_short_option o os kws pos 34 | else mainLoop os kws (o :: pos) 35 | else (kws, rev pos) 36 | and fn handle_long_option o os kws pos = 37 | if let (brk, _) = strstr "=" o then 38 | -- Long option with '=' 39 | let lopt = substr (2 .. brk-1) o in 40 | let {has_arg, value, arg_pat} = get_rules lopt in 41 | if has_arg then 42 | let arg = substr (brk+1..*) o in 43 | if arg =~ arg_pat then 44 | mainLoop os ((value, arg) :: kws) pos 45 | else raise $ invalid_option_argument lopt 46 | else raise `unexpected_argument 47 | else 48 | let lopt = substr (2..*) o in 49 | let {has_arg, value, arg_pat} = get_rules lopt in 50 | if has_arg then 51 | if let arg::os = os then 52 | if arg =~ arg_pat then 53 | mainLoop os ((value, arg) :: kws) pos 54 | else raise $ invalid_option_argument lopt 55 | else raise `missing_argument 56 | else mainLoop os ((value, true) :: kws) pos 57 | and fn handle_short_option o os kws pos = 58 | let shopt = substr (1, 1) o in 59 | let {has_arg, value, arg_pat} = get_rules shopt in 60 | if strlen o > 2 then 61 | -- Option and argument are merged 62 | if has_arg then 63 | let arg = substr (2..*) o in 64 | if arg =~ arg_pat then 65 | mainLoop os ((value, arg) :: kws) pos 66 | else raise $ invalid_option_argument shopt 67 | else raise `unexpected_argument 68 | else 69 | if has_arg then 70 | if let arg::os = os then 71 | if arg =~ arg_pat then 72 | mainLoop os ((value, arg) :: kws) pos 73 | else raise invalid_option_argument shopt 74 | else raise `missing_argument 75 | else mainLoop os ((value, true) :: kws) pos 76 | in 77 | mainLoop os [] [] 78 | in 79 | 80 | let pub get = 81 | {help| 82 | = CmdArg.get 83 | 84 | == DESCRIPTION 85 | Parse command line arguments in GNU style. Both short and long formats are available. 86 | 87 | == SYNOPSIS 88 | 89 | get -> (opts, non-opt-args) 90 | 91 | === ARGUMENTS 92 | * _list-of-options_ is a list of configurations for expected argumets of the form 93 | 94 | \{name = string?, value = , has_arg = boolean?} 95 | 96 | * _list-of-arguments_ is a list of strings to be parsed (to parse command-line 97 | arguments passed to your script use \`cdr command_line`. 98 | |help}; 99 | get_options 100 | in 101 | 102 | nil 103 | -------------------------------------------------------------------------------- /libs/ctype/lib.c: -------------------------------------------------------------------------------- 1 | #include "ether/ether.h" 2 | 3 | #include 4 | 5 | #define IMPL(fn) \ 6 | eth_t \ 7 | _##fn(void) \ 8 | { \ 9 | eth_t x = *eth_sp++; \ 10 | if (x->type != eth_number_type) \ 11 | { \ 12 | eth_drop(x); \ 13 | return eth_exn(eth_type_error()); \ 14 | } \ 15 | int c = eth_num_val(x); \ 16 | eth_drop(x); \ 17 | return eth_boolean(fn(c)); \ 18 | } 19 | 20 | IMPL(isalnum) 21 | IMPL(isalpha) 22 | IMPL(iscntrl) 23 | IMPL(isdigit) 24 | IMPL(isgraph) 25 | IMPL(islower) 26 | IMPL(isprint) 27 | IMPL(ispunct) 28 | IMPL(isspace) 29 | IMPL(isupper) 30 | IMPL(isxdigit) 31 | IMPL(isascii) 32 | IMPL(isblank) 33 | 34 | int 35 | ether_module(eth_module *mod, eth_root *topenv) 36 | { 37 | #define DEF(fn) eth_define(mod, "__" #fn, eth_proc(_##fn, 1)) 38 | 39 | DEF(isalnum); 40 | DEF(isalpha); 41 | DEF(iscntrl); 42 | DEF(isdigit); 43 | DEF(isgraph); 44 | DEF(islower); 45 | DEF(isprint); 46 | DEF(ispunct); 47 | DEF(isspace); 48 | DEF(isupper); 49 | DEF(isxdigit); 50 | DEF(isascii); 51 | DEF(isblank); 52 | 53 | eth_module *script = eth_load_module_from_script2(topenv, "./lib.eth", NULL, mod); 54 | if (not script) 55 | return -1; 56 | eth_copy_defs(script, mod); 57 | eth_destroy_module(script); 58 | 59 | return 0; 60 | } 61 | -------------------------------------------------------------------------------- /libs/ctype/lib.eth: -------------------------------------------------------------------------------- 1 | let {*} = import 'string' in 2 | 3 | let fn adjust_arg x = ord x if string? x else x in 4 | 5 | let pub fn isalnum x = __isalnum (adjust_arg x) in 6 | let pub fn isalpha x = __isalpha (adjust_arg x) in 7 | let pub fn iscntrl x = __iscntrl (adjust_arg x) in 8 | let pub fn isdigit x = __isdigit (adjust_arg x) in 9 | let pub fn isgraph x = __isgraph (adjust_arg x) in 10 | let pub fn islower x = __islower (adjust_arg x) in 11 | let pub fn isprint x = __isprint (adjust_arg x) in 12 | let pub fn ispunct x = __ispunct (adjust_arg x) in 13 | let pub fn isspace x = __isspace (adjust_arg x) in 14 | let pub fn isupper x = __isupper (adjust_arg x) in 15 | let pub fn isxdigit x = __isxdigit (adjust_arg x) in 16 | let pub fn isascii x = __isascii (adjust_arg x) in 17 | let pub fn isblank x = __isblank (adjust_arg x) in 18 | 19 | nil 20 | -------------------------------------------------------------------------------- /libs/io/lib.eth: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Misc: 3 | -- * fopen 4 | -- 5 | -- Input: 6 | -- * read_of (C) 7 | -- * read 8 | -- * read_i8_of (C) 9 | -- * read_i16_of (C) 10 | -- * read_i32_of (C) 11 | -- * read_i64_of (C) 12 | -- * read_u8_of (C) 13 | -- * read_u16_of (C) 14 | -- * read_u32_of (C) 15 | -- * read_u64_of (C) 16 | -- * read_f32_of (C) 17 | -- * read_f64_of (C) 18 | -- * read_line_of (C) 19 | -- * read_line_of_opt 20 | -- * read_line 21 | -- * read_line_opt 22 | -- * read_file (C) 23 | -- 24 | -- Output: 25 | -- * print (C) 26 | -- * printf 27 | -- * fprintf 28 | -- * eprintf 29 | -- * write_to (C) 30 | -- * write 31 | -- * write_i8_to (C) 32 | -- * write_i16_to (C) 33 | -- * write_i32_to (C) 34 | -- * write_i64_to (C) 35 | -- * write_u8_to (C) 36 | -- * write_u16_to (C) 37 | -- * write_u32_to (C) 38 | -- * write_u64_to (C) 39 | -- * write_f32_to (C) 40 | -- * write_f64_to (C) 41 | -- 42 | -- Miscelenious: 43 | -- * tell (C) 44 | -- * seek (C) 45 | -- * shell 46 | -- 47 | 48 | let list = import 'list' in 49 | let string = import 'string' in 50 | 51 | let pub fopen = __open in 52 | 53 | 54 | let pub fn read n = read_of stdin n in 55 | 56 | 57 | let pub fn read_of_opt file n = 58 | try some (read_of file n) 59 | except `end_of_file -> false 60 | in 61 | let pub fn read_opt n = read_of_opt stdin n in 62 | 63 | 64 | let pub fn read_line = read_line_of stdin in 65 | 66 | 67 | let pub fn read_line_of_opt file = 68 | try some (read_line_of file) 69 | except `end_of_file -> false 70 | in 71 | let pub fn read_line_opt = read_line_of_opt stdin in 72 | 73 | let rec pub fn read_lines_of file = 74 | if let some line = read_line_of_opt file then 75 | line :: lazy read_lines_of file 76 | else nil 77 | in 78 | let pub fn read_lines = read_lines_of stdin in 79 | 80 | let pub printf = __printf stdout in 81 | let pub fn fprintf file = __printf file in 82 | let pub eprintf = __printf stderr in 83 | 84 | let pub write = write_to stdout in 85 | 86 | let pub fn seek_set x = {seek_set = x} in 87 | let pub fn seek_cur x = {seek_cur = x} in 88 | let pub fn seek_end x = {seek_end = x} in 89 | let pub fn seek file pos = 90 | let (offs, whence) = 91 | if let seek_set x = pos then (x, 0) 92 | else if let seek_cur x = pos then (x, 1) 93 | else if let seek_end x = pos then (x, 2) 94 | else invalid_argument nil 95 | in __seek file offs whence 96 | in 97 | 98 | let pub fn shell cmd = 99 | let pipe = open_pipe_in cmd in 100 | let rec fn loop acc = 101 | if let some data = read_of_opt pipe 0x100 102 | then loop (data :: acc) 103 | else list.rev acc |> string.strcat |> string.chomp 104 | in 105 | let out = loop [] in 106 | if close pipe == 0 then out 107 | else failure nil 108 | in 109 | 110 | nil 111 | -------------------------------------------------------------------------------- /libs/os/lib.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #define _GNU_SOURCE 17 | #include "ether/ether.h" 18 | 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | 27 | static eth_t 28 | _chdir(void) 29 | { 30 | eth_args args = eth_start(1); 31 | eth_t path = eth_arg2(args, eth_string_type); 32 | if (chdir(eth_str_cstr(path))) 33 | eth_throw(args, eth_num(errno)); 34 | eth_return(args, eth_nil); 35 | } 36 | 37 | static eth_t 38 | _access(void) 39 | { 40 | eth_args args = eth_start(2); 41 | eth_t path = eth_arg2(args, eth_string_type); 42 | eth_t amode = eth_arg2(args, eth_number_type); 43 | if (access(eth_str_cstr(path), eth_num_val(amode))) 44 | { 45 | if (errno == EACCES) 46 | eth_return(args, eth_false); 47 | else 48 | eth_throw(args, eth_num(errno)); 49 | } 50 | eth_return(args, eth_true); 51 | } 52 | 53 | static eth_t 54 | _getenv(void) 55 | { 56 | eth_args args = eth_start(1); 57 | eth_t name = eth_arg2(args, eth_string_type); 58 | const char *val = getenv(eth_str_cstr(name)); 59 | if (val) 60 | eth_return(args, eth_str(val)); 61 | else 62 | eth_throw(args, eth_failure()); 63 | } 64 | 65 | static eth_t 66 | _setenv(void) 67 | { 68 | eth_args args = eth_start(3); 69 | eth_t name = eth_arg2(args, eth_string_type); 70 | eth_t value = eth_arg2(args, eth_string_type); 71 | eth_t overwrite = eth_arg(args); 72 | errno = 0; 73 | if (setenv(eth_str_cstr(name), eth_str_cstr(value), overwrite != eth_false)) 74 | eth_throw(args, eth_num(errno)); 75 | eth_return(args, eth_nil); 76 | } 77 | 78 | static eth_t 79 | _unsetenv(void) 80 | { 81 | eth_args args = eth_start(1); 82 | eth_t name = eth_arg2(args, eth_string_type); 83 | errno = 0; 84 | if (unsetenv(eth_str_cstr(name))) 85 | eth_throw(args, eth_num(errno)); 86 | eth_return(args, eth_nil); 87 | } 88 | 89 | static eth_t 90 | _getcwd(void) 91 | { 92 | char buf[PATH_MAX]; 93 | if (not getcwd(buf, PATH_MAX)) 94 | return eth_exn(eth_num(errno)); 95 | return eth_str(buf); 96 | } 97 | 98 | static eth_t 99 | _realpath(void) 100 | { 101 | eth_args args = eth_start(1); 102 | eth_t path = eth_arg2(args, eth_string_type); 103 | char buf[PATH_MAX]; 104 | if (not realpath(eth_str_cstr(path), buf)) 105 | eth_throw(args, eth_num(errno)); 106 | eth_return(args, eth_str(buf)); 107 | } 108 | 109 | static eth_t 110 | _mkdtemp(void) 111 | { 112 | eth_args args = eth_start(1); 113 | eth_t temp = eth_arg2(args, eth_string_type); 114 | char buf[eth_str_len(temp)+1]; 115 | strcpy(buf, eth_str_cstr(temp)); 116 | if (not mkdtemp(buf)) 117 | eth_throw(args, eth_str(eth_errno_to_str(errno))); 118 | else 119 | eth_return(args, eth_str(buf)); 120 | } 121 | 122 | static eth_t 123 | _fork(void) 124 | { 125 | int pid = fork(); 126 | return pid < 0 ? eth_exn(eth_num(errno)) : eth_num(pid); 127 | } 128 | 129 | // TODO: need some different structure for return value (dont return exit-status 130 | // only) 131 | static eth_t 132 | _waitpid(void) 133 | { 134 | eth_args args = eth_start(2); 135 | eth_t pid = eth_arg2(args, eth_number_type); 136 | eth_t options = eth_arg2(args, eth_number_type); 137 | int wstatus = 0; 138 | 139 | int ret = waitpid(eth_num_val(pid), &wstatus, (int)eth_num_val(options)); 140 | int err = errno; 141 | if (ret < 0) 142 | eth_throw(args, eth_num(err)); 143 | eth_t ret_wstatus; 144 | if (WIFEXITED(wstatus)) 145 | ret_wstatus = eth_num(WEXITSTATUS(wstatus)); 146 | else 147 | ret_wstatus = eth_nil; 148 | eth_return(args, eth_tup2(eth_num(ret), ret_wstatus)); 149 | } 150 | 151 | static eth_t 152 | _pipe(void) 153 | { 154 | int fildes[2]; 155 | if (pipe(fildes) < 0) 156 | return eth_exn(eth_num(errno)); 157 | else 158 | { 159 | eth_t rx = eth_open_fd(fildes[0], "r"); 160 | eth_t tx = eth_open_fd(fildes[1], "w"); 161 | return eth_tup2(rx, tx); 162 | } 163 | } 164 | 165 | static eth_t 166 | _pipe2(void) 167 | { 168 | eth_args args = eth_start(1); 169 | eth_t flags = eth_arg2(args, eth_number_type); 170 | 171 | int fildes[2]; 172 | if (pipe2(fildes, eth_num_val(flags)) < 0) 173 | eth_throw(args, eth_num(errno)); 174 | else 175 | { 176 | eth_t rx = eth_open_fd(fildes[0], "r"); 177 | eth_t tx = eth_open_fd(fildes[1], "w"); 178 | eth_return(args, eth_tup2(rx, tx)); 179 | } 180 | } 181 | 182 | static eth_t 183 | _fileno(void) 184 | { 185 | eth_args args = eth_start(1); 186 | eth_t file = eth_arg2(args, eth_file_type); 187 | 188 | int fd = fileno(eth_get_file_stream(file)); 189 | int err = errno; 190 | if (fd < 0) 191 | eth_throw(args, eth_num(err)); 192 | else 193 | eth_return(args, eth_num(fd)); 194 | } 195 | 196 | 197 | int 198 | ether_module(eth_module *mod, eth_root *topenv) 199 | { 200 | eth_module *detail = eth_create_module("os.detail", NULL); 201 | eth_copy_module_path(eth_get_root_env(topenv), eth_get_env(detail)); 202 | 203 | eth_define(detail, "__chdir", eth_proc(_chdir, 1)); 204 | 205 | eth_define(detail, "__f_ok", eth_num(F_OK)); 206 | eth_define(detail, "__r_ok", eth_num(R_OK)); 207 | eth_define(detail, "__w_ok", eth_num(W_OK)); 208 | eth_define(detail, "__x_ok", eth_num(X_OK)); 209 | eth_define(detail, "__access", eth_proc(_access, 2)); 210 | eth_define(detail, "__getcwd", eth_proc(_getcwd)); 211 | 212 | eth_define(detail, "__getenv", eth_proc(_getenv, 1)); 213 | eth_define(detail, "__setenv", eth_proc(_setenv, 3)); 214 | eth_define(detail, "__unsetenv", eth_proc(_unsetenv, 1)); 215 | 216 | eth_define(detail, "__realpath", eth_proc(_realpath, 1)); 217 | 218 | eth_define(detail, "__mkdtemp", eth_proc(_mkdtemp, 1)); 219 | 220 | eth_define(detail, "__fork", eth_proc(_fork)); 221 | eth_define(detail, "__waitpid", eth_proc(_waitpid, 2)); 222 | 223 | eth_define(detail, "__pipe", eth_proc(_pipe)); 224 | eth_define(detail, "__pipe2", eth_proc(_pipe2, 1)); 225 | 226 | eth_define(detail, "__fileno", eth_proc(_fileno, 1)); 227 | 228 | eth_define(detail, "__o_cloexec", eth_num(O_CLOEXEC)); 229 | eth_define(detail, "__o_direct", eth_num(O_DIRECT)); 230 | eth_define(detail, "__o_nonblock", eth_num(O_NONBLOCK)); 231 | 232 | eth_module *aux = eth_load_module_from_script2(topenv, "./lib.eth", NULL, detail); 233 | eth_destroy_module(detail); 234 | if (not aux) 235 | return -1; 236 | 237 | eth_copy_defs(aux, mod); 238 | eth_destroy_module(aux); 239 | 240 | return 0; 241 | } 242 | 243 | -------------------------------------------------------------------------------- /libs/os/lib.eth: -------------------------------------------------------------------------------- 1 | 2 | let {*} = import 'string' in 3 | 4 | -------------------------------------------------------------------------------- 5 | -- Functions: 6 | -- * chdir 7 | -- * access 8 | -- * getcwd 9 | -- * realpath 10 | -- 11 | -- Values: 12 | -- * f_ok, r_ok, w_ok, x_ok 13 | 14 | let pub F_OK = __f_ok in 15 | let pub R_OK = __r_ok in 16 | let pub W_OK = __w_ok in 17 | let pub X_OK = __x_ok in 18 | 19 | let pub O_CLOEXEC = __o_cloexec in 20 | let pub O_DIRECT = __o_direct in 21 | let pub O_NONBLOCK = __o_nonblock in 22 | 23 | let pub fn chdir dir = 24 | try __chdir dir 25 | except errno -> raise $ system_error errno 26 | in 27 | 28 | let pub fn access path amode = 29 | {help| 30 | = Os.access 31 | 32 | == SYNOPSIS 33 | 34 | access -> boolean? 35 | 36 | == DESCRIPTION 37 | The function shall chek the file named by the pathname (possibly relative) 38 | _path_ for acessibility according to the bit pattern specified in _amode_. 39 | 40 | The value of _amode_ is either the bitwise-inclusive OR of \`r_ok`, \`w_ok`, \`x_ok` or existence test, \`f_ok`. 41 | 42 | See also man(3) access for complete documentation. 43 | |help}; 44 | try __access path amode 45 | except errno -> raise $ system_error errno 46 | in 47 | 48 | let pub fn getcwd = 49 | try __getcwd () 50 | except errno -> raise $ system_error errno 51 | in 52 | 53 | let pub getenv = __getenv in 54 | 55 | let pub fn setenv name value overwrite = 56 | try __setenv name value overwrite 57 | except errno -> raise $ system_error errno 58 | in 59 | 60 | let pub fn unsetenv name = 61 | try __unsetenv name 62 | except errno -> raise $ system_error errno 63 | in 64 | 65 | let fn fix_path path = 66 | if (substr path (0 .. 1) path eq "~/") or false 67 | then getenv "HOME" ++ substr (1..*) path 68 | else path 69 | in 70 | let pub fn realpath path = 71 | try __realpath $ fix_path path 72 | except errno -> raise $ system_error errno 73 | in 74 | 75 | let pub fn mkdtemp temp = 76 | {help| 77 | = Os.mkdtemp 78 | 79 | == Synopsis 80 | 81 | mkdtemp -> string? 82 | 83 | == DESCRIPTION 84 | Create temporary directory with name created from _template-string_ and return 85 | obtained path. 86 | 87 | ==== ARGUMENTS 88 | - _emplate-string_: Template path for the directory ending with six 'X' characters. 89 | |help}; 90 | try __mkdtemp temp 91 | except errno -> raise $ system_error errno 92 | in 93 | 94 | let pub fn fork = 95 | try __fork () 96 | except errno -> raise $ system_error errno 97 | in 98 | 99 | let pub fn waitpid pid opts = 100 | try __waitpid pid opts 101 | except errno -> raise $ system_error errno 102 | in 103 | 104 | let pub fn pipe = 105 | try __pipe () 106 | except errno -> raise $ system_error errno 107 | in 108 | 109 | let pub fn pipe2 flags = 110 | try __pipe2 flags 111 | except errno -> raise $ system_error errno 112 | in 113 | 114 | let pub fn fileno file = 115 | try __fileno file 116 | except errno -> raise $ system_error errno 117 | in 118 | 119 | nil 120 | -------------------------------------------------------------------------------- /libs/ref/lib.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | static eth_t 19 | _strong(void) 20 | { 21 | eth_t x = *eth_sp++; 22 | eth_t ref = eth_create_strong_ref(x); 23 | return ref; 24 | } 25 | 26 | static eth_t 27 | _get(void) 28 | { 29 | eth_t x = *eth_sp++; 30 | if (eth_unlikely(x->type != eth_strong_ref_type)) 31 | { 32 | eth_drop(x); 33 | return eth_exn(eth_type_error()); 34 | } 35 | eth_t ret = eth_ref_get(x); 36 | eth_ref(ret); 37 | eth_drop(x); 38 | eth_dec(ret); 39 | return ret; 40 | } 41 | 42 | static eth_t 43 | _set(void) 44 | { 45 | eth_args args = eth_start(2); 46 | eth_t ref = eth_arg(args); 47 | eth_t x = eth_arg(args); 48 | if (ref->type == eth_strong_ref_type) 49 | eth_set_strong_ref(ref, x); 50 | else 51 | eth_throw(args, eth_exn(eth_type_error())); 52 | eth_return(args, eth_nil); 53 | } 54 | 55 | int 56 | ether_module(eth_module *mod) 57 | { 58 | eth_define(mod, "strong", eth_create_proc(_strong, 1, NULL, NULL)); 59 | eth_define(mod, "get", eth_create_proc(_get, 1, NULL, NULL)); 60 | eth_define(mod, "set", eth_create_proc(_set, 2, NULL, NULL)); 61 | 62 | return 0; 63 | } 64 | -------------------------------------------------------------------------------- /libs/regexp/lib.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | 20 | static eth_t 21 | _create(void) 22 | { 23 | eth_use_symbol(Regexp_error); 24 | eth_args args = eth_start(2); 25 | eth_t pat = eth_arg2(args, eth_string_type); 26 | eth_t opt = eth_arg2(args, eth_number_type); 27 | eth_t re = eth_create_regexp(eth_str_cstr(pat), eth_num_val(opt), NULL, NULL); 28 | if (not re) 29 | eth_throw(args, Regexp_error); 30 | eth_return(args, re); 31 | } 32 | 33 | static eth_t 34 | _study(void) 35 | { 36 | eth_args args = eth_start(1); 37 | eth_t re = eth_arg2(args, eth_regexp_type); 38 | eth_study_regexp(re); 39 | eth_return(args, re); 40 | } 41 | 42 | int 43 | ether_module(eth_module *mod, eth_root *topenv) 44 | { 45 | eth_define(mod, "_create", eth_create_proc(_create, 2, NULL, NULL)); 46 | eth_define(mod, "_study", eth_create_proc(_study, 1, NULL, NULL)); 47 | 48 | eth_define(mod, "pcre_anchored", eth_num(PCRE_ANCHORED)); 49 | eth_define(mod, "pcre_auto_callout", eth_num(PCRE_AUTO_CALLOUT)); 50 | eth_define(mod, "pcre_bsr_anycrlf", eth_num(PCRE_BSR_ANYCRLF)); 51 | eth_define(mod, "pcre_bsr_unicode", eth_num(PCRE_BSR_UNICODE)); 52 | eth_define(mod, "pcre_caseless", eth_num(PCRE_CASELESS)); 53 | eth_define(mod, "pcre_dollar_endonly", eth_num(PCRE_DOLLAR_ENDONLY)); 54 | eth_define(mod, "pcre_dotall", eth_num(PCRE_DOTALL)); 55 | eth_define(mod, "pcre_dupnames", eth_num(PCRE_DUPNAMES)); 56 | eth_define(mod, "pcre_extended", eth_num(PCRE_EXTENDED)); 57 | eth_define(mod, "pcre_extra", eth_num(PCRE_EXTRA)); 58 | eth_define(mod, "pcre_firstline", eth_num(PCRE_FIRSTLINE)); 59 | eth_define(mod, "pcre_javascript_compat", eth_num(PCRE_JAVASCRIPT_COMPAT)); 60 | eth_define(mod, "pcre_multiline", eth_num(PCRE_MULTILINE)); 61 | #ifdef PCRE_NEVER_UTF 62 | eth_define(mod, "pcre_never_utf", eth_num(PCRE_NEVER_UTF)); 63 | #endif 64 | eth_define(mod, "pcre_newline_any", eth_num(PCRE_NEWLINE_ANY)); 65 | eth_define(mod, "pcre_newline_anycrlf", eth_num(PCRE_NEWLINE_ANYCRLF)); 66 | eth_define(mod, "pcre_newline_cr", eth_num(PCRE_NEWLINE_CR)); 67 | eth_define(mod, "pcre_newline_crlf", eth_num(PCRE_NEWLINE_CRLF)); 68 | eth_define(mod, "pcre_newline_lf", eth_num(PCRE_NEWLINE_LF)); 69 | eth_define(mod, "pcre_no_auto_capture", eth_num(PCRE_NO_AUTO_CAPTURE)); 70 | #ifdef PCRE_NO_AUTO_POSSESS 71 | eth_define(mod, "pcre_no_auto_possess", eth_num(PCRE_NO_AUTO_POSSESS)); 72 | #endif 73 | eth_define(mod, "pcre_no_start_optimize", eth_num(PCRE_NO_START_OPTIMIZE)); 74 | eth_define(mod, "pcre_no_utf16_check", eth_num(PCRE_NO_UTF16_CHECK)); 75 | eth_define(mod, "pcre_no_utf32_check", eth_num(PCRE_NO_UTF32_CHECK)); 76 | eth_define(mod, "pcre_no_utf8_check", eth_num(PCRE_NO_UTF8_CHECK)); 77 | eth_define(mod, "pcre_ucp", eth_num(PCRE_UCP)); 78 | eth_define(mod, "pcre_ungreedy", eth_num(PCRE_UNGREEDY)); 79 | eth_define(mod, "pcre_utf16", eth_num(PCRE_UTF16)); 80 | eth_define(mod, "pcre_utf32", eth_num(PCRE_UTF32)); 81 | eth_define(mod, "pcre_utf8", eth_num(PCRE_UTF8)); 82 | 83 | eth_module *ethmod = eth_load_module_from_script2(topenv, "lib.eth", NULL, mod); 84 | if (not ethmod) 85 | return -1; 86 | eth_copy_defs(ethmod, mod); 87 | eth_destroy_module(ethmod); 88 | 89 | return 0; 90 | } 91 | -------------------------------------------------------------------------------- /libs/regexp/lib.eth: -------------------------------------------------------------------------------- 1 | 2 | let pub fn create arg = 3 | if let (pat, opt) = arg then 4 | _create pat opt 5 | else 6 | _create arg 0 7 | in 8 | 9 | let pub study = _study in 10 | 11 | nil 12 | -------------------------------------------------------------------------------- /libs/std.eth: -------------------------------------------------------------------------------- 1 | 2 | let {pub *} = import 'list' in 3 | let {pub *} = import 'string' in 4 | 5 | nil 6 | 7 | -------------------------------------------------------------------------------- /libs/string/lib.eth: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Strings 3 | -- Constructors: 4 | -- * cat (C) 5 | -- * join 6 | -- * malloc 7 | -- * calloc 8 | -- * make (C) 9 | -- 10 | -- Miscelenious: 11 | -- * strlen (C) 12 | -- * to_upper (C) 13 | -- * to_lower (C) 14 | -- * chr (C) 15 | -- * ord (C) 16 | -- * to_number (C) 17 | -- * to_symobl (C) 18 | -- 19 | -- Stripping: 20 | -- * chomp (C) 21 | -- * chop (C) 22 | -- * trim_left (C) 23 | -- * trim_right (C) 24 | -- * trim 25 | -- 26 | -- Element access (C): 27 | -- * sub 28 | -- * get 29 | -- 30 | -- Comparison: 31 | -- * strcmp (C) 32 | -- * strcasecmp (C) 33 | -- 34 | -- Searching: 35 | -- * find 36 | -- 37 | 38 | let list = import 'list' in 39 | 40 | 41 | -- Prelude 42 | let pub strcat = __strcat in 43 | let pub fn join sep xs = 44 | if xs is nil then "" 45 | else if let hd::[] = xs then hd 46 | else if let hd::tl = xs then 47 | list.fold_left (fn x y -> strcat [x, sep, y]) hd tl 48 | else invalid_argument nil 49 | in 50 | let pub to_upper = __to_upper in 51 | let pub to_lower = __to_lower in 52 | let pub chr = __chr in 53 | let pub ord = __ord in 54 | let pub to_number = __to_number in 55 | let pub to_symbol = __to_symbol in 56 | let pub chomp = __chomp in 57 | let pub chop = __chop in 58 | let pub trim_left = __trim_left in 59 | let pub trim_right = __trim_right in 60 | let pub fn trim s = trim_left $ trim_right $ s in 61 | let pub strcmp = __strcmp in 62 | let pub strcasecmp = __strcasecmp in 63 | let pub match = __match in 64 | let pub gsub = __gsub in 65 | let pub rev_split = __rev_split in 66 | let pub fn split re str = list.rev $ rev_split re str in 67 | 68 | let pub malloc = 69 | {help| 70 | = String.malloc 71 | == DESCRIPTION: 72 | Create an uninitialized string of given length.\n 73 | == SYNOPSIS\n 74 | malloc number? -> string? 75 | |help}; 76 | __malloc 77 | in 78 | 79 | let pub calloc = 80 | {help| 81 | = String.calloc 82 | == DESCRIPTION: 83 | Create a string of given length initialized with zeros. 84 | == SYNOPSIS 85 | calloc number? -> string? 86 | |help}; 87 | __calloc 88 | in 89 | 90 | -------------------------------------------------------------------------------- 91 | let pub make_string = 92 | {help| 93 | = String.make 94 | == DESCRIPTION 95 | Create a string of given length filled with a first character of supplied 96 | string. If it is of zero length, then the it is treated as 0-byte. 97 | == SYNOPSIS 98 | make number? string? -> string? 99 | |help}; 100 | __make 101 | in 102 | 103 | let pub strlen = __len in 104 | let pub fn substr x s = 105 | if let (k, n) = x then __substr s k n 106 | else if let l .. r = x then __substr s l (r - l + 1) 107 | else if let l..* = x then __substr s l (strlen s - l) 108 | else if let *..r = x then __substr s 0 (r + 1) 109 | else invalid_argument nil 110 | in 111 | 112 | -------------------------------------------------------------------------------- 113 | -- Regexp 114 | -- * match (C) 115 | -- * rev_split (C) 116 | -- * split 117 | -- * gsub 118 | 119 | let pub fn strstr pat s = 120 | if regexp? pat then 121 | __find_regexp pat s 122 | else if string? pat then 123 | if let some start = __strstr_opt s pat then 124 | (start, start + strlen pat) 125 | else false 126 | else type_error nil 127 | in 128 | 129 | nil 130 | -------------------------------------------------------------------------------- /libs/vector/lib.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | ETH_MODULE("vector") 19 | 20 | static eth_t 21 | of_list(void) 22 | { 23 | eth_use_symbol(Improper_list) 24 | eth_t l = *eth_sp++; 25 | eth_t vec = eth_create_vector(); 26 | eth_t it; 27 | for (it = l; it->type == eth_pair_type; it = eth_cdr(it)) 28 | eth_push_mut(vec, eth_car(it)); 29 | if (eth_unlikely(it != eth_nil)) 30 | { 31 | eth_drop(vec); 32 | return eth_exn(Improper_list); 33 | } 34 | eth_drop(l); 35 | return vec; 36 | } 37 | 38 | static eth_t 39 | push(void) 40 | { 41 | eth_t v = *eth_sp++; 42 | eth_t x = *eth_sp++; 43 | if (eth_unlikely(v->type != eth_vector_type)) 44 | { 45 | eth_drop_2(v, x); 46 | return eth_exn(eth_type_error()); 47 | } 48 | if (v->rc == 0 and v != x) 49 | { 50 | eth_push_mut(v, x); 51 | return v; 52 | } 53 | else 54 | return eth_push_pers(v, x); 55 | } 56 | 57 | static eth_t 58 | insert(void) 59 | { 60 | eth_use_symbol(Range_error); 61 | eth_t v = *eth_sp++; 62 | eth_t k = *eth_sp++; 63 | eth_t x = *eth_sp++; 64 | if (eth_unlikely(v->type != eth_vector_type or k->type != eth_number_type)) 65 | { 66 | eth_drop_3(v, k, x); 67 | return eth_exn(eth_type_error()); 68 | } 69 | int len = eth_vec_len(v); 70 | int kval = eth_num_val(k); 71 | if (eth_unlikely(kval < 0 or kval >= len)) 72 | { 73 | eth_drop_3(v, k, v); 74 | return eth_exn(Range_error); 75 | } 76 | if (v->rc == 0 and v != x) 77 | { 78 | eth_insert_mut(v, kval, x); 79 | eth_drop(k); 80 | return v; 81 | } 82 | else 83 | { 84 | eth_t ret = eth_insert_pers(v, kval, x); 85 | eth_drop(k); 86 | return ret; 87 | } 88 | } 89 | 90 | static eth_t 91 | front(void) 92 | { 93 | eth_use_symbol(Range_error) 94 | eth_t v = *eth_sp++; 95 | if (eth_unlikely(v->type != eth_vector_type)) 96 | { 97 | eth_drop(v); 98 | return eth_exn(eth_type_error()); 99 | } 100 | if (eth_vec_len(v) == 0) 101 | { 102 | eth_drop(v); 103 | return eth_exn(Range_error); 104 | } 105 | eth_t ret = eth_front(v); 106 | eth_ref(ret); 107 | eth_drop(v); 108 | eth_dec(ret); 109 | return ret; 110 | } 111 | 112 | static eth_t 113 | back(void) 114 | { 115 | eth_use_symbol(Range_error) 116 | eth_t v = *eth_sp++; 117 | if (eth_unlikely(v->type != eth_vector_type)) 118 | { 119 | eth_drop(v); 120 | return eth_exn(eth_type_error()); 121 | } 122 | if (eth_vec_len(v) == 0) 123 | { 124 | eth_drop(v); 125 | return eth_exn(Range_error); 126 | } 127 | eth_t ret = eth_back(v); 128 | eth_ref(ret); 129 | eth_drop(v); 130 | eth_dec(ret); 131 | return ret; 132 | } 133 | 134 | static eth_t 135 | get(void) 136 | { 137 | eth_use_symbol(Range_error) 138 | eth_t v = *eth_sp++; 139 | eth_t k = *eth_sp++; 140 | if (eth_unlikely(v->type != eth_vector_type or k->type != eth_number_type)) 141 | { 142 | eth_drop_2(v, k); 143 | return eth_exn(eth_type_error()); 144 | } 145 | int len = eth_vec_len(v); 146 | int kval = eth_num_val(k); 147 | if (eth_unlikely(kval < 0 or kval >= len)) 148 | { 149 | eth_drop_2(v, k); 150 | return eth_exn(Range_error); 151 | } 152 | eth_t ret = eth_vec_get(v, kval); 153 | eth_ref(ret); 154 | eth_drop_2(v, k); 155 | eth_dec(ret); 156 | return ret; 157 | } 158 | 159 | static eth_t 160 | iter(void) 161 | { 162 | eth_args args = eth_start(2); 163 | const eth_t f = eth_arg2(args, eth_function_type); 164 | const eth_t v = eth_arg2(args, eth_vector_type); 165 | 166 | eth_vector_iterator iter; 167 | eth_vector_begin(v, &iter, 0); 168 | while (not iter.isend) 169 | { 170 | for (eth_t *p = iter.slice.begin; p != iter.slice.end; ++p) 171 | { 172 | eth_reserve_stack(1); 173 | eth_sp[0] = *p; 174 | eth_t r = eth_apply(f, 1); 175 | if (eth_unlikely(r->type == eth_exception_type)) 176 | eth_rethrow(args, v); 177 | eth_drop(r); 178 | } 179 | 180 | eth_vector_next(&iter); 181 | } 182 | 183 | eth_return(args, eth_nil); 184 | } 185 | 186 | static eth_t 187 | iteri(void) 188 | { 189 | eth_args args = eth_start(2); 190 | const eth_t f = eth_arg2(args, eth_function_type); 191 | const eth_t v = eth_arg2(args, eth_vector_type); 192 | 193 | eth_vector_iterator iter; 194 | eth_vector_begin(v, &iter, 0); 195 | int i = 0; 196 | while (not iter.isend) 197 | { 198 | for (eth_t *p = iter.slice.begin; p != iter.slice.end; ++p) 199 | { 200 | eth_reserve_stack(2); 201 | eth_sp[0] = eth_num(i); 202 | eth_sp[1] = *p; 203 | eth_t r = eth_apply(f, 2); 204 | if (eth_unlikely(r->type == eth_exception_type)) 205 | eth_rethrow(args, v); 206 | eth_drop(r); 207 | 208 | i++; 209 | } 210 | 211 | eth_vector_next(&iter); 212 | } 213 | 214 | eth_return(args, eth_nil); 215 | } 216 | 217 | 218 | int 219 | ether_module(eth_module *mod, eth_root *topenv) 220 | { 221 | eth_define(mod, "of_list", eth_create_proc(of_list, 1, NULL, NULL)); 222 | eth_define(mod, "push", eth_create_proc(push, 2, NULL, NULL)); 223 | eth_define(mod, "insert", eth_create_proc(insert, 3, NULL, NULL)); 224 | eth_define(mod, "front", eth_create_proc(front, 1, NULL, NULL)); 225 | eth_define(mod, "back", eth_create_proc(back, 1, NULL, NULL)); 226 | eth_define(mod, "get", eth_create_proc(get, 2, NULL, NULL)); 227 | eth_define(mod, "iter", eth_create_proc(iter, 2, NULL, NULL)); 228 | eth_define(mod, "iteri", eth_create_proc(iteri, 2, NULL, NULL)); 229 | 230 | eth_module *aux = eth_load_module_from_script2(topenv, "./lib.eth", NULL, mod); 231 | if (not aux) 232 | return -1; 233 | eth_copy_defs(aux, mod); 234 | eth_destroy_module(aux); 235 | return 0; 236 | } 237 | -------------------------------------------------------------------------------- /libs/vector/lib.eth: -------------------------------------------------------------------------------- 1 | 2 | let pub empty = of_list [] in 3 | 4 | -- TODO: optimize 5 | let pub fn init n f = 6 | let rec fn loop i acc = 7 | if i < n then 8 | loop (i + 1) (push acc (f i)) 9 | else acc 10 | in loop 0 empty 11 | in 12 | 13 | -- TODO: optimize 14 | let pub fn make n x c= init n (const x) in 15 | 16 | nil 17 | 18 | -------------------------------------------------------------------------------- /mainpage.md: -------------------------------------------------------------------------------- 1 | 2 |

3 | 4 |

5 | 6 | 7 | # Contents 8 | - [Examples](#examples) 9 | - [Build and installation](#build-and-installation) 10 | - [Running in interactive mode](#repl) 11 | - [Syntax higlighting](#syntax-higlighting) 12 | - [Ether Wiki](https://github.com/pidhii/ether/wiki) 13 | - [Where to get help](#where-to-get-help) 14 | - [FAQ](#faq) 15 | 16 | 17 | 18 | # Examples 19 | - [basics](./samples/basics.eth) 20 | - [merge-sort](./samples/mergesort.eth) 21 | 22 | 23 | 24 | # Build and installation 25 | Build and install with [CMake](https://cmake.org/runningcmake/). 26 | *Debug* and *Release* build types are supported. 27 | 28 | To build *Release* configuration do 29 | - create directory for temporary files: 30 | ```sh 31 | $ mkdir build 32 | ``` 33 | - run CMake to generate build-scripts: 34 | ```sh 35 | $ cmake -D CMAKE_BUILD_TYPE=Release \ # we want Release-configuration 36 | -D CMAKE_INSTALL_PREFIX= \ 37 | -B build \ # temporary directory for a build 38 | -S . # path to Ether sources 39 | ``` 40 | - build and install (we are using GNU Make here): 41 | ```sh 42 | $ make -C build install 43 | ``` 44 | - additionaly you can run some tests: 45 | ```sh 46 | $ make -C build test 47 | ``` 48 | - now you can add Ether to your system environment: 49 | ```sh 50 | $ prefix= 51 | $ export PATH=$prefix/bin:path 52 | $ export PKG_CONFIG_PATH=${PKG_CONFIG_PATH:+${PKG_CONFIG_PATH}:}$prefix/lib/pkgconfig 53 | ``` 54 | or you can use [env.sh](./env.sh) to setup environment in current shell: 55 | ```sh 56 | $ source env.sh 57 | ``` 58 | 59 | 60 | 61 | # REPL 62 | To run Ether in interactive mode just run it straightaway: 63 | ``` 64 | $ ether 65 | Ether REPL 66 | version: 0.2.0 67 | build: Release 68 | build flags: -Wall -Werror -Wextra -Wno-unused -Wno-error=cpp -rdynamic -O3 -DNDEBUG 69 | prefix: /home/pidhii/sandbox/create/ether/Release/install 70 | 71 | Enter (EOF) to exit 72 | Commands: 73 | '.' to reset input buffer (cancel current expression) 74 | '.help' show help and available commands 75 | '.help ' show help for given identifier 76 | '.complete-empty' display all available identifiers when completing empty word 77 | '.no-complete-empty' disable effect of the previous command 78 | 79 | > 80 | ``` 81 | 82 | **Note** that some syntacticly valid expressions will not work for REPL. It is 83 | due to "machanisms" of REPL are different to those applied to script processing. 84 | 85 | 86 | 87 | # Syntax higlighting 88 | As you may have noticed, ether syntax is wery similar to ML's one, so generaly 89 | you can just set your editor to treat it like OCaml for examle. However there 90 | are differences, and some of ether-only expressions tend to appear very often 91 | in the code (e.g. `if let `). 92 | 93 | ## Vim 94 | I'm maintaining native syntax configuration only for Vim (not familiar with other 95 | editors). See [ether-vim](https://github.com/pidhii/ether-vim) for the plugin. 96 | You can install with [pathogen](https://github.com/tpope/vim-pathogen). 97 | 98 | To make Vim recognise ether scripts you can add following line to your .vimrc: 99 | ```vim 100 | autocmd BufRead,BufNewFile *.eth set filetype=ether syntax=ether 101 | ``` 102 | 103 | If you use [NERDCommenter](https://www.vim.org/scripts/script.php?script_id=1218) 104 | you can also add: 105 | ```vim 106 | let g:NERDCustomDelimiters = { 107 | \ 'ether': { 'left': '--', 'leftAlt': '--[[', 'rightAlt': ']]', 'nested': 1 } 108 | \ } 109 | ``` 110 | 111 | 112 | 113 | # Where to get help 114 | Enter [REPL](#repl) and try: 115 | ``` 116 | .help [.] 117 | ``` 118 | 119 | 120 | 121 | # FAQ 122 | Just joking =) 123 | 124 | -------------------------------------------------------------------------------- /samples/basics.eth: -------------------------------------------------------------------------------- 1 | 2 | -- Define a variable 3 | let my_variable = 666 in 4 | 5 | 6 | -- Lists 7 | print [1, 2, 3] eq 1 :: 2 :: 3 :: []; --> true 8 | 9 | 10 | -- Equality operators 11 | print (1 == 1); --> true 12 | print (1 != 2); --> true 13 | print ("string" eq "string"); --> true 14 | print ("string" not eq "different string"); --> true 15 | print ([1, [2], 3] eq [1, [2], 3]); --> true 16 | print (true is true); --> true 17 | print (true is not false); --> true 18 | 19 | 20 | -- Numeric comaprison operators (<, >, <=, >=) can be chained together 21 | let other_variable = 228 in 22 | print (other_variable < my_variable is not false); --> true 23 | 24 | 25 | -- Function 26 | let fn square x = x * x in 27 | print (square 2); 28 | 29 | 30 | -- Recursive function 31 | let rec fn factorial x = 32 | if x <= 1 then 1 33 | else x * factorial (x - 1) 34 | in 35 | 36 | print (factorial 3); 37 | 38 | 39 | -- Multiple cross-referencing functions 40 | let rec fn even? x = 41 | x == 0 || odd? (x - 1) 42 | and fn odd? x = 43 | x != 0 && even? (x - 1) 44 | in 45 | 46 | print (even? 42); 47 | 48 | 49 | -- Better way to write factorial: tail-recursion 50 | let rec fn factorial2 x acc = 51 | if x <= 1 then acc 52 | else factorial2 (x - 1) (acc * x) 53 | in 54 | 55 | 56 | print (factorial2 1000000 1); 57 | 58 | 59 | -- Exception handling 60 | try factorial 1000000 61 | except `stack_overflow -> print "Stack overflow"; 62 | 63 | 64 | -- Currying 65 | let fn add x y = x + y in 66 | let increment = add 1 in 67 | print (increment 3); 68 | 69 | 70 | -- Higher order functions 71 | let rec fn map f xs = 72 | if let x :: xs' = xs then 73 | f x :: map f xs' 74 | else [] 75 | in 76 | 77 | print (map increment [1, 2, 3]); 78 | 79 | 80 | -- Closures/lambda functions 81 | print (map (fn x -> x^2) [1, 2, 3]); 82 | 83 | 84 | -- Pattern matching 85 | let x :: xs = [1, 2, 3] in 86 | print (x, xs); 87 | 88 | 89 | -- ... 90 | let fn safe_div x y = 91 | if y != 0 then some (x / y) else false 92 | in 93 | let some x = safe_div 1 2 in 94 | print x; 95 | 96 | 97 | -- Tuples 98 | let (a, b) = (`a, `b) in 99 | print (a, b); --> `a `b 100 | 101 | 102 | -- Records (a.k.a. structs) 103 | let info = {name = "Jill", login = "Mikle Jackson"} in 104 | let {login} = info in 105 | print login; --> Mikle Jackson 106 | print (info.login eq login); --> true 107 | 108 | 109 | -- FizzBuzz 110 | -- 111 | -- `|>` is a "pipe"-operator from OCaml: `x |> f` is equivalent to `f x` 112 | -- `()` is a synonim for `nil`. 113 | let {*} = import 'list' in 114 | range (1 .. 100) |> iter (fn i -> 115 | if i mod 3 == 0 then print "FIZZ" 116 | else if i mod 5 == 0 then print "BUZZ" 117 | else print i 118 | ) 119 | 120 | -------------------------------------------------------------------------------- /samples/mergesort.eth: -------------------------------------------------------------------------------- 1 | 2 | let list = import 'list' in 3 | let string = import 'string' in 4 | let io = import 'io' in 5 | 6 | -- Split a list on two halves using slow/fast iterators approach. 7 | -- 8 | -- Note that the left part is returned in reversed order, however it does not 9 | -- realy matter for the algorithm. 10 | -- 11 | -- Also note that the `loop` is calling itself from a propper tail position. 12 | -- Thus this function is evaluated withing fixed/finite stack frame, and it 13 | -- will never generate a `Stack_overflow` exception. 14 | let fn split xs = 15 | --This is the way you write loops: just create an auxilary function 16 | let rec fn loop slow fast acc = 17 | -- Try to move fast iterator on two positions further; otherwize, we are 18 | -- done 19 | if let _::_::fast = fast then 20 | --Now move slow iterator by one position and continue the loop 21 | let x :: slow = slow in 22 | loop slow fast (x :: acc) 23 | else (acc, slow) 24 | in 25 | loop xs xs nil 26 | in 27 | 28 | -- Merge two sorted lists preserving order. 29 | let fn merge xs ys = 30 | let rec fn loop xs ys acc = 31 | -- This dispatch would look much better with MATCH expression like in OCaml, 32 | -- however I haven't yet implemented it. 33 | if let x :: xs' = xs then 34 | if let y :: ys' = ys then 35 | -- Take the smallest of x and y and prepend it to the result 36 | if x < y 37 | then loop xs' ys (x :: acc) 38 | else loop xs ys' (y :: acc) 39 | else 40 | -- No more ys left, append all remaining xs to the result 41 | list.rev_append acc xs 42 | else 43 | -- No more xs left, append all remaining ys to the result 44 | list.rev_append acc ys 45 | in 46 | loop xs ys nil 47 | in 48 | 49 | -- Sort a list of numbers in increasing order. 50 | let rec fn sort xs = 51 | -- Check if length of the list is greater than 1; otherwize, there is nothing 52 | -- to sort 53 | if let _::_::_ = xs then 54 | let (l, r) = split xs in 55 | merge (sort l) (sort r) 56 | else xs 57 | in 58 | 59 | -- Read a list of numbers. 60 | let fn read_list file = 61 | -- Builtin `read_line_of` will throw `end_of_file` exception upon reaching 62 | -- end of file, so we could use TRY/WITH expression to do the job. 63 | -- 64 | -- However, we want to be tail-recursive, but it is impossible to achieve 65 | -- if we perform recursive call withing TRY-block. Instead, we will wrap 66 | -- the `read_line_of` into a new function and use "Option"-monad (sort of). 67 | -- Note, `read_line_opt` is available in IO-module, but it may be a good 68 | -- example. 69 | -- 70 | -- In case of succesfull reading, it will return a variant `Some `; 71 | -- otherwize, it returns nil. Note that in fact it does not matter what do 72 | -- we return in case of end_of_file exception. We only need it to be NOT the 73 | -- `Some _`-variant. 74 | let fn read_line_opt file = 75 | try some (io.read_line_of file) 76 | except `end_of_file -> nil 77 | in 78 | 79 | -- And here is the actual loop to read the list 80 | let rec fn loop acc = 81 | if let some x = read_line_opt file then 82 | -- Note the `$`: this is an application operator from Haskell. The whole 83 | -- role of `$` is to have the lowest precedence of all operators 84 | loop ((string.to_number (string.chomp x)) :: acc) 85 | else acc 86 | in 87 | loop nil 88 | in 89 | 90 | -- Read a list from standard input. 91 | -- 92 | -- Press after each entered number. ...we could have done it better, 93 | -- however I think this is out of the scope of this tutorial. 94 | -- Use (close input) to finish entering the list. 95 | let l = read_list stdin in 96 | print ("Given list:", l); 97 | 98 | -- Sort it 99 | print ("Sorted list:", sort l); 100 | 101 | -------------------------------------------------------------------------------- /samples/test-samples.eth: -------------------------------------------------------------------------------- 1 | 2 | let {*} = import 'os' in 3 | let {*} = import 'io' in 4 | let {*} = import 'list' in 5 | let {*} = import 'string' in 6 | 7 | chdir $ get command_line 1; 8 | 9 | let fn test_mergesort = 10 | let origlist = [1, 9, 4, 5, 7, 6, 8, 2, 3] in 11 | let ret = 12 | origlist 13 | |> map $ format "%d" 14 | |> join "\n" 15 | |> (fn x -> shell {q|ether ./mergesort.eth <<<'{x}' | grep "Sorted list"|q}) 16 | |> match /\[.+\]/ 17 | |> car 18 | |> load_string 19 | |> first 20 | in 21 | 22 | let correct = list $ sort (<) origlist in 23 | 24 | assert ret eq correct 25 | in 26 | 27 | let fn test_basics = 28 | assert system "ether ./basics.eth &>/dev/null" == 0 29 | in 30 | 31 | test_basics (); 32 | print "> 'test_basics` succeed"; 33 | 34 | test_mergesort (); 35 | print "> 'test_mergesort` succeed"; 36 | 37 | -------------------------------------------------------------------------------- /src/alloc.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #if defined(ETH_DEBUG_MODE) 19 | # warning Using eth_malloc instead of uniform allocators. 20 | # define ALLOCATOR(n) \ 21 | static \ 22 | struct cod_ualloc_h##n g_allocator_h##n; \ 23 | \ 24 | void* \ 25 | eth_alloc_h##n() \ 26 | { \ 27 | return eth_malloc(sizeof(struct h##n)); \ 28 | } \ 29 | \ 30 | void \ 31 | eth_free_h##n(void *ptr) \ 32 | { \ 33 | free(ptr); \ 34 | } 35 | #else 36 | # define ALLOCATOR(n) \ 37 | static \ 38 | struct cod_ualloc_h##n g_allocator_h##n; \ 39 | \ 40 | void* __attribute__((hot, flatten)) \ 41 | eth_alloc_h##n() \ 42 | { \ 43 | return cod_ualloc_h##n##_alloc(&g_allocator_h##n); \ 44 | } \ 45 | \ 46 | void __attribute__((hot, flatten)) \ 47 | eth_free_h##n(void *ptr) \ 48 | { \ 49 | cod_ualloc_h##n##_free(&g_allocator_h##n, ptr); \ 50 | } 51 | #endif 52 | 53 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 54 | struct h1 { eth_header hdr; eth_dword_t data[1]; }; 55 | #define UALLOC_NAME h1 56 | #define UALLOC_TYPE struct h1 57 | #define UALLOC_POOL_SIZE 0x40 58 | #include "codeine/ualloc.h" 59 | 60 | static 61 | struct cod_ualloc_h1 g_allocator_h1; 62 | 63 | void* __attribute__((flatten)) 64 | eth_alloc_h1() 65 | { 66 | return cod_ualloc_h1_alloc(&g_allocator_h1); 67 | } 68 | 69 | void __attribute__((flatten)) 70 | eth_free_h1(void *ptr) 71 | { 72 | cod_ualloc_h1_free(&g_allocator_h1, ptr); 73 | } 74 | 75 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 76 | struct h2 { eth_header hdr; eth_dword_t data[2]; }; 77 | #define UALLOC_NAME h2 78 | #define UALLOC_TYPE struct h2 79 | /*#define UALLOC_POOL_SIZE 0x1000*/ 80 | #include "codeine/ualloc.h" 81 | ALLOCATOR(2) 82 | 83 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 84 | struct h3 { eth_header hdr; eth_dword_t data[3]; }; 85 | #define UALLOC_NAME h3 86 | #define UALLOC_TYPE struct h3 87 | #define UALLOC_POOL_SIZE 0x40 88 | #include "codeine/ualloc.h" 89 | 90 | static 91 | struct cod_ualloc_h3 g_allocator_h3; 92 | 93 | void* __attribute__((flatten)) 94 | eth_alloc_h3() 95 | { 96 | return cod_ualloc_h3_alloc(&g_allocator_h3); 97 | } 98 | 99 | void __attribute__((flatten)) 100 | eth_free_h3(void *ptr) 101 | { 102 | cod_ualloc_h3_free(&g_allocator_h3, ptr); 103 | } 104 | 105 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 106 | struct h4 { eth_header hdr; eth_dword_t data[4]; }; 107 | #define UALLOC_NAME h4 108 | #define UALLOC_TYPE struct h4 109 | #define UALLOC_POOL_SIZE 0x40 110 | #include "codeine/ualloc.h" 111 | 112 | static 113 | struct cod_ualloc_h4 g_allocator_h4; 114 | 115 | void* __attribute__((flatten)) 116 | eth_alloc_h4() 117 | { 118 | return cod_ualloc_h4_alloc(&g_allocator_h4); 119 | } 120 | 121 | void __attribute__((flatten)) 122 | eth_free_h4(void *ptr) 123 | { 124 | cod_ualloc_h4_free(&g_allocator_h4, ptr); 125 | } 126 | 127 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 128 | struct h5 { eth_header hdr; eth_dword_t data[5]; }; 129 | #define UALLOC_NAME h5 130 | #define UALLOC_TYPE struct h5 131 | #define UALLOC_POOL_SIZE 0x40 132 | #include "codeine/ualloc.h" 133 | 134 | static 135 | struct cod_ualloc_h5 g_allocator_h5; 136 | 137 | void* __attribute__((flatten)) 138 | eth_alloc_h5() 139 | { 140 | return cod_ualloc_h5_alloc(&g_allocator_h5); 141 | } 142 | 143 | void __attribute__((flatten)) 144 | eth_free_h5(void *ptr) 145 | { 146 | cod_ualloc_h5_free(&g_allocator_h5, ptr); 147 | } 148 | 149 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 150 | struct h6 { eth_header hdr; eth_dword_t data[6]; }; 151 | #define UALLOC_NAME h6 152 | #define UALLOC_TYPE struct h6 153 | #define UALLOC_POOL_SIZE 0x40 154 | #include "codeine/ualloc.h" 155 | 156 | static 157 | struct cod_ualloc_h6 g_allocator_h6; 158 | 159 | void* __attribute__((hot, flatten)) 160 | eth_alloc_h6() 161 | { 162 | return cod_ualloc_h6_alloc(&g_allocator_h6); 163 | } 164 | 165 | void __attribute__((hot, flatten)) 166 | eth_free_h6(void *ptr) 167 | { 168 | cod_ualloc_h6_free(&g_allocator_h6, ptr); 169 | } 170 | 171 | 172 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 173 | __attribute__((constructor(101))) void 174 | _eth_init_alloc(void) 175 | { 176 | cod_ualloc_h1_init(&g_allocator_h1); 177 | cod_ualloc_h2_init(&g_allocator_h2); 178 | cod_ualloc_h3_init(&g_allocator_h3); 179 | cod_ualloc_h4_init(&g_allocator_h4); 180 | cod_ualloc_h5_init(&g_allocator_h5); 181 | cod_ualloc_h6_init(&g_allocator_h6); 182 | } 183 | 184 | void 185 | _eth_cleanup_alloc(void) 186 | { 187 | cod_ualloc_h1_destroy(&g_allocator_h1); 188 | cod_ualloc_h2_destroy(&g_allocator_h2); 189 | cod_ualloc_h3_destroy(&g_allocator_h3); 190 | cod_ualloc_h4_destroy(&g_allocator_h4); 191 | cod_ualloc_h5_destroy(&g_allocator_h5); 192 | cod_ualloc_h6_destroy(&g_allocator_h6); 193 | } 194 | 195 | -------------------------------------------------------------------------------- /src/ast-var.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | static inline eth_var* 23 | create_var(eth_var_cfg cfg) 24 | { 25 | eth_var *var = calloc(1, sizeof(eth_var)); 26 | var->ident = strdup(cfg.ident); 27 | if ((var->cval = cfg.cval)) 28 | eth_ref(var->cval); 29 | var->vid = cfg.vid; 30 | if ((var->attr = cfg.attr)) 31 | eth_ref_attr(var->attr); 32 | return var; 33 | } 34 | 35 | static inline void 36 | destroy_var(eth_var *var) 37 | { 38 | free(var->ident); 39 | if (var->cval) 40 | eth_unref(var->cval); 41 | if (var->attr) 42 | eth_unref_attr(var->attr); 43 | free(var); 44 | } 45 | 46 | eth_var_list* 47 | eth_create_var_list(void) 48 | { 49 | eth_var_list *lst = eth_malloc(sizeof(eth_var_list)); 50 | lst->len = 0; 51 | lst->head = NULL; 52 | return lst; 53 | } 54 | 55 | void 56 | eth_destroy_var_list(eth_var_list *lst) 57 | { 58 | eth_var *head = lst->head; 59 | while (head) 60 | { 61 | eth_var *tmp = head->next; 62 | destroy_var(head); 63 | head = tmp; 64 | } 65 | free(lst); 66 | } 67 | 68 | eth_var* 69 | eth_prepend_var(eth_var_list *lst, eth_var_cfg cfg) 70 | { 71 | eth_var *var = create_var(cfg); 72 | var->next = lst->head; 73 | lst->head = var; 74 | lst->len += 1; 75 | return var; 76 | } 77 | 78 | eth_var* 79 | eth_append_var(eth_var_list *lst, eth_var_cfg cfg) 80 | { 81 | eth_var *var = create_var(cfg); 82 | if (lst->head == NULL) 83 | { 84 | lst->head = var; 85 | } 86 | else 87 | { 88 | eth_var *it = lst->head; 89 | while (it->next) 90 | it = it->next; 91 | it->next = var; 92 | } 93 | lst->len += 1; 94 | return var; 95 | } 96 | 97 | void 98 | eth_pop_var(eth_var_list *lst, int n) 99 | { 100 | eth_var *head = lst->head; 101 | assert(n <= lst->len); 102 | for (int i = 0; i < n; ++i) 103 | { 104 | eth_var *tmp = head->next; 105 | destroy_var(head); 106 | head = tmp; 107 | } 108 | lst->head = head; 109 | lst->len -= n; 110 | } 111 | 112 | eth_var* 113 | eth_find_var(eth_var *head, const char *ident, int *cnt) 114 | { 115 | int i = 0; 116 | while (head && strcmp(head->ident, ident)) 117 | { 118 | head = head->next; 119 | i += 1; 120 | } 121 | if (cnt) *cnt = i; 122 | return head; 123 | } 124 | -------------------------------------------------------------------------------- /src/attr.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | 21 | eth_attr* 22 | eth_create_attr(int flag) 23 | { 24 | eth_attr *attr = eth_malloc(sizeof(eth_attr)); 25 | *attr = (eth_attr) { 26 | .rc = 0, 27 | .flag = flag, 28 | .help = NULL, 29 | .loc = NULL, 30 | }; 31 | return attr; 32 | } 33 | 34 | static void 35 | destroy_attr(eth_attr *attr) 36 | { 37 | if (attr->help) 38 | free(attr->help); 39 | if (attr->loc) 40 | eth_unref_location(attr->loc); 41 | free(attr); 42 | } 43 | 44 | void 45 | eth_set_help(eth_attr *attr, const char *help) 46 | { 47 | if (attr->help) 48 | free(attr->help); 49 | attr->help = strdup(help); 50 | } 51 | 52 | void 53 | eth_set_location(eth_attr *attr, eth_location *loc) 54 | { 55 | eth_ref_location(loc); 56 | if (attr->loc) 57 | eth_unref_location(attr->loc); 58 | attr->loc = loc; 59 | } 60 | 61 | void 62 | eth_ref_attr(eth_attr *attr) 63 | { 64 | attr->rc += 1; 65 | } 66 | 67 | void 68 | eth_unref_attr(eth_attr *attr) 69 | { 70 | if (--attr->rc == 0) 71 | destroy_attr(attr); 72 | } 73 | 74 | void 75 | eth_drop_attr(eth_attr *attr) 76 | { 77 | if (attr->rc == 0) 78 | destroy_attr(attr); 79 | } 80 | -------------------------------------------------------------------------------- /src/bit-array.h: -------------------------------------------------------------------------------- 1 | #ifndef ETHER_BIT_ARRAY 2 | #define ETHER_BIT_ARRAY 3 | 4 | #include 5 | #include 6 | 7 | /* 8 | * Layout of the array is the following: 9 | * 10 | * |8|7|...|1|16|15|...|9|... 11 | */ 12 | 13 | static inline int 14 | bit_array_size(int nbits) 15 | { 16 | div_t d = div(nbits, 8); 17 | return (d.quot + !!d.rem) << 3; 18 | } 19 | 20 | static inline void 21 | set_bit(uint8_t arr[], int k) 22 | { 23 | div_t d = div(k, 8); 24 | arr[d.quot] = 1 << d.rem; 25 | } 26 | 27 | static inline void 28 | clear_bit(uint8_t arr[], int k) 29 | { 30 | div_t d = div(k, 8); 31 | arr[d.quot] &= ~(1 << d.rem); 32 | } 33 | 34 | static inline int 35 | test_bit(uint8_t arr[], int k) 36 | { 37 | div_t d = div(k, 8); 38 | return !!(arr[d.quot] & (1 << d.rem)); 39 | } 40 | 41 | #endif 42 | -------------------------------------------------------------------------------- /src/boolean.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | 20 | eth_type *eth_boolean_type; 21 | eth_t eth_true, eth_false; 22 | eth_t eth_false_true[2]; 23 | 24 | static void 25 | write_boolean(eth_type *__attribute((unused)) type, eth_t x, FILE *stream) 26 | { 27 | fputs(x == eth_true ? "true" : "false", stream); 28 | } 29 | 30 | ETH_TYPE_CONSTRUCTOR(init_boolean_type) 31 | { 32 | static eth_header g_true, g_false; 33 | 34 | eth_boolean_type = eth_create_type("boolean"); 35 | eth_boolean_type->write = write_boolean; 36 | eth_boolean_type->display = write_boolean; 37 | 38 | eth_true = &g_true; 39 | eth_init_header(eth_true, eth_boolean_type); 40 | eth_ref(eth_true); 41 | 42 | eth_false = &g_false; 43 | eth_init_header(eth_false, eth_boolean_type); 44 | eth_ref(eth_false); 45 | 46 | eth_false_true[0] = eth_false; 47 | eth_false_true[1] = eth_true; 48 | } 49 | -------------------------------------------------------------------------------- /src/c++/ether.cpp: -------------------------------------------------------------------------------- 1 | #include "ether/ether.hpp" 2 | 3 | 4 | eth_type *eth::user_data_type; 5 | 6 | eth::value 7 | eth::user_data(void *data) 8 | { 9 | detail::_user_data_wrapper *ud = new detail::_user_data_wrapper; 10 | eth_init_header(ud, user_data_type); 11 | ud->dtor = detail::_default_dtor; 12 | return value {ETH(ud)}; 13 | } 14 | 15 | void* 16 | eth::value::udata() const 17 | { 18 | if (m_ptr->type != user_data_type) 19 | throw type_exn {"not a user-data"}; 20 | return reinterpret_cast(m_ptr)->data; 21 | } 22 | 23 | void* 24 | eth::value::drain_udata() 25 | { 26 | if (m_ptr->type != user_data_type) 27 | throw type_exn {"not a user-data"}; 28 | detail::_user_data_wrapper *ud = 29 | reinterpret_cast(m_ptr); 30 | ud->dtor = detail::_default_dtor; 31 | void *data = ud->data; 32 | ud->data = nullptr; 33 | return data; 34 | } 35 | 36 | 37 | static void 38 | _user_data_destroy(eth_type*, eth_t x) 39 | { 40 | eth::detail::_user_data_wrapper *ud = 41 | reinterpret_cast(x); 42 | ud->dtor(ud->data); 43 | delete ud; 44 | } 45 | 46 | static void 47 | _init_user_data_type() 48 | { 49 | eth::user_data_type = eth_create_type("user-data"); 50 | eth::user_data_type->destroy = _user_data_destroy; 51 | } 52 | 53 | static void 54 | _cleanup_user_data_type() 55 | { eth_destroy_type(eth::user_data_type); } 56 | 57 | 58 | static bool s_initialized = false; 59 | 60 | void 61 | eth::init(void *argv) 62 | { 63 | if (not s_initialized) 64 | { 65 | eth_init(argv); 66 | _init_user_data_type(); 67 | } 68 | s_initialized = true; 69 | } 70 | 71 | void 72 | eth::cleanup() 73 | { 74 | if (s_initialized) 75 | { 76 | eth_cleanup(); 77 | _cleanup_user_data_type(); 78 | } 79 | s_initialized = false; 80 | } 81 | 82 | -------------------------------------------------------------------------------- /src/c++/sandbox.cpp: -------------------------------------------------------------------------------- 1 | #include "ether/sandbox.hpp" 2 | 3 | #include 4 | #include 5 | 6 | 7 | eth::sandbox::sandbox() 8 | : m_root {eth_create_root()}, 9 | m_module {eth_create_module("", nullptr)} 10 | { } 11 | 12 | eth::sandbox::sandbox(const std::string &pathroot) 13 | : m_root {eth_create_root()}, 14 | m_module {eth_create_module("", pathroot.c_str())} 15 | { } 16 | 17 | eth::sandbox::~sandbox() 18 | { 19 | eth_destroy_root(m_root); 20 | eth_destroy_module(m_module); 21 | } 22 | 23 | std::string 24 | eth::sandbox::resolve_path(const std::string &path) 25 | { 26 | char buf[PATH_MAX]; 27 | if (eth_resolve_path(eth_get_root_env(m_root), path.c_str(), buf)) 28 | return buf; 29 | return ""; 30 | } 31 | 32 | void 33 | eth::sandbox::add_module_path(const std::string &path) 34 | { 35 | if (not eth_add_module_path(eth_get_root_env(m_root), path.c_str())) 36 | throw runtime_exn {"failed to add module-path"}; 37 | } 38 | 39 | eth::value 40 | eth::sandbox::eval(const std::string &str) 41 | { 42 | eth_evaluator evl; 43 | evl.root = m_root; 44 | evl.mod = m_module; 45 | 46 | char buf[str.size() + 1]; 47 | strcpy(buf, str.c_str()); 48 | FILE *bufstream = fmemopen(buf, str.size(), "r"); 49 | eth_scanner *scan = eth_create_repl_scanner(m_root, bufstream); 50 | eth_ast *expr = eth_parse_repl(scan); 51 | eth_destroy_scanner(scan); 52 | fclose(bufstream); 53 | if (not expr) 54 | throw runtime_exn {"parse error"}; 55 | 56 | eth_t ret = eth_eval(&evl, expr); 57 | if (not ret) 58 | throw runtime_exn {"WTF, eth_eval() returned NULL"}; 59 | 60 | eth_ref(ret); 61 | eth_drop_ast(expr); 62 | eth_dec(ret); 63 | return value {ret}; 64 | } 65 | 66 | eth::value 67 | eth::sandbox::operator [] (const std::string &var_name) const 68 | { 69 | eth_def *def = eth_find_def(m_module, var_name.c_str()); 70 | if (def == nullptr) 71 | throw logic_exn {"no such variable"}; 72 | return value {def->val}; 73 | } 74 | 75 | void 76 | eth::sandbox::define(const std::string &var_name, const value &val) 77 | { eth_define(m_module, var_name.c_str(), val.ptr()); } 78 | 79 | eth::value 80 | eth::sandbox::source(const std::string &path) 81 | { 82 | const std::string fullpath = resolve_path(path); 83 | if (fullpath.empty()) 84 | throw runtime_exn {"no such file"}; 85 | 86 | eth_t ret; 87 | eth_module *script = 88 | eth_load_module_from_script2(m_root, fullpath.c_str(), &ret, m_module); 89 | if (not script) 90 | throw runtime_exn {"load-failure"}; 91 | 92 | eth_copy_defs(script, m_module); 93 | eth_destroy_module(script); 94 | return value {ret}; 95 | } 96 | 97 | -------------------------------------------------------------------------------- /src/c++/value.cpp: -------------------------------------------------------------------------------- 1 | #include "ether/ether.hpp" 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #include 9 | 10 | 11 | eth::value& 12 | eth::value::operator = (const eth::value &other) 13 | { 14 | eth_t oldptr = m_ptr; 15 | eth_ref(m_ptr = other.m_ptr); 16 | eth_unref(oldptr); 17 | return *this; 18 | } 19 | 20 | 21 | eth::value& 22 | eth::value::operator = (eth::value &&other) 23 | { 24 | if (m_ptr != other.m_ptr) 25 | { 26 | eth_unref(m_ptr); 27 | m_ptr = other.m_ptr; 28 | other.m_ptr = nullptr; 29 | } 30 | return *this; 31 | } 32 | 33 | 34 | const char* 35 | eth::value::str() const 36 | { 37 | if (eth_likely(is_string())) 38 | return eth_str_cstr(m_ptr); 39 | else 40 | throw type_exn {"not a string"}; 41 | }; 42 | 43 | 44 | eth::number_t 45 | eth::value::num() const 46 | { 47 | if (eth_likely(is_number())) 48 | return eth_num_val(m_ptr); 49 | else 50 | throw type_exn {"not a number"}; 51 | } 52 | 53 | 54 | eth::value 55 | eth::value::car() const 56 | { 57 | if (eth_likely(is_pair())) 58 | return value {eth_car(m_ptr)}; 59 | else 60 | throw type_exn {"not a pair"}; 61 | } 62 | 63 | 64 | eth::value 65 | eth::value::cdr() const 66 | { 67 | if (eth_likely(is_pair())) 68 | return value {eth_cdr(m_ptr)}; 69 | else 70 | throw type_exn {"not a pair"}; 71 | } 72 | 73 | 74 | eth::value 75 | eth::value::operator [] (const eth::value &k) const 76 | { 77 | if (is_record()) 78 | { 79 | size_t symid; 80 | if (k.is_symbol()) 81 | symid = eth_get_symbol_id(k.m_ptr); 82 | else if (k.is_string()) 83 | symid = eth_get_symbol_id(eth_sym(k.str())); 84 | else 85 | throw type_exn {"record must be indexed via symbols or strings"}; 86 | const int idx = eth_get_field_by_id(m_ptr->type, symid); 87 | if (idx == m_ptr->type->nfields) 88 | { 89 | std::ostringstream what; 90 | what << "no field '" << k.d() << "' in " << d(); 91 | throw logic_exn {what.str()}; 92 | } 93 | return value {eth_tup_get(m_ptr, idx)}; 94 | } 95 | else if (is_tuple()) 96 | { 97 | if (not k.is_number()) 98 | throw type_exn {"tuple must be indexed via numbers"}; 99 | if (k.num() >= eth_struct_size(m_ptr->type)) 100 | throw runtime_exn {"touple index out of bounds"}; 101 | return value {eth_tup_get(m_ptr, size_t(k.num()))}; 102 | } 103 | else if (is_dict()) 104 | { 105 | eth_t exn = nullptr; 106 | if (eth_t ret = eth_rbtree_mfind(m_ptr, k.m_ptr, &exn)) 107 | return value {eth_tup_get(ret, 1)}; 108 | else 109 | { 110 | std::ostringstream what; 111 | what << "failed to index dictionary: " << value(exn).d(); 112 | eth_drop(exn); 113 | throw runtime_exn {what.str()}; 114 | } 115 | throw logic_exn {"unimplemented"}; 116 | } 117 | else if (const eth_t m = eth_find_method(m_ptr->type->methods, eth_get_method)) 118 | { 119 | eth_reserve_stack(2); 120 | eth_sp[0] = m_ptr; 121 | eth_sp[1] = k.m_ptr; 122 | const eth_t ret = eth_apply(m, 2); 123 | if (ret->type == eth_exception_type) 124 | { 125 | std::ostringstream what; 126 | what << value(ret).d(); 127 | eth_drop(ret); 128 | throw runtime_exn {what.str()}; 129 | } 130 | return value {ret}; 131 | } 132 | 133 | throw type_exn {"can't index object of type " + std::string(m_ptr->type->name)}; 134 | } 135 | 136 | 137 | std::ostream& 138 | operator << (std::ostream &os, const eth::detail::format_proxy::write &v) 139 | { 140 | char *ptr = nullptr; 141 | size_t size = 0; 142 | FILE *out = open_memstream(&ptr, &size); 143 | if (out == nullptr) 144 | { 145 | int err = errno; 146 | std::string msg = "operator << (std::ostream&, const eth::value&): "; 147 | msg += strerror(err); 148 | throw eth::runtime_exn {msg}; 149 | } 150 | 151 | eth_write(v.value.ptr(), out); 152 | 153 | fflush(out); 154 | os << ptr; 155 | fclose(out); 156 | free(ptr); 157 | 158 | return os; 159 | } 160 | 161 | std::ostream& 162 | operator << (std::ostream &os, const eth::detail::format_proxy::display &v) 163 | { 164 | char *ptr = nullptr; 165 | size_t size = 0; 166 | FILE *out = open_memstream(&ptr, &size); 167 | if (out == nullptr) 168 | { 169 | int err = errno; 170 | std::string msg = "operator << (std::ostream&, const eth::value&): "; 171 | msg += strerror(err); 172 | throw eth::runtime_exn {msg}; 173 | } 174 | 175 | eth_display(v.value.ptr(), out); 176 | 177 | fflush(out); 178 | os << ptr; 179 | fclose(out); 180 | free(ptr); 181 | 182 | return os; 183 | } 184 | 185 | -------------------------------------------------------------------------------- /src/errno.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | #include "error-codes.h" 18 | 19 | const char* 20 | eth_errno_to_str(int e) 21 | { 22 | if (e >= g_ncodes or g_codes[e] == NULL) 23 | return "UNDEFINED"; 24 | else 25 | return g_codes[e]; 26 | } 27 | -------------------------------------------------------------------------------- /src/error-codes.h: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | static int g_ncodes = 130; 17 | static char *g_codes[] = { 18 | [19] = "ENODEV", 19 | [50] = "ENOCSI", 20 | [113] = "EHOSTUNREACH", 21 | [42] = "ENOMSG", 22 | [117] = "EUCLEAN", 23 | [45] = "EL2NSYNC", 24 | [51] = "EL2HLT", 25 | [61] = "ENODATA", 26 | [15] = "ENOTBLK", 27 | [38] = "ENOSYS", 28 | [32] = "EPIPE", 29 | [22] = "EINVAL", 30 | [75] = "EOVERFLOW", 31 | [68] = "EADV", 32 | [4] = "EINTR", 33 | [87] = "EUSERS", 34 | [39] = "ENOTEMPTY", 35 | [105] = "ENOBUFS", 36 | [71] = "EPROTO", 37 | [66] = "EREMOTE", 38 | [119] = "ENAVAIL", 39 | [10] = "ECHILD", 40 | [40] = "ELOOP", 41 | [18] = "EXDEV", 42 | [7] = "E2BIG", 43 | [3] = "ESRCH", 44 | [90] = "EMSGSIZE", 45 | [97] = "EAFNOSUPPORT", 46 | [53] = "EBADR", 47 | [112] = "EHOSTDOWN", 48 | [96] = "EPFNOSUPPORT", 49 | [92] = "ENOPROTOOPT", 50 | [16] = "EBUSY", 51 | [11] = "EAGAIN", 52 | [77] = "EBADFD", 53 | [73] = "EDOTDOT", 54 | [106] = "EISCONN", 55 | [55] = "ENOANO", 56 | [108] = "ESHUTDOWN", 57 | [44] = "ECHRNG", 58 | [80] = "ELIBBAD", 59 | [64] = "ENONET", 60 | [52] = "EBADE", 61 | [9] = "EBADF", 62 | [72] = "EMULTIHOP", 63 | [5] = "EIO", 64 | [49] = "EUNATCH", 65 | [91] = "EPROTOTYPE", 66 | [28] = "ENOSPC", 67 | [8] = "ENOEXEC", 68 | [114] = "EALREADY", 69 | [100] = "ENETDOWN", 70 | [118] = "ENOTNAM", 71 | [13] = "EACCES", 72 | [48] = "ELNRNG", 73 | [84] = "EILSEQ", 74 | [20] = "ENOTDIR", 75 | [76] = "ENOTUNIQ", 76 | [1] = "EPERM", 77 | [33] = "EDOM", 78 | [54] = "EXFULL", 79 | [111] = "ECONNREFUSED", 80 | [21] = "EISDIR", 81 | [93] = "EPROTONOSUPPORT", 82 | [30] = "EROFS", 83 | [99] = "EADDRNOTAVAIL", 84 | [43] = "EIDRM", 85 | [70] = "ECOMM", 86 | [69] = "ESRMNT", 87 | [121] = "EREMOTEIO", 88 | [47] = "EL3RST", 89 | [74] = "EBADMSG", 90 | [23] = "ENFILE", 91 | [82] = "ELIBMAX", 92 | [29] = "ESPIPE", 93 | [67] = "ENOLINK", 94 | [102] = "ENETRESET", 95 | [110] = "ETIMEDOUT", 96 | [2] = "ENOENT", 97 | [17] = "EEXIST", 98 | [122] = "EDQUOT", 99 | [60] = "ENOSTR", 100 | [57] = "EBADSLT", 101 | [56] = "EBADRQC", 102 | [79] = "ELIBACC", 103 | [14] = "EFAULT", 104 | [27] = "EFBIG", 105 | [35] = "EDEADLOCK", 106 | [107] = "ENOTCONN", 107 | [89] = "EDESTADDRREQ", 108 | [81] = "ELIBSCN", 109 | [37] = "ENOLCK", 110 | [120] = "EISNAM", 111 | [103] = "ECONNABORTED", 112 | [101] = "ENETUNREACH", 113 | [116] = "ESTALE", 114 | [63] = "ENOSR", 115 | [12] = "ENOMEM", 116 | [88] = "ENOTSOCK", 117 | [86] = "ESTRPIPE", 118 | [31] = "EMLINK", 119 | [34] = "ERANGE", 120 | [83] = "ELIBEXEC", 121 | [46] = "EL3HLT", 122 | [104] = "ECONNRESET", 123 | [98] = "EADDRINUSE", 124 | [95] = "ENOTSUP", 125 | [78] = "EREMCHG", 126 | [36] = "ENAMETOOLONG", 127 | [25] = "ENOTTY", 128 | [85] = "ERESTART", 129 | [94] = "ESOCKTNOSUPPORT", 130 | [62] = "ETIME", 131 | [59] = "EBFONT", 132 | [109] = "ETOOMANYREFS", 133 | [24] = "EMFILE", 134 | [26] = "ETXTBSY", 135 | [115] = "EINPROGRESS", 136 | [6] = "ENXIO", 137 | [65] = "ENOPKG", 138 | [123] = "ENOMEDIUM", 139 | [124] = "EMEDIUMTYPE", 140 | [125] = "ECANCELED", 141 | [126] = "ENOKEY", 142 | [127] = "EKEYEXPIRED", 143 | [128] = "EKEYREVOKED", 144 | [129] = "EKEYREJECTED", 145 | [130] = "EOWNERDEAD", 146 | [131] = "ENOTRECOVERABLE", 147 | [132] = "ERFKILL", 148 | }; 149 | -------------------------------------------------------------------------------- /src/ether.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | 25 | ETH_MODULE("ether") 26 | 27 | static eth_t *_main_arg_stack; 28 | 29 | eth_t *eth_sb; 30 | eth_t *eth_sp; 31 | size_t eth_ss; 32 | eth_function *eth_this; 33 | uintptr_t eth_cpu_se; 34 | 35 | const char * 36 | eth_get_prefix(void) 37 | { 38 | static char buf[PATH_MAX]; 39 | static bool first = true; 40 | static char *prefix = NULL; 41 | 42 | if (first) 43 | { 44 | FILE *in = popen("pkg-config ether --variable=prefix", "r"); 45 | if (in) 46 | { 47 | char *line = NULL; 48 | size_t n = 0; 49 | ssize_t nrd = getline(&line, &n, in); 50 | if (pclose(in) == 0) 51 | { 52 | assert(nrd > 1); 53 | line[nrd - 1] = 0; // remove newline 54 | strcpy(buf, line); 55 | prefix = buf; 56 | } 57 | free(line); 58 | } 59 | 60 | #ifdef ETHER_PREFIX 61 | if (prefix == NULL) 62 | { 63 | sprintf(buf, ETHER_PREFIX); 64 | prefix = buf; 65 | } 66 | #endif 67 | 68 | first = false; 69 | } 70 | 71 | return prefix; 72 | } 73 | 74 | const char * 75 | eth_get_module_path(void) 76 | { 77 | static char buf[PATH_MAX]; 78 | static char *path; 79 | static bool first = true; 80 | if (first) 81 | { 82 | first = false; 83 | char *envpath = getenv("ETHER_PATH"); 84 | if (envpath) 85 | { 86 | strcpy(buf, envpath); 87 | path = buf; 88 | } 89 | else if (eth_get_prefix()) 90 | { 91 | sprintf(buf, "%s/lib/ether", eth_get_prefix()); 92 | path = buf; 93 | } 94 | else 95 | path = NULL; 96 | } 97 | return path; 98 | } 99 | 100 | #ifndef ETHER_VERSION 101 | #define ETHER_VERSION "" 102 | #endif 103 | 104 | const char * 105 | eth_get_version(void) 106 | { 107 | return ETHER_VERSION; 108 | } 109 | 110 | #ifndef ETHER_BUILD 111 | #define ETHER_BUILD "" 112 | #endif 113 | 114 | const char * 115 | eth_get_build(void) 116 | { 117 | return ETHER_BUILD; 118 | } 119 | 120 | #ifndef ETHER_BUILD_FLAGS 121 | #define ETHER_BUILD_FLAGS "" 122 | #endif 123 | 124 | const char * 125 | eth_get_build_flags(void) 126 | { 127 | return ETHER_BUILD_FLAGS; 128 | } 129 | 130 | static uint8_t g_siphash_key[16] = {1, 2, 3, 4, 5, 6, 7, 8, 131 | 9, 10, 11, 12, 13, 14, 15, 16}; 132 | 133 | const uint8_t * 134 | eth_get_siphash_key(void) 135 | { 136 | return g_siphash_key; 137 | } 138 | 139 | void 140 | eth_init(void *argv) 141 | { 142 | eco_init_this_thread(); 143 | 144 | if (eth_get_prefix() == NULL) 145 | { 146 | eth_warning("can't determine installation prefix, " 147 | "may fail to resolve installed modules"); 148 | } 149 | 150 | _main_arg_stack = eth_malloc(ETH_STACK_SIZE); 151 | // move SP to the end of the allocated memory 152 | eth_sp = (eth_t *)((uintptr_t)_main_arg_stack + ETH_STACK_SIZE); 153 | // and allign it at bytes 154 | eth_sp = (eth_t *)((uintptr_t)eth_sp & ~(sizeof(void *) - 1)); 155 | // save stack base and size for tests on overflow 156 | eth_sb = eth_sp; 157 | eth_ss = (uintptr_t)eth_sb - (uintptr_t)_main_arg_stack; 158 | 159 | struct rlimit limit; 160 | getrlimit(RLIMIT_STACK, &limit); 161 | size_t ss = limit.rlim_cur / 2; // ...I don't know... 162 | uintptr_t sb = (uintptr_t)argv; 163 | eth_cpu_se = sb - ss; 164 | } 165 | 166 | void 167 | eth_cleanup(void) 168 | { 169 | if (eth_sp != eth_sb) 170 | eth_warning("stack pointer is not on the top of the stack"); 171 | } 172 | 173 | const char * 174 | eth_binop_sym(eth_binop op) 175 | { 176 | static char sym[][5] = { 177 | "+", "-", "*", "/", "mod", "^", "land", "lor", 178 | "lxor", "lshl", "lshr", "ashl", "ashr", "<", "<=", ">", 179 | ">=", "==", "!=", "is", "eq", "::"}; 180 | return sym[op]; 181 | } 182 | 183 | const char * 184 | eth_binop_name(eth_binop op) 185 | { 186 | static char sym[][5] = {"add", "sub", "mul", "div", "mod", "pow", 187 | "land", "lor", "lxor", "lshl", "lshr", "ashl", 188 | "ashr", "lt", "le", "gt", "ge", "eq", 189 | "ne", "is", "eq", "cons"}; 190 | return sym[op]; 191 | } 192 | 193 | const char * 194 | eth_unop_sym(eth_unop op) 195 | { 196 | static char sym[][5] = { 197 | "not", 198 | "lnot", 199 | }; 200 | return sym[op]; 201 | } 202 | 203 | const char * 204 | eth_unop_name(eth_unop op) 205 | { 206 | static char sym[][5] = { 207 | "not", 208 | "lnot", 209 | }; 210 | return sym[op]; 211 | } 212 | 213 | eth_t 214 | eth_system_error(int __attribute((unused)) err) 215 | { 216 | eth_use_symbol(system_error); 217 | return system_error; 218 | } 219 | 220 | eth_t 221 | eth_type_error(void) 222 | { 223 | eth_use_symbol(type_error); 224 | return type_error; 225 | } 226 | 227 | eth_t 228 | eth_invalid_argument(void) 229 | { 230 | eth_use_symbol(invalid_argument); 231 | return invalid_argument; 232 | } 233 | 234 | eth_t 235 | eth_failure(void) 236 | { 237 | eth_use_symbol(failure); 238 | return failure; 239 | } 240 | -------------------------------------------------------------------------------- /src/exception.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | 21 | eth_type *eth_exception_type; 22 | 23 | static void 24 | destroy_exception(eth_type *__attribute((unused)) type, eth_t x) 25 | { 26 | eth_exception *e = ETH_EXCEPTION(x); 27 | eth_unref(e->what); 28 | for (int i = 0; i < e->tracelen; ++i) 29 | eth_unref_location(e->trace[i]); 30 | free(e->trace); 31 | free(x); 32 | } 33 | 34 | static void 35 | write_exception(eth_type *__attribute((unused)) type, eth_t x, FILE *out) 36 | { 37 | eth_fprintf(out, "exception { ~w }", ETH_EXCEPTION(x)->what); 38 | } 39 | 40 | ETH_TYPE_CONSTRUCTOR(init_exception_type) 41 | { 42 | eth_field what = {"what", offsetof(eth_exception, what)}; 43 | eth_exception_type = eth_create_struct_type("exception", &what, 1); 44 | eth_exception_type->destroy = destroy_exception; 45 | eth_exception_type->write = write_exception; 46 | } 47 | 48 | eth_t 49 | eth_create_exception(eth_t what) 50 | { 51 | eth_exception *exn = eth_malloc(sizeof(eth_exception)); 52 | eth_init_header(exn, eth_exception_type); 53 | eth_ref(exn->what = what); 54 | exn->trace = eth_malloc(sizeof(eth_location *)); 55 | exn->tracelen = 0; 56 | return ETH(exn); 57 | } 58 | 59 | eth_t 60 | eth_copy_exception(eth_t exn) 61 | { 62 | eth_exception *e = ETH_EXCEPTION(exn); 63 | eth_exception *ret = ETH_EXCEPTION(eth_create_exception(e->what)); 64 | ret->tracelen = e->tracelen; 65 | ret->trace = realloc(ret->trace, sizeof(eth_location) * e->tracelen); 66 | for (int i = 0; i < e->tracelen; ++i) 67 | eth_ref_location(ret->trace[i] = e->trace[i]); 68 | return ETH(ret); 69 | } 70 | 71 | void 72 | eth_push_trace(eth_t exn, eth_location *loc) 73 | { 74 | eth_exception *e = ETH_EXCEPTION(exn); 75 | e->trace = realloc(e->trace, sizeof(eth_location) * (e->tracelen + 1)); 76 | assert(e->trace); 77 | e->trace[e->tracelen++] = loc; 78 | eth_ref_location(loc); 79 | } 80 | -------------------------------------------------------------------------------- /src/exit.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | 21 | eth_type *eth_exit_type; 22 | 23 | static void 24 | destroy_exit_object(eth_type *__attribute((unused)) type, eth_t x) 25 | { 26 | free(x); 27 | } 28 | 29 | ETH_TYPE_CONSTRUCTOR(init_exit_type) 30 | { 31 | // use struct-type to enable pattern-matching 32 | eth_exit_type = eth_create_struct_type("exit-object", NULL, 0); 33 | eth_exit_type->destroy = destroy_exit_object; 34 | } 35 | 36 | eth_t 37 | eth_create_exit_object(int status) 38 | { 39 | eth_exit_object *e = eth_malloc(sizeof(eth_exit_object)); 40 | eth_init_header(e, eth_exit_type); 41 | e->status = status; 42 | return ETH(e); 43 | } 44 | -------------------------------------------------------------------------------- /src/file.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | ETH_MODULE("ether:file") 23 | 24 | #define OPEN (1 << 0) 25 | #define PIPE (1 << 1) 26 | #define OWNR (1 << 2) 27 | 28 | eth_type *eth_file_type; 29 | eth_t eth_stdin, eth_stdout, eth_stderr; 30 | 31 | typedef struct { 32 | eth_header header; 33 | FILE *stream; 34 | int flag; 35 | void *data; 36 | void (*dtor)(void *); 37 | } file; 38 | 39 | extern inline int 40 | eth_is_open(eth_t f) 41 | { 42 | return ((file *)f)->flag & OPEN; 43 | } 44 | 45 | extern inline int 46 | eth_is_pipe(eth_t f) 47 | { 48 | return ((file *)f)->flag & PIPE; 49 | } 50 | 51 | int 52 | eth_close(eth_t x) 53 | { 54 | file *f = (void *)x; 55 | if (eth_is_open(x)) 56 | { 57 | f->flag ^= OPEN; 58 | if (f->flag & OWNR) 59 | { 60 | if (eth_is_pipe(x)) 61 | return pclose(f->stream); 62 | else 63 | return fclose(f->stream); 64 | } 65 | } 66 | return 0; 67 | } 68 | 69 | FILE * 70 | eth_get_file_stream(eth_t x) 71 | { 72 | return ((file *)x)->stream; 73 | } 74 | 75 | static void 76 | destroy_file(eth_type *__attribute((unused)) type, eth_t x) 77 | { 78 | file *f = (void *)x; 79 | 80 | if (eth_is_open(x)) 81 | { 82 | if (eth_close(x)) 83 | { 84 | if (eth_is_pipe(x)) 85 | eth_warning("pclose: %s", strerror(errno)); 86 | else 87 | eth_warning("fclose: %s", strerror(errno)); 88 | } 89 | } 90 | 91 | if (f->dtor) 92 | f->dtor(f->data); 93 | 94 | free(f); 95 | } 96 | 97 | static void 98 | init_file(void *f) 99 | { 100 | eth_init_header(f, eth_file_type); 101 | ((file *)f)->data = NULL; 102 | ((file *)f)->dtor = NULL; 103 | } 104 | 105 | ETH_TYPE_CONSTRUCTOR(init_file_type) 106 | { 107 | eth_file_type = eth_create_type("file"); 108 | eth_file_type->destroy = destroy_file; 109 | 110 | static file _stdin, _stdout, _stderr; 111 | eth_stdin = ETH(&_stdin); 112 | eth_stdout = ETH(&_stdout); 113 | eth_stderr = ETH(&_stderr); 114 | init_file(eth_stdin); 115 | init_file(eth_stdout); 116 | init_file(eth_stderr); 117 | _stdin.stream = stdin; 118 | _stdin.flag = OPEN; 119 | _stdout.stream = stdout; 120 | _stdout.flag = OPEN; 121 | _stderr.stream = stderr; 122 | _stderr.flag = OPEN; 123 | eth_ref(eth_stdin); 124 | eth_ref(eth_stdout); 125 | eth_ref(eth_stderr); 126 | } 127 | 128 | eth_t 129 | eth_open(const char *path, const char *mod) 130 | { 131 | FILE *stream = fopen(path, mod); 132 | if (stream == NULL) 133 | return NULL; 134 | file *f = eth_malloc(sizeof(file)); 135 | init_file(f); 136 | f->stream = stream; 137 | f->flag = OPEN | OWNR; 138 | return ETH(f); 139 | } 140 | 141 | eth_t 142 | eth_open_fd(int fd, const char *mod) 143 | { 144 | FILE *stream = fdopen(fd, mod); 145 | if (stream == NULL) 146 | return NULL; 147 | file *f = eth_malloc(sizeof(file)); 148 | init_file(f); 149 | f->stream = stream; 150 | f->flag = OPEN | OWNR; 151 | return ETH(f); 152 | } 153 | 154 | eth_t 155 | eth_open_stream(FILE *stream) 156 | { 157 | file *f = eth_malloc(sizeof(file)); 158 | init_file(f); 159 | f->stream = stream; 160 | f->flag = OPEN | OWNR; 161 | return ETH(f); 162 | } 163 | 164 | eth_t 165 | eth_open_pipe(const char *command, const char *mod) 166 | { 167 | FILE *stream = popen(command, mod); 168 | if (stream == NULL) 169 | return NULL; 170 | file *f = eth_malloc(sizeof(file)); 171 | init_file(f); 172 | f->stream = stream; 173 | f->flag = OPEN | PIPE | OWNR; 174 | return ETH(f); 175 | } 176 | 177 | void 178 | eth_set_file_data(eth_t x, void *data, void (*dtor)(void *)) 179 | { 180 | file *f = (file *)x; 181 | f->data = data; 182 | f->dtor = dtor; 183 | } 184 | 185 | void 186 | eth_disown_file(eth_t x) 187 | { 188 | file *f = (file *)x; 189 | f->flag ^= OWNR; 190 | } 191 | -------------------------------------------------------------------------------- /src/format.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | int 23 | eth_study_format(const char *fmt) 24 | { 25 | int n = 0; 26 | const char *p = fmt; 27 | while (true) 28 | { 29 | if ((p = strchr(p, '%'))) 30 | { 31 | if (p[1] == 'w' || p[1] == 'd') 32 | { 33 | n += 1; 34 | p += 2; 35 | } 36 | else if (p[1] == '%') 37 | { 38 | p += 2; 39 | } 40 | else 41 | { 42 | return -1; 43 | } 44 | continue; 45 | } 46 | return n; 47 | } 48 | } 49 | 50 | bool 51 | eth_format(FILE *out, const char *fmt, eth_t args[], int n) 52 | { 53 | int ipar = 0; 54 | for (const char *p = fmt; *p; ++p) 55 | { 56 | switch (*p) 57 | { 58 | case '%': 59 | switch (p[1]) 60 | { 61 | case 'w': 62 | eth_write(args[ipar], out); 63 | eth_drop(args[ipar]); 64 | ipar += 1; 65 | p += 1; 66 | break; 67 | 68 | case 'd': 69 | eth_display(args[ipar], out); 70 | eth_drop(args[ipar]); 71 | ipar += 1; 72 | p += 1; 73 | break; 74 | 75 | case '%': 76 | putc('%', out); 77 | p += 1; 78 | break; 79 | 80 | default: 81 | assert(!"wtf"); 82 | abort(); 83 | } 84 | break; 85 | 86 | default: 87 | putc(*p, out); 88 | } 89 | } 90 | 91 | return true; 92 | } 93 | 94 | -------------------------------------------------------------------------------- /src/function.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | ETH_MODULE("ether:function") 23 | 24 | eth_type *eth_function_type; 25 | 26 | eth_source * 27 | eth_create_source(eth_ast *ast, eth_ir *ir, eth_ssa *ssa) 28 | { 29 | eth_source *src = eth_malloc(sizeof(eth_source)); 30 | src->rc = 0; 31 | eth_ref_ast(src->ast = ast); 32 | eth_ref_ir(src->ir = ir); 33 | eth_ref_ssa(src->ssa = ssa); 34 | return src; 35 | } 36 | 37 | static inline void 38 | destroy_source(eth_source *src) 39 | { 40 | eth_unref_ast(src->ast); 41 | eth_unref_ir(src->ir); 42 | eth_unref_ssa(src->ssa); 43 | free(src); 44 | } 45 | 46 | void 47 | eth_ref_source(eth_source *src) 48 | { 49 | src->rc += 1; 50 | } 51 | 52 | void 53 | eth_unref_source(eth_source *src) 54 | { 55 | if (--src->rc == 0) 56 | destroy_source(src); 57 | } 58 | 59 | void 60 | eth_drop_source(eth_source *src) 61 | { 62 | if (src->rc == 0) 63 | destroy_source(src); 64 | } 65 | 66 | // TODO: may cause stack overflow during UNREF of captures 67 | static void 68 | function_destroy(eth_type *__attribute((unused)) type, eth_t x) 69 | { 70 | eth_function *func = ETH_FUNCTION(x); 71 | 72 | if (func->islam) 73 | { 74 | if (func->clos.scp) 75 | { /* Deffer deletion to be hendled by the scope. */ 76 | eth_drop_out(func->clos.scp); 77 | return; 78 | } 79 | 80 | for (int i = 0; i < func->clos.ncap; ++i) 81 | eth_unref(func->clos.cap[i]); 82 | free(func->clos.cap); 83 | eth_unref_source(func->clos.src); 84 | eth_unref_bytecode(func->clos.bc); 85 | } 86 | else 87 | { 88 | if (func->proc.dtor) 89 | func->proc.dtor(func->proc.data); 90 | } 91 | eth_free_h6(func); 92 | } 93 | 94 | void 95 | eth_deactivate_clos(eth_function *func) 96 | { 97 | // destroy all fields 98 | for (int i = 0; i < func->clos.ncap; ++i) 99 | { 100 | if (func->clos.cap[i]->rc > 0) 101 | eth_unref(func->clos.cap[i]); 102 | } 103 | free(func->clos.cap); 104 | eth_unref_source(func->clos.src); 105 | eth_unref_bytecode(func->clos.bc); 106 | 107 | // replace with dummy proc 108 | func->islam = false; 109 | func->proc.handle = NULL; 110 | func->proc.data = NULL; 111 | func->proc.dtor = NULL; 112 | } 113 | 114 | ETH_TYPE_CONSTRUCTOR(init_function_type) 115 | { 116 | eth_function_type = eth_create_type("function"); 117 | eth_function_type->destroy = function_destroy; 118 | } 119 | 120 | static inline eth_function *__attribute__((eth_malloc)) 121 | create_function(void) 122 | { 123 | eth_function *func = eth_alloc_h6(); 124 | eth_init_header(func, eth_function_type); 125 | return func; 126 | } 127 | 128 | eth_t 129 | eth_create_proc(eth_t (*f)(void), int n, void *data, void (*dtor)(void *), ...) 130 | { 131 | eth_function *func = create_function(); 132 | func->islam = false; 133 | func->arity = n; 134 | func->proc.handle = f; 135 | func->proc.data = data; 136 | func->proc.dtor = dtor; 137 | return ETH(func); 138 | } 139 | 140 | eth_t 141 | eth_create_clos(eth_source *src, eth_bytecode *bc, eth_t *cap, int ncap, 142 | int arity) 143 | { 144 | eth_function *func = create_function(); 145 | func->islam = true; 146 | func->arity = arity; 147 | func->clos.src = src; 148 | func->clos.bc = bc; 149 | func->clos.cap = cap; 150 | func->clos.ncap = ncap; 151 | func->clos.scp = NULL; 152 | eth_ref_source(src); 153 | eth_ref_bytecode(bc); 154 | return ETH(func); 155 | } 156 | 157 | static eth_t 158 | dummy_proc(void) 159 | { 160 | eth_error("evaluation of uninitalized function"); 161 | abort(); 162 | } 163 | 164 | eth_t 165 | eth_create_dummy_func(int arity) 166 | { 167 | return eth_create_proc(dummy_proc, arity, NULL, NULL); 168 | } 169 | 170 | void 171 | eth_finalize_clos(eth_function *func, eth_source *src, eth_bytecode *bc, 172 | eth_t *cap, int ncap, int arity) 173 | { 174 | assert(arity == func->arity); 175 | func->islam = true; 176 | func->arity = arity; 177 | func->clos.src = src; 178 | func->clos.bc = bc; 179 | func->clos.cap = cap; 180 | func->clos.ncap = ncap; 181 | func->clos.scp = NULL; 182 | eth_ref_source(src); 183 | eth_ref_bytecode(bc); 184 | } 185 | 186 | typedef struct { 187 | eth_t f; 188 | int n; 189 | eth_t p[]; 190 | } curry_data; 191 | 192 | static void 193 | destroy_curried(curry_data *data) 194 | { 195 | eth_unref(data->f); 196 | for (int i = 0; i < data->n; ++i) 197 | eth_unref(data->p[i]); 198 | size_t datasz = sizeof(curry_data) + sizeof(eth_t) * data->n; 199 | if (datasz <= ETH_H6_SIZE) 200 | eth_free_h6(data); 201 | else 202 | free(data); 203 | } 204 | 205 | static eth_t 206 | curried(void) 207 | { 208 | curry_data *data = eth_this->proc.data; 209 | eth_reserve_stack(data->n); 210 | if (ETH(eth_this)->rc == 0) 211 | { 212 | // remove reference from curried arguments 213 | for (int i = 0; i < data->n; ++i) 214 | { 215 | eth_dec(data->p[i]); 216 | eth_sp[i] = data->p[i]; 217 | } 218 | data->n = 0; // don't touch them in destructor 219 | } 220 | else 221 | { 222 | memcpy(eth_sp, data->p, sizeof(eth_t) * data->n); 223 | } 224 | return eth_apply(data->f, eth_this->arity + data->n); 225 | } 226 | 227 | eth_t 228 | _eth_partial_apply(eth_function *fn, int narg) 229 | { 230 | int arity = fn->arity; 231 | 232 | if (arity < narg) 233 | { 234 | for (int i = arity; i < narg; eth_ref(eth_sp[i++])) 235 | ; 236 | eth_t tmp_f = _eth_raw_apply(ETH(fn)); 237 | narg -= arity; 238 | 239 | if (eth_unlikely(tmp_f->type != eth_function_type)) 240 | { 241 | eth_ref(tmp_f); 242 | while (narg--) 243 | eth_unref(*eth_sp++); 244 | eth_dec(tmp_f); 245 | 246 | if (tmp_f->type == eth_exception_type) 247 | return tmp_f; 248 | else 249 | { 250 | /*eth_trace("tried to apply to `~w`", tmp_f);*/ 251 | eth_drop(tmp_f); 252 | return eth_exn(eth_sym("apply_error")); 253 | } 254 | } 255 | 256 | for (int i = 0; i < narg; eth_dec(eth_sp[i++])) 257 | ; 258 | eth_ref(tmp_f); 259 | eth_t ret = eth_apply(tmp_f, narg); 260 | eth_ref(ret); 261 | eth_unref(tmp_f); 262 | eth_dec(ret); 263 | return ret; 264 | } 265 | else 266 | { 267 | size_t datasz = sizeof(curry_data) + sizeof(eth_t) * narg; 268 | curry_data *data = 269 | datasz <= ETH_H6_SIZE ? eth_alloc_h6() : eth_malloc(datasz); 270 | eth_ref(data->f = ETH(fn)); 271 | data->n = narg; 272 | for (int i = 0; i < narg; ++i) 273 | eth_ref(data->p[i] = eth_sp[i]); 274 | eth_pop_stack(narg); 275 | return eth_create_proc(curried, arity - narg, data, 276 | (void *)destroy_curried); 277 | } 278 | } 279 | -------------------------------------------------------------------------------- /src/hash-table.c: -------------------------------------------------------------------------------- 1 | #include "ether/ether.h" 2 | 3 | 4 | 5 | typedef struct { 6 | eth_header header; 7 | } eth_hash_table; 8 | -------------------------------------------------------------------------------- /src/ir-spec.c: -------------------------------------------------------------------------------- 1 | #include "ether/ether.h" 2 | 3 | #include 4 | 5 | 6 | void 7 | eth_destroy_spec(eth_spec* spec) 8 | { 9 | switch (spec->tag) 10 | { 11 | case ETH_SPEC_TYPE: 12 | free(spec); 13 | break; 14 | } 15 | } 16 | 17 | eth_spec* 18 | eth_create_type_spec(int varid, eth_type *type) 19 | { 20 | eth_spec *spec = eth_malloc(sizeof(eth_spec)); 21 | spec->tag = ETH_SPEC_TYPE; 22 | spec->type_spec.varid = varid; 23 | spec->type_spec.type = type; 24 | return spec; 25 | } 26 | 27 | 28 | -------------------------------------------------------------------------------- /src/ir.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | ETH_MODULE("ether:ir") 23 | 24 | eth_ir* 25 | eth_create_ir(eth_ir_node *body, int nvars) 26 | { 27 | eth_ir *ir = eth_malloc(sizeof(eth_ir)); 28 | ir->rc = 0; 29 | eth_ref_ir_node(ir->body = body); 30 | ir->nvars = nvars; 31 | ir->nspecs = 0; 32 | ir->specs = NULL; 33 | return ir; 34 | } 35 | 36 | static void 37 | destroy_ir(eth_ir *ir) 38 | { 39 | eth_unref_ir_node(ir->body); 40 | if (ir->specs) 41 | { 42 | for (int i = 0; i < ir->nspecs; ++i) 43 | eth_destroy_spec(ir->specs[i]); 44 | free(ir->specs); 45 | } 46 | free(ir); 47 | } 48 | 49 | void 50 | eth_ref_ir(eth_ir *ir) 51 | { 52 | ir->rc += 1; 53 | } 54 | 55 | void 56 | eth_drop_ir(eth_ir *ir) 57 | { 58 | if (ir->rc == 0) 59 | destroy_ir(ir); 60 | } 61 | 62 | void 63 | eth_unref_ir(eth_ir *ir) 64 | { 65 | if (--ir->rc == 0) 66 | destroy_ir(ir); 67 | } 68 | 69 | void 70 | eth_add_spec(eth_ir *ir, eth_spec *spec) 71 | { 72 | eth_spec **newspecs = 73 | reallocarray(ir->specs, ir->nspecs+1, sizeof(eth_spec*)); 74 | if (newspecs == NULL) 75 | { 76 | eth_error("allocation failure"); 77 | abort(); 78 | } 79 | newspecs[ir->nspecs] = spec; 80 | ir->specs = newspecs; 81 | ir->nspecs += 1; 82 | } 83 | 84 | -------------------------------------------------------------------------------- /src/lazy.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | eth_type *eth_lazy_type; 19 | 20 | static void 21 | destroy_lazy(eth_type *__attribute((unused)) type, eth_t x) 22 | { 23 | eth_lazy *lazy = (eth_lazy *)x; 24 | eth_unref(lazy->value); 25 | eth_free_h2(lazy); 26 | } 27 | 28 | static eth_t 29 | apply_impl(void) 30 | { 31 | eth_args args = eth_start(1); 32 | eth_t lazy = eth_arg2(args, eth_lazy_type); 33 | eth_return(args, eth_get_lazy_value(lazy)); 34 | } 35 | 36 | ETH_TYPE_CONSTRUCTOR(init_lazy_type) 37 | { 38 | eth_lazy_type = eth_create_type("lazy"); 39 | eth_lazy_type->destroy = destroy_lazy; 40 | eth_add_method(eth_lazy_type->methods, eth_apply_method, 41 | eth_proc(apply_impl, 1)); 42 | } 43 | -------------------------------------------------------------------------------- /src/location.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | 24 | 25 | ETH_MODULE("ether:location") 26 | 27 | 28 | eth_location* 29 | eth_create_location(int fl, int fc, int ll, int lc, const char *path) 30 | { 31 | eth_location *loc = eth_malloc(sizeof(eth_location)); 32 | loc->rc = 0; 33 | loc->fl = fl; 34 | loc->fc = fc; 35 | loc->ll = ll; 36 | loc->lc = lc; 37 | loc->filepath = strdup(path); 38 | return loc; 39 | } 40 | 41 | static void 42 | destroy_location(eth_location *loc) 43 | { 44 | free(loc->filepath); 45 | free(loc); 46 | } 47 | 48 | void 49 | eth_ref_location(eth_location *loc) 50 | { 51 | loc->rc += 1; 52 | } 53 | 54 | void 55 | eth_unref_location(eth_location *loc) 56 | { 57 | if (--loc->rc == 0) 58 | destroy_location(loc); 59 | } 60 | 61 | void 62 | eth_drop_location(eth_location *loc) 63 | { 64 | if (loc->rc == 0) 65 | destroy_location(loc); 66 | } 67 | 68 | char* 69 | eth_get_location_file(eth_location *loc, char *out) 70 | { 71 | char buf[PATH_MAX]; 72 | strcpy(buf, loc->filepath); 73 | char *file = basename(buf); 74 | 75 | if (loc->fl == loc->ll) 76 | sprintf(out, " %s %d:%d-%d", file, loc->fl, loc->fc, loc->lc); 77 | else 78 | sprintf(out, " %s %d:%d-%d:%d", file, loc->fl, loc->fc, loc->ll, loc->lc); 79 | 80 | return out; 81 | } 82 | 83 | int 84 | eth_print_location_opt(eth_location *loc, FILE *stream, int opt) 85 | { 86 | if (loc == NULL) 87 | return -1; 88 | 89 | FILE *fs = fopen(loc->filepath, "r"); 90 | if (fs == NULL) 91 | return -1; 92 | 93 | if (opt & ETH_LOPT_FILE) 94 | { 95 | //char buf[PATH_MAX]; 96 | //eth_get_location_file(loc, buf); 97 | //fprintf(stream, "%s:\n", buf); 98 | fprintf(stream, "%s:\n", loc->filepath); 99 | 100 | if (opt & ETH_LOPT_NEWLINES) 101 | putc('\n', stream); 102 | } 103 | 104 | int start = loc->fl; 105 | int end = loc->lc > 1 ? loc->ll : loc->ll-1; 106 | if (opt & ETH_LOPT_EXTRALINES) 107 | { 108 | if (start > 1) 109 | start -= 1; 110 | end += 1; 111 | } 112 | 113 | int line = 1; 114 | int col = 1; 115 | int hl = false; 116 | do 117 | { 118 | errno = 0; 119 | int c = fgetc(fs); 120 | if (errno) 121 | { 122 | eth_error("print location: %s\n", strerror(errno)); 123 | fclose(fs); 124 | return -1; 125 | } 126 | if (c == EOF) 127 | { 128 | fclose(fs); 129 | fputs("\e[0m", stream); 130 | goto end; 131 | } 132 | 133 | if (line >= start && line <= end) 134 | { 135 | if (not (opt & ETH_LOPT_NOCOLOR)) 136 | { 137 | if (line == loc->fl && col == loc->fc) 138 | { 139 | hl = true; 140 | fputs("\e[38;5;9;1m", stream); 141 | } 142 | } 143 | 144 | if (col == 1) 145 | { 146 | if (hl) 147 | fputs("\e[0m", stream); 148 | 149 | if (not (opt & ETH_LOPT_NOLINENO)) 150 | fprintf(stream, " %6d | ", line); 151 | else 152 | fprintf(stream, "| "); 153 | 154 | if (hl) 155 | fputs("\e[38;5;9;1m", stream); 156 | } 157 | 158 | putc(c, stream); 159 | 160 | if (not (opt & ETH_LOPT_NOCOLOR)) 161 | { 162 | if (line == loc->ll && col == loc->lc - 1) 163 | { 164 | fputs("\e[0m", stream); 165 | hl = false; 166 | } 167 | } 168 | } 169 | 170 | if (c == '\n') 171 | { 172 | line += 1; 173 | col = 1; 174 | } 175 | else 176 | { 177 | col += 1; 178 | } 179 | 180 | } while (line <= end); 181 | 182 | fclose(fs); 183 | 184 | end: 185 | if (opt & ETH_LOPT_NEWLINES) 186 | putc('\n', stream); 187 | return 0; 188 | } 189 | 190 | int 191 | eth_print_location(eth_location *loc, FILE *stream) 192 | { 193 | int opt = ETH_LOPT_FILE | ETH_LOPT_NEWLINES | ETH_LOPT_EXTRALINES; 194 | return eth_print_location_opt(loc, stream, opt); 195 | } 196 | -------------------------------------------------------------------------------- /src/log.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | 21 | enum eth_log_level eth_log_level = ETH_LOG_WARNING; 22 | 23 | static 24 | int g_indent = 0; 25 | 26 | void 27 | eth_indent_log(void) 28 | { 29 | g_indent += 2; 30 | } 31 | 32 | void 33 | eth_dedent_log(void) 34 | { 35 | g_indent -= 2; 36 | } 37 | 38 | void 39 | eth_log_aux(bool enable, const char *module, const char *file, const char *func, 40 | int line, const char *style, FILE *os, const char *fmt, ...) 41 | { 42 | if (not enable) return; 43 | 44 | fflush(stdout); 45 | fflush(stderr); 46 | 47 | #ifdef ETH_DEBUG_MODE 48 | fprintf(os, "[%s %s \e[0m] at %s:%d (in %s()): ", style, module, file, line, func); 49 | #else 50 | fprintf(os, "[%s ether \e[0m] ", style); 51 | #endif 52 | 53 | for (int i = 0; i < g_indent; ++i) 54 | { 55 | if (i % 2 == 0) 56 | fputs("¦", os); 57 | else 58 | fputc(' ', os); 59 | } 60 | 61 | va_list arg; 62 | va_start(arg, fmt); 63 | eth_vfprintf(os, fmt, arg); 64 | if (va_arg(arg, int)) 65 | putc('\n', os); 66 | va_end(arg); 67 | 68 | } 69 | -------------------------------------------------------------------------------- /src/methods.c: -------------------------------------------------------------------------------- 1 | #include "ether/ether.h" 2 | 3 | #include "codeine/hash-map.h" 4 | 5 | #include 6 | 7 | ETH_MODULE("ether:methods") 8 | 9 | #ifndef ETH_METHOD_STAB_SIZE 10 | # define ETH_METHOD_STAB_SIZE 30 11 | #endif 12 | 13 | 14 | eth_type *eth_method_type; 15 | eth_t eth_apply_method; 16 | eth_t eth_enum_ctor_method; 17 | eth_t eth_get_method; 18 | eth_t eth_set_method; 19 | eth_t eth_write_method; 20 | eth_t eth_display_method; 21 | eth_t eth_len_method; 22 | eth_t eth_cmp_method; 23 | 24 | 25 | static void 26 | _destroy_method(eth_type *type, eth_t x) 27 | { 28 | eth_method *method = (eth_method*)x; 29 | if (method->spec.default_impl) 30 | eth_unref(method->spec.default_impl); 31 | eth_free(method, sizeof(eth_method)); 32 | } 33 | 34 | static eth_t 35 | _apply(void) 36 | { 37 | eth_use_symbol(unimplemented_method); 38 | eth_args args = eth_start(2); 39 | eth_t method = eth_arg(args); 40 | eth_t object = eth_arg(args); 41 | eth_t apply = eth_find_method(object->type->methods, method); 42 | if (apply == NULL) 43 | eth_throw(args, unimplemented_method); 44 | 45 | eth_reserve_stack(1); 46 | eth_sp[0] = object; 47 | eth_t ret = eth_apply(apply, 1); 48 | eth_return(args, ret); 49 | } 50 | 51 | __attribute__((constructor(102))) void 52 | _eth_init_methods(void) 53 | { 54 | eth_method_type = eth_create_type("method"); 55 | eth_method_type->destroy = _destroy_method; 56 | 57 | eth_ref(eth_apply_method = eth_create_method(1, NULL)); 58 | eth_ref(eth_enum_ctor_method = eth_create_method(0, NULL)); 59 | eth_ref(eth_get_method = eth_create_method(2, NULL)); 60 | eth_ref(eth_set_method = eth_create_method(3, NULL)); 61 | eth_ref(eth_write_method = eth_create_method(2, NULL)); 62 | eth_ref(eth_display_method = eth_create_method(2, NULL)); 63 | eth_ref(eth_len_method = eth_create_method(1, NULL)); 64 | eth_ref(eth_cmp_method = eth_create_method(2, NULL)); 65 | 66 | eth_add_method(eth_method_type->methods, eth_apply_method, 67 | eth_proc(_apply, 2, eth_apply_method)); 68 | } 69 | 70 | void 71 | _eth_cleanup_methods(void) 72 | { 73 | eth_unref(eth_apply_method); 74 | eth_destroy_type(eth_method_type); 75 | } 76 | 77 | 78 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 79 | // eth_method 80 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 81 | eth_t 82 | eth_create_method(int arity, eth_t default_impl /* or NULL */) 83 | { 84 | eth_method *method = eth_alloc(sizeof(eth_method)); 85 | method->spec.arity = arity; 86 | if ((method->spec.default_impl = default_impl)) 87 | eth_ref(default_impl); 88 | eth_init_header(&method->hdr, eth_method_type); 89 | return ETH(method); 90 | } 91 | 92 | 93 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 94 | // eth_methods 95 | // -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 96 | typedef struct { 97 | eth_t method; 98 | eth_t impl; 99 | } method; 100 | 101 | struct eth_methods { 102 | size_t size; 103 | union { 104 | method stab[ETH_METHOD_STAB_SIZE+1]; 105 | cod_hash_map *ltab; 106 | }; 107 | }; 108 | 109 | static size_t 110 | find_in_stab(method *stab, size_t size, eth_t m) 111 | { 112 | stab[size].method = m; 113 | for (size_t i = 0; true; ++i) 114 | { 115 | if (stab[i].method == m) 116 | return i; 117 | } 118 | } 119 | 120 | static void 121 | sort_stab(method *stab, size_t size) 122 | { 123 | int cmp(const void *p1, const void *p2) 124 | { 125 | const method *m1 = p1; 126 | const method *m2 = p2; 127 | return m1->method - m2->method; 128 | } 129 | qsort(stab, size, sizeof(method), cmp); 130 | } 131 | 132 | eth_methods* 133 | eth_create_methods() 134 | { 135 | eth_methods *ms = eth_malloc(sizeof(eth_methods)); 136 | ms->size = 0; 137 | return ms; 138 | } 139 | 140 | static void 141 | _free_method(void *ptr) 142 | { 143 | method *m = ptr; 144 | eth_unref(m->method); 145 | eth_unref(m->impl); 146 | free(m); 147 | } 148 | 149 | void 150 | eth_destroy_methods(eth_methods *ms) 151 | { 152 | if (ms->size >= ETH_METHOD_STAB_SIZE) 153 | cod_hash_map_delete(ms->ltab, _free_method); 154 | else 155 | { 156 | for (size_t i = 0; i < ms->size; ++i) 157 | { 158 | eth_unref(ms->stab[i].method); 159 | eth_unref(ms->stab[i].impl); 160 | } 161 | } 162 | free(ms); 163 | } 164 | 165 | bool 166 | eth_add_method(eth_methods *ms, eth_t _method, eth_t impl) 167 | { 168 | if (ms->size + 1 < ETH_METHOD_STAB_SIZE) 169 | { // using stab 170 | if (find_in_stab(ms->stab, ms->size, _method) < ms->size) 171 | return false; 172 | method *m = ms->stab + ms->size++; 173 | m->method = _method; 174 | eth_ref(m->method = _method); 175 | eth_ref(m->impl = impl); 176 | sort_stab(ms->stab, ms->size); 177 | } 178 | else 179 | { 180 | if (ms->size + 1 == ETH_METHOD_STAB_SIZE) 181 | { // stab is full => switch to ltab 182 | if (find_in_stab(ms->stab, ms->size, _method) < ms->size) 183 | // will not insert anyway if it is a duplicate 184 | return false; 185 | 186 | cod_hash_map *ltab = cod_hash_map_new(COD_HASH_MAP_INTKEYS); 187 | // copy stab to ltab 188 | for (int i = 0; i < ETH_METHOD_STAB_SIZE; ++i) 189 | { 190 | method *m = eth_malloc(sizeof(method)); 191 | *m = ms->stab[i]; 192 | cod_hash_map_insert(ltab, (void*)_method, (uintptr_t)_method, m, NULL); 193 | } 194 | ms->ltab = ltab; 195 | } 196 | 197 | if (cod_hash_map_find(ms->ltab, (void*)_method, (uintptr_t)_method)) 198 | return false; 199 | 200 | method *m = eth_malloc(sizeof(method)); 201 | eth_ref(m->method = _method); 202 | eth_ref(m->impl = impl); 203 | cod_hash_map_insert(ms->ltab, (void*)_method, (uintptr_t)_method, m, NULL); 204 | } 205 | 206 | return true; 207 | } 208 | 209 | eth_t 210 | eth_find_method(eth_methods *ms, eth_t _method) 211 | { 212 | if (ms->size <= ETH_METHOD_STAB_SIZE) 213 | { 214 | const size_t idx = find_in_stab(ms->stab, ms->size, _method); 215 | if (eth_unlikely(idx >= ms->size)) 216 | return NULL; 217 | else 218 | return ms->stab[idx].impl; 219 | } 220 | else 221 | { 222 | cod_hash_map_elt *elt = 223 | cod_hash_map_find(ms->ltab, (void*)_method, (uintptr_t)_method); 224 | if (elt == NULL) 225 | return NULL; 226 | method *m = elt->val; 227 | return m->impl; 228 | } 229 | } 230 | 231 | -------------------------------------------------------------------------------- /src/module.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | #include "codeine/vec.h" 18 | 19 | #include 20 | #include 21 | #include 22 | 23 | 24 | ETH_MODULE("ether:module") 25 | 26 | typedef struct { 27 | void *data; 28 | void (*dtor)(void*); 29 | } closure; 30 | 31 | typedef struct { 32 | void (*cb)(void*); 33 | void *data; 34 | } exit_handle; 35 | 36 | struct eth_module { 37 | /** \brief Module's name. */ 38 | char *name; 39 | 40 | /** \brief Module's environment (the thing implementing submodules). */ 41 | eth_env *env; 42 | 43 | /** \brief Destructors to be called on deinitializatoin of a module. */ 44 | cod_vec(closure) clos; 45 | 46 | /** \name Public variables. 47 | * \todo Use some dictionary. 48 | * @{ */ 49 | int ndefs, defscap; 50 | eth_def *defs; 51 | /** @} */ 52 | 53 | cod_vec(exit_handle) exithndls; 54 | 55 | /** \name Reference counting 56 | * \brief Reference counting to handle dpendency-relations between modules. 57 | * I.e., if module A imports B, then B must be kept alive, no matter what, 58 | * untill A is deinitialized. The reason (initial one, at least) is that if B 59 | * defines a new type, and A, e.g., defines a global variable of this type, 60 | * then destructor of that type (so the type-object itself) must be aveilable 61 | * during deinitialization of A. Thus deinitialization of modules must be done 62 | * in some complicated order respecting dependency-trees, which is implicitly 63 | * satisfied by reference ("dependency") counting. 64 | * @{ */ 65 | //size_t rc; 66 | //cod_vec(eth_module*) deps; 67 | /** @} */ 68 | 69 | // XXX: ugly workaround 70 | eth_root *memroot; 71 | char *mempath; 72 | }; 73 | 74 | eth_module* 75 | eth_create_module(const char *name, const char *dir) 76 | { 77 | eth_module *mod = eth_malloc(sizeof(eth_module)); 78 | mod->name = name ? strdup(name) : strdup(""); 79 | mod->ndefs = 0; 80 | mod->defscap = 0x10; 81 | mod->defs = eth_malloc(sizeof(eth_def) * mod->defscap); 82 | mod->env = eth_create_empty_env(); 83 | mod->memroot = NULL; 84 | mod->mempath = NULL; 85 | if (dir) 86 | eth_add_module_path(mod->env, dir); 87 | cod_vec_init(mod->clos); 88 | cod_vec_init(mod->exithndls); 89 | return mod; 90 | } 91 | 92 | void 93 | eth_add_exit_handle(eth_module *mod, void (*cb)(void*), void *data) 94 | { 95 | exit_handle hndle = { .cb = cb, .data = data }; 96 | cod_vec_push(mod->exithndls, hndle); 97 | } 98 | 99 | 100 | void 101 | eth_destroy_module(eth_module *mod) 102 | { 103 | cod_vec_iter(mod->exithndls, i, x, 104 | eth_debug("exit handle: %p(%p)", x.cb, x.data); 105 | x.cb(x.data) 106 | ); 107 | cod_vec_destroy(mod->exithndls); 108 | 109 | if (mod->mempath) 110 | { 111 | eth_debug("module '%s' was memorized, now forgeting it", mod->name); 112 | eth_forget_module(mod->memroot, mod->mempath); 113 | free(mod->mempath); 114 | } 115 | 116 | /*eth_debug("destroying module %s:", mod->name);*/ 117 | free(mod->name); 118 | for (int i = 0; i < mod->ndefs; ++i) 119 | { 120 | /*eth_debug("- delete '%s'", mod->defs[i].ident);*/ 121 | free(mod->defs[i].ident); 122 | eth_unref(mod->defs[i].val); 123 | eth_unref_attr(mod->defs[i].attr); 124 | } 125 | free(mod->defs); 126 | eth_destroy_env(mod->env); 127 | cod_vec_iter(mod->clos, i, x, if (x.dtor) x.dtor(x.data)); 128 | cod_vec_destroy(mod->clos); 129 | free(mod); 130 | } 131 | 132 | const char* 133 | eth_get_module_name(const eth_module *mod) 134 | { 135 | return mod->name; 136 | } 137 | 138 | int 139 | eth_get_ndefs(const eth_module *mod) 140 | { 141 | return mod->ndefs; 142 | } 143 | 144 | eth_def* 145 | eth_get_defs(const eth_module *mod, eth_def out[]) 146 | { 147 | memcpy(out, mod->defs, sizeof(eth_def) * mod->ndefs); 148 | return out; 149 | } 150 | 151 | eth_env* 152 | eth_get_env(const eth_module *mod) 153 | { 154 | return mod->env; 155 | } 156 | 157 | void 158 | _eth_mark_memorized_module(eth_module *mod, eth_root *root, const char *path) 159 | { 160 | assert(mod->memroot == NULL); 161 | assert(mod->mempath == NULL); 162 | mod->memroot = root; 163 | mod->mempath = strdup(path); 164 | } 165 | 166 | void 167 | eth_define_attr(eth_module *mod, const char *ident, eth_t val, eth_attr *attr) 168 | { 169 | if (eth_unlikely(mod->ndefs == mod->defscap)) 170 | { 171 | mod->defscap <<= 1; 172 | mod->defs = realloc(mod->defs, sizeof(eth_def) * mod->defscap); 173 | } 174 | eth_def def = { 175 | .ident = strdup(ident), 176 | .val = val, 177 | .attr = attr, 178 | }; 179 | mod->defs[mod->ndefs++] = def; 180 | eth_ref_attr(def.attr); 181 | eth_ref(val); 182 | } 183 | 184 | 185 | void 186 | eth_define(eth_module *mod, const char *ident, eth_t val) 187 | { 188 | eth_define_attr(mod, ident, val, eth_create_attr(0)); 189 | } 190 | 191 | void 192 | eth_copy_defs(const eth_module *src, eth_module *dst) 193 | { 194 | for (int i = 0; i < src->ndefs; ++i) 195 | { 196 | const eth_def *def = src->defs + i; 197 | eth_define_attr(dst, def->ident, def->val, def->attr); 198 | } 199 | } 200 | 201 | eth_def* 202 | eth_find_def(const eth_module *mod, const char *ident) 203 | { 204 | for (int i = 0; i < mod->ndefs; ++i) 205 | { 206 | if (strcmp(mod->defs[i].ident, ident) == 0) 207 | return mod->defs + i; 208 | } 209 | return NULL; 210 | } 211 | 212 | void 213 | eth_add_destructor(eth_module *mod, void *data, void (*dtor)(void*)) 214 | { 215 | closure c = { .data = data, .dtor = dtor }; 216 | cod_vec_push(mod->clos, c); 217 | } 218 | 219 | -------------------------------------------------------------------------------- /src/mtree.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | 21 | void 22 | eth_init_mtree_case(eth_mtree_case *c, const eth_type *type, const int offs[], 23 | const int ssavids[], int n, eth_mtree *tree) 24 | { 25 | c->type = type; 26 | c->offs = eth_malloc(sizeof(int) * n); 27 | c->ssavids = eth_malloc(sizeof(int) * n); 28 | c->n = n; 29 | c->tree = tree; 30 | memcpy(c->offs, offs, sizeof(int) * n); 31 | memcpy(c->ssavids, ssavids, sizeof(int) * n); 32 | } 33 | 34 | void 35 | eth_cleanup_mtree_case(eth_mtree_case *c) 36 | { 37 | free(c->offs); 38 | free(c->ssavids); 39 | eth_destroy_mtree(c->tree); 40 | } 41 | 42 | void 43 | eth_init_mtree_ccase(eth_mtree_ccase *c, eth_t cval, eth_mtree *tree) 44 | { 45 | eth_ref(c->cval = cval); 46 | c->tree = tree; 47 | } 48 | 49 | void 50 | eth_cleanup_mtree_ccase(eth_mtree_ccase *c) 51 | { 52 | eth_unref(c->cval); 53 | eth_destroy_mtree(c->tree); 54 | } 55 | 56 | eth_mtree* 57 | eth_create_fail(void) 58 | { 59 | eth_mtree *t = eth_malloc(sizeof(eth_mtree)); 60 | t->tag = ETH_MTREE_FAIL; 61 | return t; 62 | } 63 | 64 | eth_mtree* 65 | eth_create_leaf(eth_insn *body) 66 | { 67 | eth_mtree *t = eth_malloc(sizeof(eth_mtree)); 68 | t->tag = ETH_MTREE_LEAF; 69 | t->leaf = body; 70 | return t; 71 | } 72 | 73 | eth_mtree* 74 | eth_create_switch(int ssavid, const eth_mtree_case cases[], int ncases, 75 | eth_mtree *dflt) 76 | { 77 | eth_mtree *t = eth_malloc(sizeof(eth_mtree)); 78 | t->tag = ETH_MTREE_SWITCH; 79 | t->swtch.ssavid = ssavid; 80 | t->swtch.cases = eth_malloc(sizeof(eth_mtree_case) * ncases); 81 | t->swtch.ncases = ncases; 82 | memcpy(t->swtch.cases, cases, sizeof(eth_mtree_case) * ncases); 83 | t->swtch.dflt = dflt; 84 | return t; 85 | } 86 | 87 | eth_mtree* 88 | eth_create_cswitch(int ssavid, const eth_mtree_ccase cases[], int ncases, 89 | eth_mtree *dflt) 90 | { 91 | eth_mtree *t = eth_malloc(sizeof(eth_mtree)); 92 | t->tag = ETH_MTREE_CSWITCH; 93 | t->cswtch.ssavid = ssavid; 94 | t->cswtch.cases = eth_malloc(sizeof(eth_mtree_ccase) * ncases); 95 | t->cswtch.ncases = ncases; 96 | memcpy(t->cswtch.cases, cases, sizeof(eth_mtree_ccase) * ncases); 97 | t->cswtch.dflt = dflt; 98 | return t; 99 | } 100 | 101 | void 102 | eth_destroy_mtree(eth_mtree *t) 103 | { 104 | switch (t->tag) 105 | { 106 | case ETH_MTREE_FAIL: 107 | break; 108 | 109 | case ETH_MTREE_LEAF: 110 | eth_destroy_insn_list(t->leaf); 111 | break; 112 | 113 | case ETH_MTREE_SWITCH: 114 | for (int i = 0; i < t->swtch.ncases; ++i) 115 | eth_cleanup_mtree_case(t->swtch.cases + i); 116 | free(t->swtch.cases); 117 | eth_destroy_mtree(t->swtch.dflt); 118 | break; 119 | 120 | case ETH_MTREE_CSWITCH: 121 | for (int i = 0; i < t->cswtch.ncases; ++i) 122 | eth_cleanup_mtree_ccase(t->cswtch.cases + i); 123 | free(t->cswtch.cases); 124 | eth_destroy_mtree(t->cswtch.dflt); 125 | break; 126 | } 127 | 128 | free(t); 129 | } 130 | 131 | -------------------------------------------------------------------------------- /src/nil.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | eth_type *eth_nil_type; 19 | eth_t eth_nil; 20 | 21 | static void 22 | write_nil(eth_type *__attribute((unused)) type, eth_t __attribute((unused)) x, 23 | FILE *out) 24 | { 25 | fputs("nil", out); 26 | } 27 | 28 | static eth_t 29 | len_impl(void) 30 | { 31 | eth_drop(*eth_sp++); 32 | return eth_num(0); 33 | } 34 | 35 | ETH_TYPE_CONSTRUCTOR(init_nil_type) 36 | { 37 | static eth_header nil; 38 | 39 | eth_nil_type = eth_create_type("nil"); 40 | eth_nil_type->write = write_nil; 41 | eth_nil_type->display = write_nil; 42 | eth_add_method(eth_nil_type->methods, eth_len_method, eth_proc(len_impl, 1)); 43 | 44 | eth_nil = &nil; 45 | eth_init_header(eth_nil, eth_nil_type); 46 | eth_ref(eth_nil); 47 | } 48 | -------------------------------------------------------------------------------- /src/number.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | 20 | eth_type *eth_number_type; 21 | 22 | static void 23 | number_destroy(eth_type *__attribute((unused)) type, eth_t num) 24 | { 25 | eth_free_h2(num); 26 | } 27 | 28 | static void 29 | number_write(eth_type *__attribute((unused)) type, eth_t x, FILE *out) 30 | { 31 | eth_number_t val = ETH_NUMBER(x)->val; 32 | if ((val == INFINITY) | (val == -INFINITY)) 33 | { 34 | fputs(val < 0 ? "-inf" : "inf", out); 35 | return; 36 | } 37 | 38 | #if ETH_NUMBER_TYPE == ETH_NUMBER_LONGDOUBLE 39 | long double i, f = modfl(val, &i); 40 | fprintf(out, f == 0 ? "%.Lf" : "%Lg", val); 41 | #elif ETH_NUMBER_TYPE == ETH_NUMBER_DOUBLE 42 | double i, f = modf(val, &i); 43 | fprintf(out, f == 0 ? "%.f" : "%g", val); 44 | #else 45 | float i, f = modff(val, &i); 46 | fprintf(out, f == 0 ? "%.f" : "%g", val); 47 | #endif 48 | } 49 | 50 | static void 51 | number_display(eth_type *__attribute((unused)) type, eth_t x, FILE *out) 52 | { 53 | eth_number_t val = ETH_NUMBER(x)->val; 54 | if ((val == INFINITY) | (val == -INFINITY)) 55 | { 56 | fputs(val < 0 ? "-inf" : "inf", out); 57 | return; 58 | } 59 | #if ETH_NUMBER_TYPE == ETH_NUMBER_LONGDOUBLE 60 | long double i, f = modfl(val, &i); 61 | fprintf(out, f == 0 ? "%.Lf" : "%Lg", val); 62 | #elif ETH_NUMBER_TYPE == ETH_NUMBER_DOUBLE 63 | double i, f = modf(val, &i); 64 | fprintf(out, f == 0 ? "%.f" : "%g", val); 65 | #else 66 | float i, f = modff(val, &i); 67 | fprintf(out, f == 0 ? "%.f" : "%g", val); 68 | #endif 69 | } 70 | 71 | static bool 72 | number_equal(eth_type *__attribute((unused)) type, eth_t x, eth_t y) 73 | { 74 | return eth_num_val(x) == eth_num_val(y); 75 | } 76 | 77 | static eth_t 78 | cmp_impl(void) 79 | { 80 | eth_args args = eth_start(2); 81 | eth_t x = eth_arg2(args, eth_number_type); 82 | eth_t y = eth_arg2(args, eth_number_type); 83 | eth_return(args, eth_num(eth_num_val(y) - eth_num_val(x))); 84 | } 85 | 86 | ETH_TYPE_CONSTRUCTOR(init_number_type) 87 | { 88 | eth_number_type = eth_create_type("number"); 89 | eth_number_type->destroy = number_destroy; 90 | eth_number_type->write = number_write; 91 | eth_number_type->display = number_display; 92 | eth_number_type->equal = number_equal; 93 | eth_add_method(eth_number_type->methods, eth_cmp_method, 94 | eth_proc(cmp_impl, 2)); 95 | } 96 | -------------------------------------------------------------------------------- /src/pair.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | eth_type *eth_pair_type; 19 | 20 | static void 21 | destroy_pair(eth_type *__attribute((unused)) type, eth_t x) 22 | { 23 | while (x->type == eth_pair_type) 24 | { 25 | eth_t tmp = eth_cdr(x); 26 | eth_unref(eth_car(x)); 27 | eth_free_h2(x); 28 | x = tmp; 29 | 30 | if (eth_unlikely(eth_dec(x) > 0)) 31 | return; 32 | } 33 | eth_drop(x); 34 | } 35 | 36 | static void 37 | write_pair(eth_type *__attribute((unused)) type, eth_t x, FILE *stream) 38 | { 39 | if (eth_is_proper_list(x)) 40 | { 41 | putc('[', stream); 42 | while (x->type == eth_pair_type) 43 | { 44 | eth_write(eth_car(x), stream); 45 | x = eth_cdr(x); 46 | if (x != eth_nil) 47 | fputs(", ", stream); 48 | } 49 | putc(']', stream); 50 | } 51 | else 52 | { 53 | while (x->type == eth_pair_type) 54 | { 55 | if (eth_car(x)->type == eth_pair_type) 56 | putc('(', stream); 57 | eth_write(eth_car(x), stream); 58 | if (eth_car(x)->type == eth_pair_type) 59 | putc(')', stream); 60 | fputs("::", stream); 61 | x = eth_cdr(x); 62 | } 63 | eth_write(x, stream); 64 | } 65 | } 66 | 67 | static bool 68 | pair_equal(eth_type *__attribute((unused)) type, eth_t x, eth_t y) 69 | { 70 | while (x->type == eth_pair_type and y->type == eth_pair_type) 71 | { 72 | if (not eth_equal(eth_car(x), eth_car(y))) 73 | return false; 74 | x = eth_cdr(x); 75 | y = eth_cdr(y); 76 | } 77 | return eth_equal(x, y); 78 | } 79 | 80 | static eth_t 81 | len_impl(void) 82 | { 83 | eth_args args = eth_start(1); 84 | eth_t l = eth_arg(args); 85 | eth_return(args, eth_num(eth_length(l, NULL))); 86 | } 87 | 88 | ETH_TYPE_CONSTRUCTOR(init_pair_type) 89 | { 90 | eth_field fields[] = {{"car", offsetof(eth_pair, car)}, 91 | {"cdr", offsetof(eth_pair, cdr)}}; 92 | eth_pair_type = eth_create_struct_type("pair", fields, 2); 93 | eth_pair_type->destroy = destroy_pair; 94 | eth_pair_type->write = write_pair; 95 | eth_pair_type->equal = pair_equal; 96 | eth_add_method(eth_pair_type->methods, eth_len_method, eth_proc(len_impl, 1)); 97 | } 98 | -------------------------------------------------------------------------------- /src/printf.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | #include 22 | 23 | void 24 | eth_vfprintf(FILE *out, const char *fmt, va_list arg) 25 | { 26 | if (*fmt == 0) return; 27 | 28 | char *p = strchr(fmt, '~'); 29 | if (p && (p[1] == 'w' || p[1] == 'd')) 30 | { 31 | if (p != fmt) 32 | { 33 | int n = p - fmt; 34 | char buf[n + 1]; 35 | memcpy(buf, fmt, n); 36 | buf[n] = 0; 37 | vfprintf(out, buf, arg); 38 | } 39 | 40 | eth_t x = va_arg(arg, eth_t); 41 | switch (p[1]) 42 | { 43 | case 'w': 44 | eth_write(x, out); 45 | break; 46 | 47 | case 'd': 48 | eth_display(x, out); 49 | break; 50 | } 51 | 52 | eth_vfprintf(out, p + 2, arg); 53 | } 54 | else 55 | vfprintf(out, fmt, arg); 56 | } 57 | 58 | void 59 | eth_vprintf(const char *fmt, va_list arg) 60 | { 61 | eth_vfprintf(stdout, fmt, arg); 62 | } 63 | 64 | void 65 | eth_fprintf(FILE *out, const char *fmt, ...) 66 | { 67 | va_list arg; 68 | va_start(arg, fmt); 69 | eth_vfprintf(out, fmt, arg); 70 | va_end(arg); 71 | } 72 | 73 | void 74 | eth_printf(const char *fmt, ...) 75 | { 76 | va_list arg; 77 | va_start(arg, fmt); 78 | eth_vprintf(fmt, arg); 79 | va_end(arg); 80 | } 81 | 82 | -------------------------------------------------------------------------------- /src/range.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | 20 | eth_type *eth_rangelr_type, *eth_rangel_type, *eth_ranger_type; 21 | 22 | static void 23 | destroy_lr(eth_type *__attribute((unused)) type, eth_t x) 24 | { 25 | eth_rangelr *rng = (void *)x; 26 | eth_unref(rng->l); 27 | eth_unref(rng->r); 28 | eth_free_h2(rng); 29 | } 30 | 31 | static void 32 | destroy_l(eth_type *__attribute((unused)) type, eth_t x) 33 | { 34 | eth_rangel *rng = (void *)x; 35 | eth_unref(rng->l); 36 | eth_free_h1(rng); 37 | } 38 | 39 | static void 40 | destroy_r(eth_type *__attribute((unused)) type, eth_t x) 41 | { 42 | eth_ranger *rng = (void *)x; 43 | eth_unref(rng->r); 44 | eth_free_h1(rng); 45 | } 46 | 47 | static bool 48 | rangelr_equal(eth_type *__attribute((unused)) type, eth_t x, eth_t y) 49 | { 50 | eth_rangelr *rng1 = (void *)x; 51 | eth_rangelr *rng2 = (void *)y; 52 | return eth_equal(rng1->l, rng2->l) and eth_equal(rng1->r, rng2->r); 53 | } 54 | 55 | static bool 56 | rangel_equal(eth_type *__attribute((unused)) type, eth_t x, eth_t y) 57 | { 58 | eth_rangel *rng1 = (void *)x; 59 | eth_rangel *rng2 = (void *)y; 60 | return eth_equal(rng1->l, rng2->l); 61 | } 62 | 63 | static bool 64 | ranger_equal(eth_type *__attribute((unused)) type, eth_t x, eth_t y) 65 | { 66 | eth_ranger *rng1 = (void *)x; 67 | eth_ranger *rng2 = (void *)y; 68 | return eth_equal(rng1->r, rng2->r); 69 | } 70 | 71 | ETH_TYPE_CONSTRUCTOR(init_range_types) 72 | { 73 | eth_field fieldslr[] = { 74 | {"l", offsetof(eth_rangelr, l)}, 75 | {"r", offsetof(eth_rangelr, r)}, 76 | }; 77 | eth_field fieldsl[] = {{"l", offsetof(eth_rangel, l)}}; 78 | eth_field fieldsr[] = {{"r", offsetof(eth_ranger, r)}}; 79 | eth_rangelr_type = eth_create_struct_type("rangelr", fieldslr, 2); 80 | eth_rangel_type = eth_create_struct_type("rangel", fieldsl, 1); 81 | eth_ranger_type = eth_create_struct_type("ranger", fieldsr, 1); 82 | eth_rangelr_type->destroy = destroy_lr; 83 | eth_rangel_type->destroy = destroy_l; 84 | eth_ranger_type->destroy = destroy_r; 85 | eth_rangelr_type->equal = rangelr_equal; 86 | eth_rangel_type->equal = rangel_equal; 87 | eth_ranger_type->equal = ranger_equal; 88 | eth_rangelr_type->flag |= ETH_TFLAG_PLAIN; 89 | eth_rangel_type->flag |= ETH_TFLAG_PLAIN; 90 | eth_ranger_type->flag |= ETH_TFLAG_PLAIN; 91 | } 92 | -------------------------------------------------------------------------------- /src/ref.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | eth_type *eth_strong_ref_type; 19 | 20 | static void 21 | destroy_strong_ref(eth_type *__attribute((unused)) type, eth_t x) 22 | { 23 | eth_unref(eth_ref_get(x)); 24 | eth_free_h1(x); 25 | } 26 | 27 | ETH_TYPE_CONSTRUCTOR(init_ref_type) 28 | { 29 | eth_strong_ref_type = eth_create_type("strong-ref"); 30 | eth_strong_ref_type->destroy = destroy_strong_ref; 31 | } 32 | 33 | eth_t 34 | eth_create_strong_ref(eth_t init) 35 | { 36 | eth_mut_ref *ref = eth_alloc_h1(); 37 | eth_init_header(ref, eth_strong_ref_type); 38 | eth_ref(ref->val = init); 39 | return ETH(ref); 40 | } 41 | -------------------------------------------------------------------------------- /src/regexp.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "pcre.h" 17 | 18 | #include "ether/ether.h" 19 | 20 | #include 21 | 22 | ETH_MODULE("ether:regexp") 23 | 24 | eth_type *eth_regexp_type; 25 | 26 | #define ETH_OVECTOR_N 0x64 27 | #define ETH_OVECTOR_SIZE (ETH_OVECTOR_N * 3) 28 | 29 | static int g_ovector[ETH_OVECTOR_SIZE]; 30 | 31 | const int * 32 | eth_ovector(void) 33 | { 34 | return g_ovector; 35 | } 36 | 37 | struct eth_regexp { 38 | eth_header header; 39 | pcre *re; 40 | pcre_extra *extra; 41 | }; 42 | 43 | static void 44 | destroy_regexp(eth_type *__attribute((unused)) type, eth_t x) 45 | { 46 | eth_regexp *regexp = (void *)x; 47 | if (regexp->extra) 48 | pcre_free_study(regexp->extra); 49 | pcre_free(regexp->re); 50 | free(regexp); 51 | } 52 | 53 | ETH_TYPE_CONSTRUCTOR(init_regextp_type) 54 | { 55 | eth_regexp_type = eth_create_type("regexp"); 56 | eth_regexp_type->destroy = destroy_regexp; 57 | } 58 | 59 | eth_t 60 | eth_create_regexp(const char *pat, int opts, const char **eptr, int *eoffs) 61 | { 62 | const char *_eptr = NULL; 63 | int _eoffs = 0; 64 | if (eptr == NULL) 65 | eptr = &_eptr; 66 | if (eoffs == NULL) 67 | eoffs = &_eoffs; 68 | 69 | pcre *re = pcre_compile(pat, opts, eptr, eoffs, NULL); 70 | if (re == NULL) 71 | { 72 | eth_debug("PCRE-compile failed: %s", eptr); 73 | return NULL; 74 | } 75 | eth_regexp *regexp = eth_malloc(sizeof(eth_regexp)); 76 | eth_init_header(regexp, eth_regexp_type); 77 | regexp->re = re; 78 | regexp->extra = NULL; 79 | return ETH(regexp); 80 | } 81 | 82 | void 83 | eth_study_regexp(eth_t x) 84 | { 85 | eth_regexp *regexp = (void *)x; 86 | if (not regexp->extra) 87 | { 88 | int opt = PCRE_STUDY_JIT_COMPILE | PCRE_STUDY_EXTRA_NEEDED; 89 | const char *err; 90 | regexp->extra = pcre_study(regexp->re, opt, &err); 91 | } 92 | } 93 | 94 | int 95 | eth_get_regexp_ncaptures(eth_t x) 96 | { 97 | eth_regexp *regexp = (void *)x; 98 | int n; 99 | if (pcre_fullinfo(regexp->re, NULL, PCRE_INFO_CAPTURECOUNT, &n)) 100 | return -1; 101 | return n; 102 | } 103 | 104 | int 105 | eth_exec_regexp(eth_t x, const char *str, int len, int opts) 106 | { 107 | if (len <= 0) 108 | len = strlen(str); 109 | 110 | int ncap = eth_get_regexp_ncaptures(x); 111 | if (ncap + 1 > ETH_OVECTOR_N) 112 | { 113 | eth_warning("regular expression has too many captures"); 114 | return -1; 115 | } 116 | 117 | eth_regexp *regexp = (void *)x; 118 | int n = pcre_exec(regexp->re, regexp->extra, str, len, 0, opts, g_ovector, 119 | ETH_OVECTOR_SIZE); 120 | 121 | return n; 122 | } 123 | -------------------------------------------------------------------------------- /src/repl.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | 21 | eth_env* 22 | eth_get_evaluator_env(eth_evaluator *evl) 23 | { 24 | return eth_get_root_env(evl->root); 25 | } 26 | 27 | static void 28 | set_pub(eth_ast_pattern *pat) 29 | { 30 | switch (pat->tag) 31 | { 32 | case ETH_AST_PATTERN_DUMMY: 33 | case ETH_AST_PATTERN_CONSTANT: 34 | break; 35 | 36 | case ETH_AST_PATTERN_IDENT: 37 | if (not pat->ident.attr) 38 | eth_ref_attr(pat->ident.attr = eth_create_attr(0)); 39 | pat->ident.attr->flag |= ETH_ATTR_PUB; 40 | break; 41 | 42 | case ETH_AST_PATTERN_UNPACK: 43 | for (int i = 0; i < pat->unpack.n; ++i) 44 | set_pub(pat->unpack.subpats[i]); 45 | break; 46 | 47 | case ETH_AST_PATTERN_RECORD: 48 | for (int i = 0; i < pat->record.n; ++i) 49 | set_pub(pat->record.subpats[i]); 50 | break; 51 | 52 | case ETH_AST_PATTERN_RECORD_STAR: 53 | if (not pat->recordstar.attr) 54 | eth_ref_attr(pat->recordstar.attr = eth_create_attr(0)); 55 | pat->recordstar.attr->flag |= ETH_ATTR_PUB; 56 | break; 57 | } 58 | } 59 | 60 | eth_t 61 | eth_eval(eth_evaluator *evl, eth_ast *ast) 62 | { 63 | switch (ast->tag) 64 | { 65 | case ETH_AST_LET: 66 | case ETH_AST_LETREC: 67 | { 68 | // add pub-qualifier for all variables 69 | for (int i = 0; i < ast->let.n; ++i) 70 | set_pub(ast->let.pats[i]); 71 | 72 | eth_ir_defs defs; 73 | eth_ir *ir = 74 | eth_build_module_ir(ast, evl->root, evl->mod, &defs, evl->mod); 75 | if (not ir) 76 | return NULL; 77 | 78 | eth_ssa *ssa = eth_build_ssa(ir, &defs); 79 | eth_drop_ir(ir); 80 | if (not ssa) 81 | { 82 | eth_destroy_ir_defs(&defs); 83 | return NULL; 84 | } 85 | 86 | eth_bytecode *bc = eth_build_bytecode(ssa, 0); 87 | eth_drop_ssa(ssa); 88 | if (not bc) 89 | { 90 | eth_destroy_ir_defs(&defs); 91 | return NULL; 92 | } 93 | 94 | eth_t ret = eth_vm(bc); 95 | eth_ref(ret); 96 | eth_drop_bytecode(bc); 97 | if (ret->type == eth_exception_type) 98 | { 99 | eth_destroy_ir_defs(&defs); 100 | eth_unref(ret); 101 | return NULL; 102 | } 103 | 104 | // get defs: 105 | int i = 0; 106 | for (eth_t it = eth_tup_get(ret, 1); it != eth_nil; it = eth_cdr(it), ++i) 107 | eth_define_attr(evl->mod, defs.defs[i].ident, eth_car(it), defs.defs[i].attr); 108 | eth_destroy_ir_defs(&defs); 109 | eth_unref(ret); 110 | 111 | return eth_nil; 112 | } 113 | 114 | default: 115 | { 116 | eth_ir *ir = eth_build_ir(ast, evl->root, evl->mod); 117 | if (not ir) 118 | return NULL; 119 | 120 | eth_ssa *ssa = eth_build_ssa(ir, NULL); 121 | eth_drop_ir(ir); 122 | if (not ssa) 123 | return NULL; 124 | 125 | eth_bytecode *bc = eth_build_bytecode(ssa, 0); 126 | eth_drop_ssa(ssa); 127 | if (not bc) 128 | return NULL; 129 | 130 | eth_t ret = eth_vm(bc); 131 | eth_ref(ret); 132 | eth_drop_bytecode(bc); 133 | eth_dec(ret); 134 | return ret; 135 | } 136 | } 137 | } 138 | 139 | -------------------------------------------------------------------------------- /src/root.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | #include "codeine/hash-map.h" 18 | #include "codeine/hash.h" 19 | 20 | #include 21 | 22 | 23 | ETH_MODULE("ether:root") 24 | 25 | #define hash cod_djb2 26 | 27 | 28 | static void 29 | destroy_module_entry(void *ptr) 30 | { 31 | eth_module_entry *ent = ptr; 32 | eth_debug("calling DTOR for module '%s'", eth_get_module_name(ent->mod)); 33 | eth_destroy_module(ent->mod); 34 | if (ent->dl) 35 | dlclose(ent->dl); 36 | free(ent); 37 | } 38 | 39 | struct eth_root { 40 | cod_hash_map *pathmap; 41 | eth_module *builtins; 42 | eth_env *env; 43 | int destroying; /* XXX hardcoded marker to avoid access to path-map while it 44 | is being deinitialized */ 45 | }; 46 | 47 | eth_root* 48 | eth_create_root(void) 49 | { 50 | eth_root *root = eth_malloc(sizeof(eth_root)); 51 | root->pathmap = cod_hash_map_new(0); 52 | root->env = eth_create_env(); 53 | root->destroying = false; 54 | root->builtins = eth_create_builtins(root); 55 | return root; 56 | } 57 | 58 | void 59 | eth_destroy_root(eth_root *root) 60 | { 61 | root->destroying = true; 62 | cod_hash_map_delete(root->pathmap, destroy_module_entry); 63 | eth_destroy_module(root->builtins); 64 | eth_destroy_env(root->env); 65 | free(root); 66 | } 67 | 68 | eth_env* 69 | eth_get_root_env(eth_root *root) 70 | { 71 | return root->env; 72 | } 73 | 74 | const eth_module* 75 | eth_get_builtins(const eth_root *root) 76 | { 77 | return root->builtins; 78 | } 79 | 80 | void 81 | _eth_set_builtins(eth_root *root, eth_module *mod) 82 | { 83 | root->builtins = mod; 84 | } 85 | 86 | eth_module_entry* 87 | eth_get_memorized_module(const eth_root *root, const char *path) 88 | { 89 | cod_hash_map_elt *elt = cod_hash_map_find(root->pathmap, path, hash(path)); 90 | return elt ? elt->val : NULL; 91 | } 92 | 93 | eth_module_entry* 94 | eth_memorize_module(eth_root *root, const char *path, eth_module *mod) 95 | { 96 | extern void 97 | _eth_mark_memorized_module(eth_module *mod, eth_root *root, const char *path); 98 | 99 | // check path is already known 100 | if (eth_get_memorized_module(root, path)) 101 | { 102 | eth_warning("module under \"%s\" is already in known", path); 103 | eth_warning("wont reassign it to module '%s'", eth_get_module_name(mod)); 104 | return NULL; 105 | } 106 | 107 | // create new module-entry 108 | eth_module_entry *ent = eth_malloc(sizeof(eth_module_entry)); 109 | ent->mod = mod; 110 | ent->dl = NULL; 111 | ent->flag = 0; 112 | 113 | cod_hash_map_insert(root->pathmap, path, hash(path), (void*)ent, NULL); 114 | _eth_mark_memorized_module((eth_module*)mod, root, path); 115 | 116 | return ent; 117 | } 118 | 119 | void 120 | eth_forget_module(eth_root *root, const char *path) 121 | { 122 | if (root->destroying) 123 | return; 124 | 125 | if (not cod_hash_map_erase(root->pathmap, path, hash(path), free)) 126 | { 127 | eth_warning("no module under \"%s\"", path); 128 | eth_warning("please ensure that the path abowe is a full path"); 129 | } 130 | } 131 | 132 | eth_t 133 | eth_get_builtin(eth_root *root, const char *name) 134 | { 135 | eth_def *def = eth_find_def(root->builtins, name); 136 | if (def) 137 | return def->val; 138 | else 139 | return NULL; 140 | } 141 | 142 | -------------------------------------------------------------------------------- /src/scanner-data.h: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #ifndef SCANNER_DATA 17 | #define SCANNER_DATA 18 | 19 | #include "ether/ether.h" 20 | 21 | #include 22 | 23 | #include 24 | #include 25 | #include 26 | 27 | 28 | enum { QUOTES_DEFAULT, QUOTES_STRING }; 29 | typedef struct { int tag; char *str; } quote; 30 | 31 | static inline void 32 | destroy_quote(quote q) 33 | { 34 | if (q.tag == QUOTES_STRING) 35 | free(q.str); 36 | } 37 | 38 | typedef struct indent_level { 39 | int nspaces; 40 | bool issilent; 41 | } indent_level; 42 | 43 | struct eth_scanner_data { 44 | cod_vec(int) primtoks; 45 | cod_vec(int) fmtbracecnt; 46 | cod_vec(quote) quotestack; 47 | cod_vec(indent_level) indentstack; 48 | int curindent; 49 | cod_vec(int) indlvlstack; 50 | cod_vec(int) statestack; 51 | int curstate; 52 | bool isrepl; 53 | eth_root *root; 54 | }; 55 | 56 | static inline void 57 | _push_quote(struct eth_scanner_data *data, int tag, const char *maybestr) 58 | { 59 | quote q = { .tag = tag, .str = maybestr ? strdup(maybestr) : NULL }; 60 | cod_vec_push(data->quotestack, q); 61 | } 62 | 63 | static inline void 64 | _pop_quote(struct eth_scanner_data *data) 65 | { 66 | destroy_quote(cod_vec_pop(data->quotestack)); 67 | } 68 | 69 | #endif 70 | -------------------------------------------------------------------------------- /src/scanner.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include "scanner-data.h" 19 | 20 | #include 21 | #include 22 | #include 23 | 24 | 25 | extern int 26 | yylex_init(eth_scanner **scanptr); 27 | 28 | extern int 29 | yylex_destroy(eth_scanner *scan); 30 | 31 | extern void 32 | yyset_in(FILE *in, eth_scanner *scan); 33 | 34 | extern FILE* 35 | yyget_in(eth_scanner *scan); 36 | 37 | extern void 38 | yyset_extra(eth_scanner_data *data, eth_scanner *scan); 39 | 40 | extern eth_scanner_data* 41 | yyget_extra(eth_scanner *scan); 42 | 43 | eth_scanner* 44 | eth_create_scanner(eth_root *root, FILE *stream) 45 | { 46 | eth_scanner *scan; 47 | yylex_init(&scan); 48 | yyset_in(stream, scan); 49 | 50 | eth_scanner_data *data = eth_malloc(sizeof(eth_scanner_data)); 51 | data->root = root; 52 | cod_vec_init(data->primtoks); 53 | cod_vec_init(data->fmtbracecnt); 54 | cod_vec_init(data->quotestack); 55 | cod_vec_init(data->indentstack); 56 | data->curindent = 0; 57 | cod_vec_init(data->indlvlstack); 58 | cod_vec_init(data->statestack); 59 | data->curstate = 0 /* INITIAL */; 60 | data->isrepl = false; 61 | yyset_extra(data, scan); 62 | 63 | return scan; 64 | } 65 | 66 | eth_scanner* 67 | eth_create_repl_scanner(eth_root *root, FILE *stream) 68 | { 69 | eth_scanner *scan = eth_create_scanner(root, stream); 70 | eth_get_scanner_data(scan)->isrepl = true; 71 | return scan; 72 | } 73 | 74 | void 75 | eth_destroy_scanner(eth_scanner *scan) 76 | { 77 | eth_scanner_data *data = yyget_extra(scan); 78 | cod_vec_destroy(data->primtoks); 79 | cod_vec_destroy(data->fmtbracecnt); 80 | assert(data->quotestack.len == 0); 81 | cod_vec_destroy(data->quotestack); 82 | cod_vec_destroy(data->indentstack); 83 | cod_vec_destroy(data->indlvlstack); 84 | cod_vec_destroy(data->statestack); 85 | free(data); 86 | 87 | yylex_destroy(scan); 88 | } 89 | 90 | FILE* 91 | eth_get_scanner_input(eth_scanner *scan) 92 | { 93 | return yyget_in(scan); 94 | } 95 | 96 | eth_scanner_data* 97 | eth_get_scanner_data(eth_scanner *scan) 98 | { 99 | return yyget_extra(scan); 100 | } 101 | 102 | bool 103 | eth_is_repl_scanner(eth_scanner *scan) 104 | { 105 | return eth_get_scanner_data(scan)->isrepl; 106 | } 107 | 108 | -------------------------------------------------------------------------------- /src/scp.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | ETH_MODULE("scp") 23 | 24 | eth_scp* 25 | eth_create_scp(eth_function **fns, int nfns) 26 | { 27 | eth_scp *scp = eth_malloc(sizeof(eth_scp)); 28 | scp->fns = eth_malloc(sizeof(eth_function*) * nfns); 29 | scp->nfns = nfns; 30 | scp->rc = nfns; 31 | memcpy(scp->fns, fns, sizeof(eth_function*) * nfns); 32 | 33 | for (int i = 0; i < nfns; ++i) 34 | fns[i]->clos.scp = scp; 35 | 36 | return scp; 37 | } 38 | 39 | void 40 | eth_destroy_scp(eth_scp *scp) 41 | { 42 | free(scp->fns); 43 | free(scp); 44 | } 45 | 46 | void 47 | eth_drop_out(eth_scp *scp) 48 | { 49 | size_t nfns = scp->nfns; 50 | eth_function **restrict fns = scp->fns; 51 | 52 | if (--scp->rc != 0) 53 | return; 54 | 55 | // validate scope-RC: 56 | size_t rc = 0; 57 | for (size_t i = 0; i < nfns; ++i) 58 | rc += (fns[i]->header.rc != 0); 59 | if ((scp->rc = rc) != 0) 60 | return; 61 | 62 | // Drop scope: 63 | // 1. deactivate closures 64 | // 2. release closures 65 | for (size_t i = 0; i < nfns; ++i) 66 | eth_deactivate_clos(fns[i]); 67 | // -- 68 | for (size_t i = 0; i < nfns; ++i) 69 | eth_delete(ETH(fns[i])); 70 | 71 | eth_destroy_scp(scp); 72 | } 73 | -------------------------------------------------------------------------------- /src/ssa-tape.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | eth_ssa_tape* 23 | eth_create_ssa_tape_at(eth_insn *at) 24 | { 25 | eth_ssa_tape *tape = eth_malloc(sizeof(eth_ssa_tape)); 26 | tape->head = tape->point = at; 27 | return tape; 28 | } 29 | 30 | eth_ssa_tape* 31 | eth_create_ssa_tape() 32 | { 33 | return eth_create_ssa_tape_at(NULL); 34 | } 35 | 36 | void 37 | eth_destroy_ssa_tape(eth_ssa_tape *tape) 38 | { 39 | free(tape); 40 | } 41 | 42 | void 43 | eth_insert_insn_after(eth_insn *where, eth_insn *insn) 44 | { 45 | assert(!insn->prev && !insn->next); 46 | insn->prev = where; 47 | insn->next = where->next; 48 | if (where->next) 49 | where->next->prev = insn; 50 | where->next = insn; 51 | } 52 | 53 | void 54 | eth_insert_insn_before(eth_insn *where, eth_insn *insn) 55 | { 56 | assert(!insn->prev && !insn->next); 57 | 58 | if (where->flag & ETH_IFLAG_NOBEFORE) 59 | return eth_insert_insn_after(where, insn); 60 | 61 | insn->next = where; 62 | insn->prev = where->prev; 63 | if (where->prev) 64 | { 65 | switch (where->prev->tag) 66 | { 67 | case ETH_INSN_IF: 68 | if (where->prev->iff.thenbr == where) 69 | where->prev->iff.thenbr = insn; 70 | else if (where->prev->iff.elsebr == where) 71 | where->prev->iff.elsebr = insn; 72 | else 73 | where->prev->next = insn; 74 | break; 75 | 76 | case ETH_INSN_TRY: 77 | if (where->prev->try.trybr == where) 78 | where->prev->try.trybr = insn; 79 | else if (where->prev->try.catchbr == where) 80 | where->prev->try.catchbr = insn; 81 | else 82 | where->prev->next = insn; 83 | break; 84 | 85 | default: 86 | where->prev->next = insn; 87 | } 88 | } 89 | where->prev = insn; 90 | } 91 | 92 | void 93 | eth_write_insn(eth_ssa_tape *tape, eth_insn *insn) 94 | { 95 | assert(!insn->prev && !insn->next); 96 | if (tape->point) 97 | eth_insert_insn_after(tape->point, insn); 98 | else 99 | tape->head = insn; 100 | tape->point = insn; 101 | } 102 | 103 | -------------------------------------------------------------------------------- /src/state.c: -------------------------------------------------------------------------------- 1 | #include "ether/ether.h" 2 | 3 | #include 4 | #include 5 | 6 | 7 | #define ETH_NEW_CPU_STACK_NPAG 1 8 | 9 | // FIXME stack overflow not detected 10 | eth_state* 11 | eth_create_initial_state(int cpu_stack_npag, eco_entry_point_t entry) 12 | { 13 | eth_state *s = eth_malloc(sizeof(eth_state)); 14 | memset(s, 0, sizeof(eth_state)); 15 | 16 | // new cpu stack 17 | eco_allocate_guarded_stack(cpu_stack_npag, &s->cpustack); 18 | 19 | // new arg stack 20 | s->astack = eth_malloc(ETH_STACK_SIZE); 21 | eth_t *asb = (eth_t*)((uintptr_t)s->astack + ETH_STACK_SIZE); 22 | asb = (eth_t*)((uintptr_t)asb & ~(sizeof(void*)-1)); 23 | size_t ass = (uintptr_t)asb - (uintptr_t)s->astack; 24 | 25 | // init cpu context 26 | eco_init(&s->cpustate, entry, s->cpustack.stack, s->cpustack.stack_size); 27 | 28 | // init vm context 29 | s->vmstate.sb = asb; 30 | s->vmstate.sp = asb; 31 | s->vmstate.ss = ass; 32 | s->vmstate.cpuse = (uintptr_t)s->cpustack.mem_ptr; 33 | 34 | return s; 35 | } 36 | 37 | void 38 | eth_destroy_state(eth_state *state) 39 | { 40 | eco_cleanup(&state->cpustate); 41 | eco_destroy_guarded_stack(&state->cpustack); 42 | free(state->astack); 43 | free(state); 44 | } 45 | 46 | 47 | static void 48 | _save_vm_state(eth_vm_state *vms) 49 | { 50 | vms->sp = eth_sp; 51 | vms->sb = eth_sb; 52 | vms->ss = eth_ss; 53 | vms->thiss = eth_this; 54 | vms->cpuse = eth_cpu_se; 55 | } 56 | 57 | static void 58 | _load_vm_state(const eth_vm_state *vms) 59 | { 60 | eth_sp = vms->sp; 61 | eth_sb = vms->sb; 62 | eth_ss = vms->ss; 63 | eth_this = vms->thiss; 64 | eth_cpu_se = vms->cpuse; 65 | } 66 | 67 | bool 68 | eth_switch_state(eth_state *from, eth_state *to, void *parcel, 69 | eth_state **ret_caller, void **ret_parcel) 70 | { 71 | _save_vm_state(&from->vmstate); 72 | _load_vm_state(&to->vmstate); 73 | 74 | if (not eco_switch((eco_t*)from, (eco_t*)to, parcel, (eco_t**)ret_caller, 75 | ret_parcel)) 76 | { // didn't switch 77 | // => recover VM state manually 78 | _load_vm_state(&from->vmstate); 79 | return false; 80 | } 81 | else 82 | { // returned from other switch 83 | // => VM state is already set up 84 | return true; 85 | } 86 | } 87 | 88 | -------------------------------------------------------------------------------- /src/string.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | #include 22 | 23 | eth_type *eth_string_type; 24 | 25 | static eth_t g_chars[256]; 26 | 27 | static void 28 | destroy_string(eth_type *__attribute((unused)) type, eth_t x) 29 | { 30 | free(ETH_STRING(x)->cstr); 31 | free(x); 32 | } 33 | 34 | static void 35 | write_string(eth_type *__attribute((unused)) type, eth_t x, FILE *out) 36 | { 37 | fputc('\'', out); 38 | const char *p = eth_str_cstr(x); 39 | for (int i = 0; i < eth_str_len(x); ++i) 40 | { 41 | if (isprint(p[i])) 42 | putc(p[i], out); 43 | else 44 | { 45 | switch (p[i]) 46 | { 47 | case '\'': 48 | fputs("\\'", out); 49 | break; 50 | case '\0': 51 | fputs("\\0", out); 52 | break; 53 | case '\a': 54 | fputs("\\a", out); 55 | break; 56 | case '\b': 57 | fputs("\\b", out); 58 | break; 59 | case '\f': 60 | fputs("\\f", out); 61 | break; 62 | case '\n': 63 | fputs("\\n", out); 64 | break; 65 | case '\r': 66 | fputs("\\r", out); 67 | break; 68 | case '\t': 69 | fputs("\\t", out); 70 | break; 71 | case '\v': 72 | fputs("\\v", out); 73 | break; 74 | default: 75 | fprintf(out, "\\x%hhx", p[i]); 76 | } 77 | } 78 | } 79 | fputc('\'', out); 80 | } 81 | 82 | static void 83 | display_string(eth_type *__attribute((unused)) type, eth_t x, FILE *out) 84 | { 85 | fwrite(eth_str_cstr(x), 1, eth_str_len(x), out); 86 | } 87 | 88 | static bool 89 | string_equal(eth_type *__attribute((unused)) type, eth_t x, eth_t y) 90 | { 91 | return eth_str_len(x) == eth_str_len(y) and 92 | memcmp(eth_str_cstr(x), eth_str_cstr(y), eth_str_len(x)) == 0; 93 | } 94 | 95 | static eth_t 96 | cmp_impl(void) 97 | { 98 | eth_args args = eth_start(2); 99 | eth_t x = eth_arg2(args, eth_string_type); 100 | eth_t y = eth_arg2(args, eth_string_type); 101 | eth_return(args, eth_num(strcmp(eth_str_cstr(x), eth_str_cstr(y)))); 102 | } 103 | 104 | static eth_t 105 | len_impl(void) 106 | { 107 | eth_args args = eth_start(1); 108 | eth_t s = eth_arg2(args, eth_string_type); 109 | eth_return(args, eth_num(eth_str_len(s))); 110 | } 111 | 112 | ETH_TYPE_CONSTRUCTOR(init_string_type) 113 | { 114 | eth_string_type = eth_create_type("string"); 115 | eth_string_type->destroy = destroy_string; 116 | eth_string_type->write = write_string; 117 | eth_string_type->display = display_string; 118 | eth_string_type->equal = string_equal; 119 | eth_add_method(eth_string_type->methods, eth_cmp_method, 120 | eth_proc(cmp_impl, 2)); 121 | eth_add_method(eth_string_type->methods, eth_len_method, 122 | eth_proc(len_impl, 1)); 123 | 124 | for (int i = 0; i < 256; ++i) 125 | { 126 | char *s = eth_malloc(2); 127 | s[0] = i; 128 | s[1] = '\0'; 129 | g_chars[i] = eth_create_string_from_ptr2(s, 1); 130 | eth_ref(g_chars[i]); 131 | } 132 | } 133 | 134 | void 135 | _eth_cleanup_strings(void) 136 | { 137 | for (int i = 0; i < 256; ++i) 138 | eth_unref(g_chars[i]); 139 | eth_destroy_type(eth_string_type); 140 | } 141 | 142 | eth_t 143 | eth_create_string_from_ptr2(char *cstr, int len) 144 | { 145 | eth_string *str = eth_malloc(sizeof(eth_string)); 146 | eth_init_header(str, eth_string_type); 147 | str->len = len; 148 | str->cstr = cstr; 149 | return ETH(str); 150 | } 151 | 152 | eth_t 153 | eth_create_string_from_ptr(char *cstr) 154 | { 155 | return eth_create_string_from_ptr2(cstr, strlen(cstr)); 156 | } 157 | 158 | eth_t 159 | eth_create_string(const char *cstr) 160 | { 161 | int len = strlen(cstr); 162 | char *mystr = eth_malloc(len + 1); 163 | memcpy(mystr, cstr, len + 1); 164 | return eth_create_string_from_ptr2(mystr, len); 165 | } 166 | 167 | eth_t 168 | eth_create_string2(const char *str, int len) 169 | { 170 | char *mystr = eth_malloc(len + 1); 171 | memcpy(mystr, str, len); 172 | mystr[len] = 0; 173 | return eth_create_string_from_ptr2(mystr, len); 174 | } 175 | 176 | eth_t 177 | eth_create_string_from_char(char c) 178 | { 179 | return g_chars[(uint8_t)c]; 180 | } 181 | -------------------------------------------------------------------------------- /src/symbol.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "codeine/hash-map.h" 17 | #include "codeine/hash.h" 18 | #include "ether/ether.h" 19 | 20 | #include 21 | #include 22 | #include 23 | 24 | ETH_MODULE("ether:symbol") 25 | 26 | eth_type *eth_symbol_type; 27 | 28 | typedef struct { 29 | eth_header header; 30 | char *str; 31 | size_t len; 32 | eth_hash_t hash; 33 | } symbol; 34 | 35 | static cod_hash_map *g_symtab; 36 | 37 | eth_t eth_ordsyms[ETH_NORDSYMS]; 38 | 39 | static void 40 | destroy_symbol(void *ptr) 41 | { 42 | symbol *sym = ptr; 43 | /*assert(sym->header.rc == 1);*/ 44 | if (eth_unlikely(sym->header.rc != 1)) 45 | { 46 | eth_warning("RC for symbol '%s' /= 1", sym->str); 47 | } 48 | free(sym); 49 | } 50 | 51 | static void 52 | write_symbol(eth_type *type, eth_t x, FILE *stream) 53 | { 54 | symbol *sym = (void *)x; 55 | fprintf(stream, "`%s", sym->str); 56 | } 57 | 58 | static void 59 | _eth_make_ordered_symbols(void) 60 | { 61 | symbol *osyms[ETH_NORDSYMS]; 62 | 63 | for (int i = 0; i < ETH_NORDSYMS; ++i) 64 | osyms[i] = eth_malloc(sizeof(symbol)); 65 | int cmp(const void *p1, const void *p2) { return p1 - p2; } 66 | qsort(osyms, ETH_NORDSYMS, sizeof(symbol *), cmp); 67 | 68 | char buf[42]; 69 | for (int i = 0; i < ETH_NORDSYMS; ++i) 70 | { 71 | symbol *sym = osyms[i]; 72 | sprintf(buf, "_%d", i); 73 | 74 | eth_hash_t hash = 75 | cod_halfsiphash(eth_get_siphash_key(), (void *)buf, strlen(buf)); 76 | 77 | eth_init_header(sym, eth_symbol_type); 78 | sym->header.rc = 1; 79 | sym->hash = hash; 80 | sym->str = strdup(buf); 81 | sym->len = strlen(buf); 82 | cod_hash_map_insert_drain(g_symtab, sym->str, hash, sym, NULL); 83 | eth_ordsyms[i] = ETH(sym); 84 | } 85 | } 86 | 87 | __attribute__((constructor(103))) static void 88 | init_symbol_type() 89 | { 90 | g_symtab = cod_hash_map_new(0); 91 | 92 | eth_symbol_type = eth_create_type("symbol"); 93 | eth_symbol_type->write = write_symbol; 94 | 95 | _eth_make_ordered_symbols(); 96 | } 97 | 98 | void 99 | _eth_cleanup_symbol_type(void) 100 | { 101 | cod_hash_map_delete(g_symtab, destroy_symbol); 102 | eth_destroy_type(eth_symbol_type); 103 | } 104 | 105 | eth_t 106 | eth_create_symbol(const char *str) 107 | { 108 | size_t len = strlen(str); 109 | eth_hash_t hash = cod_halfsiphash(eth_get_siphash_key(), (void *)str, len); 110 | 111 | cod_hash_map_elt *elt; 112 | if ((elt = cod_hash_map_find(g_symtab, str, hash))) 113 | { 114 | symbol *sym = elt->val; 115 | return ETH(sym); 116 | } 117 | else 118 | { 119 | symbol *sym = eth_malloc(sizeof(symbol)); 120 | eth_init_header(sym, eth_symbol_type); 121 | sym->header.rc = 1; 122 | sym->hash = hash; 123 | sym->str = strdup(str); 124 | sym->len = len; 125 | int ok = cod_hash_map_insert_drain(g_symtab, sym->str, hash, sym, NULL); 126 | assert(ok); 127 | return ETH(sym); 128 | } 129 | } 130 | 131 | const char * 132 | eth_get_symbol_cstr(eth_t x) 133 | { 134 | symbol *sym = (void *)x; 135 | return sym->str; 136 | } 137 | 138 | eth_hash_t 139 | eth_get_symbol_hash(eth_t x) 140 | { 141 | symbol *sym = (void *)x; 142 | return sym->hash; 143 | } 144 | -------------------------------------------------------------------------------- /src/type.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 2020 Ivan Pidhurskyi 2 | * 3 | * This program is free software: you can redistribute it and/or modify 4 | * it under the terms of the GNU General Public License as published by 5 | * the Free Software Foundation, either version 3 of the License, or 6 | * (at your option) any later version. 7 | * 8 | * This program is distributed in the hope that it will be useful, 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | * GNU General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU General Public License 14 | * along with this program. If not, see . 15 | */ 16 | #include "ether/ether.h" 17 | 18 | #include 19 | #include 20 | #include 21 | #include 22 | 23 | ETH_MODULE("type") 24 | 25 | static void 26 | default_destroy(eth_type *type, eth_t x) 27 | { 28 | eth_warning("destructor for type '%s' not specified", type->name); 29 | } 30 | 31 | static void 32 | default_display(eth_type *type, eth_t x, FILE *stream) 33 | { 34 | type->write(type, x, stream); 35 | } 36 | 37 | static eth_t 38 | cast_error(eth_type* type, eth_t x) 39 | { 40 | eth_use_symbol(cast_error); 41 | return eth_exn(cast_error); 42 | } 43 | 44 | static eth_type* 45 | create_type(const char *name, const char *tag, int nfields) 46 | { 47 | eth_type *type = eth_malloc(sizeof(eth_type) + sizeof(size_t) * (nfields + 1)); 48 | type->name = strdup(name); 49 | type->tag = NULL; 50 | type->destroy = default_destroy; 51 | type->write = eth_default_write; 52 | type->display = default_display; 53 | type->equal = NULL; 54 | type->notify_copy = NULL; 55 | type->nfields = 0; 56 | type->fields = NULL; 57 | type->clos = NULL; 58 | type->dtor = NULL; 59 | type->flag = 0; 60 | type->methods = eth_create_methods(); 61 | return type; 62 | } 63 | 64 | eth_type* 65 | eth_create_tagged_type(const char *name, const char *tag) 66 | { 67 | return create_type(name, tag, 0); 68 | } 69 | 70 | eth_type* 71 | eth_create_tagged_struct_type(const char *name, const char *tag, 72 | const eth_field *fields, int n) 73 | { 74 | eth_type *type = create_type(name, tag, n); 75 | type->fields = eth_malloc(sizeof(eth_field) * n); 76 | type->nfields = n; 77 | for (int i = 0; i < n; ++i) 78 | { 79 | type->fields[i].name = strdup(fields[i].name); 80 | type->fields[i].offs = fields[i].offs; 81 | type->fieldids[i] = eth_get_symbol_id(eth_sym(fields[i].name)); 82 | } 83 | return type; 84 | } 85 | 86 | 87 | void 88 | eth_destroy_type(eth_type *type) 89 | { 90 | if (type->dtor) 91 | type->dtor(type->clos); 92 | 93 | if (type->fields) 94 | { 95 | for (int i = 0; i < type->nfields; ++i) 96 | free(type->fields[i].name); 97 | free(type->fields); 98 | } 99 | 100 | free(type->name); 101 | eth_destroy_methods(type->methods); 102 | free(type); 103 | } 104 | 105 | eth_field* __attribute__((pure)) 106 | eth_get_field(eth_type *type, const char *field) 107 | { 108 | for (int i = 0; i < type->nfields; ++i) 109 | { 110 | if (strcmp(field, type->fields[i].name) == 0) 111 | return type->fields + i; 112 | } 113 | return NULL; 114 | } 115 | 116 | size_t 117 | eth_get_field_id_by_offs(const eth_type *type, ptrdiff_t offs) 118 | { 119 | int n = type->nfields; 120 | for (int i = 0; i < n; ++i) 121 | { 122 | if (type->fields[i].offs == offs) 123 | return type->fieldids[i]; 124 | } 125 | abort(); 126 | } 127 | 128 | void 129 | eth_default_write(eth_type *type, eth_t x, FILE *out) 130 | { 131 | fprintf(out, "<%s %p>", type->name, x); 132 | } 133 | 134 | eth_t 135 | eth_cast_id(eth_type *type, eth_t x) 136 | { 137 | return x; 138 | } 139 | 140 | void 141 | eth_write(eth_t x, FILE *out) 142 | { 143 | eth_t m; 144 | if ((m = eth_find_method(x->type->methods, eth_write_method))) 145 | { 146 | eth_ref(x); 147 | eth_reserve_stack(2); 148 | eth_sp[0] = x; 149 | eth_disown_file(eth_sp[1] = eth_open_stream(out)); 150 | eth_drop(eth_apply(m, 2)); 151 | eth_dec(x); 152 | } 153 | else 154 | x->type->write(x->type, x, out); 155 | } 156 | 157 | void 158 | eth_display(eth_t x, FILE *out) 159 | { 160 | eth_t m; 161 | if ((m = eth_find_method(x->type->methods, eth_display_method))) 162 | { 163 | eth_ref(x); 164 | eth_reserve_stack(2); 165 | eth_sp[0] = x; 166 | eth_disown_file(eth_sp[1] = eth_open_stream(out)); 167 | eth_drop(eth_apply(m, 2)); 168 | eth_dec(x); 169 | } 170 | else if ((m = eth_find_method(x->type->methods, eth_write_method))) 171 | { 172 | eth_ref(x); 173 | eth_reserve_stack(2); 174 | eth_sp[0] = x; 175 | eth_disown_file(eth_sp[1] = eth_open_stream(out)); 176 | eth_drop(eth_apply(m, 2)); 177 | eth_dec(x); 178 | } 179 | else 180 | x->type->display(x->type, x, out); 181 | } 182 | 183 | bool 184 | eth_equal(eth_t x, eth_t y) 185 | { 186 | if (x == y) 187 | return true; 188 | else if (x->type != y->type) 189 | return false; 190 | else if (x->type->equal) 191 | return x->type->equal(x->type, x, y); 192 | else 193 | return false; 194 | } 195 | 196 | eth_t 197 | eth_list(eth_t x) 198 | { 199 | if (x == eth_nil || x->type == eth_pair_type) 200 | { 201 | return x; 202 | } 203 | else if (x->type == eth_string_type) 204 | { 205 | eth_t acc = eth_nil; 206 | const char *str = eth_str_cstr(x); 207 | for (int i = eth_str_len(x) - 1; i >= 0; --i) 208 | acc = eth_cons(eth_create_string_from_char(str[i]), acc); 209 | return acc; 210 | } 211 | else if (eth_is_tuple(x->type)) 212 | { 213 | int n = eth_struct_size(x->type); 214 | eth_t acc = eth_nil; 215 | for (int i = n - 1; i >= 0; --i) 216 | acc = eth_cons(eth_tup_get(x, i), acc); 217 | return acc; 218 | } 219 | else if (eth_is_record(x->type)) 220 | { 221 | int n = eth_struct_size(x->type); 222 | eth_t acc = eth_nil; 223 | for (int i = n - 1; i >= 0; --i) 224 | { 225 | eth_t key = eth_str(x->type->fields[i].name); 226 | eth_t val = eth_tup_get(x, i); 227 | acc = eth_cons(eth_tup2(key, val), acc); 228 | } 229 | return acc; 230 | } 231 | else if (x->type == eth_vector_type) 232 | { 233 | // TODO: optimize 234 | int n = eth_vec_len(x); 235 | eth_t acc = eth_nil; 236 | for (int i = n - 1; i >= 0; --i) 237 | acc = eth_cons(eth_vec_get(x, i), acc); 238 | return acc; 239 | } 240 | else if (x->type == eth_rbtree_type) 241 | { 242 | eth_t acc = eth_nil; 243 | bool iter(eth_t x, void*) { acc = eth_cons(x, acc); return true; } 244 | eth_rbtree_rev_foreach(x, iter, NULL); 245 | return acc; 246 | } 247 | else 248 | return NULL; 249 | } 250 | 251 | -------------------------------------------------------------------------------- /t/Seq.eth: -------------------------------------------------------------------------------- 1 | 2 | let rec pub range from to = 3 | if from < to then 4 | from :: (fn -> range (from + 1) to) 5 | else [] 6 | 7 | let rec pub map f s = 8 | if let x :: xs = s then 9 | f x :: (fn -> map f xs!) 10 | else [] 11 | 12 | let rec pub filter f s = 13 | if let x :: xs = s then 14 | if f x then x :: (fn -> filter f xs!) 15 | else filter f xs! 16 | else [] 17 | 18 | let rec pub fold_left f z s = 19 | if let x :: xs = s then 20 | fold_left f (f z x) xs! 21 | else z 22 | 23 | let rec pub of_list l = 24 | if let x :: xs = l then 25 | x :: (fn -> of_list xs) 26 | else [] 27 | 28 | let pub cons x s = x :: (fn -> s) 29 | 30 | let rec pub to_rev_list s = 31 | let rec loop s l = 32 | if let x :: xs = s then 33 | loop xs! (x :: l) 34 | else l 35 | loop s [] 36 | 37 | let pub to_list s = List.rev (to_rev_list s) 38 | 39 | nil 40 | -------------------------------------------------------------------------------- /t/bench.eth: -------------------------------------------------------------------------------- 1 | 2 | let rec fn revAppend xs acc = 3 | if let x::xs = xs then 4 | revAppend xs (x :: acc) 5 | else acc 6 | in 7 | 8 | let fn reverse xs = revAppend xs nil in 9 | 10 | let fn revMap f xs = 11 | let rec fn loop xs acc = 12 | if let x::xs = xs then 13 | loop xs (f x :: acc) 14 | else acc 15 | in loop xs nil 16 | in 17 | 18 | let fn map f xs = reverse $ revMap f xs in 19 | 20 | let fn revFilter f xs = 21 | let rec fn loop xs acc = 22 | if let x::xs = xs then 23 | loop xs (if f x then x :: acc else acc) 24 | else acc 25 | in loop xs nil 26 | in 27 | 28 | let fn filter f xs = reverse $ revFilter f xs in 29 | 30 | let rec fn foldLeft f z xs = 31 | if let x :: xs = xs then 32 | foldLeft f (f z x) xs 33 | else z 34 | in 35 | 36 | let fn range from to = 37 | let rec fn loop i acc = 38 | if i < from then acc 39 | else loop (i - 1) (i :: acc) 40 | in loop (to - 1) nil 41 | in 42 | 43 | let fn even x = x mod 2 == 0 in 44 | let fn odd x = x mod 2 != 0 in 45 | 46 | let rec fn doTimes n thunk = 47 | if n == 0 then nil 48 | else (thunk nil; doTimes (n - 1) thunk) 49 | in 50 | 51 | 52 | let n = 1_00_000 in 53 | 54 | let job_user_nobrain = 55 | fn _ -> 56 | range 0 n | map (fn x -> x + 1) | filter even? | foldLeft (+) 0 57 | in 58 | 59 | let job_user_smart = 60 | fn _ -> 61 | range 0 n | revMap (fn x -> x + 1) | revFilter even? | foldLeft (+) 0 62 | in 63 | 64 | let job_native = 65 | let {*} = import 'list' in 66 | fn _ -> 67 | range 0 n --(0..n) 68 | | rev_filter_map (fn x -> if odd? x then some (x + 1)) 69 | | fold_left (+) 0 70 | in 71 | 72 | 73 | --let job = job_user_nobrain in 74 | let job = job_user_smart in 75 | --let job = job_native in 76 | 77 | print $ job nil; 78 | doTimes 10 job 79 | 80 | -------------------------------------------------------------------------------- /t/cmdarg.eth: -------------------------------------------------------------------------------- 1 | let {*} = import 'list' in 2 | let cmdarg = import 'cmdarg' in 3 | 4 | let options = 5 | [ 6 | {name = "long-arg", value = "long-arg", has_arg = true}, 7 | {name = "long-no-arg", value = "long-no-arg", has_arg = false}, 8 | {name = "a", value = "short-arg", has_arg = true}, 9 | {name = "f", value = "short-no-arg", has_arg = false}, 10 | {name = ["help", "h"], value = "h", has_arg = false}, 11 | ] 12 | in 13 | 14 | let tests = 15 | [ 16 | ( 17 | let cmd = ["first", "--long-arg", "arg", "second", "--long-no-arg", "-a", "1", "-f", "third"] in 18 | let (kw, pos) = cmdarg.get options cmd in 19 | ("test-1", fn -> all? id [ 20 | pos eq ["first", "second", "third"], 21 | assoc "long-arg" kw eq "arg", 22 | assoc "long-no-arg" kw eq true, 23 | assoc "short-arg" kw eq "1", 24 | assoc "short-no-arg" kw eq true, 25 | ]) 26 | ), 27 | ( 28 | let cmd = ["first","--long-arg=arg","second","--long-no-arg","-a1","-f","third"] in 29 | let (kw, pos) = cmdarg.get options cmd in 30 | ("test-2", fn -> all? id [ 31 | pos eq ["first", "second", "third"], 32 | assoc "long-arg" kw eq "arg", 33 | assoc "long-no-arg" kw eq true, 34 | assoc "short-arg" kw eq "1", 35 | assoc "short-no-arg" kw eq true 36 | ]) 37 | ), 38 | 39 | ( 40 | let cmd = ["--long-arg="] in 41 | let (kw, pos) = cmdarg.get options cmd in 42 | ("test-3", fn -> assoc "long-arg" kw eq "") 43 | ), 44 | 45 | ( 46 | let cmd = ["--long-arg"] in 47 | ("test-4", fn -> 48 | try (cmdarg.get options cmd; false) 49 | except e -> e eq `missing_argument 50 | ) 51 | ), 52 | 53 | ( 54 | let cmd = ["-a"] in 55 | ("test-5", fn -> 56 | try (cmdarg.get options cmd; false) 57 | except e -> e eq `missing_argument 58 | ) 59 | ), 60 | 61 | ( 62 | let cmd = ["--long-no-arg=x"] in 63 | ("test-6", fn -> 64 | try (cmdarg.get options cmd; false) 65 | except e -> e eq `unexpected_argument 66 | ) 67 | ), 68 | 69 | ( 70 | let cmd = ["-fx"] in 71 | ("test-7", fn -> 72 | try (cmdarg.get options cmd; false) 73 | except e -> e eq `unexpected_argument 74 | ) 75 | ), 76 | 77 | ( 78 | let cmd = ["-o"] in 79 | ("test-8", fn -> 80 | try (cmdarg.get options cmd; false) 81 | except e -> e eq `undefined_option 82 | ) 83 | ), 84 | 85 | ("test-9", fn -> 86 | let cmd1 = ["-h"] in 87 | let kw1 = first $ cmdarg.get options cmd1 in 88 | let cmd2 = ["--help"] in 89 | let kw2 = first $ cmdarg.get options cmd2 in 90 | assoc "h" kw1 eq true && assoc "h" kw2 eq true 91 | ), 92 | ] 93 | in 94 | 95 | let (nok, nfail) = (import 'test').run [(nil, tests)] in 96 | if nfail > 0 then 97 | exit 1 98 | 99 | -------------------------------------------------------------------------------- /t/foo/foo.eth: -------------------------------------------------------------------------------- 1 | 2 | let pub foo() { 3 | print("foo!") 4 | } 5 | 6 | -------------------------------------------------------------------------------- /t/foo/install.eth: -------------------------------------------------------------------------------- 1 | 2 | let pub name = "Foo" 3 | let pub main = "foo.eth" 4 | 5 | let pub build() { 6 | print("BUILDING FOO") 7 | } 8 | 9 | let pub post_install() { 10 | print("CLEANUP FOO") 11 | } 12 | 13 | 14 | -------------------------------------------------------------------------------- /t/iter.eth: -------------------------------------------------------------------------------- 1 | import 'list' 2 | 3 | let pub map f {state, next} = 4 | { state 5 | , next = fn i -> when let (x, i) = next i then (f x, i) 6 | } 7 | 8 | let pub take n {state, next} = 9 | { state = (state, n) 10 | , next = fn arg -> 11 | let (i, n) = arg 12 | when n > 0 then 13 | try 14 | let (x, i) = next i 15 | (x, (i, n - 1)) 16 | with Match_error -> raise `range_error 17 | } 18 | 19 | let pub filter f {state, next} = 20 | let rec next' i = 21 | when let (x, i) = next i then 22 | if f x then (x, i) 23 | else next' i 24 | {state, next = next'} 25 | 26 | let pub of_list xs = 27 | { state = xs 28 | , next = fn xs -> when let x::xs = xs then (x, xs) 29 | } 30 | 31 | let pub to_list {state, next} = 32 | let rec loop i acc = 33 | if let (x, i) = next i then 34 | loop i (x::acc) 35 | else list.rev acc 36 | loop state nil 37 | 38 | let pub range from to = 39 | { state = from 40 | , next = fn i -> when i < to then (i, i + 1) 41 | } 42 | 43 | let pub fold_left f z {state, next} = 44 | let rec loop i acc = 45 | if let (x, i) = next i then 46 | loop i (f acc x) 47 | else acc 48 | loop state z 49 | 50 | 51 | when defined __main then 52 | let n = 10_000_000 53 | let job! = range 0 n | map (x -> x + 1) | filter even? | fold_left (+) 0 54 | print job! 55 | job! 56 | 57 | -------------------------------------------------------------------------------- /t/mergesort.eth: -------------------------------------------------------------------------------- 1 | 2 | let split = 3 | let rec loop slow fast acc = 4 | if let _::_::fast = fast then 5 | let x::slow = slow in 6 | loop slow fast (x::acc) 7 | else (acc, slow) 8 | in fn xs -> loop xs xs nil 9 | in 10 | 11 | -- Merge two sorted lists preserving order. 12 | let merge = 13 | let rec loop xs ys acc = 14 | if let x::xs' = xs then 15 | if let y::ys' = ys then 16 | -- Take the smallest of x and y 17 | if x < y 18 | then loop xs' ys (x::acc) 19 | else loop xs ys' (y::acc) 20 | else 21 | -- No more ys left, append all remaining xs to the result 22 | List.rev_append acc xs 23 | else 24 | -- No more xs left, append all remaining ys to the result 25 | List.rev_append acc ys 26 | in fn xs ys -> loop xs ys nil 27 | in 28 | 29 | -- Sort a list of numbers in increasing order. 30 | let rec sort xs = 31 | if let _::_::_ = xs then 32 | -- Split xs by halves 33 | let (l, r) = split xs in 34 | -- Sort each of the halves and merge them back 35 | merge (sort l) (sort r) 36 | else xs 37 | in 38 | 39 | 40 | let read_list file = 41 | let read_line_opt file = 42 | try Some (read_line_of file) 43 | with End_of_file -> false 44 | in 45 | let rec loop acc = 46 | if let Some x = read_line_opt file then 47 | loop (String.(to_number $ chomp x) :: acc) 48 | else acc 49 | in loop nil 50 | in 51 | 52 | let l = List.rev $ read_list $ open_in "t/list.txt" in 53 | print ("Given list:", List.take 10 l); 54 | [1..10] |> List.iter (fn _ -> 55 | print ("Sorted list:", List.take 10 $ sort l) 56 | ); 57 | 58 | -------------------------------------------------------------------------------- /t/mergesort.py: -------------------------------------------------------------------------------- 1 | 2 | def merge(left, right): 3 | result = [] 4 | left_count = 0 5 | right_count = 0 6 | try: 7 | # while len(left) > left_count and len(right) > right_count: 8 | while True: 9 | if left[left_count] > right[right_count]: 10 | result.append(right[right_count]) 11 | right_count += 1 12 | else: 13 | result.append(left[left_count]) 14 | left_count += 1 15 | except IndexError: 16 | return result + left[left_count:] + right[right_count:] 17 | 18 | result += left[left_count:] 19 | result += right[right_count:] 20 | return result 21 | 22 | def merge_sort(seq): 23 | if len(seq) == 1: 24 | return seq 25 | m = len(seq) // 2 26 | left = merge_sort(seq[:m]) 27 | right = merge_sort(seq[m:]) 28 | return merge(left, right) 29 | 30 | 31 | # Driver code to test above 32 | arr = [int(line) for line in open("t/list.txt")] 33 | print ("Given array is", arr[0:10], "...") 34 | for _ in range(10): 35 | print ("Sorted array is", merge_sort(arr)[0:10], "...") 36 | 37 | -------------------------------------------------------------------------------- /t/test-dope.eth: -------------------------------------------------------------------------------- 1 | 2 | open 'os' in 3 | 4 | let [_ dope testDir] = command_line 5 | let dope = realpath(dope) 6 | let testDir = realpath(testDir) 7 | chdir(testDir) 8 | 9 | system("echo ether: `which ether`") 10 | print("dope: {dope}") 11 | system("echo pwd: $PWD") 12 | let fail() { 13 | system("ether {dope} uninstall foo &>/dev/null") 14 | system("rm -rf foo/.git &>/dev/null") 15 | exit(1) 16 | } 17 | 18 | system("cd foo && git init && git add . && git commit -m 'Test' && git tag '2.2.8'") 19 | 20 | system("{dope} install ./foo") == 0 || fail() 21 | system("{dope} uninstall foo") == 0 || fail() 22 | system("{dope} install ./foo") == 0 || fail() 23 | system("{dope} uninstall foo") == 0 || fail() 24 | 25 | system("rm -rf foo/.git &>/dev/null") 26 | -------------------------------------------------------------------------------- /t/test.eth: -------------------------------------------------------------------------------- 1 | 2 | let {*} = import 'list' in 3 | let {*} = import 'io' in 4 | 5 | let test_sample = 6 | let fn do_test name thunk = 7 | printf "- %d " name; 8 | try 9 | if thunk () then 10 | printf "\x1b[38;5;2;1m✓\x1b[0m\n"; 11 | return true 12 | else 13 | printf "\x1b[38;5;1;1m✗\x1b[0m\n"; 14 | return false 15 | except e -> 16 | printf "\x1b[38;5;1;1m✗ (%w)\x1b[0m\n" e; 17 | return false 18 | in 19 | 20 | fold_left (fn (nok, nfail) (name, thunk) -> 21 | if do_test name thunk 22 | then (nok+1, nfail) 23 | else (nok, nfail+1) 24 | ) (0, 0) 25 | in 26 | 27 | let fn sumres (nok, nfail) (nok', nfail') = 28 | (nok + nok', nfail + nfail') 29 | in 30 | 31 | let pub fn run samples = 32 | let fn do_sample res (title, tlist) = 33 | print ""; 34 | do if title is not nil then 35 | printf "\x1b[1mTest %d\x1b[0m\n" title 36 | done 37 | sumres res (test_sample tlist) 38 | in 39 | 40 | let (nok, nfail) as res = fold_left do_sample (0, 0) samples in 41 | print ""; 42 | printf "\x1b[1mSummary\x1b[0m\n"; 43 | printf "- succeed: \x1b[38;5;2;1m%d\x1b[0m\n" nok; 44 | printf "- failed: \x1b[38;5;1;1m%d\x1b[0m\n" nfail; 45 | res 46 | in 47 | 48 | nil 49 | 50 | -------------------------------------------------------------------------------- /t/test.py: -------------------------------------------------------------------------------- 1 | def foldl(f, acc, l): 2 | for x in l: 3 | acc = f(acc, x) 4 | return acc 5 | 6 | def myfilter(f, l): 7 | # return [x for x in l if f(x)] 8 | ret = [] 9 | for x in l: 10 | if f(x): ret.append(x) 11 | return ret 12 | 13 | def myrange(f, t): 14 | # return range(f, t) 15 | ret = [] 16 | while f < t: 17 | ret.append(f) 18 | f += 1 19 | return ret 20 | 21 | def mymap(f, l): 22 | # return [f(x) for x in l] 23 | ret = [] 24 | for x in l: 25 | ret.append(f(x)) 26 | return ret 27 | 28 | def add(x, y): return x + y 29 | def iseven(x): return x % 2 == 0 30 | def isodd(x): return x % 2 != 0 31 | 32 | 33 | n = 10000000 34 | 35 | def job_user(): 36 | return foldl(add, 0, myfilter(iseven, mymap(lambda x: x + 1, myrange(0, n)))) 37 | 38 | def job_native(): 39 | return foldl(add, 0, [x + 1 for x in range(0, n) if isodd(x)]) 40 | 41 | # job = job_user 42 | job = job_native 43 | 44 | print(job()) 45 | for _ in range(1): 46 | job() 47 | 48 | --------------------------------------------------------------------------------