├── .astylerc ├── .github └── workflows │ └── ccpp.yml ├── .gitmodules ├── .ycm_extra_conf.py ├── LICENSE ├── Makefile ├── README.md ├── doc ├── 0040-array.md └── screenshot.png ├── examples └── fac.stt ├── include ├── apply.h ├── array.h ├── ast.h ├── core.h ├── djb2.h ├── env.h ├── eval.h ├── exc.h ├── ir.h ├── lexer.h ├── list.h ├── log.h ├── map.h ├── parser.h ├── primes.h ├── reader.h ├── reader_stack.h └── value.h ├── src ├── apply.c ├── array.c ├── ast.c ├── core.c ├── core.stt ├── djb2.c ├── env.c ├── eval.c ├── exc.c ├── ir.c ├── lexer.c ├── list.c ├── log.c ├── main.c ├── map.c ├── parser.c ├── primes.c ├── reader.c ├── reader_stack.c └── value.c └── test ├── Makefile ├── data ├── lexer_reference.txt └── lexer_test.str ├── lang ├── core.stt └── more.stt ├── minunit.h ├── test_array.c ├── test_ast.c ├── test_djb2.c ├── test_env.c ├── test_ir.c ├── test_lexer.c ├── test_list.c ├── test_map.c ├── test_parser.c └── test_primes.c /.astylerc: -------------------------------------------------------------------------------- 1 | --style=kr 2 | --pad-oper 3 | --preserve-date 4 | --max-code-length=100 5 | --align-pointer=name 6 | -------------------------------------------------------------------------------- /.github/workflows/ccpp.yml: -------------------------------------------------------------------------------- 1 | name: C/C++ CI 2 | 3 | on: [push] 4 | 5 | jobs: 6 | build: 7 | name: ${{ matrix.os }} | ${{ matrix.compiler }} 8 | runs-on: ${{ matrix.os }} 9 | strategy: 10 | matrix: 11 | os: [macos-latest] 12 | compiler: [clang] 13 | steps: 14 | - uses: actions/checkout@v1 15 | - name: Checkout submodules using a PAT 16 | run: | 17 | git config --file .gitmodules --get-regexp url | while read url; do 18 | git config --file=.gitmodules $(echo "$url" | sed -E "s/git@github.com:|https:\/\/github.com\//https:\/\/${{ secrets.CI_PAT }}:${{ secrets.CI_PAT }}@github.com\//") 19 | done 20 | git submodule sync 21 | git submodule update --init --recursive 22 | - name: make (${{ matrix.compiler }}) 23 | run: make CC=${{ matrix.compiler }} 24 | - name: make test (${{ matrix.compiler }}) 25 | run: make test CC=${{ matrix.compiler }} 26 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "lib/gc"] 2 | path = lib/gc 3 | url = git@github.com:mkirchner/gc.git 4 | branch = master 5 | -------------------------------------------------------------------------------- /.ycm_extra_conf.py: -------------------------------------------------------------------------------- 1 | # This file is NOT licensed under the GPLv3, which is the license for the rest 2 | # of YouCompleteMe. 3 | # 4 | # Here's the license text for this file: 5 | # 6 | # This is free and unencumbered software released into the public domain. 7 | # 8 | # Anyone is free to copy, modify, publish, use, compile, sell, or 9 | # distribute this software, either in source code form or as a compiled 10 | # binary, for any purpose, commercial or non-commercial, and by any 11 | # means. 12 | # 13 | # In jurisdictions that recognize copyright laws, the author or authors 14 | # of this software dedicate any and all copyright interest in the 15 | # software to the public domain. We make this dedication for the benefit 16 | # of the public at large and to the detriment of our heirs and 17 | # successors. We intend this dedication to be an overt act of 18 | # relinquishment in perpetuity of all present and future rights to this 19 | # software under copyright law. 20 | # 21 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 22 | # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 23 | # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 24 | # IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 25 | # OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 26 | # ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 27 | # OTHER DEALINGS IN THE SOFTWARE. 28 | # 29 | # For more information, please refer to 30 | 31 | from distutils.sysconfig import get_python_inc 32 | import platform 33 | import os 34 | import subprocess 35 | import ycm_core 36 | 37 | DIR_OF_THIS_SCRIPT = os.path.abspath( os.path.dirname( __file__ ) ) 38 | DIR_OF_THIRD_PARTY = os.path.join( DIR_OF_THIS_SCRIPT, 'lib' ) 39 | SOURCE_EXTENSIONS = [ '.c' ] 40 | 41 | # These are the compilation flags that will be used in case there's no 42 | # compilation database set (by default, one is not set). 43 | # CHANGE THIS LIST OF FLAGS. YES, THIS IS THE DROID YOU HAVE BEEN LOOKING FOR. 44 | flags = [ 45 | '-Wall', 46 | '-Wextra', 47 | '-Werror', 48 | '-pedantic', 49 | '-std=c99', 50 | '-xc', 51 | '-Iinclude', 52 | '-I/usr/lib/', 53 | '-I/usr/include/' 54 | ] 55 | 56 | # Set this to the absolute path to the folder (NOT the file!) containing the 57 | # compile_commands.json file to use that instead of 'flags'. See here for 58 | # more details: http://clang.llvm.org/docs/JSONCompilationDatabase.html 59 | # 60 | # You can get CMake to generate this file for you by adding: 61 | # set( CMAKE_EXPORT_COMPILE_COMMANDS 1 ) 62 | # to your CMakeLists.txt file. 63 | # 64 | # Most projects will NOT need to set this to anything; you can just change the 65 | # 'flags' list of compilation flags. Notice that YCM itself uses that approach. 66 | compilation_database_folder = '' 67 | 68 | if os.path.exists( compilation_database_folder ): 69 | database = ycm_core.CompilationDatabase( compilation_database_folder ) 70 | else: 71 | database = None 72 | 73 | 74 | def IsHeaderFile( filename ): 75 | extension = os.path.splitext( filename )[ 1 ] 76 | return extension in [ '.h' ] 77 | 78 | 79 | def FindCorrespondingSourceFile( filename ): 80 | if IsHeaderFile( filename ): 81 | basename = os.path.splitext( filename )[ 0 ] 82 | for extension in SOURCE_EXTENSIONS: 83 | replacement_file = basename + extension 84 | if os.path.exists( replacement_file ): 85 | return replacement_file 86 | return filename 87 | 88 | 89 | def Settings( **kwargs ): 90 | if kwargs[ 'language' ] == 'cfamily': 91 | # If the file is a header, try to find the corresponding source file and 92 | # retrieve its flags from the compilation database if using one. This is 93 | # necessary since compilation databases don't have entries for header files. 94 | # In addition, use this source file as the translation unit. This makes it 95 | # possible to jump from a declaration in the header file to its definition 96 | # in the corresponding source file. 97 | filename = FindCorrespondingSourceFile( kwargs[ 'filename' ] ) 98 | 99 | if not database: 100 | return { 101 | 'flags': flags, 102 | 'include_paths_relative_to_dir': DIR_OF_THIS_SCRIPT, 103 | 'override_filename': filename 104 | } 105 | 106 | compilation_info = database.GetCompilationInfoForFile( filename ) 107 | if not compilation_info.compiler_flags_: 108 | return {} 109 | 110 | # Bear in mind that compilation_info.compiler_flags_ does NOT return a 111 | # python list, but a "list-like" StringVec object. 112 | final_flags = list( compilation_info.compiler_flags_ ) 113 | 114 | return { 115 | 'flags': final_flags, 116 | 'include_paths_relative_to_dir': compilation_info.compiler_working_dir_, 117 | 'override_filename': filename 118 | } 119 | return {} 120 | 121 | 122 | def GetStandardLibraryIndexInSysPath( sys_path ): 123 | for path in sys_path: 124 | if os.path.isfile( os.path.join( path, 'os.py' ) ): 125 | return sys_path.index( path ) 126 | raise RuntimeError( 'Could not find standard library path in Python path.' ) 127 | 128 | 129 | def PythonSysPath( **kwargs ): 130 | sys_path = kwargs[ 'sys_path' ] 131 | for folder in os.listdir( DIR_OF_THIRD_PARTY ): 132 | if folder == 'python-future': 133 | folder = os.path.join( folder, 'src' ) 134 | sys_path.insert( GetStandardLibraryIndexInSysPath( sys_path ) + 1, 135 | os.path.realpath( os.path.join( DIR_OF_THIRD_PARTY, 136 | folder ) ) ) 137 | continue 138 | 139 | if folder == 'cregex': 140 | interpreter_path = kwargs[ 'interpreter_path' ] 141 | major_version = subprocess.check_output( [ 142 | interpreter_path, '-c', 'import sys; print( sys.version_info[ 0 ] )' ] 143 | ).rstrip().decode( 'utf8' ) 144 | folder = os.path.join( folder, 'regex_{}'.format( major_version ) ) 145 | 146 | sys_path.insert( 0, os.path.realpath( os.path.join( DIR_OF_THIRD_PARTY, 147 | folder ) ) ) 148 | return sys_path 149 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 Marc Kirchner 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 7 | of the Software, and to permit persons to whom the Software is furnished to do 8 | so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # stutter Makefile 3 | # 4 | GIT_VERSION := "$(shell git describe --abbrev=8 --dirty --always --tags)" 5 | 6 | CC=clang 7 | CFLAGS=-g -Wall -Wextra -pedantic -Iinclude -Ilib/gc/src -D__STUTTER_VERSION__=\"$(GIT_VERSION)\" -fprofile-arcs -ftest-coverage -Wno-gnu-zero-variadic-macro-arguments -Wno-gnu-case-range 8 | LDFLAGS=-g -Lbuild/src -Lbuild/lib/gc/src --coverage 9 | LDLIBS=-ledit 10 | RM=rm 11 | BUILD_DIR=./build 12 | 13 | STUTTER_BINARY=stutter 14 | STUTTER_SRCS=$(wildcard src/*.c) lib/gc/src/gc.c 15 | STUTTER_OBJS=$(STUTTER_SRCS:%.c=$(BUILD_DIR)/%.o) 16 | 17 | .PHONY: stutter 18 | stutter: $(BUILD_DIR)/$(STUTTER_BINARY) 19 | 20 | $(BUILD_DIR)/$(STUTTER_BINARY): $(STUTTER_OBJS) 21 | mkdir -p $(@D) 22 | $(CC) $(LDFLAGS) $(LDLIBS) $^ -o $@ 23 | 24 | $(BUILD_DIR)/src/%.o: src/%.c 25 | mkdir -p $(@D) 26 | $(CC) $(CFLAGS) -c $< -o $@ 27 | 28 | $(BUILD_DIR)/lib/gc/src/%.o: lib/gc/src/%.c 29 | mkdir -p $(@D) 30 | $(CC) $(CFLAGS) -c $< -o $@ 31 | 32 | .PHONY: test 33 | test: 34 | $(MAKE) -C $@ 35 | 36 | .PHONY: clean 37 | clean: 38 | $(RM) -f $(STUTTER_OBJS) 39 | $(RM) -f $(BUILD_DIR)/src/*gcd* 40 | $(RM) -f $(BUILD_DIR)/lib/gc/src/*gcd* 41 | $(RM) -f $(BUILD_DIR)/test/*gcd* 42 | $(MAKE) -C test clean 43 | 44 | distclean: clean 45 | $(RM) -f $(BUILD_DIR)/$(STUTTER_BINARY) 46 | $(MAKE) -C test distclean 47 | 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Build Status](https://github.com/mkirchner/stutter/workflows/C/C++%20CI/badge.svg) 2 | 3 | Stutter - Lisp, from scratch, in C 4 | ================================== 5 | 6 | ![screenshot](doc/screenshot.png) 7 | 8 | `stutter` is an educational Lisp interpreter implementation in C, written 9 | entirely from scratch, not using any libraries (with the notable exception of 10 | `editline` to maintain my sanity). 11 | 12 | In other words, `stutter` is a practical exercise in a broad set of CS topics 13 | including 14 | 15 | * formal languages (lexing, parsing, abstract syntax trees) 16 | * metalinguistic evaluation (eval/apply, macros) 17 | * data structures (lists, trees, maps, arrays) 18 | * automatic memory management (mark & sweep garbage collection) 19 | 20 | All of it is implemented in one of the most bare-bones, down-to-earth 21 | (and unforgiving) languages out there: C99. 22 | 23 | `stutter` is a work in progress (and will be, for the forseeable future). See 24 | [the tests](test/lang/) to get an idea of what the language is already capable 25 | of. 26 | 27 | 28 | The Rules 29 | --------- 30 | 31 | Obviously, in modern our modern times, writing a Lisp interpreter is not 32 | as challenging as it used to be since there are a lot of libraries that can 33 | help us to achieve that goal. Hence, two rules: 34 | 35 | 1. Write everything from scratch. 36 | 2. Do not question the rules. 37 | 38 | 39 | Getting started 40 | --------------- 41 | 42 | Clone the repo and its submodules (submodules because the garbarge collector is in a [separate repo](https://github.com/mkirchner/gc)). 43 | 44 | ```bash 45 | $ git clone --recursive git@github.com:mkirchner/stutter.git 46 | $ cd stutter 47 | $ make && make test 48 | ``` 49 | 50 | This should work on a Mac with a recent `clang`. No efforts to make it portable 51 | (yet). 52 | 53 | 54 | ### Next steps 55 | 56 | - [ ] Add a VM and support to compile to bytecode 57 | - [ ] Document core language 58 | - [ ] Better error reporting 59 | - [ ] Surface lexer token line/col info in the reader 60 | - [ ] Core capabilities 61 | - [ ] `keyword` support 62 | - [ ] `vector` support (`Array` C type is implemented but not surfaced) 63 | - [ ] `hash-map` support (`Map` C type is available but not surfaced) 64 | - [ ] Add a type system 65 | -------------------------------------------------------------------------------- /doc/0040-array.md: -------------------------------------------------------------------------------- 1 | The Array 2 | ========= 3 | 4 | * heap-based array 5 | * uses `char*` as base type (since C guarantees `sizeof(char)` == 1) 6 | * one (!) `char*` pointer to contiguous memory 7 | * implements front- and back operations, front-aligned, hence back-operations 8 | are fast, front operations require shifting the memory around 9 | * concepts 10 | * difference between size & capacity 11 | * using `memcopy()` and `memmove()` (the latter for overlapping mem regions) 12 | * using `realloc()` for resizing 13 | * [dlmalloc implementation notes][lea_00] 14 | * refer to how a memory allocator work [0][soshnikov_19], [1][jones_12] 15 | * also the `brk`, `sbrk`, `mmap` calls 16 | * nifty things 17 | * using a macro to enable multiple return values in all `array_typed_*` 18 | functions 19 | * finding the next largest power of two: from [bit twiddling 20 | hacks][bit_twiddling]. 21 | 22 | 23 | [bit_twiddling]: http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2 24 | [soshnikov_19]: http://dmitrysoshnikov.com/compilers/writing-a-memory-allocator/ 25 | [jones_12]: http://gchandbook.org 26 | [lea_00]: http://gee.cs.oswego.edu/dl/html/malloc.html 27 | -------------------------------------------------------------------------------- /doc/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mkirchner/stutter/43a612af68b33baa9bba688759d961cf5dff7f36/doc/screenshot.png -------------------------------------------------------------------------------- /examples/fac.stt: -------------------------------------------------------------------------------- 1 | (define fac-rec 2 | (lambda (n acc) 3 | (if (<= n 1) 4 | acc 5 | (fac-rec (- n 1) (* acc n))))) 6 | 7 | (define fac 8 | (lambda (n) 9 | (fac-rec n 1))) 10 | 11 | 12 | (fac 5) 13 | -------------------------------------------------------------------------------- /include/apply.h: -------------------------------------------------------------------------------- 1 | #ifndef __APPLY_H__ 2 | #define __APPLY_H__ 3 | 4 | #include 5 | #include 6 | 7 | Value *apply(Value *fn, Value *args, Value **tco_expr, Environment **tco_env); 8 | 9 | #endif /* !APPLY_H */ 10 | -------------------------------------------------------------------------------- /include/array.h: -------------------------------------------------------------------------------- 1 | #ifndef __ARRAY_H__ 2 | #define __ARRAY_H__ 3 | 4 | #include 5 | 6 | /* 7 | * Contiguous, indexable chunk of memory. 8 | */ 9 | typedef struct array { 10 | char *p; 11 | size_t size; 12 | size_t capacity; 13 | size_t bytes; 14 | } Array; 15 | 16 | 17 | Array *array_new(const size_t item_size); 18 | Array *array_new_with_capacity(const size_t isize, const size_t capacity); 19 | void array_delete(Array *a); 20 | 21 | #define array_size(a) (a->size) 22 | #define array_capacity(a) (a->capacity) 23 | 24 | void *array_at(Array *a, size_t i); 25 | #define array_typed_at(a,i,t) ((t*) array_at(a, i)) 26 | void array_push_back(Array *a, const void *value, size_t n); 27 | void array_push_front(Array *a, const void *value, size_t n); 28 | void *array_pop_back(Array *a); 29 | #define array_typed_pop_back(a,t) ((t*) array_pop_back(a)) 30 | void *array_pop_front(Array *a); 31 | #define array_typed_pop_front(a,t) ((t*) array_pop_front(a)) 32 | void array_shrink(Array *a); 33 | 34 | #endif /* !__ARRAY_H__ */ 35 | -------------------------------------------------------------------------------- /include/ast.h: -------------------------------------------------------------------------------- 1 | #ifndef __AST_H__ 2 | #define __AST_H__ 3 | 4 | #include 5 | 6 | /* 7 | * stutter grammar 8 | * 9 | * program ::= sexpr EOF 10 | * sexpr ::= atom | LPAREN list RPAREN | QUOTE sexpr 11 | * list ::= sexpr list | ∅ 12 | * atom ::= STRING | SYMBOL | INT | FLOAT 13 | * 14 | */ 15 | 16 | struct AstAtom; 17 | struct AstList; 18 | 19 | typedef enum { 20 | AST_SEXPR_LIST, 21 | AST_SEXPR_ATOM, 22 | AST_SEXPR_QUOTE, 23 | AST_SEXPR_QUASIQUOTE, 24 | AST_SEXPR_UNQUOTE, 25 | AST_SEXPR_SPLICE_UNQUOTE, 26 | AST_LIST_COMPOUND, 27 | AST_LIST_EMPTY, 28 | AST_ATOM_SYMBOL, 29 | AST_ATOM_INT, 30 | AST_ATOM_FLOAT, 31 | AST_ATOM_STRING 32 | } AstNodeType; 33 | 34 | typedef struct { 35 | AstNodeType type; 36 | // Location loc; // FIXME 37 | } AstNode; 38 | 39 | typedef struct AstSexpr { 40 | AstNode node; 41 | union { 42 | struct AstList *list; 43 | struct AstAtom *atom; 44 | struct AstSexpr *quoted; 45 | } as; 46 | } AstSexpr; 47 | 48 | typedef struct AstList { 49 | AstNode node; 50 | union { 51 | struct { 52 | struct AstSexpr *sexpr; 53 | struct AstList *list; 54 | } compound; 55 | } as; 56 | } AstList; 57 | 58 | typedef struct AstAtom { 59 | AstNode node; 60 | union { 61 | char *symbol; 62 | int integer; 63 | double decimal; 64 | char *string; 65 | } as; 66 | } AstAtom; 67 | 68 | AstNode *ast_new_node(size_t size, AstNodeType node_type); 69 | #define AST_NEW_NODE(ptr_type, node_type) (ptr_type*)ast_new_node(sizeof(type)) 70 | 71 | AstSexpr *ast_new_sexpr(); 72 | AstSexpr *ast_sexpr_from_list(AstList *list); 73 | AstSexpr *ast_sexpr_from_atom(AstAtom *atom); 74 | AstSexpr *ast_sexpr_from_quote(AstSexpr *quoted); 75 | AstSexpr *ast_sexpr_from_quasiquote(AstSexpr *quoted); 76 | AstList *ast_new_list(); 77 | AstList *ast_list_from_compound_list(AstSexpr *s, AstList *l); 78 | AstList *ast_list_empty(); 79 | AstAtom *ast_new_atom(); 80 | AstAtom *ast_atom_from_symbol(char *symbol); 81 | AstAtom *ast_atom_from_string(char *string); 82 | AstAtom *ast_atom_from_int(int number); 83 | AstAtom *ast_atom_from_float(double number); 84 | 85 | void ast_delete_sexpr(AstSexpr *s); 86 | void ast_delete_list(AstList *l); 87 | void ast_delete_atom(AstAtom *a); 88 | 89 | void ast_print(AstNode *ast); 90 | void ast_print_atom(AstAtom *ast, int indent); 91 | void ast_print_list(AstList *ast, int indent); 92 | void ast_print_sexpr(AstSexpr *ast, int indent); 93 | 94 | #endif /* !__AST_H__ */ 95 | -------------------------------------------------------------------------------- /include/core.h: -------------------------------------------------------------------------------- 1 | #ifndef __CORE_H__ 2 | #define __CORE_H__ 3 | 4 | #include "value.h" 5 | #include "env.h" 6 | 7 | typedef struct { 8 | char *name; 9 | Value *(*fn)(const Value *args); 10 | } CoreFn; 11 | 12 | extern CoreFn core_fns[]; 13 | 14 | Value *core_add(const Value *args); 15 | Value *core_apply(const Value *args); 16 | Value *core_assert(const Value *args); 17 | Value *core_concat(const Value *args); 18 | Value *core_cons(const Value *args); 19 | Value *core_count(const Value *args); 20 | Value *core_div(const Value *args); 21 | Value *core_eq(const Value *args); 22 | Value *core_first(const Value *args); 23 | Value *core_geq(const Value *args); 24 | Value *core_gt(const Value *args); 25 | Value *core_is_empty(const Value *args); 26 | Value *core_is_false(const Value *args); 27 | Value *core_is_list(const Value *args); 28 | Value *core_is_nil(const Value *args); 29 | Value *core_is_symbol(const Value *args); 30 | Value *core_is_true(const Value *args); 31 | Value *core_leq(const Value *args); 32 | Value *core_list(const Value *args); 33 | Value *core_lt(const Value *args); 34 | Value *core_map(const Value *args); 35 | Value *core_mul(const Value *args); 36 | Value *core_nth(const Value *args); 37 | Value *core_pr(const Value *args); 38 | Value *core_pr_str(const Value *args); 39 | Value *core_prn(const Value *args); 40 | Value *core_rest(const Value *args); 41 | Value *core_slurp(const Value *args); 42 | Value *core_str(const Value *args); 43 | Value *core_sub(const Value *args); 44 | Value *core_symbol(const Value *args); 45 | Value *core_throw(const Value *args); 46 | 47 | /* utility functions */ 48 | bool is_truthy(const Value *v); 49 | 50 | #endif /* !CORE_H */ 51 | -------------------------------------------------------------------------------- /include/djb2.h: -------------------------------------------------------------------------------- 1 | /* 2 | * djb2.h 3 | * 4 | * http://www.cse.yorku.ca/~oz/hash.html 5 | */ 6 | 7 | #ifndef __DJB2_H__ 8 | #define __DJB2_H__ 9 | 10 | unsigned long djb2(char *str); 11 | 12 | #endif /* !__DJB2_H__ */ 13 | -------------------------------------------------------------------------------- /include/env.h: -------------------------------------------------------------------------------- 1 | #ifndef __ENV_H__ 2 | #define __ENV_H__ 3 | 4 | #include 5 | #include "map.h" 6 | 7 | struct Value; 8 | 9 | typedef struct Environment { 10 | Map *map; 11 | struct Environment *parent; 12 | } Environment; 13 | 14 | Environment *env_new(Environment *parent); 15 | void env_delete(Environment *env); 16 | 17 | void env_set(Environment *env, char *symbol, const struct Value *value); 18 | struct Value *env_get(Environment *env, char *symbol); 19 | bool env_contains(Environment *env, char *symbol); 20 | 21 | #endif /* !__ENV_H__ */ 22 | -------------------------------------------------------------------------------- /include/eval.h: -------------------------------------------------------------------------------- 1 | #ifndef __EVAL_H__ 2 | #define __EVAL_H__ 3 | 4 | #include 5 | #include 6 | 7 | Value *eval(Value *expr, Environment *env); 8 | 9 | #endif /* !EVAL_H */ 10 | -------------------------------------------------------------------------------- /include/exc.h: -------------------------------------------------------------------------------- 1 | #ifndef __EXC_H__ 2 | #define __EXC_H__ 3 | 4 | #include "value.h" 5 | 6 | void exc_set(const Value *error); 7 | const Value *exc_get(); 8 | void exc_clear(); 9 | bool exc_is_pending(); 10 | 11 | #endif /* !__EXC_H__ */ 12 | -------------------------------------------------------------------------------- /include/ir.h: -------------------------------------------------------------------------------- 1 | #ifndef IR_H 2 | #define IR_H 3 | 4 | #include "ast.h" 5 | #include "value.h" 6 | 7 | Value *ir_from_ast(AstSexpr *ast); 8 | Value *ir_from_ast_atom(AstAtom *); 9 | Value *ir_from_ast_list(AstList *); 10 | Value *ir_from_ast_sexpr(AstSexpr *); 11 | 12 | #endif /* !IR_H */ 13 | -------------------------------------------------------------------------------- /include/lexer.h: -------------------------------------------------------------------------------- 1 | #ifndef __LEXER_H__ 2 | #define __LEXER_H__ 3 | 4 | #include 5 | 6 | typedef enum { 7 | LEXER_TOK_ERROR, 8 | LEXER_TOK_INT, 9 | LEXER_TOK_FLOAT, 10 | LEXER_TOK_STRING, 11 | LEXER_TOK_SYMBOL, 12 | LEXER_TOK_LPAREN, 13 | LEXER_TOK_RPAREN, 14 | LEXER_TOK_QUOTE, 15 | LEXER_TOK_QUASIQUOTE, 16 | LEXER_TOK_UNQUOTE, 17 | LEXER_TOK_SPLICE_UNQUOTE, 18 | LEXER_TOK_EOF 19 | } TokenType; 20 | 21 | extern const char *token_type_names[]; 22 | 23 | typedef struct { 24 | TokenType type; 25 | union { 26 | char *str; 27 | int int_; 28 | double double_; 29 | } as; 30 | size_t line; 31 | size_t column; 32 | } LexerToken; 33 | 34 | #define LEXER_TOKEN_VAL_AS_STR(t) (t->as.str) 35 | #define LEXER_TOKEN_VAL_AS_INT(t) (t->as.int_) 36 | #define LEXER_TOKEN_VAL_AS_FLOAT(t) (t->as.double_) 37 | 38 | typedef enum { 39 | LEXER_STATE_ZERO, 40 | LEXER_STATE_COMMENT, 41 | LEXER_STATE_NUMBER, 42 | LEXER_STATE_FLOAT, 43 | LEXER_STATE_SYMBOL, 44 | LEXER_STATE_STRING, 45 | LEXER_STATE_ESCAPESTRING, 46 | LEXER_STATE_UNQUOTE, 47 | LEXER_STATE_MINUS 48 | } LexerState; 49 | 50 | typedef struct { 51 | FILE *fp; 52 | LexerState state; 53 | size_t line_no; 54 | size_t char_no; 55 | } Lexer; 56 | 57 | /* object lifecycle */ 58 | Lexer *lexer_new(FILE *fp); 59 | void lexer_delete(Lexer *l); 60 | 61 | /* interface */ 62 | LexerToken *lexer_get_token(Lexer *l); 63 | void lexer_delete_token(LexerToken *tok); 64 | 65 | #endif /* !__LEXER_H__ */ 66 | -------------------------------------------------------------------------------- /include/list.h: -------------------------------------------------------------------------------- 1 | #ifndef __LIST_H__ 2 | #define __LIST_H__ 3 | 4 | #include 5 | #include 6 | 7 | struct Value; 8 | 9 | /** 10 | * A list item. 11 | * 12 | */ 13 | typedef struct ListItem { 14 | const struct Value *val; /**< pointer to an immutable `Value` instance */ 15 | struct ListItem *next; /**< pointer to the next list item */ 16 | } ListItem; 17 | 18 | /** 19 | * A singly linked list of immutable values. 20 | * 21 | */ 22 | typedef struct List { 23 | struct ListItem *head; /**< pointer to the first item in the list */ 24 | size_t size; /**< size of the list */ 25 | } List; 26 | 27 | /** 28 | * Create a new list. 29 | * 30 | * @return A new list instance. 31 | * 32 | */ 33 | const List *list_new(); 34 | 35 | /** 36 | * Duplicate an existing list. 37 | * 38 | * This creates a flat copy of the list; the val pointers in the copy 39 | * point to the same Value instances as the source. 40 | * 41 | * @param l The list to duplicate 42 | * @return A pointer to a copy of the list 43 | * 44 | */ 45 | const List *list_dup(const List *l); 46 | 47 | /** 48 | * Return the first value in a list. 49 | * 50 | * Rules: 51 | * - The head of (a b ... c) is a 52 | * - The head of (a) is a 53 | * - The head of the empty list is nil (we're returning NULL) 54 | * 55 | * @param l A list 56 | * @return A pointer to the value of the first item in the list or 57 | * NULL if `l` is empty. 58 | */ 59 | const struct Value *list_head(const List *l); 60 | 61 | /** 62 | * Returns the tail of a list. 63 | * 64 | * Rules: 65 | * - The tail of (a b ... c) is (b ... c) 66 | * - The tail of (a) is the empty list 67 | * - The tail of the empty list is the empty list 68 | * 69 | * @param l A list instance. 70 | * @return A pointer to the value instance at the head of the list 71 | */ 72 | const List *list_tail(const List *l); 73 | 74 | /** 75 | * Return the n-th item in a list. 76 | * 77 | * Returns the n-th item in a list or NULL if the list is shorter than n. 78 | * This is an O(n) operation since we need to walk the list. 79 | * 80 | * @param l A list instance 81 | * @param n The index into the list 82 | * @return A pointer to value instance at the list index, or NULL 83 | * 84 | */ 85 | const struct Value *list_nth(const List *l, const size_t n); 86 | 87 | /** 88 | * Insert a value at the beginning of the list. 89 | * 90 | * This is an O(1) operation. 91 | * 92 | * @param l A list 93 | * @param value The value to prepend 94 | * @return A copy of `l` with `value` prepended. 95 | * 96 | */ 97 | const List *list_prepend(const List *l, const struct Value *value); 98 | 99 | /** 100 | * Append a value at the end of the list. 101 | * 102 | * This is an O(n) operation. 103 | * 104 | * @param l A list 105 | * @param value The value to append 106 | * @return A copy of `l` with `value` appended. 107 | * 108 | */ 109 | const List *list_append(const List *l, const struct Value *value); 110 | 111 | /** 112 | * Return the size of a list. 113 | * 114 | * This is O(1) since we're keeping tabs on the list size. 115 | * 116 | * @param l A list 117 | * @return The size of the list `l`. 118 | * 119 | */ 120 | size_t list_size(const List *l); 121 | 122 | /** 123 | * Test if a list is empty. 124 | * 125 | * @param l A list 126 | * @return True if the list `l` is empty, otherwise false. 127 | * 128 | */ 129 | bool list_is_empty(const List *l); 130 | 131 | #endif /* !__LIST_H__ */ 132 | -------------------------------------------------------------------------------- /include/log.h: -------------------------------------------------------------------------------- 1 | #ifndef __LOG_H__ 2 | #define __LOG_H__ 3 | 4 | #include 5 | 6 | #define LOGLEVEL LOGLEVEL_DEBUG 7 | 8 | enum { 9 | LOGLEVEL_CRITICAL, // 0 10 | LOGLEVEL_WARNING, // 1 11 | LOGLEVEL_INFO, // 2 12 | LOGLEVEL_DEBUG, // 3 13 | LOGLEVEL_NONE // 4 14 | }; 15 | 16 | extern const char *log_level_strings[]; 17 | 18 | #define log(level, fmt, ...) \ 19 | do { if (level <= LOGLEVEL) fprintf(stderr, "[%s] %s:%s:%d: " fmt "\n", log_level_strings[level], __func__, __FILE__, __LINE__, ##__VA_ARGS__); } while (0) 20 | 21 | #define LOG_CRITICAL(fmt, ...) log(LOGLEVEL_CRITICAL, fmt, ##__VA_ARGS__) 22 | #define LOG_WARNING(fmt, ...) log(LOGLEVEL_WARNING, fmt, ##__VA_ARGS__) 23 | #define LOG_INFO(fmt, ...) log(LOGLEVEL_INFO, fmt, ##__VA_ARGS__) 24 | #define LOG_DEBUG(fmt, ...) log(LOGLEVEL_DEBUG, fmt, ##__VA_ARGS__) 25 | 26 | #endif /* !__LOG_H__ */ 27 | -------------------------------------------------------------------------------- /include/map.h: -------------------------------------------------------------------------------- 1 | /* 2 | * A simple hashtable implementation for string keys, using separate chaining. 3 | */ 4 | 5 | #ifndef __HT_H__ 6 | #define __HT_H__ 7 | 8 | #include 9 | #include 10 | 11 | typedef struct MapItem { 12 | char *key; 13 | void *value; 14 | size_t size; 15 | struct MapItem *next; 16 | } MapItem; 17 | 18 | typedef struct Map { 19 | size_t capacity; 20 | size_t size; 21 | MapItem **items; 22 | } Map; 23 | 24 | Map *map_new(size_t n); 25 | void map_delete(Map *); 26 | 27 | void *map_get(Map *ht, char *key); 28 | void map_put(Map *ht, char *key, void *value, size_t siz); 29 | void map_remove(Map *ht, char *key); 30 | void map_resize(Map *ht, size_t capacity); 31 | 32 | // helpers 33 | 34 | bool is_prime(size_t n); 35 | 36 | #endif /* !__HT_H__ */ 37 | -------------------------------------------------------------------------------- /include/parser.h: -------------------------------------------------------------------------------- 1 | #ifndef __PARSER_H__ 2 | #define __PARSER_H__ 3 | 4 | #include 5 | #include "value.h" 6 | 7 | enum ParseResult { 8 | PARSER_FAIL, 9 | PARSER_SUCCESS 10 | }; 11 | typedef enum ParseResult ParseResult; 12 | 13 | ParseResult parser_parse(FILE *stream, Value **ast); 14 | 15 | #endif /* !__PARSER_H__ */ 16 | -------------------------------------------------------------------------------- /include/primes.h: -------------------------------------------------------------------------------- 1 | #ifndef __PRIMES_H__ 2 | #define __PRIMES_H__ 3 | 4 | #include 5 | #include 6 | 7 | bool is_prime(size_t n); 8 | size_t next_prime(size_t n); 9 | 10 | #endif /* !__PRIMES_H__ */ 11 | -------------------------------------------------------------------------------- /include/reader.h: -------------------------------------------------------------------------------- 1 | #ifndef __READER_H__ 2 | #define __READER_H__ 3 | 4 | #include 5 | 6 | #include "lexer.h" 7 | #include "ast.h" 8 | 9 | #define READER_SUCCESS 0 10 | #define READER_FAILURE 1 11 | 12 | typedef struct { 13 | Lexer *lexer; 14 | } Reader; 15 | 16 | /* 17 | * Macros to simplify AST interaction 18 | */ 19 | 20 | /* 21 | * The reader interface 22 | */ 23 | Reader *reader_new(FILE *stream); 24 | void reader_delete(Reader *r); 25 | AstSexpr *reader_read(Reader *r); 26 | 27 | #endif /* !__READER_H__ */ 28 | -------------------------------------------------------------------------------- /include/reader_stack.h: -------------------------------------------------------------------------------- 1 | #ifndef __STACK_H__ 2 | #define __STACK_H__ 3 | 4 | #include 5 | #include 6 | 7 | #include "ast.h" 8 | 9 | typedef enum { 10 | N_PROG, 11 | N_SEXP, 12 | N_LIST, 13 | N_ATOM, 14 | T_EOF, 15 | T_LPAREN, 16 | T_RPAREN, 17 | T_QUOTE, 18 | T_QUASIQUOTE, 19 | T_UNQUOTE, 20 | T_SPLICE_UNQUOTE, 21 | T_INT, 22 | T_FLOAT, 23 | T_STR, 24 | T_SYM 25 | } ReaderStackTokenType; 26 | 27 | extern const char *reader_stack_token_type_names[]; 28 | 29 | typedef struct ReaderStackToken { 30 | ReaderStackTokenType type; 31 | union { 32 | struct AstList *list; 33 | struct AstAtom *atom; 34 | struct AstSexpr *quoted; 35 | struct AstSexpr *sexp; 36 | } ast; 37 | } ReaderStackToken; 38 | 39 | 40 | typedef struct ReaderStack { 41 | size_t capacity; 42 | size_t size; 43 | ReaderStackToken *bos; /* bottom of stack */ 44 | } ReaderStack; 45 | 46 | ReaderStack *reader_stack_new(size_t capacity); 47 | void reader_stack_delete(ReaderStack *stack); 48 | 49 | void reader_stack_push(ReaderStack *stack, ReaderStackToken item); 50 | int reader_stack_pop(ReaderStack *stack, ReaderStackToken *value); 51 | int reader_stack_peek(ReaderStack *stack, ReaderStackToken *value); 52 | bool reader_is_terminal(ReaderStackToken value); 53 | bool reader_is_nonterminal(ReaderStackToken value); 54 | 55 | #endif /* !__STACK_H__ */ 56 | -------------------------------------------------------------------------------- /include/value.h: -------------------------------------------------------------------------------- 1 | #ifndef VALUE_H 2 | #define VALUE_H 3 | 4 | #include "array.h" 5 | #include "env.h" 6 | #include "gc.h" 7 | #include "list.h" 8 | #include "map.h" 9 | 10 | #define BOOL(v) (v->value.bool_) 11 | #define BUILTIN_FN(v) (v->value.builtin_fn) 12 | #define EXCEPTION(v) (v->value.str) 13 | #define FLOAT(v) (v->value.float_) 14 | #define FN(v) (v->value.fn) 15 | #define INT(v) (v->value.int_) 16 | #define LIST(v) (v->value.list) 17 | #define STRING(v) (v->value.str) 18 | #define SYMBOL(v) (v->value.str) 19 | 20 | typedef enum { 21 | VALUE_BOOL, 22 | VALUE_BUILTIN_FN, 23 | VALUE_EXCEPTION, 24 | VALUE_FLOAT, 25 | VALUE_FN, 26 | VALUE_INT, 27 | VALUE_LIST, 28 | VALUE_MACRO_FN, 29 | VALUE_NIL, 30 | VALUE_STRING, 31 | VALUE_SYMBOL 32 | } ValueType; 33 | 34 | extern const char *value_type_names[]; 35 | 36 | typedef struct CompositeFunction { 37 | struct Value *args; 38 | struct Value *body; 39 | Environment *env; 40 | } CompositeFunction; 41 | 42 | typedef struct Value { 43 | ValueType type; 44 | union { 45 | bool bool_; 46 | int int_; 47 | double float_; 48 | char *str; 49 | Array *vector; 50 | const List *list; 51 | Map *map; 52 | struct Value *(*builtin_fn)(const struct Value *); 53 | CompositeFunction *fn; 54 | } value; 55 | } Value; 56 | 57 | /* 58 | * constants 59 | */ 60 | extern Value *VALUE_CONST_TRUE; 61 | extern Value *VALUE_CONST_FALSE; 62 | extern Value *VALUE_CONST_NIL; 63 | 64 | /* 65 | * functions 66 | */ 67 | bool is_symbol(const Value *value); 68 | bool is_macro(const Value *value); 69 | bool is_list(const Value *value); 70 | bool is_exception(const Value *value); 71 | Value *value_new_nil(); 72 | Value *value_new_bool(const bool bool_); 73 | Value *value_new_exception(const char *str); 74 | Value *value_make_exception(const char *fmt, ...); 75 | Value *value_new_int(int int_); 76 | Value *value_new_float(float float_); 77 | Value *value_new_builtin_fn(Value * (fn)(const Value *)); 78 | Value *value_new_fn(Value *args, Value *body, Environment *env); 79 | Value *value_new_macro(Value *args, Value *body, Environment *env); 80 | Value *value_new_string(const char *str); 81 | Value *value_new_symbol(const char *str); 82 | Value *value_new_list(const List *l); 83 | Value *value_make_list(Value *v); 84 | Value *value_head(const Value *v); 85 | Value *value_tail(const Value *v); 86 | void value_delete(Value *v); 87 | void value_print(const Value *v); 88 | 89 | 90 | #endif /* !VALUE_H */ 91 | -------------------------------------------------------------------------------- /src/apply.c: -------------------------------------------------------------------------------- 1 | #include "apply.h" 2 | 3 | #include 4 | 5 | #include "stdbool.h" 6 | #include "eval.h" 7 | #include "exc.h" 8 | #include "list.h" 9 | #include "log.h" 10 | 11 | 12 | static bool is_builtin_fn(const Value *value) 13 | { 14 | return value->type == VALUE_BUILTIN_FN; 15 | } 16 | 17 | static bool is_compound_fn(const Value *fn) 18 | { 19 | return fn->type == VALUE_FN || fn->type == VALUE_MACRO_FN; 20 | } 21 | 22 | static Value *apply_builtin_fn(Value *fn, Value *args) 23 | { 24 | if (fn && fn->type == VALUE_BUILTIN_FN && fn->value.builtin_fn) { 25 | return fn->value.builtin_fn(args); 26 | } 27 | exc_set(value_make_exception("Could not apply builtin fn")); 28 | return NULL; 29 | } 30 | 31 | static Value *apply_compound_fn(Value *fn, Value *args, 32 | Value **tco_expr, Environment **tco_env) 33 | { 34 | if (fn && is_compound_fn(fn) && fn->value.fn) { 35 | // args are fully evaluated, so bind them to the names in the fn def on 36 | // top of the closure of f 37 | const List *arg_names = fn->value.fn->args->value.list; 38 | const List *arg_values = args->value.list; 39 | // bind arguments 40 | Environment *env = env_new(fn->value.fn->env); 41 | Value *arg_name = list_head(arg_names); 42 | Value *arg_value = list_head(arg_values); 43 | bool more = false; 44 | while(arg_name) { 45 | if (!is_symbol(arg_name)) { 46 | exc_set(value_make_exception("Parameter names must be symbols")); 47 | return NULL; 48 | } 49 | if (strcmp(SYMBOL(arg_name), "&") == 0) { 50 | more = true; 51 | break; 52 | } 53 | if (!arg_value) { 54 | break; 55 | } 56 | env_set(env, arg_name->value.str, arg_value); 57 | arg_names = list_tail(arg_names); 58 | arg_values = list_tail(arg_values); 59 | arg_name = list_head(arg_names); 60 | arg_value = list_head(arg_values); 61 | } 62 | if (more) { 63 | Value *rest_name = list_head(list_tail(arg_names)); 64 | if (!rest_name) { 65 | exc_set(value_make_exception("Variadic arg list requires a name")); 66 | return NULL; 67 | } 68 | Value *rest_value = value_new_list(arg_values); 69 | env_set(env, SYMBOL(rest_name), rest_value); 70 | arg_name = list_head(arg_names); 71 | arg_name = arg_value = NULL; 72 | } 73 | if (arg_name != arg_value) { 74 | exc_set(value_make_exception("Invalid number of arguments for compound fn")); 75 | } 76 | // eval via TCO: don't call eval here, return the pointers 77 | *tco_expr = fn->value.fn->body; 78 | *tco_env = env; 79 | return NULL; 80 | } 81 | LOG_CRITICAL("Could not apply compound fn"); 82 | exc_set(value_make_exception("Could not apply compound fn")); 83 | return NULL; 84 | } 85 | 86 | Value *apply(Value *fn, Value *args, Value **tco_expr, Environment **tco_env) 87 | { 88 | if (!fn) { 89 | LOG_CRITICAL("Apply requires a valid fn to apply"); 90 | return NULL; 91 | } 92 | *tco_expr = NULL; 93 | *tco_env = NULL; 94 | if (is_builtin_fn(fn)) { 95 | return apply_builtin_fn(fn, args); 96 | } else if (is_compound_fn(fn)) { 97 | return apply_compound_fn(fn, args, tco_expr, tco_env); 98 | } else { 99 | exc_set(value_make_exception("apply: not a function")); 100 | return NULL; 101 | } 102 | } 103 | 104 | -------------------------------------------------------------------------------- /src/array.c: -------------------------------------------------------------------------------- 1 | #include "array.h" 2 | 3 | #include 4 | #include 5 | 6 | 7 | Array *array_new(const size_t item_size) 8 | { 9 | // default to 2 elements for empty arrays 10 | return array_new_with_capacity(item_size, 2); 11 | } 12 | 13 | Array *array_new_with_capacity(const size_t item_size, const size_t capacity) 14 | { 15 | Array *array = malloc(sizeof(Array)); 16 | array->p = calloc(capacity, item_size); 17 | array->bytes = item_size; 18 | array->capacity = capacity; 19 | array->size = 0; 20 | return array; 21 | } 22 | 23 | void array_delete(Array *a) 24 | { 25 | free(a->p); 26 | free(a); 27 | } 28 | 29 | static uint64_t next_power_of_2(uint64_t v) 30 | { 31 | // http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2 32 | v--; 33 | v |= v >> 1; 34 | v |= v >> 2; 35 | v |= v >> 4; 36 | v |= v >> 8; 37 | v |= v >> 16; 38 | v |= v >> 32; 39 | v++; 40 | return v; 41 | } 42 | 43 | static void array_resize(Array *a, size_t requested_capacity) 44 | { 45 | size_t new_capacity = next_power_of_2(requested_capacity); 46 | if (a->size > new_capacity) a->size = new_capacity; 47 | a->p = realloc(a->p, new_capacity * a->bytes); 48 | a->capacity = new_capacity; 49 | } 50 | 51 | void *array_at(Array *a, size_t i) 52 | { 53 | return (void *) (a->p + i * a->bytes); 54 | } 55 | 56 | void array_push_back(Array *a, const void *value, size_t n) 57 | { 58 | size_t total = n + a->size; 59 | array_resize(a, total); 60 | char *pos = a->p + (a->size * a->bytes); 61 | memcpy(pos, value, n * a->bytes); 62 | a->size += n; 63 | } 64 | 65 | void array_push_front(Array *a, const void *value, size_t n) 66 | { 67 | size_t total = n + a->size; 68 | // allocate sufficient memory 69 | array_resize(a, total); 70 | // shift contents away from the front 71 | size_t width = n * a->bytes; 72 | char *pos = a->p + width; 73 | memmove(pos, a->p, a->size * a->bytes); 74 | // insert at the front 75 | memcpy(a->p, value, width); 76 | // update the size info 77 | a->size += n; 78 | } 79 | 80 | void *array_pop_back(Array *a) 81 | { 82 | if (a->size == 0) return NULL; 83 | a->size--; 84 | return a->p + a->size * a->bytes; 85 | } 86 | 87 | void *array_pop_front(Array *a) 88 | { 89 | if (a->size == 0) 90 | return NULL; 91 | // swap 92 | char tmp[a->bytes]; 93 | memcpy(&tmp, a->p, a->bytes); 94 | memmove(a->p, a->p + a->bytes, (a->size - 1) * a->bytes); 95 | a->size--; 96 | memcpy(a->p + a->size * a->bytes, &tmp, a->bytes); 97 | return (void *) (a->p + a->size * a->bytes); 98 | } 99 | 100 | void array_shrink(Array *a) 101 | { 102 | array_resize(a, a->size); 103 | } 104 | -------------------------------------------------------------------------------- /src/ast.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "ast.h" 3 | 4 | AstNode *ast_new_node(size_t size, AstNodeType node_type) 5 | { 6 | AstNode *node = malloc(size); 7 | node->type = node_type; 8 | return node; 9 | } 10 | 11 | AstSexpr *ast_new_sexpr() 12 | { 13 | AstSexpr *sexpr = malloc(sizeof(AstSexpr)); 14 | return sexpr; 15 | } 16 | 17 | AstSexpr *ast_sexpr_from_list(AstList *list) 18 | { 19 | AstSexpr *sexpr = malloc(sizeof(AstSexpr)); 20 | sexpr->node.type = AST_SEXPR_LIST; 21 | sexpr->as.list = list; 22 | return sexpr; 23 | } 24 | 25 | AstSexpr *ast_sexpr_from_atom(AstAtom *atom) 26 | { 27 | AstSexpr *sexpr = malloc(sizeof(AstSexpr)); 28 | sexpr->node.type = AST_SEXPR_ATOM; 29 | sexpr->as.atom = atom; 30 | return sexpr; 31 | } 32 | 33 | static AstSexpr *ast_sexpr_from_anyquote(AstSexpr *quoted, AstNodeType t) 34 | { 35 | AstSexpr *sexpr = malloc(sizeof(AstSexpr)); 36 | sexpr->node.type = t; 37 | sexpr->as.quoted = quoted; 38 | return sexpr; 39 | } 40 | 41 | AstSexpr *ast_sexpr_from_quote(AstSexpr *quoted) 42 | { 43 | return ast_sexpr_from_anyquote(quoted, AST_SEXPR_QUOTE); 44 | } 45 | 46 | AstSexpr *ast_sexpr_from_quasiquote(AstSexpr *quoted) 47 | { 48 | return ast_sexpr_from_anyquote(quoted, AST_SEXPR_QUASIQUOTE); 49 | } 50 | 51 | AstList *ast_new_list() 52 | { 53 | AstList *list = malloc(sizeof(AstList)); 54 | list->node.type = AST_LIST_EMPTY; // default to empty list 55 | return list; 56 | } 57 | 58 | AstList *ast_list_from_compound_list(AstSexpr *s, AstList *l) 59 | { 60 | AstList *list = malloc(sizeof(AstList)); 61 | list->node.type = AST_LIST_COMPOUND; 62 | list->as.compound.sexpr = s; 63 | list->as.compound.list = l; 64 | return list; 65 | } 66 | 67 | AstList *ast_list_empty() 68 | { 69 | AstList *list = malloc(sizeof(AstList)); 70 | list->node.type = AST_LIST_EMPTY; 71 | return list; 72 | } 73 | 74 | AstAtom *ast_new_atom() 75 | { 76 | AstAtom *atom = malloc(sizeof(AstAtom)); 77 | return atom; 78 | } 79 | 80 | AstAtom *ast_atom_from_symbol(char *symbol) 81 | { 82 | AstAtom *atom = malloc(sizeof(AstAtom)); 83 | atom->node.type = AST_ATOM_SYMBOL; 84 | atom->as.symbol = symbol; 85 | return atom; 86 | } 87 | 88 | AstAtom *ast_atom_from_string(char *string) 89 | { 90 | AstAtom *atom = malloc(sizeof(AstAtom)); 91 | atom->node.type = AST_ATOM_STRING; 92 | atom->as.string = string; 93 | return atom; 94 | } 95 | 96 | AstAtom *ast_atom_from_int(int integer) 97 | { 98 | AstAtom *atom = malloc(sizeof(AstAtom)); 99 | atom->node.type = AST_ATOM_INT; 100 | atom->as.integer = integer; 101 | return atom; 102 | } 103 | 104 | AstAtom *ast_atom_from_float(double number) 105 | { 106 | AstAtom *atom = malloc(sizeof(AstAtom)); 107 | atom->node.type = AST_ATOM_FLOAT; 108 | atom->as.decimal = number; 109 | return atom; 110 | } 111 | 112 | void ast_delete_node(AstNode *n) 113 | { 114 | switch(n->type) { 115 | case AST_SEXPR_ATOM: 116 | case AST_SEXPR_LIST: 117 | case AST_SEXPR_QUOTE: 118 | case AST_SEXPR_QUASIQUOTE: 119 | case AST_SEXPR_SPLICE_UNQUOTE: 120 | case AST_SEXPR_UNQUOTE: 121 | ast_delete_sexpr((AstSexpr *) n); 122 | break; 123 | case AST_LIST_COMPOUND: 124 | case AST_LIST_EMPTY: 125 | ast_delete_list((AstList *) n); 126 | break; 127 | case AST_ATOM_SYMBOL: 128 | case AST_ATOM_INT: 129 | case AST_ATOM_FLOAT: 130 | case AST_ATOM_STRING: 131 | ast_delete_atom((AstAtom *) n); 132 | break; 133 | } 134 | } 135 | 136 | void ast_delete_sexpr(AstSexpr *s) 137 | { 138 | if (s) { 139 | switch(s->node.type) { 140 | case AST_SEXPR_ATOM: 141 | ast_delete_atom(s->as.atom); 142 | break; 143 | case AST_SEXPR_LIST: 144 | ast_delete_list(s->as.list); 145 | break; 146 | case AST_SEXPR_QUOTE: 147 | case AST_SEXPR_QUASIQUOTE: 148 | case AST_SEXPR_SPLICE_UNQUOTE: 149 | case AST_SEXPR_UNQUOTE: 150 | ast_delete_sexpr(s->as.quoted); 151 | break; 152 | } 153 | free(s); 154 | } 155 | } 156 | 157 | void ast_delete_list(AstList *l) 158 | { 159 | if (l) { 160 | switch(l->node.type) { 161 | case AST_LIST_COMPOUND: 162 | ast_delete_sexpr(l->as.compound.sexpr); 163 | ast_delete_list(l->as.compound.list); 164 | break; 165 | case AST_LIST_EMPTY: 166 | break; 167 | } 168 | free(l); 169 | } 170 | } 171 | 172 | void ast_delete_atom(AstAtom *a) 173 | { 174 | // atoms do not reserve memory for member but use const refs 175 | if (a) { 176 | switch(a->node.type) { 177 | case AST_ATOM_SYMBOL: 178 | free(a->as.symbol); 179 | break; 180 | case AST_ATOM_STRING: 181 | free(a->as.string); 182 | break; 183 | default: 184 | break; 185 | } 186 | free(a); 187 | } 188 | } 189 | 190 | 191 | void ast_print(AstNode *ast) 192 | { 193 | switch(ast->type) { 194 | case AST_SEXPR_ATOM: 195 | case AST_SEXPR_LIST: 196 | case AST_SEXPR_QUOTE: 197 | case AST_SEXPR_QUASIQUOTE: 198 | case AST_SEXPR_SPLICE_UNQUOTE: 199 | case AST_SEXPR_UNQUOTE: 200 | ast_print_sexpr((AstSexpr *) ast, 0); 201 | break; 202 | case AST_LIST_COMPOUND: 203 | case AST_LIST_EMPTY: 204 | ast_print_list((AstList *) ast, 0); 205 | break; 206 | case AST_ATOM_SYMBOL: 207 | case AST_ATOM_STRING: 208 | case AST_ATOM_INT: 209 | case AST_ATOM_FLOAT: 210 | ast_print_atom((AstAtom *) ast, 0); 211 | break; 212 | } 213 | } 214 | 215 | void ast_print_sexpr(AstSexpr *s, int indent) 216 | { 217 | if (s) { 218 | printf("%*s\n", indent, ""); 219 | switch(s->node.type) { 220 | case AST_SEXPR_ATOM: 221 | ast_print_atom(s->as.atom, indent + 2); 222 | break; 223 | case AST_SEXPR_LIST: 224 | ast_print_list(s->as.list, indent + 2); 225 | break; 226 | case AST_SEXPR_QUOTE: 227 | case AST_SEXPR_QUASIQUOTE: 228 | case AST_SEXPR_SPLICE_UNQUOTE: 229 | case AST_SEXPR_UNQUOTE: 230 | ast_print_sexpr(s->as.quoted, indent + 2); 231 | break; 232 | } 233 | printf("%*s\n", indent, ""); 234 | } 235 | } 236 | 237 | void ast_print_list(AstList *l, int indent) 238 | { 239 | if (l) { 240 | printf("%*s\n", indent, ""); 241 | switch(l->node.type) { 242 | case AST_LIST_COMPOUND: 243 | ast_print_sexpr(l->as.compound.sexpr, indent + 2); 244 | ast_print_list(l->as.compound.list, indent + 2); 245 | break; 246 | case AST_LIST_EMPTY: 247 | break; 248 | } 249 | printf("%*s\n", indent, ""); 250 | } 251 | } 252 | 253 | void ast_print_atom(AstAtom *a, int indent) 254 | { 255 | if (a) { 256 | switch(a->node.type) { 257 | case AST_ATOM_INT: 258 | printf("%*s\n", indent, "", a->as.integer); 259 | break; 260 | case AST_ATOM_FLOAT: 261 | printf("%*s\n", indent, "", a->as.decimal); 262 | break; 263 | case AST_ATOM_STRING: 264 | printf("%*s\n", indent, "", a->as.string); 265 | break; 266 | case AST_ATOM_SYMBOL: 267 | printf("%*s\n", indent, "", a->as.symbol); 268 | break; 269 | } 270 | } 271 | } 272 | -------------------------------------------------------------------------------- /src/core.c: -------------------------------------------------------------------------------- 1 | #include "core.h" 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include "apply.h" 8 | #include "eval.h" 9 | #include "exc.h" 10 | #include "log.h" 11 | 12 | 13 | #define NARGS(args) list_size(LIST(args)) 14 | #define ARG(args, n) list_nth(LIST(args), n) 15 | 16 | #define CHECK_ARGLIST(args) do {\ 17 | if (!(args && args->type == VALUE_LIST)) {\ 18 | exc_set(value_make_exception("Invalid argument list in core function"));\ 19 | return NULL;\ 20 | }\ 21 | } while (0) 22 | 23 | #define REQUIRE_VALUE_TYPE(value, t, msg) do {\ 24 | if (value->type != t) {\ 25 | LOG_CRITICAL("%s: expected %s, got %s", msg, value_type_names[t], value_type_names[value->type]);\ 26 | exc_set(value_make_exception("%s: expected %s, got %s", msg, value_type_names[t], value_type_names[value->type]));\ 27 | return NULL;\ 28 | }\ 29 | } while (0) 30 | 31 | 32 | #define REQUIRE_LIST_CARDINALITY(val, n, msg) do {\ 33 | if (list_size(val->value.list) != n) {\ 34 | LOG_CRITICAL("%s: expected %lu, got %lu", msg, n, list_size(val->value.list));\ 35 | exc_set(value_make_exception("%s: expected %lu, got %lu", msg, n, list_size(val->value.list)));\ 36 | return NULL;\ 37 | }\ 38 | } while (0) 39 | 40 | #define REQUIRE_LIST_CARDINALITY_GE(val, n, msg) do {\ 41 | if (list_size(val->value.list) < (size_t) n) {\ 42 | LOG_CRITICAL("%s: expected at least %lu, got %lu", msg, n, list_size(val->value.list));\ 43 | exc_set(value_make_exception("%s: expected at least %lu, got %lu", msg, n, list_size(val->value.list)));\ 44 | return NULL;\ 45 | }\ 46 | } while (0) 47 | 48 | 49 | bool is_truthy(const Value *v) 50 | { 51 | /* we follow Clojure's lead: the only values that are considered 52 | * logical false are `false` and `nil` */ 53 | assert(v); 54 | switch(v->type) { 55 | case VALUE_NIL: 56 | return false; 57 | case VALUE_EXCEPTION: 58 | return false; 59 | case VALUE_BOOL: 60 | return v->value.bool_ == true; 61 | case VALUE_INT: 62 | case VALUE_FLOAT: 63 | case VALUE_STRING: 64 | case VALUE_SYMBOL: 65 | case VALUE_LIST: 66 | case VALUE_FN: 67 | case VALUE_MACRO_FN: 68 | case VALUE_BUILTIN_FN: 69 | return true; 70 | } 71 | } 72 | 73 | static bool is_true(const Value *v) 74 | { 75 | assert(v); 76 | return v->type == VALUE_BOOL && v->value.bool_; 77 | } 78 | 79 | static bool is_false(const Value *v) 80 | { 81 | assert(v); 82 | return v->type == VALUE_BOOL && !v->value.bool_; 83 | } 84 | 85 | static bool is_nil(const Value *v) 86 | { 87 | assert(v); 88 | return v->type == VALUE_NIL; 89 | } 90 | 91 | Value *core_list(const Value *args) 92 | { 93 | CHECK_ARGLIST(args); 94 | return value_new_list(LIST(args)); 95 | } 96 | 97 | Value *core_is_list(const Value *args) 98 | { 99 | CHECK_ARGLIST(args); 100 | REQUIRE_LIST_CARDINALITY(args, 1ul, "list? requires exactly one parameter"); 101 | Value *arg0 = ARG(args, 0); 102 | return arg0->type == VALUE_LIST ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 103 | } 104 | 105 | Value *core_is_empty(const Value *args) 106 | { 107 | CHECK_ARGLIST(args); 108 | REQUIRE_LIST_CARDINALITY(args, 1ul, "empty? requires exactly one parameter"); 109 | Value *arg0 = ARG(args, 0); 110 | REQUIRE_VALUE_TYPE(arg0, VALUE_LIST, "empty? requires a list type"); 111 | return NARGS(arg0) == 0 ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 112 | } 113 | 114 | static float acc_add(float acc, float x) 115 | { 116 | return acc + x; 117 | } 118 | 119 | static float acc_sub(float acc, float x) 120 | { 121 | return acc - x; 122 | } 123 | 124 | static float acc_mul(float acc, float x) 125 | { 126 | return acc * x; 127 | } 128 | 129 | static float acc_div(float acc, float x) 130 | { 131 | return acc / x; 132 | } 133 | 134 | 135 | static Value *core_acc(const Value *args, float (*acc_fn)(float, float)) 136 | { 137 | CHECK_ARGLIST(args); 138 | REQUIRE_LIST_CARDINALITY_GE(args, 1ul, "Require at least one argument"); 139 | assert(acc_fn); 140 | bool all_int = true; 141 | const List *list = args->value.list; 142 | Value *head = list_head(list); 143 | float acc; 144 | if (head->type == VALUE_FLOAT) { 145 | acc = head->value.float_; 146 | all_int = false; 147 | } else if (head->type == VALUE_INT) { 148 | acc = (float) head->value.int_; 149 | } else { 150 | exc_set(value_make_exception("Non-numeric argument in accumulation")); 151 | return NULL; 152 | } 153 | list = list_tail(list); 154 | while ((head = list_head(list)) != NULL) { 155 | if (head->type == VALUE_FLOAT) { 156 | acc = acc_fn(acc, head->value.float_); 157 | all_int = false; 158 | } else if (head->type == VALUE_INT) { 159 | acc = acc_fn(acc, (float) head->value.int_); 160 | } else { 161 | exc_set(value_make_exception("Non-numeric argument in accumulation")); 162 | return NULL; 163 | } 164 | list = list_tail(list); 165 | } 166 | Value *ret; 167 | if (all_int) { 168 | ret = value_new_int((int) acc); 169 | } else { 170 | ret = value_new_float(acc); 171 | } 172 | return ret; 173 | } 174 | 175 | Value *core_add(const Value *args) 176 | { 177 | return core_acc(args, acc_add); 178 | } 179 | 180 | Value *core_sub(const Value *args) 181 | { 182 | return core_acc(args, acc_sub); 183 | } 184 | 185 | Value *core_mul(const Value *args) 186 | { 187 | return core_acc(args, acc_mul); 188 | } 189 | 190 | Value *core_div(const Value *args) 191 | { 192 | return core_acc(args, acc_div); 193 | } 194 | 195 | static Value *cmp_eq(const Value *a, const Value *b) 196 | { 197 | if (a->type == b->type) { 198 | switch(a->type) { 199 | case VALUE_NIL: 200 | /* NIL equals NIL */ 201 | return VALUE_CONST_TRUE; 202 | case VALUE_EXCEPTION: 203 | /* Errors do not support comparison */ 204 | exc_set(value_make_exception("Comparison of error values is not supported")); 205 | return NULL; 206 | case VALUE_BOOL: 207 | return BOOL(a) == BOOL(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 208 | case VALUE_INT: 209 | return INT(a) == INT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 210 | case VALUE_FLOAT: 211 | return FLOAT(a) == FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 212 | case VALUE_STRING: 213 | case VALUE_SYMBOL: 214 | return strcmp(STRING(a), STRING(b)) == 0 ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 215 | case VALUE_BUILTIN_FN: 216 | /* For built-in functions we currently use identity == equality */ 217 | return BUILTIN_FN(a) == BUILTIN_FN(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 218 | case VALUE_FN: 219 | case VALUE_MACRO_FN: 220 | /* For composite functions we currently use identity == equality */ 221 | return FN(a) == FN(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 222 | case VALUE_LIST: 223 | if (list_size(LIST(a)) == list_size(LIST(b))) { 224 | /* empty lists can be equal */ 225 | if (list_size(LIST(a)) == 0) { 226 | return VALUE_CONST_TRUE; 227 | } 228 | /* else compare contents */ 229 | const List *list_a = LIST(a); 230 | const List *list_b = LIST(b); 231 | Value *head_a; 232 | Value *head_b; 233 | while ((head_a = list_head(list_a)) && (head_b = list_head(list_b))) { 234 | Value *cmp_result = cmp_eq(head_a, head_b); 235 | if (!(cmp_result == VALUE_CONST_TRUE)) { 236 | return cmp_result; /* NULL or VALUE_CONST_FALSE */ 237 | } 238 | list_a = list_tail(list_a); 239 | list_b = list_tail(list_b); 240 | } 241 | return VALUE_CONST_TRUE; 242 | } 243 | return VALUE_CONST_FALSE; 244 | } 245 | } else if (a->type == VALUE_INT && b->type == VALUE_FLOAT) { 246 | return ((float) INT(a)) == FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 247 | } else if (b->type == VALUE_INT && a->type == VALUE_FLOAT) { 248 | return ((float) INT(b)) == FLOAT(a) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 249 | } else if (b->type == VALUE_NIL || a->type == VALUE_NIL) { 250 | /* nil can be compared to anything but will yield false unless compared 251 | * to itself */ 252 | return VALUE_CONST_FALSE; 253 | } 254 | exc_set(value_make_exception("Cannot compare incompatible types")); 255 | return NULL; 256 | } 257 | 258 | static Value *cmp_lt(const Value *a, const Value *b) 259 | { 260 | if (a->type == b->type) { 261 | switch(a->type) { 262 | case VALUE_NIL: 263 | exc_set(value_make_exception("Cannot order NIL values")); 264 | return NULL; 265 | case VALUE_EXCEPTION: 266 | exc_set(value_make_exception("Cannot order EXCEPTION values")); 267 | return NULL; 268 | case VALUE_BOOL: 269 | exc_set(value_make_exception("Cannot order BOOLEAN values")); 270 | return NULL; 271 | case VALUE_INT: 272 | return INT(a) < INT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 273 | case VALUE_FLOAT: 274 | return FLOAT(a) < FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 275 | case VALUE_STRING: 276 | case VALUE_SYMBOL: 277 | return strcmp(STRING(a), STRING(b)) < 0 ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 278 | case VALUE_BUILTIN_FN: 279 | case VALUE_FN: 280 | case VALUE_MACRO_FN: 281 | exc_set(value_make_exception("Cannot order functions")); 282 | return NULL; 283 | case VALUE_LIST: 284 | exc_set(value_make_exception("Cannot order lists")); 285 | return NULL; 286 | } 287 | } else if (a->type == VALUE_INT && b->type == VALUE_FLOAT) { 288 | return ((float) INT(a)) < FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 289 | } else if (b->type == VALUE_INT && a->type == VALUE_FLOAT) { 290 | return FLOAT(a) < ((float) INT(b)) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 291 | } 292 | exc_set(value_make_exception("Cannot compare incompatible types")); 293 | return NULL; 294 | } 295 | 296 | static Value *cmp_leq(const Value *a, const Value *b) 297 | { 298 | if (a->type == b->type) { 299 | switch(a->type) { 300 | case VALUE_NIL: 301 | exc_set(value_make_exception("Cannot order NIL values")); 302 | return NULL; 303 | case VALUE_EXCEPTION: 304 | exc_set(value_make_exception("Cannot order EXCEPTION values")); 305 | return NULL; 306 | case VALUE_BOOL: 307 | exc_set(value_make_exception("Cannot order BOOLEAN values")); 308 | return NULL; 309 | case VALUE_INT: 310 | return INT(a) <= INT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 311 | case VALUE_FLOAT: 312 | return FLOAT(a) <= FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 313 | case VALUE_STRING: 314 | case VALUE_SYMBOL: 315 | return strcmp(STRING(a), STRING(b)) <= 0 ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 316 | case VALUE_BUILTIN_FN: 317 | case VALUE_FN: 318 | case VALUE_MACRO_FN: 319 | exc_set(value_make_exception("Cannot order functions")); 320 | return NULL; 321 | case VALUE_LIST: 322 | exc_set(value_make_exception("Cannot order lists")); 323 | return NULL; 324 | } 325 | } else if (a->type == VALUE_INT && b->type == VALUE_FLOAT) { 326 | return ((float) INT(a)) <= FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 327 | } else if (b->type == VALUE_INT && a->type == VALUE_FLOAT) { 328 | return FLOAT(a) <= ((float) INT(b)) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 329 | } 330 | exc_set(value_make_exception("Cannot compare incompatible types")); 331 | return NULL; 332 | } 333 | 334 | static Value *cmp_gt(const Value *a, const Value *b) 335 | { 336 | if (a->type == b->type) { 337 | switch(a->type) { 338 | case VALUE_NIL: 339 | exc_set(value_make_exception("Cannot order NIL values")); 340 | return NULL; 341 | case VALUE_EXCEPTION: 342 | exc_set(value_make_exception("Cannot order EXCEPTION values")); 343 | return NULL; 344 | case VALUE_BOOL: 345 | exc_set(value_make_exception("Cannot order BOOLEAN values")); 346 | return NULL; 347 | case VALUE_INT: 348 | return INT(a) > INT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 349 | case VALUE_FLOAT: 350 | return FLOAT(a) > FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 351 | case VALUE_STRING: 352 | case VALUE_SYMBOL: 353 | return strcmp(STRING(a), STRING(b)) > 0 ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 354 | case VALUE_BUILTIN_FN: 355 | case VALUE_FN: 356 | case VALUE_MACRO_FN: 357 | exc_set(value_make_exception("Cannot order functions")); 358 | return NULL; 359 | case VALUE_LIST: 360 | exc_set(value_make_exception("Cannot order lists")); 361 | return NULL; 362 | } 363 | } else if (a->type == VALUE_INT && b->type == VALUE_FLOAT) { 364 | return ((float) INT(a)) > FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 365 | } else if (b->type == VALUE_INT && a->type == VALUE_FLOAT) { 366 | return FLOAT(a) > ((float) INT(b)) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 367 | } 368 | exc_set(value_make_exception("Cannot compare incompatible types")); 369 | return NULL; 370 | } 371 | 372 | static Value *cmp_geq(const Value *a, const Value *b) 373 | { 374 | if (a->type == b->type) { 375 | switch(a->type) { 376 | case VALUE_NIL: 377 | exc_set(value_make_exception("Cannot order NIL values")); 378 | return NULL; 379 | case VALUE_EXCEPTION: 380 | exc_set(value_make_exception("Cannot order EXCEPTION values")); 381 | return NULL; 382 | case VALUE_BOOL: 383 | exc_set(value_make_exception("Cannot order BOOLEAN values")); 384 | return NULL; 385 | case VALUE_INT: 386 | return INT(a) >= INT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 387 | case VALUE_FLOAT: 388 | return FLOAT(a) >= FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 389 | case VALUE_STRING: 390 | case VALUE_SYMBOL: 391 | return strcmp(STRING(a), STRING(b)) >= 0 ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 392 | case VALUE_BUILTIN_FN: 393 | case VALUE_FN: 394 | case VALUE_MACRO_FN: 395 | exc_set(value_make_exception("Cannot order functions")); 396 | return NULL; 397 | case VALUE_LIST: 398 | exc_set(value_make_exception("Cannot order lists")); 399 | return NULL; 400 | } 401 | } else if (a->type == VALUE_INT && b->type == VALUE_FLOAT) { 402 | return ((float) INT(a)) >= FLOAT(b) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 403 | } else if (b->type == VALUE_INT && a->type == VALUE_FLOAT) { 404 | return FLOAT(a) >= ((float) INT(b)) ? VALUE_CONST_TRUE : VALUE_CONST_FALSE; 405 | } 406 | exc_set(value_make_exception("Cannot compare incompatible types")); 407 | return NULL; 408 | } 409 | 410 | static Value *compare(const Value *args, Value * (*comparison_fn)(const Value *, const Value *)) 411 | { 412 | // (= a b c) 413 | CHECK_ARGLIST(args); 414 | REQUIRE_LIST_CARDINALITY_GE(args, 2ul, "Require at least two values to compare"); 415 | const List *list = LIST(args); 416 | Value *head; 417 | Value *prev = NULL; 418 | while ((head = list_head(list)) != NULL) { 419 | if (prev) { 420 | Value *cmp_result = comparison_fn(prev, head); 421 | if (!(cmp_result == VALUE_CONST_TRUE)) { 422 | return cmp_result; 423 | } 424 | } 425 | prev = head; 426 | list = list_tail(list); 427 | } 428 | return VALUE_CONST_TRUE; 429 | } 430 | 431 | Value *core_eq(const Value *args) 432 | { 433 | return compare(args, cmp_eq); 434 | } 435 | 436 | Value *core_lt(const Value *args) 437 | { 438 | return compare(args, cmp_lt); 439 | } 440 | 441 | Value *core_leq(const Value *args) 442 | { 443 | return compare(args, cmp_leq); 444 | } 445 | 446 | Value *core_gt(const Value *args) 447 | { 448 | return compare(args, cmp_gt); 449 | } 450 | 451 | Value *core_geq(const Value *args) 452 | { 453 | return compare(args, cmp_geq); 454 | } 455 | 456 | 457 | static char *str_append(char *str, size_t n_str, char *partial, size_t n_partial) 458 | { 459 | str = realloc(str, n_str + n_partial + 1); 460 | strncat(str, partial, n_partial); 461 | return str; 462 | } 463 | 464 | static char *core_str_inner(char *str, const Value *v) 465 | { 466 | char *partial; 467 | switch(v->type) { 468 | case VALUE_NIL: 469 | str = str_append(str, strlen(str), "nil", 3); 470 | break; 471 | case VALUE_BOOL: 472 | partial = BOOL(v) ? "true" : "false"; 473 | str = str_append(str, strlen(str), partial, strlen(partial)); 474 | break; 475 | case VALUE_INT: 476 | asprintf(&partial, "%d", INT(v)); 477 | str = str_append(str, strlen(str), partial, strlen(partial)); 478 | free(partial); 479 | break; 480 | case VALUE_FLOAT: 481 | asprintf(&partial, "%f", FLOAT(v)); 482 | str = str_append(str, strlen(str), partial, strlen(partial)); 483 | free(partial); 484 | break; 485 | case VALUE_STRING: 486 | case VALUE_SYMBOL: 487 | case VALUE_EXCEPTION: 488 | asprintf(&partial, "%s", STRING(v)); 489 | str = str_append(str, strlen(str), partial, strlen(partial)); 490 | free(partial); 491 | break; 492 | case VALUE_LIST: 493 | str = str_append(str, strlen(str), "(", 1); 494 | Value *head2; 495 | const List *tail2 = v->value.list; 496 | while((head2 = list_head(tail2)) != NULL) { 497 | str = core_str_inner(str, head2); 498 | tail2 = list_tail(tail2); 499 | if (list_head(tail2)) { 500 | str = str_append(str, strlen(str), " ", 1); 501 | } 502 | } 503 | str = str_append(str, strlen(str), ")", 1); 504 | break; 505 | case VALUE_FN: 506 | case VALUE_MACRO_FN: 507 | str = str_append(str, strlen(str), "(lambda ", 8); 508 | str = core_str_inner(str, FN(v)->args); 509 | str = str_append(str, strlen(str), " ", 1); 510 | str = core_str_inner(str, FN(v)->body); 511 | str = str_append(str, strlen(str), ")", 1); 512 | break; 513 | case VALUE_BUILTIN_FN: 514 | asprintf(&partial, "#", (void *) v->value.builtin_fn); 515 | str = str_append(str, strlen(str), partial, strlen(partial)); 516 | free(partial); 517 | break; 518 | } 519 | return str; 520 | } 521 | 522 | Value *core_str_outer(const Value *args, bool printable) 523 | { 524 | if (!args) 525 | return value_new_string(""); 526 | 527 | char *str = calloc(1, sizeof(char)); 528 | if (args->type == VALUE_LIST) { 529 | const List *list = LIST(args); 530 | Value *head; 531 | while ((head = list_head(list)) != NULL) { 532 | str = core_str_inner(str, head); 533 | list = list_tail(list); 534 | if (printable) { 535 | str = str_append(str, strlen(str), " ", 1); 536 | } 537 | } 538 | } else { 539 | str = core_str_inner(str, args); 540 | } 541 | Value *ret = value_new_string(str); 542 | free(str); 543 | return ret; 544 | } 545 | 546 | Value *core_str(const Value *args) 547 | { 548 | return core_str_outer(args, false); 549 | } 550 | 551 | Value *core_pr(const Value *args) 552 | { 553 | Value *str = core_str_outer(args, true); 554 | fprintf(stdout, "%s", str->value.str); 555 | return VALUE_CONST_NIL; 556 | } 557 | 558 | 559 | Value *core_pr_str(const Value *args) 560 | { 561 | return core_str_outer(args, true); 562 | } 563 | 564 | 565 | Value *core_prn(const Value *args) 566 | { 567 | Value *str = core_str_outer(args, true); 568 | fprintf(stdout, "%s", str->value.str); 569 | fprintf(stdout, "\n"); 570 | fflush(stdout); 571 | return VALUE_CONST_NIL; 572 | } 573 | 574 | 575 | Value *core_count(const Value *args) 576 | { 577 | CHECK_ARGLIST(args); 578 | Value *list = ARG(args, 0); 579 | if (is_nil(list)) { 580 | return value_new_int(0); 581 | } 582 | REQUIRE_VALUE_TYPE(list, VALUE_LIST, "count requires a list argument"); 583 | return value_new_int(NARGS(list)); 584 | } 585 | 586 | Value *core_slurp(const Value *args) 587 | { 588 | CHECK_ARGLIST(args); 589 | REQUIRE_LIST_CARDINALITY(args, 1ul, "slurp takes exactly one argument"); 590 | // This is not for binary streams since we're using ftell. 591 | // (It's portable, though) 592 | Value *v = ARG(args, 0); 593 | REQUIRE_VALUE_TYPE(v, VALUE_STRING, "slurp takes a string argument"); 594 | Value *retval = NULL; 595 | FILE *f = NULL; 596 | if (!(f = fopen(STRING(v), "r"))) { 597 | exc_set(value_make_exception("Failed to open file %s: %s", STRING(v), strerror(errno))); 598 | goto out; 599 | } 600 | int ret; 601 | if ((ret = fseek(f, 0L, SEEK_END)) != 0) { 602 | exc_set(value_make_exception("Failed to determine file size for %s: %s", 603 | STRING(v), strerror(errno))); 604 | goto out_file; 605 | } 606 | long fsize; 607 | if ((fsize = ftell(f)) < 0) { 608 | exc_set(value_make_exception("Failed to determine file size for %s: %s", 609 | STRING(v), strerror(errno))); 610 | goto out_file; 611 | } 612 | char *buf = malloc(fsize + 1); 613 | if ((ret = fseek(f, 0L, SEEK_SET)) != 0) { 614 | exc_set(value_make_exception("Failed to read file %s", STRING(v))); 615 | goto out_buf; 616 | } 617 | size_t n_read; 618 | if ((n_read = fread(buf, 1, fsize, f)) < (size_t) fsize) { 619 | exc_set(value_make_exception("Failed to read file %s", STRING(v))); 620 | goto out_buf; 621 | } 622 | buf[fsize] = '\0'; 623 | retval = value_new_string(buf); // FIXME: fx value constructors to avoid copy 624 | out_buf: 625 | free(buf); 626 | out_file: 627 | fclose(f); 628 | out: 629 | return retval; 630 | } 631 | 632 | 633 | Value *core_cons(const Value *args) 634 | { 635 | CHECK_ARGLIST(args); 636 | REQUIRE_LIST_CARDINALITY(args, 2ul, "CONS takes exactly two arguments"); 637 | Value *first = ARG(args, 0); 638 | Value *second = ARG(args, 1); 639 | REQUIRE_VALUE_TYPE(second, VALUE_LIST, "the second parameter to CONS must be a list"); 640 | return value_new_list(list_prepend(LIST(second), first)); 641 | } 642 | 643 | Value *core_concat(const Value *args) 644 | { 645 | CHECK_ARGLIST(args); 646 | const List *concat = list_new(); 647 | for (const ListItem *i = LIST(args)->head; i != NULL; i = i->next) { 648 | Value *v = i->val; 649 | REQUIRE_VALUE_TYPE(v, VALUE_LIST, "all parameters to CONCAT must be lists"); 650 | for (const ListItem *j = LIST(v)->head; j != NULL; j = j->next) { 651 | concat = list_append(concat, j->val); 652 | } 653 | } 654 | return value_new_list(concat); 655 | } 656 | 657 | Value *core_map(const Value *args) 658 | { 659 | /* (map f '(a b c ...)) */ 660 | CHECK_ARGLIST(args); 661 | REQUIRE_LIST_CARDINALITY(args, 2ul, "MAP takes exactly two parameters"); 662 | Value *fn = ARG(args, 0); 663 | Value *fn_args = ARG(args, 1); 664 | 665 | REQUIRE_VALUE_TYPE(fn_args, VALUE_LIST, "The second parameter to MAP must be a list"); 666 | const List *mapped = list_new(); 667 | Value *tco_expr = NULL; 668 | Environment *tco_env; 669 | for (size_t i = 0; i < list_size(LIST(fn_args)); ++i) { 670 | Value *result = apply(fn, value_make_list(ARG(fn_args, i)), 671 | &tco_expr, &tco_env); 672 | /* apply() may defer to eval() because of TCO support, we 673 | * need to catch that and eval the expression */ 674 | if (tco_expr && !exc_is_pending()) { 675 | result = eval(tco_expr, tco_env); 676 | } 677 | if (!result) { 678 | assert(exc_is_pending()); 679 | return NULL; 680 | } 681 | mapped = list_append(mapped, result); 682 | } 683 | return value_new_list(mapped); 684 | } 685 | 686 | Value *core_apply(const Value *args) 687 | { 688 | /* (apply f a b c d ...) == (f a b c d ...) */ 689 | CHECK_ARGLIST(args); 690 | REQUIRE_LIST_CARDINALITY_GE(args, 2ul, "APPLY requires at least two arguments"); 691 | Value *fn = ARG(args, 0); 692 | Value *fn_args = value_new_list(list_tail(LIST(args))); 693 | size_t n_args = NARGS(fn_args); 694 | 695 | /* The last argument may be a list; if it is, we need to prepend 696 | * the other args to that list to yield the final list of arguments */ 697 | if (n_args > 0 && is_list(ARG(fn_args, n_args - 1))) { 698 | const List *concat = list_dup(LIST(ARG(fn_args, n_args - 1))); 699 | for (size_t i = 0; i < (n_args - 1); ++i) { 700 | concat = list_prepend(concat, ARG(fn_args, i)); 701 | } 702 | fn_args = value_new_list(concat); 703 | } 704 | Value *tco_expr; 705 | Environment *tco_env; 706 | Value *result = apply(fn, fn_args, &tco_expr, &tco_env); 707 | /* need to call eval since apply defers to eval for TCO support */ 708 | if (tco_expr && !exc_is_pending()) { 709 | result = eval(tco_expr, tco_env); 710 | } 711 | if (!result) { 712 | assert(exc_is_pending()); 713 | return NULL; 714 | } 715 | return result; 716 | } 717 | 718 | Value *core_is_nil(const Value *args) 719 | { 720 | CHECK_ARGLIST(args); 721 | REQUIRE_LIST_CARDINALITY(args, 1ul, "NIL? takes exactly one argument"); 722 | Value *expr = ARG(args, 0); 723 | return value_new_bool(is_nil(expr)); 724 | } 725 | 726 | Value *core_is_true(const Value *args) 727 | { 728 | CHECK_ARGLIST(args); 729 | REQUIRE_LIST_CARDINALITY(args, 1ul, "TRUE? takes exactly one argument"); 730 | Value *expr = ARG(args, 0); 731 | return value_new_bool(is_true(expr)); 732 | } 733 | 734 | Value *core_is_false(const Value *args) 735 | { 736 | CHECK_ARGLIST(args); 737 | REQUIRE_LIST_CARDINALITY(args, 1ul, "FALSE? takes exactly one argument"); 738 | Value *expr = ARG(args, 0); 739 | return value_new_bool(is_false(expr)); 740 | } 741 | 742 | Value *core_is_symbol(const Value *args) 743 | { 744 | CHECK_ARGLIST(args); 745 | REQUIRE_LIST_CARDINALITY(args, 1ul, "SYMBOL? takes exactly one argument"); 746 | Value *expr = ARG(args, 0); 747 | return value_new_bool(is_symbol(expr)); 748 | } 749 | 750 | Value *core_symbol(const Value *args) 751 | { 752 | CHECK_ARGLIST(args); 753 | REQUIRE_LIST_CARDINALITY(args, 1ul, "SYMBOL takes exactly one argument"); 754 | Value *expr = ARG(args, 0); 755 | return value_new_symbol(STRING(expr)); 756 | } 757 | 758 | Value *core_assert(const Value *args) 759 | { 760 | CHECK_ARGLIST(args); 761 | size_t nargs = NARGS(args); 762 | if (nargs < 1 || nargs > 2) { 763 | exc_set(value_make_exception("Invalid argument list in core function: " 764 | "core_assert takes 1 or 2 arguments.")); 765 | return NULL; 766 | } 767 | const Value *arg0 = ARG(args, 0); 768 | const Value *arg1 = NULL; 769 | if (nargs == 2) { 770 | arg1 = ARG(args, 1); 771 | REQUIRE_VALUE_TYPE(arg1, VALUE_STRING, 772 | "Second argument to assert must be a string"); 773 | } 774 | if (is_truthy(arg0)) { 775 | return VALUE_CONST_NIL; 776 | } 777 | if (nargs == 1) { 778 | exc_set(value_make_exception("Assert failed: %s is not true.", 779 | core_pr_str(arg0)->value.str)); 780 | } else { 781 | exc_set(value_make_exception("Assert failed: %s", STRING(arg1))); 782 | } 783 | return NULL; 784 | } 785 | 786 | Value *core_throw(const Value *args) 787 | { 788 | REQUIRE_LIST_CARDINALITY(args, 1ul, "THROW takes exactly one argument"); 789 | Value *value = ARG(args, 0); 790 | exc_set(value); // FIXME: we expect .string to be valid... 791 | return NULL; 792 | } 793 | 794 | Value *core_nth(const Value *args) 795 | { 796 | // (nth collection index) 797 | CHECK_ARGLIST(args); 798 | REQUIRE_LIST_CARDINALITY(args, 2ul, "NTH takes exactly two arguments"); 799 | Value *coll = ARG(args, 0); 800 | REQUIRE_VALUE_TYPE(coll, VALUE_LIST, "First argument to nth must be a collection"); 801 | Value *pos = ARG(args, 1); 802 | REQUIRE_VALUE_TYPE(pos, VALUE_INT, "Second argument to nth must be an integer"); 803 | if (INT(pos) < 0 || (unsigned) INT(pos) >= NARGS(coll)) { 804 | exc_set(value_make_exception("Index error")); 805 | return NULL; 806 | } 807 | return ARG(coll, (unsigned) INT(pos)); 808 | } 809 | 810 | Value *core_first(const Value *args) 811 | { 812 | // (first coll) 813 | CHECK_ARGLIST(args); 814 | REQUIRE_LIST_CARDINALITY(args, 1ul, "FIRST takes exactly one argument"); 815 | Value *coll = ARG(args, 0); 816 | if (is_nil(coll) || NARGS(coll) == 0) { 817 | return VALUE_CONST_NIL; 818 | } 819 | REQUIRE_VALUE_TYPE(coll, VALUE_LIST, "Argument to FIRST must be a collection or NIL"); 820 | return ARG(coll, 0); 821 | } 822 | 823 | Value *core_rest(const Value *args) 824 | { 825 | // (rest coll) 826 | CHECK_ARGLIST(args); 827 | REQUIRE_LIST_CARDINALITY(args, 1ul, "REST takes exactly one argument"); 828 | Value *coll = ARG(args, 0); 829 | if (is_nil(coll) || NARGS(coll) <= 1) { 830 | return value_new_list(NULL); 831 | } 832 | REQUIRE_VALUE_TYPE(coll, VALUE_LIST, "Argument to REST must be a collection or NIL"); 833 | return value_new_list(list_tail(LIST(coll))); 834 | } 835 | -------------------------------------------------------------------------------- /src/core.stt: -------------------------------------------------------------------------------- 1 | (define *VERSION* "stutter-0.1.0") 2 | 3 | (defmacro defn (name parameters body) `(define ~name (lambda ~parameters ~body))) 4 | 5 | (defn not (a) (if a false true)) 6 | -------------------------------------------------------------------------------- /src/djb2.c: -------------------------------------------------------------------------------- 1 | /* 2 | * djb2.c 3 | * 4 | * http://www.cse.yorku.ca/~oz/hash.html 5 | * 6 | * DJBX33A (Daniel J. Bernstein, Times 33 with Addition) 7 | * 8 | * This is Daniel J. Bernstein's popular `times 33' hash function as 9 | * posted by him years ago on comp.lang.c. It basically uses a function 10 | * like ``hash(i) = hash(i-1) * 33 + str[i]''. This is one of the best 11 | * known hash functions for strings. Because it is both computed very 12 | * fast and distributes very well. 13 | * 14 | * The magic of number 33, i.e. why it works better than many other 15 | * constants, prime or not, has never been adequately explained by 16 | * anyone. So I try an explanation: if one experimentally tests all 17 | * multipliers between 1 and 256 (as RSE did now) one detects that even 18 | * numbers are not useable at all. The remaining 128 odd numbers 19 | * (except for the number 1) work more or less all equally well. They 20 | * all distribute in an acceptable way and this way fill a hash table 21 | * with an average percent of approx. 86%. 22 | * 23 | * If one compares the Chi^2 values of the variants, the number 33 not 24 | * even has the best value. But the number 33 and a few other equally 25 | * good numbers like 17, 31, 63, 127 and 129 have nevertheless a great 26 | * advantage to the remaining numbers in the large set of possible 27 | * multipliers: their multiply operation can be replaced by a faster 28 | * operation based on just one shift plus either a single addition 29 | * or subtraction operation. And because a hash function has to both 30 | * distribute good _and_ has to be very fast to compute, those few 31 | * numbers should be preferred and seems to be the reason why Daniel J. 32 | * Bernstein also preferred it. 33 | * 34 | * 35 | * -- Ralf S. Engelschall 36 | */ 37 | 38 | #include "djb2.h" 39 | 40 | 41 | unsigned long djb2(char *str) 42 | { 43 | unsigned char *s = (unsigned char *) str; 44 | unsigned long hash = 5381; 45 | int c; 46 | 47 | while ((c = *s++)) { 48 | hash = ((hash << 5) + hash) + c; /* hash * 33 + c */ 49 | } 50 | 51 | return hash; 52 | } 53 | 54 | -------------------------------------------------------------------------------- /src/env.c: -------------------------------------------------------------------------------- 1 | #include "env.h" 2 | #include "gc.h" 3 | #include "log.h" 4 | #include "value.h" 5 | 6 | Environment *env_new(Environment *parent) 7 | { 8 | Environment *env = gc_malloc(&gc, sizeof(Environment)); 9 | env->parent = parent; 10 | env->map = map_new(32); 11 | return env; 12 | } 13 | 14 | void env_set(Environment *env, char *symbol, const Value *value) 15 | { 16 | map_put(env->map, symbol, (void *) value, sizeof(Value)); 17 | } 18 | 19 | Value *env_get(Environment *env, char *symbol) 20 | { 21 | Environment *cur_env = env; 22 | Value *value; 23 | while(cur_env) { 24 | if (cur_env->map) { 25 | if ((value = (Value *) map_get(cur_env->map, symbol))) { 26 | return value; 27 | } 28 | } 29 | cur_env = cur_env->parent; 30 | } 31 | return NULL; 32 | } 33 | 34 | bool env_contains(Environment *env, char *symbol) 35 | { 36 | return env_get(env, symbol) != NULL; 37 | } 38 | -------------------------------------------------------------------------------- /src/eval.c: -------------------------------------------------------------------------------- 1 | #include "eval.h" 2 | 3 | #include 4 | #include 5 | #include 6 | #include "apply.h" 7 | #include "list.h" 8 | #include "log.h" 9 | #include "core.h" 10 | #include "exc.h" 11 | 12 | static bool is_self_evaluating(const Value *value) 13 | { 14 | return value->type == VALUE_FLOAT 15 | || value->type == VALUE_INT 16 | || value->type == VALUE_STRING 17 | || value->type == VALUE_NIL 18 | || value->type == VALUE_FN; 19 | } 20 | 21 | static bool is_variable(const Value *value) 22 | { 23 | return is_symbol(value); 24 | } 25 | 26 | static bool is_list_that_starts_with(const Value *value, const char *what, size_t len) 27 | { 28 | if (value && is_list(value)) { 29 | Value *symbol; 30 | if ((symbol = list_head(LIST(value))) && is_symbol(symbol) && 31 | strncmp(SYMBOL(symbol), what, len) == 0) { 32 | return true; 33 | } 34 | } 35 | return false; 36 | } 37 | 38 | static bool is_quoted(const Value *value) 39 | { 40 | return is_list_that_starts_with(value, "quote", 5); 41 | } 42 | 43 | static bool is_quasiquoted(const Value *value) 44 | { 45 | return is_list_that_starts_with(value, "quasiquote", 10); 46 | } 47 | 48 | static bool is_assignment(const Value *value) 49 | { 50 | // (set! var value) 51 | return is_list_that_starts_with(value, "set!", 4); 52 | } 53 | 54 | static bool is_definition(const Value *value) 55 | { 56 | // (define var value) 57 | return is_list_that_starts_with(value, "def", 3); 58 | } 59 | 60 | static bool is_macro_definition(const Value *value) 61 | { 62 | // (define var value) 63 | return is_list_that_starts_with(value, "defmacro", 8); 64 | } 65 | 66 | static bool is_let(const Value *value) 67 | { 68 | // (let (n1 v1 n2 v2 ...) body) 69 | return is_list_that_starts_with(value, "let", 4); 70 | } 71 | 72 | static bool is_lambda(const Value *value) 73 | { 74 | // (lambda (p1 ... pn) body) 75 | return is_list_that_starts_with(value, "lambda", 6); 76 | } 77 | 78 | static bool is_if(const Value *value) 79 | { 80 | return is_list_that_starts_with(value, "if", 2); 81 | } 82 | 83 | static bool is_do(const Value *value) 84 | { 85 | return is_list_that_starts_with(value, "do", 2); 86 | } 87 | 88 | static bool is_try(const Value *value) 89 | { 90 | return is_list_that_starts_with(value, "try", 3); 91 | } 92 | 93 | static Value *get_macro_fn(const Value *form, Environment *env) 94 | { 95 | /* 96 | * Takes a list, extracts the first element, checks if it is 97 | * a symbol and if that symbol resolves into a macro function. 98 | */ 99 | assert(form && env); 100 | if (is_list(form)) { 101 | Value *first = list_head(LIST(form)); 102 | if (first && is_symbol(first)) { 103 | Value *fn = env_get(env, SYMBOL(first)); 104 | if (fn && is_macro(fn)) 105 | return fn; 106 | } 107 | } 108 | return NULL; 109 | } 110 | 111 | static bool is_macro_expansion(const Value *value) 112 | { 113 | return is_list_that_starts_with(value, "macroexpand", 11); 114 | } 115 | 116 | 117 | static bool is_application(const Value *value) 118 | { 119 | return is_list(value); 120 | } 121 | 122 | static bool has_cardinality(const Value *expr, const size_t cardinality) 123 | { 124 | return expr && is_list(expr) && list_size(LIST(expr)) == cardinality; 125 | } 126 | 127 | static Value *lookup_variable_value(Value *expr, Environment *env) 128 | { 129 | Value *sym = NULL; 130 | if ((sym = env_get(env, SYMBOL(expr))) == NULL) { 131 | exc_set(value_make_exception("Unknown name: %s", SYMBOL(expr))); 132 | return NULL; 133 | } 134 | return sym; 135 | } 136 | 137 | static Value *eval_quote(Value *expr) 138 | { 139 | // (quote expr) 140 | if (expr && has_cardinality(expr, 2)) { 141 | return list_nth(LIST(expr), 1); 142 | } 143 | exc_set(value_make_exception("Invalid parameter to built-in quote")); 144 | return NULL; 145 | } 146 | 147 | static Value *eval_assignment(Value *expr, Environment *env) 148 | { 149 | // (set! var value) 150 | if (has_cardinality(expr, 3)) { 151 | Value *name = list_nth(LIST(expr), 1); 152 | if (env_contains(env, SYMBOL(name))) { 153 | Value *value = list_nth(LIST(expr), 2); 154 | value = eval(value, env); 155 | if (!value) { 156 | assert(exc_is_pending()); 157 | return NULL; 158 | } 159 | env_set(env, SYMBOL(name), value); 160 | return value; 161 | } 162 | exc_set(value_make_exception("Could not find symbol %s.", SYMBOL(name))); 163 | return NULL; 164 | } 165 | exc_set(value_make_exception("set! requires 2 args")); 166 | return NULL; 167 | } 168 | 169 | static Value *eval_definition(Value *expr, Environment *env) 170 | { 171 | // (def name value) 172 | assert(expr); 173 | if (has_cardinality(expr, 3)) { 174 | Value *name = list_nth(LIST(expr), 1); 175 | Value *value = list_nth(LIST(expr), 2); 176 | value = eval(value, env); 177 | if (!value) { 178 | assert(exc_is_pending()); 179 | return NULL; 180 | } 181 | env_set(env, SYMBOL(name), value); 182 | return value; 183 | } 184 | exc_set(value_make_exception("def requires 2 args")); 185 | return NULL; 186 | } 187 | 188 | static Value *eval_macro_definition(Value *expr, Environment *env) 189 | { 190 | // (defmacro name parameters expr) 191 | if (has_cardinality(expr, 4)) { 192 | Value *name = list_nth(LIST(expr), 1); 193 | Value *args = list_nth(LIST(expr), 2); 194 | Value *body = list_nth(LIST(expr), 3); 195 | Value *macro = value_new_macro(args, body, env); 196 | env_set(env, SYMBOL(name), macro); 197 | return macro; 198 | } 199 | exc_set(value_make_exception("Invalid macro declaration")); 200 | return NULL; 201 | } 202 | 203 | static Value *eval_let(Value *expr, Environment *env, Value **tco_expr, Environment **tco_env) 204 | { 205 | // (let (n1 v1 n2 v2 ...) (body)) 206 | if (has_cardinality(expr, 3)) { 207 | Environment *inner = env_new(env); 208 | Value *assignments = list_nth(LIST(expr), 1); 209 | if (!is_list(assignments) || list_size(LIST(assignments)) % 2 != 0) { 210 | exc_set(value_make_exception("Invalid assignment list in let")); 211 | return NULL; 212 | } 213 | const List *list = LIST(assignments); 214 | Value *name = list_head(list); 215 | Value *value = list_head(list_tail(list)); 216 | Value *evaluated_value; 217 | while (name) { 218 | evaluated_value = eval(value, inner); 219 | if (!evaluated_value) { 220 | assert(exc_is_pending()); 221 | return NULL; 222 | } 223 | env_set(inner, SYMBOL(name), evaluated_value); 224 | list = list_tail(list_tail(list)); // +2 225 | name = list_head(list); 226 | value = name ? list_head(list_tail(list)) : NULL; 227 | } 228 | // TCO 229 | *tco_expr = list_nth(LIST(expr), 2); 230 | *tco_env = inner; 231 | return NULL; // tco must return NULL 232 | } 233 | exc_set(value_make_exception("Invalid let declaration, require 2 args")); 234 | return NULL; 235 | } 236 | 237 | static Value *eval_if(Value *expr, Environment *env, Value **tco_expr, Environment **tco_env) 238 | { 239 | // (if predicate consequent alternative) 240 | if (has_cardinality(expr, 4)) { 241 | Value *predicate = eval(list_nth(LIST(expr), 1), env); 242 | if (!predicate) { 243 | assert(exc_is_pending()); 244 | return NULL; 245 | } 246 | if (is_truthy(predicate)) { 247 | *tco_expr = list_nth(LIST(expr), 2); 248 | } else { 249 | *tco_expr = list_nth(LIST(expr), 3); 250 | } 251 | *tco_env = env; 252 | return NULL; // tco must return NULL 253 | } 254 | exc_set(value_make_exception("Invalid if declaration, require 3 args")); 255 | return NULL; 256 | } 257 | 258 | static Value *eval_try(Value *expr, Environment *env) 259 | { 260 | // (try sexpr (catch ex sexpr)) 261 | if (has_cardinality(expr, 3)) { 262 | Value *catch_form = list_nth(LIST(expr), 2); 263 | if (!has_cardinality(catch_form, 3)) { 264 | exc_set(value_make_exception("Invalid catch declaration, require 2 arguments")); 265 | return NULL; 266 | } 267 | Value *result = eval(list_nth(LIST(expr), 1), env); 268 | if (!result) { 269 | assert(exc_is_pending()); 270 | // LOG_CRITICAL("Caught exception: %s", EXCEPTION(exc_get())); 271 | Environment *ex_env = env_new(env); 272 | Value *name = list_nth(LIST(catch_form), 1); 273 | env_set(ex_env, STRING(name), exc_get()); 274 | exc_clear(); 275 | result = eval(list_nth(LIST(catch_form), 2), ex_env); 276 | if (!result) { 277 | // catch threw an exception 278 | assert(exc_is_pending()); 279 | return NULL; 280 | } 281 | } 282 | return result; 283 | } 284 | exc_set(value_make_exception("Invalid try declaration, require 2 arguments")); 285 | return NULL; 286 | } 287 | 288 | static Value *declare_fn(Value *expr, Environment *env) 289 | { 290 | // (lambda (p1 p2 ..) (expr)) 291 | if (has_cardinality(expr, 3)) { 292 | Value *args = list_nth(LIST(expr), 1); 293 | Value *body = list_nth(LIST(expr), 2); 294 | Value *fn = value_new_fn(args, body, env); 295 | return fn; 296 | } 297 | exc_set(value_make_exception("Invalid lambda declaration, require 2 arguments")); 298 | return NULL; 299 | } 300 | 301 | static Value *eval_do(Value *expr, Environment *env, Value **tco_expr, Environment **tco_env) 302 | { 303 | // (do sexpr sexpr ...) 304 | Value *head; 305 | const List *list = list_tail(LIST(expr)); 306 | while((head = list_head(list)) != NULL) { 307 | list = list_tail(list); 308 | if (list_size(list) == 0) { 309 | *tco_expr = head; 310 | *tco_env = env; 311 | return NULL; 312 | } 313 | Value *result = eval(head, env); 314 | if (!result) { 315 | assert(exc_is_pending()); 316 | return NULL; 317 | } 318 | } 319 | assert(0); // unreachable 320 | return NULL; 321 | } 322 | 323 | static Value *_quasiquote(Value *arg) 324 | { 325 | /* 326 | * The idea here is to recursively rewrite the syntax tree (the IR form). 327 | * Note that quasiquote, unquote and splice-unquote forms all take an expression 328 | * as their single argument (expressions are represented as atoms or lists in 329 | * IR). In addition, `splice-unquote` is only valid in a sequence context 330 | * and we expect its argument to return a sequence after evaluation. 331 | * 332 | * Hence, 333 | * 334 | * 1. If arg is not a list, we return `(quote arg)` 335 | * 2. If arg is a list and the list starts with the `unquote` symbol, we 336 | * return `arg` 337 | * 3. If arg is a list and it's first item arg[0] is a list that starts with 338 | * the `splice-unquote` symbol in arg[0][0], we return 339 | * `(concat arg[0][1] (quasiquote (tail arg)))` 340 | * 4. If the arg is an ordinary list, we cons the quasiquoted first item with 341 | * the quasiquotation of the rest: `(cons (quasiquote arg[0]) (quasiquote (tail arg)))` 342 | * 343 | * Step 3 basically replaces the `cons` with a `concat` in the right places. 344 | */ 345 | 346 | /* require a valid pointer */ 347 | if (!arg) return NULL; 348 | 349 | /* If the argument is not a list then act like quote */ 350 | if (!(is_list(arg) && list_size(LIST(arg)) > 0)) { 351 | Value *ret = value_make_list(value_new_symbol("quote")); 352 | LIST(ret) = list_append(LIST(ret), arg); 353 | return ret; 354 | } 355 | /* arg is a list, let's peek at the first item */ 356 | Value *arg0 = list_head(LIST(arg)); 357 | if (arg0->type == VALUE_SYMBOL && strncmp(STRING(arg0), "unquote", 7) == 0) { 358 | if (list_size(LIST(arg)) != 2) { 359 | exc_set(value_make_exception( 360 | "Invalid unquote declaration, require 1 argument")); 361 | return NULL; 362 | } 363 | Value *arg1 = list_nth(LIST(arg), 1); 364 | return arg1; 365 | } else if (is_list(arg0)) { 366 | /* arg is a list that starts with a list. Let's see if it starts with splice-unquote */ 367 | Value *arg00 = list_head(LIST(arg0)); 368 | if (is_symbol(arg00) && strncmp(SYMBOL(arg00), "splice-unquote", 14) == 0) { 369 | if (list_size(LIST(arg0)) != 2) { 370 | exc_set(value_make_exception("splice-unquote takes a single parameter")); 371 | return NULL; 372 | } 373 | Value *arg01 = list_nth(LIST(arg0), 1); 374 | Value *ast = value_make_list(value_new_symbol("concat")); 375 | LIST(ast) = list_append(LIST(ast), arg01); 376 | LIST(ast) = list_append(LIST(ast), _quasiquote(value_new_list(list_tail(LIST(arg))))); 377 | return ast; 378 | } 379 | } 380 | Value *ast = value_make_list(value_new_symbol("cons")); 381 | LIST(ast) = list_append(LIST(ast), _quasiquote(arg0)); 382 | LIST(ast) = list_append(LIST(ast), _quasiquote(value_new_list(list_tail(LIST(arg))))); 383 | return ast; 384 | } 385 | 386 | static Value *eval_quasiquote(Value *expr, Environment *env, 387 | Value **tco_expr, Environment **tco_env) 388 | { 389 | /* (quasiquote expr) */ 390 | if (!(is_list(expr) && list_size(LIST(expr)) == 2)) { 391 | exc_set(value_make_exception("quasiquote requires a single list as parameter")); 392 | return NULL; 393 | } 394 | Value *args = list_nth(LIST(expr), 1); 395 | *tco_expr = _quasiquote(args); 396 | *tco_env = env; 397 | return NULL; 398 | } 399 | 400 | static Value *operator(Value *expr) 401 | { 402 | Value *op = NULL; 403 | if (expr && is_list(expr)) { 404 | op = list_head(LIST(expr)); 405 | if (!op) { 406 | exc_set(value_make_exception("Could not find operator in list")); 407 | return NULL; 408 | } 409 | } 410 | return op; 411 | } 412 | 413 | static Value *operands(Value *expr) 414 | { 415 | Value *ops = NULL; 416 | if (expr && is_list(expr)) { 417 | ops = value_new_list(list_tail(LIST(expr))); 418 | } 419 | return ops; 420 | } 421 | 422 | static Value *macroexpand(Value *form, Environment *env) 423 | { 424 | assert(form && env); 425 | Value *fn; 426 | Value *args; 427 | Value *expr = form; 428 | Environment *new_env = env; 429 | while(expr && (fn = get_macro_fn(expr, new_env)) != NULL) { 430 | args = value_new_list(list_tail(LIST(expr))); 431 | apply(fn, args, &expr, &new_env); 432 | expr = eval(expr, new_env); 433 | if (!expr) { 434 | assert(exc_is_pending()); 435 | return NULL; 436 | } 437 | } 438 | return expr; 439 | } 440 | 441 | static Value *macroexpand_1(Value *expr, Environment *env) 442 | { 443 | if (!is_list(expr)) { // FIXME: this is checking the outer list 444 | exc_set(value_make_exception("Require macro call for expansion")); 445 | return NULL; 446 | } 447 | Value *args = list_head(list_tail(LIST(expr))); 448 | return macroexpand(args, env); 449 | } 450 | 451 | static Value *eval_all(Value *expr, Environment *env) 452 | { 453 | // eval every element of a list 454 | const List *list = LIST(expr); 455 | const List *evaluated_list = list_new(); 456 | Value *head; 457 | Value *evaluated_head; 458 | while ((head = list_head(list)) != NULL) { 459 | evaluated_head = eval(head, env); 460 | if (!evaluated_head) { 461 | assert(exc_is_pending()); 462 | return NULL; 463 | } 464 | evaluated_list = list_append(evaluated_list, evaluated_head); 465 | list = list_tail(list); 466 | } 467 | LIST(expr) = evaluated_list; 468 | return value_new_list(evaluated_list); 469 | } 470 | 471 | 472 | Value *eval(Value *expr, Environment *env) 473 | { 474 | Value *tco_expr = NULL; 475 | Value *ret = NULL; 476 | Environment *tco_env = NULL; 477 | tco: 478 | if (!expr) { 479 | assert(exc_is_pending()); 480 | return NULL; 481 | } 482 | if (is_self_evaluating(expr)) { 483 | return expr; 484 | } else if (is_variable(expr)) { 485 | ret = lookup_variable_value(expr, env); 486 | return ret; 487 | } 488 | expr = macroexpand(expr, env); 489 | if (!expr) { 490 | LOG_CRITICAL("Macro expansion failed."); 491 | assert(exc_is_pending()); 492 | return expr; 493 | } 494 | if (!is_list(expr)) goto tco; 495 | if (is_quoted(expr)) { 496 | return eval_quote(expr); 497 | } else if (is_quasiquoted(expr)) { 498 | tco_expr = NULL; 499 | tco_env = NULL; 500 | Value *result = eval_quasiquote(expr, env, &tco_expr, &tco_env); 501 | if (tco_expr && tco_env) { 502 | expr = tco_expr; 503 | env = tco_env; 504 | goto tco; 505 | } 506 | if (!result) { 507 | assert(exc_is_pending()); 508 | return NULL; 509 | } 510 | return result; 511 | } else if (is_assignment(expr)) { 512 | return eval_assignment(expr, env); 513 | } else if (is_macro_definition(expr)) { 514 | return eval_macro_definition(expr, env); 515 | } else if (is_definition(expr)) { 516 | return eval_definition(expr, env); 517 | } else if (is_let(expr)) { 518 | tco_expr = NULL; 519 | tco_env = NULL; 520 | Value *result = eval_let(expr, env, &tco_expr, &tco_env); 521 | if (tco_expr && tco_env) { 522 | expr = tco_expr; 523 | env = tco_env; 524 | goto tco; 525 | } 526 | if (!result) { 527 | assert(exc_is_pending()); 528 | return NULL; 529 | } 530 | return result; 531 | } else if (is_if(expr)) { 532 | tco_expr = NULL; 533 | tco_env = NULL; 534 | Value *result = eval_if(expr, env, &tco_expr, &tco_env); 535 | if (tco_expr && tco_env) { 536 | expr = tco_expr; 537 | env = tco_env; 538 | goto tco; 539 | } 540 | if (!result) { 541 | assert(exc_is_pending()); 542 | return NULL; 543 | } 544 | return result; 545 | } else if (is_do(expr)) { 546 | tco_expr = NULL; 547 | tco_env = NULL; 548 | Value *result = eval_do(expr, env, &tco_expr, &tco_env); 549 | if (tco_expr && tco_env) { 550 | expr = tco_expr; 551 | env = tco_env; 552 | goto tco; 553 | } 554 | if (!result) { 555 | assert(exc_is_pending()); 556 | return NULL; 557 | } 558 | return result; 559 | } else if (is_try(expr)) { 560 | return eval_try(expr, env); 561 | } else if (is_lambda(expr)) { 562 | return declare_fn(expr, env); 563 | } else if (is_macro_expansion(expr)) { 564 | return macroexpand_1(expr, env); 565 | } else if (is_application(expr)) { 566 | tco_expr = NULL; 567 | tco_env = NULL; 568 | Value *fn = eval(operator(expr), env); 569 | if (!fn) { 570 | assert(exc_is_pending()); 571 | return NULL; 572 | } 573 | Value *args = eval_all(operands(expr), env); 574 | if (!args) { 575 | assert(exc_is_pending()); 576 | return NULL; 577 | } 578 | ret = apply(fn, args, &tco_expr, &tco_env); 579 | if (tco_expr && tco_env) { 580 | expr = tco_expr; 581 | env = tco_env; 582 | goto tco; 583 | } 584 | if (!ret) { 585 | assert(exc_is_pending()); 586 | return NULL; 587 | } 588 | return ret; 589 | } 590 | LOG_CRITICAL("Unknown expression: %d", expr->type); 591 | exc_set(value_new_exception("Unknown expression")); 592 | return NULL; 593 | } 594 | -------------------------------------------------------------------------------- /src/exc.c: -------------------------------------------------------------------------------- 1 | #include "exc.h" 2 | #include "log.h" 3 | 4 | #include 5 | 6 | static const Value *exc_current = NULL; 7 | 8 | void exc_set(const Value *error) 9 | { 10 | if (exc_is_pending()) { 11 | LOG_CRITICAL( 12 | "Raised exception: '%s' but cannot raise without handling existing exception '%s'", 13 | STRING(error), STRING(exc_current)); 14 | assert(0); 15 | } 16 | exc_current = error; 17 | } 18 | 19 | const Value *exc_get() 20 | { 21 | return exc_current; 22 | } 23 | 24 | void exc_clear() 25 | { 26 | exc_current = NULL; 27 | } 28 | 29 | bool exc_is_pending() 30 | { 31 | return exc_current != NULL; 32 | } 33 | -------------------------------------------------------------------------------- /src/ir.c: -------------------------------------------------------------------------------- 1 | #include "ir.h" 2 | #include "log.h" 3 | 4 | Value *ir_from_ast(AstSexpr *ast) 5 | { 6 | return ir_from_ast_sexpr(ast); 7 | } 8 | 9 | Value *ir_from_ast_atom(AstAtom *atom) 10 | { 11 | Value *v; 12 | switch (atom->node.type) { 13 | case AST_ATOM_FLOAT: 14 | v = value_new_float(atom->as.decimal); 15 | break; 16 | case AST_ATOM_INT: 17 | v = value_new_int(atom->as.integer); 18 | break; 19 | case AST_ATOM_STRING: 20 | v = value_new_string(atom->as.string); 21 | break; 22 | case AST_ATOM_SYMBOL: 23 | v = value_new_symbol(atom->as.string); 24 | break; 25 | default: 26 | LOG_CRITICAL("Unknown AST atom type: %d", atom->node.type); 27 | v = NULL; 28 | } 29 | return v; 30 | } 31 | 32 | Value *ir_from_ast_list(AstList *ast_list) 33 | { 34 | if (ast_list->node.type == AST_LIST_EMPTY) { 35 | return value_new_list(NULL); 36 | } 37 | Value *sexpr = ir_from_ast_sexpr(ast_list->as.compound.sexpr); 38 | Value *list = ir_from_ast_list(ast_list->as.compound.list); 39 | list->value.list = list_prepend(list->value.list, sexpr); 40 | return list; 41 | } 42 | 43 | Value *ir_from_ast_sexpr(AstSexpr *ast) 44 | { 45 | if (!ast) return NULL; 46 | Value *result; 47 | Value *quote; 48 | Value *sexpr; 49 | switch (ast->node.type) { 50 | case AST_SEXPR_ATOM: 51 | result = ir_from_ast_atom(ast->as.atom); 52 | break; 53 | case AST_SEXPR_LIST: 54 | result = ir_from_ast_list(ast->as.list); 55 | break; 56 | case AST_SEXPR_QUOTE: 57 | result = value_new_list(NULL); 58 | sexpr = ir_from_ast_sexpr(ast->as.quoted); 59 | quote = value_new_symbol("quote"); 60 | result->value.list = list_append(result->value.list, quote); 61 | result->value.list = list_append(result->value.list, sexpr); 62 | break; 63 | case AST_SEXPR_QUASIQUOTE: 64 | result = value_new_list(NULL); 65 | sexpr = ir_from_ast_sexpr(ast->as.quoted); 66 | quote = value_new_symbol("quasiquote"); 67 | result->value.list = list_append(result->value.list, quote); 68 | result->value.list = list_append(result->value.list, sexpr); 69 | break; 70 | case AST_SEXPR_UNQUOTE: 71 | result = value_new_list(NULL); 72 | sexpr = ir_from_ast_sexpr(ast->as.quoted); 73 | quote = value_new_symbol("unquote"); 74 | result->value.list = list_append(result->value.list, quote); 75 | result->value.list = list_append(result->value.list, sexpr); 76 | break; 77 | case AST_SEXPR_SPLICE_UNQUOTE: 78 | result = value_new_list(NULL); 79 | sexpr = ir_from_ast_sexpr(ast->as.quoted); 80 | quote = value_new_symbol("splice-unquote"); 81 | result->value.list = list_append(result->value.list, quote); 82 | result->value.list = list_append(result->value.list, sexpr); 83 | break; 84 | } 85 | return result; 86 | } 87 | 88 | -------------------------------------------------------------------------------- /src/lexer.c: -------------------------------------------------------------------------------- 1 | #include "lexer.h" 2 | 3 | #include 4 | #include 5 | 6 | const char *token_type_names[] = { 7 | "LEXER_TOK_ERROR", 8 | "LEXER_TOK_INT", 9 | "LEXER_TOK_FLOAT", 10 | "LEXER_TOK_STRING", 11 | "LEXER_TOK_SYMBOL", 12 | "LEXER_TOK_LPAREN", 13 | "LEXER_TOK_RPAREN", 14 | "LEXER_TOK_QUOTE", 15 | "LEXER_TOK_QUASIQUOTE", 16 | "LEXER_TOK_UNQUOTE", 17 | "LEXER_TOK_SPLICE_UNQUOTE", 18 | "LEXER_TOK_EOF" 19 | }; 20 | 21 | static char *symbol_chars = "!&*+-0123456789<=>?@" 22 | "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 23 | "abcdefghijklmnopqrstuvwxyz"; 24 | 25 | typedef enum { 26 | KEY_BEL = 7, 27 | KEY_BS = 8, 28 | KEY_HT = 9, 29 | KEY_LF = 10, 30 | KEY_VT = 11, 31 | KEY_FF = 12, 32 | KEY_CR = 13 33 | } EscapeChars; 34 | 35 | Lexer *lexer_new(FILE *fp) 36 | { 37 | Lexer *lexer = (Lexer *) malloc(sizeof(Lexer)); 38 | *lexer = (Lexer) { 39 | .fp = fp, 40 | .state = LEXER_STATE_ZERO, 41 | .line_no = 1, 42 | .char_no = 0 43 | }; 44 | return lexer; 45 | } 46 | 47 | void lexer_delete(Lexer *l) 48 | { 49 | free(l); 50 | } 51 | 52 | void lexer_delete_token(LexerToken *t) 53 | { 54 | if (t) { 55 | switch(t->type) { 56 | case LEXER_TOK_INT: 57 | case LEXER_TOK_FLOAT: 58 | case LEXER_TOK_EOF: 59 | break; 60 | case LEXER_TOK_STRING: 61 | case LEXER_TOK_ERROR: 62 | case LEXER_TOK_SYMBOL: 63 | case LEXER_TOK_LPAREN: 64 | case LEXER_TOK_RPAREN: 65 | case LEXER_TOK_QUOTE: 66 | case LEXER_TOK_QUASIQUOTE: 67 | case LEXER_TOK_UNQUOTE: 68 | case LEXER_TOK_SPLICE_UNQUOTE: 69 | free(t->as.str); 70 | break; 71 | } 72 | free(t); 73 | } 74 | } 75 | 76 | static LexerToken *lexer_make_token(const Lexer *l, 77 | const TokenType token_type, 78 | const char *buf) 79 | { 80 | LexerToken *tok = (LexerToken *) malloc(sizeof(LexerToken)); 81 | if (tok) { 82 | tok->type = token_type; 83 | tok->line = l->line_no; 84 | tok->column = l->char_no; 85 | switch(token_type) { 86 | case LEXER_TOK_INT: 87 | tok->as.int_ = atoi(buf); 88 | break; 89 | case LEXER_TOK_FLOAT: 90 | tok->as.double_ = atof(buf); 91 | break; 92 | case LEXER_TOK_STRING: 93 | case LEXER_TOK_ERROR: 94 | case LEXER_TOK_SYMBOL: 95 | case LEXER_TOK_LPAREN: 96 | case LEXER_TOK_RPAREN: 97 | case LEXER_TOK_QUOTE: 98 | case LEXER_TOK_QUASIQUOTE: 99 | case LEXER_TOK_UNQUOTE: 100 | case LEXER_TOK_SPLICE_UNQUOTE: 101 | tok->as.str = strdup(buf); 102 | break; 103 | case LEXER_TOK_EOF: 104 | tok->as.str = NULL; 105 | break; 106 | } 107 | } 108 | return tok; 109 | } 110 | 111 | static void lexer_advance_next_char(Lexer *l) 112 | { 113 | l->char_no++; 114 | } 115 | 116 | static void lexer_advance_next_line(Lexer *l) 117 | { 118 | l->line_no++; 119 | l->char_no = 0; 120 | } 121 | 122 | LexerToken *lexer_get_token(Lexer *l) 123 | { 124 | char buf[1024] = {0}; 125 | size_t bufpos = 0; 126 | int c; 127 | char *pos; 128 | while ((c = fgetc(l->fp)) != EOF) { 129 | lexer_advance_next_char(l); 130 | switch (l->state) { 131 | case LEXER_STATE_ZERO: 132 | switch(c) { 133 | case ';': 134 | l->state = LEXER_STATE_COMMENT; 135 | break; 136 | case '(': 137 | buf[bufpos++] = c; 138 | return lexer_make_token(l, LEXER_TOK_LPAREN, buf); 139 | break; 140 | case ')': 141 | buf[bufpos++] = c; 142 | return lexer_make_token(l, LEXER_TOK_RPAREN, buf); 143 | break; 144 | case '\'': 145 | buf[bufpos++] = c; 146 | return lexer_make_token(l, LEXER_TOK_QUOTE, buf); 147 | break; 148 | case '`': 149 | buf[bufpos++] = c; 150 | return lexer_make_token(l, LEXER_TOK_QUASIQUOTE, buf); 151 | break; 152 | /* start an unquote */ 153 | case '~': 154 | buf[bufpos++] = c; 155 | l->state = LEXER_STATE_UNQUOTE; 156 | break; 157 | /* start a string */ 158 | case '\"': 159 | /* don't put c in the buffer */ 160 | l->state = LEXER_STATE_STRING; 161 | break; 162 | /* start number */ 163 | case '0' ... '9': 164 | buf[bufpos++] = c; 165 | l->state = LEXER_STATE_NUMBER; 166 | break; 167 | /* start a symbol */ 168 | case 'a' ... 'z': 169 | case 'A' ... 'Z': 170 | case '+': 171 | case '/': 172 | case '*': 173 | case '<': 174 | case '=': 175 | case '>': 176 | case '&': 177 | buf[bufpos++] = c; 178 | l->state = LEXER_STATE_SYMBOL; 179 | break; 180 | case '-': 181 | buf[bufpos++] = c; 182 | l->state = LEXER_STATE_MINUS; 183 | break; 184 | /* eat whitespace */ 185 | case ' ': 186 | case '\r': 187 | case '\t': 188 | break; 189 | case '\n': 190 | lexer_advance_next_line(l); 191 | break; 192 | /* error */ 193 | default: 194 | buf[bufpos++] = c; 195 | return lexer_make_token(l, LEXER_TOK_ERROR, buf); 196 | } 197 | break; 198 | 199 | case LEXER_STATE_COMMENT: 200 | switch(c) { 201 | case '\n': 202 | lexer_advance_next_line(l); 203 | l->state = LEXER_STATE_ZERO; 204 | break; 205 | default: 206 | /* gobble up everything until EOL */ 207 | break; 208 | } 209 | break; 210 | 211 | case LEXER_STATE_MINUS: 212 | /* This one is a little finicky since we want to allow for 213 | * symbols that start with a dash ("-main"), negative numbers 214 | * (-1, -2.4, -.7), and the subtraction operator (- 3 1). */ 215 | switch(c) { 216 | case '0' ... '9': 217 | buf[bufpos++] = c; 218 | l->state = LEXER_STATE_NUMBER; 219 | break; 220 | case '.': 221 | buf[bufpos++] = c; 222 | l->state = LEXER_STATE_FLOAT; 223 | break; 224 | /* start a symbol */ 225 | case 'a' ... 'z': 226 | case 'A' ... 'Z': 227 | case '+': 228 | case '/': 229 | case '*': 230 | case '<': 231 | case '=': 232 | case '>': 233 | ungetc(c, l->fp); 234 | l->char_no--; 235 | l->state = LEXER_STATE_SYMBOL; 236 | break; 237 | /* minus symbol */ 238 | case ' ': 239 | case '\r': 240 | case '\t': 241 | l->state = LEXER_STATE_ZERO; 242 | return lexer_make_token(l, LEXER_TOK_SYMBOL, buf); 243 | break; 244 | case '\n': 245 | lexer_advance_next_line(l); 246 | l->state = LEXER_STATE_ZERO; 247 | return lexer_make_token(l, LEXER_TOK_SYMBOL, buf); 248 | break; 249 | /* error */ 250 | default: 251 | buf[bufpos++] = c; 252 | return lexer_make_token(l, LEXER_TOK_ERROR, buf); 253 | 254 | } 255 | break; 256 | case LEXER_STATE_UNQUOTE: 257 | l->state = LEXER_STATE_ZERO; 258 | if (c == '@') { 259 | buf[bufpos++] = c; 260 | return lexer_make_token(l, LEXER_TOK_SPLICE_UNQUOTE, buf); 261 | } else { 262 | ungetc(c, l->fp); 263 | l->char_no--; 264 | return lexer_make_token(l, LEXER_TOK_UNQUOTE, buf); 265 | } 266 | break; 267 | 268 | case LEXER_STATE_STRING: 269 | if (c != '\"') { 270 | if (c == '\\') { 271 | l->state = LEXER_STATE_ESCAPESTRING; 272 | break; 273 | } 274 | buf[bufpos++] = c; 275 | if (c == '\n') lexer_advance_next_line(l); 276 | } else { 277 | /* don't put c in the buffer */ 278 | l->state = LEXER_STATE_ZERO; 279 | return lexer_make_token(l, LEXER_TOK_STRING, buf); 280 | } 281 | break; 282 | 283 | case LEXER_STATE_ESCAPESTRING: 284 | /* supports all C escape sequences except for hex and octal */ 285 | switch(c) { 286 | case '\n': 287 | /* ignore escaped line feeds */ 288 | break; 289 | case '\\': 290 | case '"': 291 | /* keep the char and go back to string processing */ 292 | buf[bufpos++] = c; 293 | break; 294 | case 'a': 295 | buf[bufpos++] = KEY_BEL; 296 | break; 297 | case 'b': 298 | buf[bufpos++] = KEY_BS; 299 | break; 300 | case 'f': 301 | buf[bufpos++] = KEY_FF; 302 | break; 303 | case 'n': 304 | buf[bufpos++] = KEY_LF; 305 | break; 306 | case 'r': 307 | buf[bufpos++] = KEY_CR; 308 | break; 309 | case 't': 310 | buf[bufpos++] = KEY_HT; 311 | break; 312 | case 'v': 313 | buf[bufpos++] = KEY_VT; 314 | break; 315 | default: 316 | /* Invalid escape sequeence. Keep the sequence and go 317 | * back to string processing */ 318 | buf[bufpos++] = '\\'; 319 | ungetc(c, l->fp); 320 | l->char_no--; 321 | break; 322 | } 323 | l->state = LEXER_STATE_STRING; 324 | break; 325 | 326 | case LEXER_STATE_NUMBER: 327 | switch(c) { 328 | case '(': 329 | case ')': 330 | ungetc(c, l->fp); 331 | l->char_no--; 332 | l->state = LEXER_STATE_ZERO; 333 | return lexer_make_token(l, LEXER_TOK_INT, buf); 334 | case '\n': 335 | lexer_advance_next_line(l); 336 | case '\t': 337 | case '\r': 338 | case ' ': 339 | l->state = LEXER_STATE_ZERO; 340 | return lexer_make_token(l, LEXER_TOK_INT, buf); 341 | case '.': 342 | buf[bufpos++] = c; 343 | l->state = LEXER_STATE_FLOAT; 344 | break; 345 | case '0' ... '9': 346 | buf[bufpos++] = c; 347 | break; 348 | default: 349 | /* error */ 350 | buf[bufpos++] = c; 351 | return lexer_make_token(l, LEXER_TOK_ERROR, buf); 352 | } 353 | break; 354 | case LEXER_STATE_FLOAT: 355 | switch(c) { 356 | case '(': 357 | case ')': 358 | ungetc(c, l->fp); 359 | l->char_no--; 360 | l->state = LEXER_STATE_ZERO; 361 | return lexer_make_token(l, LEXER_TOK_FLOAT, buf); 362 | case '\n': 363 | lexer_advance_next_line(l); 364 | case '\t': 365 | case '\r': 366 | case ' ': 367 | l->state = LEXER_STATE_ZERO; 368 | return lexer_make_token(l, LEXER_TOK_FLOAT, buf); 369 | case '0' ... '9': 370 | buf[bufpos++] = c; 371 | break; 372 | default: 373 | /* error */ 374 | l->state = LEXER_STATE_ZERO; 375 | return lexer_make_token(l, LEXER_TOK_ERROR, buf); 376 | } 377 | break; 378 | case LEXER_STATE_SYMBOL: 379 | pos = strchr(symbol_chars, c); 380 | if (pos != NULL) { 381 | buf[bufpos++] = c; 382 | } else { 383 | ungetc(c, l->fp); 384 | l->char_no--; 385 | l->state = LEXER_STATE_ZERO; 386 | return lexer_make_token(l, LEXER_TOK_SYMBOL, buf); 387 | } 388 | break; 389 | default: 390 | buf[bufpos++] = c; 391 | return lexer_make_token(l, LEXER_TOK_ERROR, buf); 392 | } 393 | } 394 | /* acceptance states */ 395 | switch(l->state) { 396 | case LEXER_STATE_ZERO: 397 | case LEXER_STATE_COMMENT: 398 | return lexer_make_token(l, LEXER_TOK_EOF, NULL); 399 | case LEXER_STATE_NUMBER: 400 | l->state = LEXER_STATE_ZERO; 401 | return lexer_make_token(l, LEXER_TOK_INT, buf); 402 | case LEXER_STATE_FLOAT: 403 | l->state = LEXER_STATE_ZERO; 404 | return lexer_make_token(l, LEXER_TOK_FLOAT, buf); 405 | case LEXER_STATE_SYMBOL: 406 | l->state = LEXER_STATE_ZERO; 407 | return lexer_make_token(l, LEXER_TOK_SYMBOL, buf); 408 | default: 409 | return lexer_make_token(l, LEXER_TOK_ERROR, buf); 410 | } 411 | } 412 | 413 | -------------------------------------------------------------------------------- /src/list.c: -------------------------------------------------------------------------------- 1 | #include "list.h" 2 | #include "gc.h" 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | 9 | /** 10 | * Create a new list item for a value. 11 | * 12 | * @param value The `struct Value` instance the items should point to 13 | * @return A pointer to a new `ListItem` instance 14 | * 15 | */ 16 | static ListItem *list_item_new(const struct Value *value) 17 | { 18 | ListItem *item = (ListItem *) gc_calloc(&gc, 1, sizeof(ListItem)); 19 | item->val = value; 20 | return item; 21 | } 22 | 23 | /** 24 | * Create a mutable copy of a list. 25 | * 26 | * Creates a new, mutable linked list where each list item points to the same 27 | * `struct Value` instance as the corresponding list item in `l`. 28 | * 29 | * @param l A pointer to the `List` instance to copy 30 | * @return A pointer to a mutable copy 31 | * 32 | */ 33 | static List *list_mutable_copy(const List *l) 34 | { 35 | List *copy = gc_calloc(&gc, 1, sizeof(List)); 36 | ListItem **q = ©->head; 37 | ListItem *const *p = &l->head; 38 | while (*p) { 39 | *q = list_item_new((*p)->val); 40 | q = &(*q)->next; 41 | p = &(*p)->next; 42 | } 43 | copy->size = l->size; 44 | return copy; 45 | } 46 | 47 | const List *list_new() 48 | { 49 | List *list = (List *) gc_calloc(&gc, 1, sizeof(List)); 50 | return list; 51 | } 52 | 53 | const List *list_dup(const List *l) 54 | { 55 | return list_mutable_copy(l); 56 | } 57 | 58 | const List *list_append(const List *l, const struct Value *value) 59 | { 60 | // O(n) append at end of list 61 | List *copy = list_mutable_copy(l); 62 | ListItem **p = ©->head; 63 | while (*p) { 64 | p = &(*p)->next; 65 | } 66 | *p = list_item_new(value); 67 | copy->size++; 68 | return copy; 69 | } 70 | 71 | const List *list_prepend(const List *l, const struct Value *value) 72 | { 73 | // O(1) prepend at start of list 74 | List *copy = list_mutable_copy(l); 75 | ListItem *item = list_item_new(value); 76 | item->next = copy->head; 77 | copy->head = item; 78 | copy->size++; 79 | return copy; 80 | } 81 | 82 | const struct Value *list_head(const List *l) 83 | { 84 | if (l && l->head) return l->head->val; 85 | return NULL; 86 | } 87 | 88 | const List *list_tail(const List *l) 89 | { 90 | if (l) { 91 | // flat copy 92 | List *tail = (List *) gc_calloc(&gc, 1, sizeof(List)); 93 | if (l->size > 1) { 94 | tail->head = l->head->next; 95 | tail->size = l->size - 1; 96 | } 97 | return tail; 98 | } 99 | return NULL; 100 | } 101 | 102 | const struct Value *list_nth(const List *l, const size_t n) 103 | { 104 | ListItem *const *p = &l->head; 105 | size_t i = n; 106 | while (*p && i--) { 107 | p = &(*p)->next; 108 | } 109 | return *p ? (*p)->val : NULL; 110 | } 111 | 112 | size_t list_size(const List *l) 113 | { 114 | return l->size; 115 | } 116 | 117 | bool list_is_empty(const List *l) 118 | { 119 | return l->size == 0; 120 | } 121 | -------------------------------------------------------------------------------- /src/log.c: -------------------------------------------------------------------------------- 1 | #include "log.h" 2 | 3 | const char *log_level_strings [] = { "CRIT", "WARN", "INFO", "DEBG", "NONE" }; 4 | 5 | -------------------------------------------------------------------------------- /src/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #include "ast.h" 9 | #include "core.h" 10 | #include "env.h" 11 | #include "eval.h" 12 | #include "exc.h" 13 | #include "gc.h" 14 | #include "list.h" 15 | #include "log.h" 16 | #include "parser.h" 17 | #include "value.h" 18 | 19 | Value *core_read_string(const Value *args); 20 | Value *core_eval(const Value *str); 21 | 22 | /* The global environment */ 23 | Environment *ENV; 24 | 25 | Environment *global_env() 26 | { 27 | Environment *env = env_new(NULL); 28 | 29 | env_set(env, "nil", VALUE_CONST_NIL); 30 | env_set(env, "true", VALUE_CONST_TRUE); 31 | env_set(env, "false", VALUE_CONST_FALSE); 32 | env_set(env, "nil?", value_new_builtin_fn(core_is_nil)); 33 | env_set(env, "true?", value_new_builtin_fn(core_is_true)); 34 | env_set(env, "false?", value_new_builtin_fn(core_is_false)); 35 | env_set(env, "symbol?", value_new_builtin_fn(core_is_symbol)); 36 | 37 | env_set(env, "pr", value_new_builtin_fn(core_pr)); 38 | env_set(env, "pr-str", value_new_builtin_fn(core_pr_str)); 39 | env_set(env, "prn", value_new_builtin_fn(core_prn)); 40 | 41 | Value *add = value_new_builtin_fn(core_add); 42 | env_set(env, "+", add); 43 | env_set(env, "add", add); 44 | Value *sub = value_new_builtin_fn(core_sub); 45 | env_set(env, "sub", sub); 46 | env_set(env, "-", sub); 47 | Value *mul = value_new_builtin_fn(core_mul); 48 | env_set(env, "*", mul); 49 | env_set(env, "mul", mul); 50 | Value *div = value_new_builtin_fn(core_div); 51 | env_set(env, "/", div); 52 | env_set(env, "div", div); 53 | 54 | Value *eq = value_new_builtin_fn(core_eq); 55 | env_set(env, "=", eq); 56 | env_set(env, "eq", eq); 57 | Value *lt = value_new_builtin_fn(core_lt); 58 | env_set(env, "<", lt); 59 | env_set(env, "lt", lt); 60 | Value *leq = value_new_builtin_fn(core_leq); 61 | env_set(env, "<=", leq); 62 | env_set(env, "leq", leq); 63 | Value *gt = value_new_builtin_fn(core_gt); 64 | env_set(env, ">", gt); 65 | env_set(env, "gt", gt); 66 | Value *geq = value_new_builtin_fn(core_geq); 67 | env_set(env, ">=", geq); 68 | env_set(env, "geq", geq); 69 | 70 | env_set(env, "list", value_new_builtin_fn(core_list)); 71 | env_set(env, "list?", value_new_builtin_fn(core_is_list)); 72 | env_set(env, "empty?", value_new_builtin_fn(core_is_empty)); 73 | env_set(env, "count", value_new_builtin_fn(core_count)); 74 | env_set(env, "nth", value_new_builtin_fn(core_nth)); 75 | env_set(env, "first", value_new_builtin_fn(core_first)); 76 | env_set(env, "rest", value_new_builtin_fn(core_rest)); 77 | 78 | env_set(env, "symbol", value_new_builtin_fn(core_symbol)); 79 | env_set(env, "str", value_new_builtin_fn(core_str)); 80 | env_set(env, "slurp", value_new_builtin_fn(core_slurp)); 81 | env_set(env, "eval", value_new_builtin_fn(core_eval)); 82 | env_set(env, "read-string", value_new_builtin_fn(core_read_string)); 83 | 84 | env_set(env, "cons", value_new_builtin_fn(core_cons)); 85 | env_set(env, "concat", value_new_builtin_fn(core_concat)); 86 | 87 | env_set(env, "map", value_new_builtin_fn(core_map)); 88 | env_set(env, "apply", value_new_builtin_fn(core_apply)); 89 | 90 | env_set(env, "assert", value_new_builtin_fn(core_assert)); 91 | env_set(env, "throw", value_new_builtin_fn(core_throw)); 92 | 93 | // add stutter basics 94 | size_t N_EXPRS = 1; 95 | const char *exprs[N_EXPRS]; 96 | exprs[0] = "(def load-file" 97 | " (lambda (path)" 98 | " (eval (read-string (str \"(do \" (slurp path) \")\")))))"; 99 | for (size_t i = 0; i < N_EXPRS; ++i) { 100 | eval(core_read_string(value_make_list(value_new_string(exprs[i]))), env); 101 | } 102 | return env; 103 | } 104 | 105 | Value *read_(char *input) 106 | { 107 | // Get a handle on the input 108 | size_t n = strlen(input); 109 | FILE *stream = fmemopen(input, n, "r"); 110 | if (!stream) { 111 | printf("%s\n", strerror(errno)); 112 | return NULL; 113 | } 114 | 115 | Value *ast = NULL; 116 | ParseResult success = parser_parse(stream, &ast); 117 | fclose(stream); 118 | return success == PARSER_SUCCESS ? ast : NULL; 119 | } 120 | 121 | Value *core_read_string(const Value *args) 122 | { 123 | if (is_list(args)) { 124 | Value *str = list_head(LIST(args)); 125 | return read_(STRING(str)); 126 | } 127 | return NULL; 128 | } 129 | 130 | 131 | Value *core_eval(const Value *args) 132 | { 133 | /* This assumes that everything is loaded in the global env. 134 | * Otherwise we should implement it as a special form. 135 | */ 136 | if (is_list(args)) { 137 | return eval(list_head(LIST(args)), ENV); 138 | } 139 | return NULL; 140 | } 141 | 142 | #define BOLD "\033[1m" 143 | #define NO_BOLD "\033[22m" 144 | 145 | const char *banner() 146 | { 147 | const char *banner = 148 | " __ __ __\n" 149 | " _____/ /___ __/ /_/ /____ _____\n" 150 | " / ___/ __/ / / / __/ __/ _ \\/ ___/\n" 151 | " (__ ) /_/ /_/ / /_/ /_/ __/ /\n" 152 | "/____/\\__/\\__,_/\\__/\\__/\\___/_/"; 153 | return banner; 154 | } 155 | 156 | void show_help() 157 | { 158 | char *help = 159 | " %s\n\n" 160 | BOLD "USAGE\n" NO_BOLD 161 | " stutter [-h] [file]\n" 162 | "\n" 163 | BOLD "ARGUMENTS\n" NO_BOLD 164 | " file Execute FILE as a stutter program\n" 165 | "\n" 166 | BOLD "OPTIONS\n" NO_BOLD 167 | " -h Show this help text\n"; 168 | fprintf(stderr, "%s", banner()); 169 | fprintf(stderr, help, __STUTTER_VERSION__); 170 | } 171 | 172 | int main(int argc, char *argv[]) 173 | { 174 | // set up garbage collection, use extended setup for bigger mem limits 175 | gc_start_ext(&gc, &argc, 16384, 16384, 0.2, 0.8, 0.5); 176 | // create env and tell GC to never collect it 177 | ENV = global_env(); 178 | gc_make_static(&gc, ENV); 179 | 180 | int c; 181 | while ((c = getopt(argc, argv, "h")) != -1) { 182 | switch(c) { 183 | case 'h': 184 | default: 185 | show_help(); 186 | exit(0); 187 | } 188 | } 189 | if (argc > 1) { 190 | /* In order to execute a file, explicitly construct a load-file 191 | * call to avoid interpretation of the filename. */ 192 | Value *src = value_make_list(value_new_symbol("load-file")); 193 | src = value_new_list(list_append(LIST(src), value_new_string(argv[optind]))); 194 | Value *eval_result = eval(src, ENV); 195 | if (eval_result) { 196 | core_prn(value_make_list(eval_result)); 197 | } else { 198 | if (exc_is_pending()) { 199 | core_prn(exc_get()); 200 | exc_clear(); 201 | } else { 202 | LOG_CRITICAL("Eval returned NULL."); 203 | } 204 | } 205 | if (!eval_result) { 206 | return 1; 207 | } else { 208 | return 0; 209 | } 210 | } 211 | 212 | // REPL 213 | if (isatty(fileno(stdin))) { 214 | fprintf(stdout, "%s %s\n\n", banner(), __STUTTER_VERSION__); 215 | } 216 | 217 | while(true) { 218 | // char *input = readline("stutter> "); 219 | char *input = readline("\U000003BB> "); 220 | if (input == NULL) { 221 | break; 222 | } 223 | if (strcmp(input, "") == 0) { 224 | continue; 225 | } 226 | add_history(input); 227 | Value *expr = read_(input); 228 | if (expr) { 229 | Value *eval_result = eval(expr, ENV); 230 | if (eval_result) { 231 | core_prn(value_make_list(eval_result)); 232 | } else { 233 | if (exc_is_pending()) { 234 | core_prn(exc_get()); 235 | exc_clear(); 236 | } else { 237 | LOG_CRITICAL("Eval returned NULL."); 238 | } 239 | } 240 | } 241 | free(input); 242 | } 243 | gc_stop(&gc); 244 | if (isatty(fileno(stdin))) { 245 | fprintf(stdout, "\n"); 246 | } 247 | return 0; 248 | } 249 | 250 | -------------------------------------------------------------------------------- /src/map.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include "djb2.h" 6 | #include "gc.h" 7 | #include "log.h" 8 | #include "map.h" 9 | #include "primes.h" 10 | 11 | static double load_factor(Map *ht) 12 | { 13 | // LOG_DEBUG("Load factor: %.2f", (double) ht->size / (double) ht->capacity); 14 | return (double) ht->size / (double) ht->capacity; 15 | } 16 | 17 | static MapItem *map_item_new(char *key, void *value, size_t siz) 18 | { 19 | MapItem *item = (MapItem *) gc_malloc(&gc, sizeof(MapItem)); 20 | item->key = gc_strdup(&gc, key); 21 | item->size = siz; 22 | item->value = gc_malloc(&gc, siz); 23 | memcpy(item->value, value, siz); 24 | item->next = NULL; 25 | return item; 26 | } 27 | 28 | static void map_item_delete(MapItem *item) 29 | { 30 | if (item) { 31 | gc_free(&gc, item->key); 32 | gc_free(&gc, item->value); 33 | gc_free(&gc, item); 34 | } 35 | } 36 | 37 | Map *map_new(size_t capacity) 38 | { 39 | Map *ht = (Map *) gc_malloc(&gc, sizeof(Map)); 40 | ht->capacity = next_prime(capacity); 41 | ht->size = 0; 42 | ht->items = gc_calloc(&gc, ht->capacity, sizeof(MapItem *)); 43 | return ht; 44 | } 45 | 46 | void map_delete(Map *ht) 47 | { 48 | MapItem *item, *tmp; 49 | for (size_t i = 0; i < ht->capacity; ++i) { 50 | if ((item = ht->items[i]) != NULL) { 51 | while (item) { 52 | tmp = item; 53 | item = item->next; 54 | map_item_delete(tmp); 55 | } 56 | } 57 | } 58 | gc_free(&gc, ht->items); 59 | gc_free(&gc, ht); 60 | } 61 | 62 | unsigned long map_index(Map *map, char *key) 63 | { 64 | return djb2(key) % map->capacity; 65 | } 66 | 67 | void map_put(Map *ht, char *key, void *value, size_t siz) 68 | { 69 | // hash 70 | unsigned long index = map_index(ht, key); 71 | // LOG_DEBUG("index: %lu", index); 72 | // create item 73 | MapItem *item = map_item_new(key, value, siz); 74 | MapItem *cur = ht->items[index]; 75 | // update if exists 76 | MapItem *prev = NULL; 77 | while(cur != NULL) { 78 | if (strcmp(cur->key, key) == 0) { 79 | // found it 80 | item->next = cur->next; 81 | if (!prev) { 82 | // position 0 83 | ht->items[index] = item; 84 | } else { 85 | // in the list 86 | prev->next = item; 87 | } 88 | map_item_delete(cur); 89 | return; 90 | } 91 | prev = cur; 92 | cur = cur->next; 93 | } 94 | // insert (at front of list) 95 | cur = ht->items[index]; 96 | item->next = cur; 97 | ht->items[index] = item; 98 | ht->size++; 99 | if (load_factor(ht) > 0.7) 100 | map_resize(ht, next_prime(ht->capacity * 2)); 101 | } 102 | 103 | void *map_get(Map *ht, char *key) 104 | { 105 | unsigned long index = map_index(ht, key); 106 | MapItem *cur = ht->items[index]; 107 | while(cur != NULL) { 108 | if (strncmp(cur->key, key, strlen(cur->key)) == 0) { 109 | return cur->value; 110 | } 111 | cur = cur->next; 112 | } 113 | return NULL; 114 | } 115 | 116 | void map_remove(Map *ht, char *key) 117 | { 118 | // ignores unknown keys 119 | unsigned long index = map_index(ht, key); 120 | MapItem *cur = ht->items[index]; 121 | MapItem *prev = NULL; 122 | MapItem *tmp = NULL; 123 | while(cur != NULL) { 124 | // Separate chaining w/ linked lists 125 | if (strcmp(cur->key, key) == 0) { 126 | // found it 127 | if (!prev) { 128 | // first item in list 129 | ht->items[index] = cur->next; 130 | } else { 131 | // not the first item in the list 132 | prev->next = cur->next; 133 | } 134 | tmp = cur; 135 | cur = cur->next; 136 | map_item_delete(tmp); 137 | ht->size--; 138 | } else { 139 | // move on 140 | prev = cur; 141 | cur = cur->next; 142 | } 143 | } 144 | if (load_factor(ht) < 0.1) 145 | map_resize(ht, next_prime(ht->capacity / 2)); 146 | } 147 | 148 | void map_resize(Map *ht, size_t new_capacity) 149 | { 150 | // Replaces the existing items array in the hash table 151 | // with a resized one and pushes items into the new, correct buckets 152 | // LOG_DEBUG("Resizing to %lu", new_capacity); 153 | MapItem **resized_items = gc_calloc(&gc, new_capacity, sizeof(MapItem *)); 154 | 155 | for (size_t i = 0; i < ht->capacity; ++i) { 156 | MapItem *item = ht->items[i]; 157 | while(item) { 158 | MapItem *next_item = item->next; 159 | unsigned long new_index = djb2(item->key) % new_capacity; 160 | item->next = resized_items[new_index]; 161 | resized_items[new_index] = item; 162 | item = next_item; 163 | } 164 | } 165 | gc_free(&gc, ht->items); 166 | ht->capacity = new_capacity; 167 | ht->items = resized_items; 168 | } 169 | -------------------------------------------------------------------------------- /src/parser.c: -------------------------------------------------------------------------------- 1 | #include "parser.h" 2 | 3 | #include "lexer.h" 4 | #include "log.h" 5 | #include "value.h" 6 | 7 | /* control debugging verbosity at the file level */ 8 | #ifndef DEBUG 9 | #undef LOGLEVEL 10 | #define LOGLEVEL LOGLEVEL_INFO 11 | #endif 12 | 13 | /* 14 | * Lexer extension to allow peeking 15 | */ 16 | 17 | typedef struct { 18 | Lexer *lexer; 19 | LexerToken *cur_tok; 20 | } TokenStream; 21 | 22 | 23 | static TokenStream *tokenstream_new(Lexer *l) 24 | { 25 | TokenStream *ts = (TokenStream *) malloc(sizeof(TokenStream)); 26 | *ts = (TokenStream) { 27 | .lexer = l, .cur_tok = NULL 28 | }; 29 | return ts; 30 | } 31 | 32 | static void tokenstream_delete(TokenStream *ts) 33 | { 34 | if (ts) { 35 | lexer_delete_token(ts->cur_tok); 36 | free(ts); 37 | } 38 | } 39 | 40 | static LexerToken *tokenstream_peek(TokenStream *ts) 41 | { 42 | if (!ts->cur_tok) { 43 | ts->cur_tok = lexer_get_token(ts->lexer); 44 | } 45 | return ts->cur_tok; 46 | } 47 | 48 | static LexerToken *tokenstream_get(TokenStream *ts) 49 | { 50 | LexerToken *tok = ts->cur_tok ? ts->cur_tok : lexer_get_token(ts->lexer); 51 | ts->cur_tok = NULL; 52 | return tok; 53 | } 54 | 55 | static void tokenstream_consume(TokenStream *ts) 56 | { 57 | if (ts->cur_tok) { 58 | lexer_delete_token(ts->cur_tok); 59 | ts->cur_tok = NULL; 60 | } else { 61 | LexerToken *tok = tokenstream_get(ts); 62 | lexer_delete_token(tok); 63 | } 64 | } 65 | 66 | /* 67 | * Parser 68 | */ 69 | 70 | /* forward declarations */ 71 | static ParseResult parser_parse_sexpr(TokenStream *ts, Value **ast); 72 | static ParseResult parser_parse_list(TokenStream *ts, Value **ast); 73 | static ParseResult parser_parse_atom(TokenStream *ts, Value **ast); 74 | static ParseResult parser_parse_program(TokenStream *ts, Value **ast); 75 | 76 | const char *QUOTES[] = { "quote", "quasiquote", "unquote", "splice-unquote" }; 77 | 78 | 79 | ParseResult parser_parse(FILE *stream, Value **ast) 80 | { 81 | Lexer *lexer = lexer_new(stream); 82 | TokenStream *ts = tokenstream_new(lexer); 83 | ParseResult success = parser_parse_program(ts, ast); 84 | tokenstream_delete(ts); 85 | lexer_delete(lexer); 86 | return success; 87 | } 88 | 89 | static ParseResult parser_parse_program(TokenStream *ts, Value **ast) 90 | { 91 | LexerToken *tok = tokenstream_peek(ts); 92 | if (!tok) { 93 | LOG_CRITICAL("Line %lu, column %lu: Unexpected lexer failure", 94 | ts->lexer->line_no, ts->lexer->char_no); 95 | *ast = NULL; 96 | return PARSER_FAIL; 97 | } 98 | switch (tok->type) { 99 | case LEXER_TOK_ERROR: { 100 | LOG_CRITICAL("Line %lu, column %lu: L -> ? has parse error at \"%s\"", 101 | ts->lexer->line_no, ts->lexer->char_no, 102 | tok->as.str); 103 | *ast = NULL; 104 | return PARSER_FAIL; 105 | } 106 | case LEXER_TOK_EOF: { 107 | LOG_CRITICAL("Line %lu, column %lu: Unexpected EOF", 108 | ts->lexer->line_no, ts->lexer->char_no); 109 | *ast = NULL; 110 | return PARSER_FAIL; 111 | } 112 | case LEXER_TOK_INT: 113 | case LEXER_TOK_FLOAT: 114 | case LEXER_TOK_STRING: 115 | case LEXER_TOK_SYMBOL: 116 | case LEXER_TOK_LPAREN: 117 | case LEXER_TOK_QUOTE: 118 | case LEXER_TOK_QUASIQUOTE: 119 | case LEXER_TOK_UNQUOTE: 120 | case LEXER_TOK_SPLICE_UNQUOTE: { 121 | LOG_DEBUG("Line %lu, column %lu: P -> L $", ts->lexer->line_no, ts->lexer->char_no); 122 | ParseResult success; 123 | Value *list = NULL; 124 | if ((success = parser_parse_list(ts, &list)) != PARSER_SUCCESS) { 125 | *ast = NULL; 126 | return PARSER_FAIL; 127 | } 128 | 129 | // consume eof 130 | tok = tokenstream_get(ts); 131 | if (!tok) { 132 | LOG_CRITICAL("Line %lu, column %lu: Unexpected lexer failure", 133 | ts->lexer->line_no, ts->lexer->char_no); 134 | *ast = NULL; 135 | return PARSER_FAIL; 136 | } 137 | if (tok->type != LEXER_TOK_EOF) { 138 | LOG_CRITICAL("Line %lu, column %lu: Expected EOF, got: %s", 139 | ts->lexer->line_no, ts->lexer->char_no, 140 | token_type_names[tok->type]); 141 | lexer_delete_token(tok); 142 | *ast = NULL; 143 | return PARSER_FAIL; 144 | } 145 | lexer_delete_token(tok); 146 | *ast = list_head(LIST(list)); 147 | return PARSER_SUCCESS; 148 | } 149 | default: { 150 | LOG_CRITICAL("Line %lu, column %lu: Unexpected token %s", 151 | ts->lexer->line_no, ts->lexer->char_no, 152 | token_type_names[tok->type]); 153 | return PARSER_FAIL; 154 | } 155 | } 156 | /* unreachable */ 157 | LOG_CRITICAL("Reached unreachable code. X-("); 158 | return PARSER_FAIL; 159 | } 160 | 161 | static ParseResult parser_parse_list(TokenStream *ts, Value **ast) 162 | { 163 | LexerToken *tok = tokenstream_peek(ts); 164 | if (!tok) { 165 | LOG_CRITICAL("Line %lu, column %lu: Unexpected lexer failure", 166 | ts->lexer->line_no, ts->lexer->char_no); 167 | *ast = NULL; 168 | return PARSER_FAIL; 169 | } 170 | switch (tok->type) { 171 | case LEXER_TOK_ERROR: { 172 | LOG_CRITICAL("Line %lu, column %lu: L -> ? has parse error at \"%s\"", 173 | ts->lexer->line_no, ts->lexer->char_no, 174 | tok->as.str); 175 | *ast = NULL; 176 | return PARSER_FAIL; 177 | } 178 | case LEXER_TOK_EOF: 179 | case LEXER_TOK_RPAREN: { 180 | LOG_DEBUG("Line %lu, column %lu: L -> eps", ts->lexer->line_no, ts->lexer->char_no); 181 | *ast = value_new_list(NULL); 182 | return PARSER_SUCCESS; 183 | } 184 | case LEXER_TOK_INT: 185 | case LEXER_TOK_FLOAT: 186 | case LEXER_TOK_STRING: 187 | case LEXER_TOK_SYMBOL: 188 | case LEXER_TOK_LPAREN: 189 | case LEXER_TOK_QUOTE: 190 | case LEXER_TOK_QUASIQUOTE: 191 | case LEXER_TOK_UNQUOTE: 192 | case LEXER_TOK_SPLICE_UNQUOTE: { 193 | LOG_DEBUG("Line %lu, column %lu: L -> S L", ts->lexer->line_no, ts->lexer->char_no); 194 | Value *sexpr = NULL; 195 | ParseResult success; 196 | if ((success = parser_parse_sexpr(ts, &sexpr)) != PARSER_SUCCESS) { 197 | *ast = NULL; 198 | return PARSER_FAIL; 199 | } 200 | Value *list2 = NULL; 201 | if ((success = parser_parse_list(ts, &list2)) != PARSER_SUCCESS) { 202 | *ast = NULL; 203 | return PARSER_FAIL; 204 | } 205 | Value *list = value_make_list(sexpr); 206 | Value *head; 207 | while((head = list_head(LIST(list2))) != NULL) { 208 | LIST(list) = list_append(LIST(list), head); 209 | LIST(list2) = list_tail(LIST(list2)); 210 | } 211 | *ast = list; 212 | return PARSER_SUCCESS; 213 | } 214 | default: { 215 | LOG_CRITICAL("Line %lu, column %lu: Unexpected token type for atom: %s", 216 | ts->lexer->line_no, ts->lexer->char_no, 217 | token_type_names[tok->type]); 218 | return PARSER_FAIL; 219 | } 220 | } 221 | /* unreachable */ 222 | LOG_CRITICAL("Reached unreachable code. X-("); 223 | return PARSER_FAIL; 224 | } 225 | 226 | static ParseResult parser_parse_sexpr(TokenStream *ts, Value **ast) 227 | { 228 | LexerToken *tok = tokenstream_peek(ts); 229 | if (!tok) { 230 | LOG_CRITICAL("Line %lu, column %lu: Unexpected lexer failure", 231 | ts->lexer->line_no, ts->lexer->char_no); 232 | return PARSER_FAIL; 233 | } 234 | size_t q = 0; 235 | switch (tok->type) { 236 | /* 237 | * S -> ( L ) 238 | */ 239 | case LEXER_TOK_LPAREN: { 240 | tokenstream_consume(ts); // LPAREN 241 | Value *list = NULL; 242 | ParseResult success = parser_parse_list(ts, &list); 243 | if (success == PARSER_SUCCESS) { 244 | tokenstream_consume(ts); // RPAREN 245 | *ast = list; 246 | return PARSER_SUCCESS; 247 | } 248 | return PARSER_FAIL; 249 | } 250 | /* 251 | * S -> quote S 252 | * 253 | * Note that the order of labels matters here. 254 | */ 255 | case LEXER_TOK_SPLICE_UNQUOTE: 256 | q++; 257 | case LEXER_TOK_UNQUOTE: 258 | q++; 259 | case LEXER_TOK_QUASIQUOTE: 260 | q++; 261 | case LEXER_TOK_QUOTE: { 262 | LOG_DEBUG("Line %lu, column %lu: S -> (quote S)", ts->lexer->line_no, ts->lexer->char_no); 263 | Value *quote = value_make_list(value_new_symbol(QUOTES[q])); 264 | Value *sexpr; 265 | tokenstream_consume(ts); 266 | if (parser_parse_sexpr(ts, &sexpr) == PARSER_SUCCESS) { 267 | LIST(quote) = list_append(LIST(quote), sexpr); 268 | *ast = quote; 269 | return PARSER_SUCCESS; 270 | } 271 | } 272 | /* 273 | * S -> A 274 | */ 275 | case LEXER_TOK_INT: 276 | case LEXER_TOK_FLOAT: 277 | case LEXER_TOK_STRING: 278 | case LEXER_TOK_SYMBOL: 279 | return parser_parse_atom(ts, ast); 280 | /* 281 | * failures and wrong tokens 282 | */ 283 | case LEXER_TOK_EOF: 284 | LOG_CRITICAL("Line %lu, column %lu: Unexpected EOF", 285 | ts->lexer->line_no, ts->lexer->char_no); 286 | return PARSER_FAIL; 287 | case LEXER_TOK_ERROR: 288 | LOG_CRITICAL("Line %lu, column %lu: Lexer error", 289 | ts->lexer->line_no, ts->lexer->char_no); 290 | return PARSER_FAIL; 291 | default: 292 | LOG_CRITICAL("Line %lu, column %lu: Unexpected token type for atom: %s", 293 | ts->lexer->line_no, ts->lexer->char_no, 294 | token_type_names[tok->type]); 295 | return PARSER_FAIL; 296 | } 297 | return PARSER_SUCCESS; 298 | } 299 | 300 | static ParseResult parser_parse_atom(TokenStream *ts, Value **ast) 301 | { 302 | LexerToken *tok = tokenstream_get(ts); 303 | if (!tok) { 304 | LOG_CRITICAL("Line %lu, column %lu: Unexpected lexer failure", 305 | ts->lexer->line_no, ts->lexer->char_no); 306 | return PARSER_FAIL; 307 | } 308 | switch (tok->type) { 309 | case LEXER_TOK_INT: 310 | *ast = value_new_int(tok->as.int_); 311 | break; 312 | case LEXER_TOK_FLOAT: 313 | *ast = value_new_float(tok->as.double_); 314 | break; 315 | case LEXER_TOK_STRING: 316 | *ast = value_new_string(tok->as.str); 317 | break; 318 | case LEXER_TOK_SYMBOL: 319 | *ast = value_new_symbol(tok->as.str); 320 | break; 321 | case LEXER_TOK_EOF: 322 | LOG_CRITICAL("Line %lu, column %lu: Unexpected EOF", 323 | ts->lexer->line_no, ts->lexer->char_no); 324 | lexer_delete_token(tok); 325 | return PARSER_FAIL; 326 | case LEXER_TOK_ERROR: 327 | LOG_CRITICAL("Line %lu, column %lu: Lexer error", 328 | ts->lexer->line_no, ts->lexer->char_no); 329 | lexer_delete_token(tok); 330 | return PARSER_FAIL; 331 | default: 332 | LOG_CRITICAL("Line %lu, column %lu: Unexpected token type for atom: %s", 333 | ts->lexer->line_no, ts->lexer->char_no, 334 | token_type_names[tok->type]); 335 | lexer_delete_token(tok); 336 | return PARSER_FAIL; 337 | } 338 | lexer_delete_token(tok); 339 | return PARSER_SUCCESS; 340 | } 341 | 342 | 343 | 344 | -------------------------------------------------------------------------------- /src/primes.c: -------------------------------------------------------------------------------- 1 | #include "primes.h" 2 | 3 | 4 | bool is_prime(size_t n) 5 | { 6 | // https://stackoverflow.com/questions/1538644/c-determine-if-a-number-is-prime 7 | if (n <= 1) 8 | return false; 9 | else if (n <= 3 && n > 1) 10 | return true; // as 2 and 3 are prime 11 | else if (n % 2 == 0 || n % 3 == 0) 12 | return false; // check if n is divisible by 2 or 3 13 | else { 14 | for (size_t i = 5; i * i <= n; i += 6) { 15 | if (n % i == 0 || n % (i + 2) == 0) 16 | return false; 17 | } 18 | return true; 19 | } 20 | } 21 | 22 | size_t next_prime(size_t n) 23 | { 24 | while (!is_prime(n)) ++n; 25 | return n; 26 | } 27 | -------------------------------------------------------------------------------- /src/reader.c: -------------------------------------------------------------------------------- 1 | #include "reader.h" 2 | #include "reader_stack.h" 3 | 4 | #include 5 | #include 6 | #include "log.h" 7 | 8 | #undef LOGLEVEL 9 | #define LOGLEVEL LOGLEVEL_INFO 10 | 11 | Reader *reader_new(FILE *stream) 12 | { 13 | Lexer *lexer = lexer_new(stream); 14 | Reader *reader = (Reader *) malloc(sizeof(Reader)); 15 | *reader = (Reader) { 16 | .lexer = lexer 17 | }; 18 | return reader; 19 | } 20 | 21 | void reader_delete(Reader *r) 22 | { 23 | free(r->lexer); 24 | free(r); 25 | } 26 | 27 | AstSexpr *reader_read(Reader *reader) 28 | { 29 | AstSexpr *ast = NULL; 30 | ReaderStack *stack = reader_stack_new(1024); 31 | ReaderStackToken eof = { .type = T_EOF, .ast = {NULL} }; 32 | ReaderStackToken start = { .type = N_PROG, .ast = {NULL} }; 33 | reader_stack_push(stack, eof); 34 | reader_stack_push(stack, start); 35 | LexerToken *tok; 36 | ReaderStackToken tos; 37 | 38 | tok = lexer_get_token(reader->lexer); 39 | while (tok != NULL) { 40 | reader_stack_peek(stack, &tos); 41 | LOG_DEBUG("tos -> %s | tok -> %s", 42 | reader_stack_token_type_names[tos.type], 43 | token_type_names[tok->type]); 44 | if (tos.type == T_EOF && tok->type == LEXER_TOK_EOF) { 45 | LOG_DEBUG("%s", "Accepting EOF."); 46 | return ast; 47 | } else if (reader_is_terminal(tos) || tok->type == LEXER_TOK_EOF) { 48 | if (tos.type == T_LPAREN && tok->type == LEXER_TOK_LPAREN) { 49 | reader_stack_pop(stack, &tos); 50 | } else if (tos.type == T_RPAREN && tok->type == LEXER_TOK_RPAREN) { 51 | reader_stack_pop(stack, &tos); 52 | } else if (tos.type == T_QUOTE && tok->type == LEXER_TOK_QUOTE) { 53 | reader_stack_pop(stack, &tos); 54 | } else if (tos.type == T_QUASIQUOTE && tok->type == LEXER_TOK_QUASIQUOTE) { 55 | reader_stack_pop(stack, &tos); 56 | } else if (tos.type == T_UNQUOTE && tok->type == LEXER_TOK_UNQUOTE) { 57 | reader_stack_pop(stack, &tos); 58 | } else if (tos.type == T_SPLICE_UNQUOTE && tok->type == LEXER_TOK_SPLICE_UNQUOTE) { 59 | reader_stack_pop(stack, &tos); 60 | } else { 61 | // report error looking for tok at top of stack 62 | LOG_CRITICAL("Parse error at %lu:%lu: expected=%s, found=%s)", 63 | tok->line, tok->column, 64 | reader_stack_token_type_names[tos.type], 65 | token_type_names[tok->type]); 66 | ast_delete_sexpr(ast); 67 | return NULL; 68 | } 69 | } else { 70 | // Non-terminals, do a leftmost derivation. 71 | /* 72 | * program ::= sexpr EOF 73 | * sexpr ::= atom | LPAREN list RPAREN | [QUASI|UN|SPLICE_UN]QUOTE sexpr 74 | * list ::= sexpr list | ∅ 75 | * atom ::= STRING | SYMBOL | INT | FLOAT 76 | */ 77 | 78 | // atoms map 1:1 so just grab the data without explicitly creating the terminal 79 | if (tos.type == N_ATOM && tok->type == LEXER_TOK_INT) { 80 | reader_stack_pop(stack, &tos); 81 | tos.ast.atom->node.type = AST_ATOM_INT; 82 | tos.ast.atom->as.integer = LEXER_TOKEN_VAL_AS_INT(tok); 83 | LOG_DEBUG("Rule: A->int (int=%d)", tos.ast.atom->as.integer); 84 | } else if (tos.type == N_ATOM && tok->type == LEXER_TOK_FLOAT) { 85 | reader_stack_pop(stack, &tos); 86 | tos.ast.atom->node.type = AST_ATOM_FLOAT; 87 | tos.ast.atom->as.decimal = LEXER_TOKEN_VAL_AS_FLOAT(tok); 88 | LOG_DEBUG("Rule: A->float (float=%.2f)", tos.ast.atom->as.decimal); 89 | } else if (tos.type == N_ATOM && tok->type == LEXER_TOK_STRING) { 90 | reader_stack_pop(stack, &tos); 91 | tos.ast.atom->node.type = AST_ATOM_STRING; 92 | tos.ast.atom->as.string = strdup(LEXER_TOKEN_VAL_AS_STR(tok)); 93 | LOG_DEBUG("Rule: A->str (str=%s)", tos.ast.atom->as.string); 94 | } else if (tos.type == N_ATOM && tok->type == LEXER_TOK_SYMBOL) { 95 | reader_stack_pop(stack, &tos); 96 | tos.ast.atom->node.type = AST_ATOM_SYMBOL; 97 | tos.ast.atom->as.string = strdup(LEXER_TOKEN_VAL_AS_STR(tok)); 98 | LOG_DEBUG("Rule: A->sym (sym=%s)", tos.ast.atom->as.symbol); 99 | } else if (tos.type == N_LIST) { 100 | if (tok->type == LEXER_TOK_LPAREN || 101 | tok->type == LEXER_TOK_QUOTE || 102 | tok->type == LEXER_TOK_QUASIQUOTE || 103 | tok->type == LEXER_TOK_UNQUOTE || 104 | tok->type == LEXER_TOK_SPLICE_UNQUOTE || 105 | tok->type == LEXER_TOK_INT || 106 | tok->type == LEXER_TOK_FLOAT || 107 | tok->type == LEXER_TOK_STRING || 108 | tok->type == LEXER_TOK_SYMBOL) { 109 | LOG_DEBUG("Rule: %s", "L->SL"); 110 | // pop current token from stack and create nodes in the AST 111 | reader_stack_pop(stack, &tos); 112 | tos.ast.list->node.type = AST_LIST_COMPOUND; 113 | tos.ast.list->as.compound.list = ast_new_list(); 114 | tos.ast.list->as.compound.sexpr = ast_new_sexpr(); 115 | // push rule RHS onto stack in reverse order 116 | ReaderStackToken token; 117 | token.type = N_LIST; 118 | token.ast.list = tos.ast.list->as.compound.list; 119 | reader_stack_push(stack, token); 120 | token.type = N_SEXP; 121 | token.ast.sexp = tos.ast.list->as.compound.sexpr; 122 | reader_stack_push(stack, token); 123 | continue; // do not advance token 124 | } else if (tok->type == LEXER_TOK_RPAREN) { 125 | reader_stack_pop(stack, &tos); 126 | tos.ast.list->node.type = AST_LIST_EMPTY; 127 | continue; // do not advance token 128 | } else { 129 | // parse error 130 | LOG_CRITICAL("Parse error at %lu:%lu: L->SL|eps expected=%s, found=%s)", 131 | tok->line, tok->column, 132 | reader_stack_token_type_names[tos.type], 133 | token_type_names[tok->type]); 134 | ast_delete_sexpr(ast); 135 | lexer_delete_token(tok); 136 | reader_stack_delete(stack); 137 | return NULL; 138 | } 139 | } else if (tos.type == N_SEXP) { 140 | if (tok->type == LEXER_TOK_INT || tok->type == LEXER_TOK_FLOAT || 141 | tok->type == LEXER_TOK_STRING || tok->type == LEXER_TOK_SYMBOL) { 142 | // S -> A 143 | LOG_DEBUG("Rule: %s", "S->A"); 144 | // pop current token from stack and create nodes in the AST 145 | reader_stack_pop(stack, &tos); 146 | tos.ast.sexp->node.type = AST_SEXPR_ATOM; 147 | tos.ast.sexp->as.atom = ast_new_atom(); 148 | ReaderStackToken token; 149 | token.type = N_ATOM; 150 | token.ast.atom = tos.ast.sexp->as.atom; 151 | reader_stack_push(stack, token); 152 | continue; // do not advance token 153 | } else if (tok->type == LEXER_TOK_LPAREN) { 154 | // S -> ( L ) 155 | LOG_DEBUG("Rule: %s", "S->(L)"); 156 | // pop current token from stack and create nodes in the AST 157 | reader_stack_pop(stack, &tos); 158 | tos.ast.sexp->node.type = AST_SEXPR_LIST; 159 | tos.ast.sexp->as.list = ast_new_list(); 160 | // push rule RHS onto stack in reverse order 161 | ReaderStackToken token; 162 | token.type = T_RPAREN; 163 | reader_stack_push(stack, token); 164 | token.type = N_LIST; 165 | token.ast.list = tos.ast.sexp->as.list; 166 | reader_stack_push(stack, token); 167 | token.type = T_LPAREN; 168 | reader_stack_push(stack, token); 169 | continue; // do not advance token 170 | } else if (tok->type == LEXER_TOK_QUOTE || 171 | tok->type == LEXER_TOK_QUASIQUOTE || 172 | tok->type == LEXER_TOK_UNQUOTE || 173 | tok->type == LEXER_TOK_SPLICE_UNQUOTE) { 174 | // S -> 'S 175 | LOG_DEBUG("Rule: %s", "S->['`~@]S"); // FIXME: add splice-unquote 176 | // pop current token from stack and create nodes in the AST 177 | reader_stack_pop(stack, &tos); 178 | if (tok->type == LEXER_TOK_QUOTE) { 179 | tos.ast.sexp->node.type = AST_SEXPR_QUOTE; 180 | } else if (tok->type == LEXER_TOK_QUASIQUOTE) { 181 | tos.ast.sexp->node.type = AST_SEXPR_QUASIQUOTE; 182 | } else if (tok->type == LEXER_TOK_UNQUOTE) { 183 | tos.ast.sexp->node.type = AST_SEXPR_UNQUOTE; 184 | } else if (tok->type == LEXER_TOK_SPLICE_UNQUOTE) { 185 | tos.ast.sexp->node.type = AST_SEXPR_SPLICE_UNQUOTE; 186 | } 187 | tos.ast.sexp->as.quoted = ast_new_sexpr(); 188 | // push rule RHS onto stack in reverse order 189 | ReaderStackToken token; 190 | token.type = N_SEXP; 191 | token.ast.sexp = tos.ast.list->as.compound.sexpr; 192 | reader_stack_push(stack, token); 193 | if (tok->type == LEXER_TOK_QUOTE) { 194 | token.type = T_QUOTE; 195 | } else if (tok->type == LEXER_TOK_QUASIQUOTE) { 196 | token.type = T_QUASIQUOTE; 197 | } else if (tok->type == LEXER_TOK_UNQUOTE) { 198 | token.type = T_UNQUOTE; 199 | } else if (tok->type == LEXER_TOK_SPLICE_UNQUOTE) { 200 | token.type = T_SPLICE_UNQUOTE; 201 | } 202 | token.ast.sexp = tos.ast.sexp->as.quoted; 203 | reader_stack_push(stack, token); 204 | continue; // do not advance token 205 | } else { 206 | // parse error 207 | LOG_CRITICAL("Parse error at %lu:%lu: S->A|(L)|'S expected=%s, found=%s)", 208 | tok->line, tok->column, 209 | reader_stack_token_type_names[tos.type], 210 | token_type_names[tok->type]); 211 | ast_delete_sexpr(ast); 212 | lexer_delete_token(tok); 213 | reader_stack_delete(stack); 214 | return NULL; 215 | } 216 | } else if (tos.type == N_PROG) { 217 | // FIXME: deal with empty file 218 | if (tok->type == LEXER_TOK_EOF) { 219 | // P -> $ 220 | LOG_DEBUG("Rule: %s", "P->$"); 221 | reader_stack_pop(stack, &tos); 222 | continue; // do not advance token 223 | } else { 224 | // P -> S$ 225 | LOG_DEBUG("Rule: %s", "P->S$"); 226 | reader_stack_pop(stack, &tos); 227 | // create root of AST 228 | ast = ast_new_sexpr(); 229 | ReaderStackToken token; 230 | token.type = N_SEXP; 231 | token.ast.sexp = ast; 232 | reader_stack_push(stack, token); 233 | continue; // do not advance token 234 | } 235 | } else { 236 | // report error looking for tok at top of stack 237 | // FIXME: better error reporting 238 | LOG_CRITICAL("Could not find rule for token %s with %s at " 239 | "top of stack.", token_type_names[tok->type], 240 | reader_stack_token_type_names[tos.type]); 241 | LOG_CRITICAL("Parse error at %lu:%lu: could not find rule for %s with input %s)", 242 | tok->line, tok->column, 243 | reader_stack_token_type_names[tos.type], 244 | token_type_names[tok->type]); 245 | ast_delete_sexpr(ast); 246 | return NULL; 247 | } 248 | } 249 | lexer_delete_token(tok); 250 | tok = lexer_get_token(reader->lexer); 251 | } 252 | lexer_delete_token(tok); 253 | reader_stack_delete(stack); 254 | return ast; 255 | } 256 | 257 | -------------------------------------------------------------------------------- /src/reader_stack.c: -------------------------------------------------------------------------------- 1 | #include "reader_stack.h" 2 | #include 3 | #include 4 | 5 | 6 | const char *reader_stack_token_type_names[] = { 7 | "N_PROG", 8 | "N_SEXP", 9 | "N_LIST", 10 | "N_ATOM", 11 | "T_EOF", 12 | "T_LPAREN", 13 | "T_RPAREN", 14 | "T_QUOTE", 15 | "T_QUASIQUOTE", 16 | "T_UNQUOTE", 17 | "T_SPLICE_UNQUOTE", 18 | "T_INT", 19 | "T_FLOAT", 20 | "T_STR", 21 | "T_SYM" 22 | }; 23 | 24 | ReaderStack *reader_stack_new(size_t capacity) 25 | { 26 | assert(capacity > 0); 27 | ReaderStack *stack = (ReaderStack *) malloc(sizeof(ReaderStack)); 28 | *stack = (ReaderStack) { 29 | .capacity = capacity, 30 | .size = 0, 31 | .bos = (ReaderStackToken *) malloc(sizeof(ReaderStackToken) * capacity) 32 | }; 33 | return stack; 34 | } 35 | 36 | void reader_stack_delete(ReaderStack *stack) 37 | { 38 | free(stack->bos); 39 | free(stack); 40 | } 41 | 42 | void reader_stack_push(ReaderStack *stack, ReaderStackToken item) 43 | { 44 | if (stack->size >= stack->capacity) { 45 | stack->bos = realloc(stack->bos, 2 * stack->capacity); 46 | } 47 | stack->bos[stack->size++] = item; 48 | } 49 | 50 | int reader_stack_pop(ReaderStack *stack, ReaderStackToken *value) 51 | { 52 | if (stack->size > 0) { 53 | *value = stack->bos[--stack->size]; 54 | return 0; 55 | } 56 | return 1; 57 | } 58 | 59 | int reader_stack_peek(ReaderStack *stack, ReaderStackToken *value) 60 | { 61 | if (stack->size > 0) { 62 | *value = stack->bos[stack->size - 1]; 63 | return 0; 64 | } 65 | return 1; 66 | } 67 | 68 | static int _get_stack_symbol_type(ReaderStackToken symbol) 69 | { 70 | // returns 0 for terminals, 1 for non-terminals 71 | switch(symbol.type) { 72 | case(N_PROG): 73 | case(N_SEXP): 74 | case(N_LIST): 75 | case(N_ATOM): 76 | return 0; 77 | case(T_EOF): 78 | case(T_LPAREN): 79 | case(T_RPAREN): 80 | case(T_QUOTE): 81 | case(T_QUASIQUOTE): 82 | case(T_UNQUOTE): 83 | case(T_SPLICE_UNQUOTE): 84 | case(T_INT): 85 | case(T_FLOAT): 86 | case(T_STR): 87 | case(T_SYM): 88 | return 1; 89 | } 90 | } 91 | 92 | bool reader_is_terminal(ReaderStackToken value) 93 | { 94 | return (_get_stack_symbol_type(value) != 0); 95 | } 96 | 97 | bool reader_is_nonterminal(ReaderStackToken value) 98 | { 99 | return (_get_stack_symbol_type(value) == 0); 100 | } 101 | -------------------------------------------------------------------------------- /src/value.c: -------------------------------------------------------------------------------- 1 | #include "value.h" 2 | #include 3 | #include "log.h" 4 | #include 5 | #include 6 | 7 | 8 | const char *value_type_names[] = { 9 | "VALUE_BOOL", 10 | "VALUE_BUILTIN_FN", 11 | "VALUE_EXCEPTION", 12 | "VALUE_FLOAT", 13 | "VALUE_FN", 14 | "VALUE_INT", 15 | "VALUE_LIST", 16 | "VALUE_MACRO_FN", 17 | "VALUE_NIL", 18 | "VALUE_STRING", 19 | "VALUE_SYMBOL" 20 | }; 21 | 22 | 23 | Value *VALUE_CONST_TRUE = &((Value) 24 | { 25 | .type = VALUE_BOOL, .value = { .bool_ = true } 26 | }); 27 | Value *VALUE_CONST_FALSE = &((Value) 28 | { 29 | .type = VALUE_BOOL, .value = { .bool_ = false } 30 | }); 31 | Value *VALUE_CONST_NIL = &((Value) 32 | { 33 | .type = VALUE_NIL, .value = { .float_ = 0.0 } 34 | }); 35 | 36 | bool is_exception(const Value *value) 37 | { 38 | return value->type == VALUE_EXCEPTION; 39 | } 40 | 41 | bool is_symbol(const Value *value) 42 | { 43 | return value->type == VALUE_SYMBOL; 44 | } 45 | 46 | bool is_macro(const Value *value) 47 | { 48 | return value->type == VALUE_MACRO_FN; 49 | } 50 | 51 | bool is_list(const Value *value) 52 | { 53 | return value->type == VALUE_LIST; 54 | } 55 | 56 | static Value *value_new(ValueType type) 57 | { 58 | Value *v = (Value *) gc_malloc(&gc, sizeof(Value)); 59 | v->type = type; 60 | return v; 61 | } 62 | 63 | Value *value_new_nil() 64 | { 65 | Value *v = value_new(VALUE_NIL); 66 | return v; 67 | } 68 | 69 | Value *value_new_bool(bool bool_) 70 | { 71 | Value *v = value_new(VALUE_BOOL); 72 | v->value.bool_ = bool_; 73 | return v; 74 | } 75 | 76 | Value *value_new_int(int int_) 77 | { 78 | Value *v = value_new(VALUE_INT); 79 | v->value.int_ = int_; 80 | return v; 81 | } 82 | 83 | Value *value_new_float(float float_) 84 | { 85 | Value *v = value_new(VALUE_FLOAT); 86 | v->value.float_ = float_; 87 | return v; 88 | } 89 | 90 | Value *value_new_builtin_fn(Value * (fn)(const Value *)) 91 | { 92 | Value *v = value_new(VALUE_BUILTIN_FN); 93 | v->value.builtin_fn = fn; 94 | return v; 95 | } 96 | 97 | Value *value_new_fn(Value *args, Value *body, Environment *env) 98 | { 99 | Value *v = value_new(VALUE_FN); 100 | v->value.fn = gc_calloc(&gc, 1, sizeof(CompositeFunction)); 101 | v->value.fn->args = args; 102 | v->value.fn->body = body; 103 | v->value.fn->env = env; 104 | return v; 105 | } 106 | 107 | Value *value_new_macro(Value *args, Value *body, Environment *env) 108 | { 109 | Value *v = value_new(VALUE_MACRO_FN); 110 | v->value.fn = gc_calloc(&gc, 1, sizeof(CompositeFunction)); 111 | v->value.fn->args = args; 112 | v->value.fn->body = body; 113 | v->value.fn->env = env; 114 | return v; 115 | } 116 | 117 | Value *value_new_string(const char *str) 118 | { 119 | Value *v = value_new(VALUE_STRING); 120 | v->value.str = gc_strdup(&gc, str); 121 | return v; 122 | } 123 | 124 | Value *value_new_exception(const char *str) 125 | { 126 | Value *v = value_new(VALUE_EXCEPTION); 127 | v->value.str = gc_strdup(&gc, str); 128 | return v; 129 | } 130 | 131 | Value *value_make_exception(const char *fmt, ...) 132 | { 133 | va_list args; 134 | va_start(args, fmt); 135 | char *message = NULL; 136 | vasprintf(&message, fmt, args); 137 | va_end(args); 138 | Value *ex = value_new_exception(message); 139 | free(message); 140 | return ex; 141 | } 142 | 143 | Value *value_new_symbol(const char *str) 144 | { 145 | Value *v = value_new(VALUE_SYMBOL); 146 | v->value.str = gc_strdup(&gc, str); 147 | return v; 148 | } 149 | 150 | Value *value_new_list(const List *l) 151 | { 152 | Value *v = value_new(VALUE_LIST); 153 | if (l) { 154 | v->value.list = list_dup(l); 155 | } else { 156 | v->value.list = list_new(); 157 | } 158 | return v; 159 | } 160 | 161 | Value *value_make_list(Value *v) 162 | { 163 | Value *r = value_new_list(NULL); 164 | LIST(r) = list_append(LIST(r), v); 165 | return r; 166 | } 167 | 168 | void value_print(const Value *v) 169 | { 170 | if (!v) return; 171 | switch(v->type) { 172 | case VALUE_NIL: 173 | fprintf(stderr, "NIL"); 174 | break; 175 | case VALUE_BOOL: 176 | fprintf(stderr, "%s", v->value.bool_ ? "true" : "false"); 177 | break; 178 | case VALUE_INT: 179 | fprintf(stderr, "%d", v->value.int_); 180 | break; 181 | case VALUE_FLOAT: 182 | fprintf(stderr, "%f", v->value.float_); 183 | break; 184 | case VALUE_EXCEPTION: 185 | case VALUE_STRING: 186 | case VALUE_SYMBOL: 187 | fprintf(stderr, "%s", v->value.str); 188 | break; 189 | case VALUE_LIST: 190 | fprintf(stderr, "( "); 191 | Value *head; 192 | const List *tail = v->value.list; 193 | while((head = list_head(tail)) != NULL) { 194 | value_print(head); 195 | fprintf(stderr, " "); 196 | tail = list_tail(tail); 197 | } 198 | fprintf(stderr, ")"); 199 | break; 200 | case VALUE_FN: 201 | fprintf(stderr, "lambda: "); 202 | value_print(FN(v)->args); 203 | value_print(FN(v)->body); 204 | break; 205 | case VALUE_MACRO_FN: 206 | fprintf(stderr, "macro: "); 207 | value_print(FN(v)->args); 208 | value_print(FN(v)->body); 209 | break; 210 | case VALUE_BUILTIN_FN: 211 | fprintf(stderr, "#<@%p>", (void *) v->value.builtin_fn); 212 | break; 213 | } 214 | 215 | } 216 | 217 | Value *value_head(const Value *v) 218 | { 219 | assert(v->type == VALUE_LIST && "Invalid argument: require list"); 220 | return list_head(LIST(v)); 221 | } 222 | 223 | Value *value_tail(const Value *v) 224 | { 225 | assert(v->type == VALUE_LIST && "Invalid argument: require list"); 226 | return value_new_list(list_tail(LIST(v))); 227 | } 228 | 229 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | CC=clang 2 | CFLAGS=-g -Wall -Wextra -pedantic -I../include -I../lib/gc/src -fprofile-arcs -ftest-coverage -Wno-gnu-zero-variadic-macro-arguments 3 | LDFLAGS=-g -L../build/src -L../lib/gc/src --coverage 4 | LDLIBS= 5 | RM=rm 6 | BUILD_DIR=../build 7 | 8 | # targets are roughly in topological order 9 | TARGETS=test_list \ 10 | test_ast \ 11 | test_array \ 12 | test_djb2 \ 13 | test_parser \ 14 | test_primes \ 15 | test_map \ 16 | test_lexer \ 17 | test_env \ 18 | test_ir 19 | 20 | 21 | define execute-command 22 | $(1) 23 | 24 | endef 25 | 26 | .PHONY: all 27 | all: $(TARGETS) 28 | $(foreach T,$(TARGETS),$(call execute-command,$(BUILD_DIR)/test/$(T))) 29 | $(BUILD_DIR)/stutter lang/core.stt 30 | $(BUILD_DIR)/stutter lang/more.stt 31 | 32 | .PHONY: clean 33 | clean: 34 | rm -rf $(BUILD_DIR)/test/* 35 | rm -f $(BUILD_DIR)/lib/gc/src/*.o 36 | 37 | test_setup: 38 | mkdir -p $(BUILD_DIR)/test 39 | mkdir -p $(BUILD_DIR)/lib/gc/src 40 | 41 | gc: ../lib/gc/src/gc.c ../lib/gc/src/log.c 42 | $(CC) $(CFLAGS) -MMD -c ../lib/gc/src/gc.c -o $(BUILD_DIR)/lib/gc/src/gc.o 43 | $(CC) $(CFLAGS) -MMD -c ../lib/gc/src/log.c -o $(BUILD_DIR)/lib/gc/src/log.o 44 | 45 | # 46 | # test_list 47 | # 48 | test_list: test_setup gc 49 | $(CC) $(CFLAGS) -MMD -c test_list.c -o $(BUILD_DIR)/test/test_list.o 50 | $(CC) $(LDFLAGS) $(LDLIBS) \ 51 | $(BUILD_DIR)/lib/gc/src/gc.o \ 52 | $(BUILD_DIR)/lib/gc/src/log.o \ 53 | $(BUILD_DIR)/src/value.o \ 54 | $(BUILD_DIR)/test/test_list.o -o $(BUILD_DIR)/test/test_list 55 | 56 | # 57 | # test_array 58 | # 59 | test_array: test_setup 60 | $(CC) $(CFLAGS) -MMD -c test_array.c -o $(BUILD_DIR)/test/test_array.o 61 | $(CC) $(LDFLAGS) $(LDLIBS) \ 62 | $(BUILD_DIR)/test/test_array.o -o $(BUILD_DIR)/test/test_array 63 | 64 | # 65 | # test_ast 66 | # 67 | test_ast: test_setup 68 | $(CC) $(CFLAGS) -MMD -c test_ast.c -o $(BUILD_DIR)/test/test_ast.o 69 | $(CC) $(LDFLAGS) $(LDLIBS) \ 70 | $(BUILD_DIR)/test/test_ast.o -o $(BUILD_DIR)/test/test_ast 71 | 72 | # 73 | # test_djb2 74 | # 75 | test_djb2: test_setup 76 | $(CC) $(CFLAGS) -MMD -c test_djb2.c -o $(BUILD_DIR)/test/test_djb2.o 77 | $(CC) $(LDFLAGS) $(LDLIBS) \ 78 | $(BUILD_DIR)/test/test_djb2.o -o $(BUILD_DIR)/test/test_djb2 79 | 80 | # 81 | # test_env 82 | # 83 | test_env: test_setup gc 84 | $(CC) $(CFLAGS) -MMD -c test_env.c -o $(BUILD_DIR)/test/test_env.o 85 | $(CC) $(LDFLAGS) $(LDLIBS) \ 86 | $(BUILD_DIR)/lib/gc/src/log.o \ 87 | $(BUILD_DIR)/lib/gc/src/gc.o \ 88 | $(BUILD_DIR)/src/djb2.o \ 89 | $(BUILD_DIR)/src/list.o \ 90 | $(BUILD_DIR)/src/map.o \ 91 | $(BUILD_DIR)/src/primes.o \ 92 | $(BUILD_DIR)/src/value.o \ 93 | $(BUILD_DIR)/test/test_env.o -o $(BUILD_DIR)/test/test_env 94 | 95 | # 96 | # test_ir 97 | # 98 | test_ir: test_setup gc 99 | $(CC) $(CFLAGS) -MMD -c test_ir.c -o $(BUILD_DIR)/test/test_ir.o 100 | $(CC) $(LDFLAGS) $(LDLIBS) \ 101 | $(BUILD_DIR)/lib/gc/src/log.o \ 102 | $(BUILD_DIR)/lib/gc/src/gc.o \ 103 | $(BUILD_DIR)/src/ast.o \ 104 | $(BUILD_DIR)/src/list.o \ 105 | $(BUILD_DIR)/src/value.o \ 106 | $(BUILD_DIR)/test/test_ir.o -o $(BUILD_DIR)/test/test_ir 107 | 108 | # 109 | # test_lexer 110 | # 111 | test_lexer: test_setup gc 112 | mkdir -p $(BUILD_DIR)/test/data 113 | $(CC) $(CFLAGS) -MMD -c test_lexer.c -o $(BUILD_DIR)/test/test_lexer.o 114 | $(CC) $(LDFLAGS) $(LDLIBS) \ 115 | $(BUILD_DIR)/test/test_lexer.o -o $(BUILD_DIR)/test/test_lexer 116 | 117 | # 118 | # test_map 119 | # 120 | test_map: test_setup gc 121 | $(CC) $(CFLAGS) -MMD -c test_map.c -o $(BUILD_DIR)/test/test_map.o 122 | $(CC) $(LDFLAGS) $(LDLIBS) \ 123 | $(BUILD_DIR)/lib/gc/src/log.o \ 124 | $(BUILD_DIR)/lib/gc/src/gc.o \ 125 | $(BUILD_DIR)/src/djb2.o \ 126 | $(BUILD_DIR)/src/list.o \ 127 | $(BUILD_DIR)/src/value.o \ 128 | $(BUILD_DIR)/src/primes.o \ 129 | $(BUILD_DIR)/test/test_map.o -o $(BUILD_DIR)/test/test_map 130 | 131 | # 132 | # test_parser 133 | # 134 | test_parser: test_setup gc 135 | mkdir -p $(BUILD_DIR)/test/data 136 | $(CC) $(CFLAGS) -MMD -c test_parser.c -o $(BUILD_DIR)/test/test_parser.o 137 | $(CC) $(LDFLAGS) $(LDLIBS) \ 138 | $(BUILD_DIR)/lib/gc/src/log.o \ 139 | $(BUILD_DIR)/lib/gc/src/gc.o \ 140 | $(BUILD_DIR)/src/lexer.o \ 141 | $(BUILD_DIR)/src/list.o \ 142 | $(BUILD_DIR)/src/value.o \ 143 | $(BUILD_DIR)/test/test_parser.o -o $(BUILD_DIR)/test/test_parser 144 | 145 | # 146 | # test_primes 147 | # 148 | test_primes: test_setup gc 149 | mkdir -p $(BUILD_DIR)/test/dat 150 | $(CC) $(CFLAGS) -MMD -c test_primes.c -o $(BUILD_DIR)/test/test_primes.o 151 | $(CC) $(LDFLAGS) $(LDLIBS) \ 152 | $(BUILD_DIR)/test/test_primes.o -o $(BUILD_DIR)/test/test_primes 153 | 154 | -------------------------------------------------------------------------------- /test/data/lexer_reference.txt: -------------------------------------------------------------------------------- 1 | INT LPAREN FLOAT RPAREN STRING SYMBOL ERROR LPAREN INT LPAREN INT RPAREN RPAREN RPAREN STRING SYMBOL QUOTE SYMBOL 2 | -------------------------------------------------------------------------------- /test/data/lexer_test.str: -------------------------------------------------------------------------------- 1 | 12 ( 34.5 ) "Hello World!" abc 23.b (12(23))) "this 2 | is a string" vEryC0mplicated->NamE 'symbol 3 | -------------------------------------------------------------------------------- /test/lang/core.stt: -------------------------------------------------------------------------------- 1 | (define report-result 2 | (lambda (result form) 3 | (prn (if result "pass" "FAIL") " ... " form))) 4 | 5 | (defmacro check (form) 6 | `(report-result ~form '~form)) 7 | 8 | (define test-basics 9 | (lambda () 10 | (do 11 | (check (= '() '()))))) 12 | 13 | (define test-arithmetic 14 | (lambda () 15 | (do 16 | (check (= (+ 1 2) 3)) 17 | (check (= (+ 5 (* 2 3)) 11)) 18 | (check (= (- (+ 5 (* 2 3)) 3) 8)) 19 | (check (= (/ (- (+ 5 (* 2 3)) 3) 4) 2)) 20 | (check (= (/ (- (+ 515 (* 87 311)) 302) 27) 1010)) 21 | (check (= (* -3 6) -18)) 22 | (check (= (/ (- (+ 515 (* -87 311)) 296) 27) -994))))) 23 | 24 | (define test-env 25 | (lambda () 26 | (do 27 | (check (= (let (x 3 y 5) (- y x)) 2)) 28 | (check (= (do (def! y0 (let (z 7) z)) y0) 7)) 29 | (check (= (let (p (+ 2 3) q (+ 2 p)) (+ p q)) 12)) 30 | (check (= 7 (let (b 12) (do (eval (read-string "(def aa 7)")) aa))))))) 31 | 32 | (define test-list 33 | (lambda () 34 | (do 35 | (check (= (list) '())) 36 | (check (= (list? (list)) true)) 37 | (check (= (empty? (list)) true)) 38 | (check (= (empty? (list 1)) false)) 39 | (check (= (list 1 2 3) '(1 2 3))) 40 | (check (= (count (list 1 2 3)) 3)) 41 | (check (= (count nil) 0)) 42 | (check (= (count (list)) 0))))) 43 | 44 | (define fib 45 | (lambda (n) 46 | (if (= n 0) 47 | 1 48 | (if (= n 1) 49 | 1 50 | (+ (fib (- n 1)) (fib (- n 2))))))) 51 | 52 | (define test-conditionals 53 | (lambda () 54 | (do 55 | (check (= (fib 4) 5)) 56 | (check (= (if true 1 2) 1)) 57 | (check (= (if false 1 2) 2)) 58 | (check (= (if "" 1 2) 1)) 59 | (check (= (if false 1 false) false)) 60 | (check (= (if true (+ 1 2) (+ 2 2)) 3)) 61 | (check (= (if false (+ 1 2) (+ 2 2)) 4)) 62 | (check (= (if nil 1 2) 2)) 63 | (check (= (if 0 1 2) 1)) 64 | (check (= (if (list) 1 2) 1)) 65 | (check (= (if (list 0 1 2) 1 2) 1)) 66 | (check (= (= (list) nil) false))))) 67 | 68 | (define test-apply 69 | (lambda () 70 | (do 71 | (check (= 5 (apply + (list 2 3)))) 72 | (check (= 9 (apply + 4 (list 5)))) 73 | (check (= (list) (apply list (list)))) 74 | (check (= true (apply symbol? (list (quote two))))) 75 | (check (= 5 (apply (lambda (a b) (+ a b)) (list 2 3)))) 76 | (check (= 9 (apply (lambda (a b) (+ a b)) 4 (list 5))))))) 77 | 78 | (define test-map 79 | (lambda () 80 | (do 81 | (check (= (list 2 3 4) (map (lambda (x) (+ x 1)) (list 1 2 3))))))) 82 | 83 | (test-basics) 84 | (test-arithmetic) 85 | (test-env) 86 | (test-list) 87 | (test-conditionals) 88 | (test-apply) 89 | (test-map) 90 | -------------------------------------------------------------------------------- /test/lang/more.stt: -------------------------------------------------------------------------------- 1 | (define report-result 2 | (lambda (result form) 3 | (prn (if result "pass" "FAIL") " ... " form))) 4 | 5 | (defmacro check (form) 6 | `(report-result ~form '~form)) 7 | 8 | 9 | (define test-not 10 | (lambda () 11 | (do 12 | (check (= true (not false))) 13 | (check (= true (not nil))) 14 | (check (= false (not true))) 15 | (check (= false (not "a"))) 16 | (check (= false (not 0)))))) 17 | 18 | (define test-variadic-args 19 | (lambda () 20 | (do 21 | (check (= true ((lambda (a & more) (list? more)) 1 2 3))) 22 | (check (= true ((lambda (a & more) (list? more)) 1))) 23 | (check (= true ((lambda (& more) (list? more))))) 24 | (check (= 0 ((lambda (& more) (count more))))) 25 | (check (= 0 ((lambda (a b c & more) (count more)) 1 2 3))) 26 | (check (= 3 ((lambda (& more) (count more)) 1 2 3)))))) 27 | 28 | (define test-equality 29 | (lambda () 30 | (do 31 | (check (= (= 0 0) true)) 32 | (check (= (= 1 1) true)) 33 | (check (= (= 0 1) false)) 34 | (check (= (= true true) true)) 35 | (check (= (= false false) true)) 36 | (check (= (= false nil) false)) 37 | (check (= (= nil nil) true)) 38 | (check (= (= (list) (list)) true)) 39 | (check (= (= (list 0 1 2) (list 0 1 2)) true)) 40 | (check (= (= (list 0 2 1) (list 0 1 2)) false)) 41 | (check (= (= (list) (list 0 1 2)) false))))) 42 | 43 | (define test-user-fns 44 | (lambda () 45 | (do 46 | (check (= ((lambda (a b) (+ b a)) 3 4) 7)) 47 | (check (= ((lambda () 2)) 2)) 48 | (check (= ((lambda (f x) (f x)) (lambda (a) (+ 1 a)) 7) 8))))) 49 | 50 | (define test-closures 51 | (lambda () 52 | (do 53 | (check (= (((lambda (a) (lambda (b) (+ a b))) 5) 7) 12))))) 54 | 55 | (define sum2 (lambda (n acc) (if (= n 0) acc (sum2 (- n 1) (+ n acc))))) 56 | (define foo (lambda (n) (if (= n 0) 0 (bar (- n 1))))) 57 | (define bar (lambda (n) (if (= n 0) 0 (foo (- n 1))))) 58 | 59 | (define test-tco 60 | (lambda () 61 | (do 62 | (check (= (foo 10) 0)) 63 | (check (= (sum2 10 0) 55)) 64 | (check (= 2 (do (do 1 2))))))) 65 | 66 | (define test-builtins 67 | (lambda () 68 | (do 69 | (check (= true (symbol? (symbol "asdf")))) 70 | (check (= true (= 'asdf (symbol "asdf"))))))) 71 | 72 | (define test-exceptions 73 | (lambda () 74 | (do 75 | (check (= "c2" (try (try (throw "e1") (catch e (throw "e2"))) (catch e "c2")))) 76 | (check (= "c2" (try (do (try "t1" (catch e "c1")) (throw "e1")) (catch e "c2"))))))) 77 | 78 | (define test-seq-fns 79 | (lambda () 80 | (do 81 | (check (= 1 (nth (list 1) 0))) 82 | (check (= 2 (nth (list 1 2) 1))) 83 | (check (= nil (nth (list 1 2 nil) 2))) 84 | 85 | (check (= nil (first '()))) 86 | (check (= nil (first nil))) 87 | (check (= nil (first (list)))) 88 | (check (= 6 (first (list 6)))) 89 | (check (= 7 (first (list 7 8 9)))) 90 | 91 | (check (= '() (rest '()))) 92 | (check (= '() (rest nil))) 93 | (check (= '() (rest (list)))) 94 | (check (= '() (rest (list 6)))) 95 | (check (= '(8 9) (rest (list 7 8 9))))))) 96 | 97 | ;; (test-not) 98 | (test-variadic-args) 99 | (test-equality) 100 | (test-user-fns) 101 | (test-closures) 102 | (test-tco) 103 | (test-builtins) 104 | (test-exceptions) 105 | (test-seq-fns) 106 | -------------------------------------------------------------------------------- /test/minunit.h: -------------------------------------------------------------------------------- 1 | #ifndef MINUNIT_H 2 | #define MINUNIT_H 3 | 4 | /* 5 | * Based on: http://www.jera.com/techinfo/jtns/jtn002.html 6 | */ 7 | 8 | #define mu_assert(test, message) do { if (!(test)) return message; } while (0) 9 | #define mu_run_test(test) do { char *message = test(); tests_run++; \ 10 | if (message) return message; } while (0) 11 | 12 | extern int tests_run; 13 | 14 | #endif /* !MINUNIT_H */ 15 | -------------------------------------------------------------------------------- /test/test_array.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "minunit.h" 4 | 5 | #include "../src/array.c" 6 | 7 | static char *test_array() 8 | { 9 | // creation 10 | Array *a = array_new(sizeof(int)); 11 | mu_assert(a != NULL, "New array should not be NULL"); 12 | 13 | // get/set 14 | int i = 42; 15 | array_push_back(a, &i, 1); 16 | mu_assert(array_size(a) == 1, "Size should be 1"); 17 | mu_assert(array_capacity(a) == 1, "Capacity should be 1"); 18 | i++; 19 | array_push_back(a, &i, 1); 20 | i++; 21 | array_push_back(a, &i, 1); 22 | i++; 23 | array_push_back(a, &i, 1); 24 | mu_assert(array_size(a) == 4, "Size should be 4"); 25 | mu_assert(array_capacity(a) == 4, "Capacity should be 4"); 26 | mu_assert(*array_typed_at(a, 0, int) == 42, "42 != 42"); 27 | mu_assert(*array_typed_at(a, 1, int) == 43, "43 != 43 1"); 28 | mu_assert(*array_typed_at(a, 2, int) == 44, "44 != 44"); 29 | mu_assert(*array_typed_at(a, 3, int) == 45, "45 != 45"); 30 | 31 | int i2[4] = {46, 47, 48, 49}; 32 | array_push_back(a, i2, 4); 33 | mu_assert(array_size(a) == 8, "Size should be 8"); 34 | mu_assert(array_capacity(a) == 8, "Capacity should be 8"); 35 | mu_assert(*array_typed_at(a, 0, int) == 42, "42 != 42"); 36 | mu_assert(*array_typed_at(a, 1, int) == 43, "43 != 43"); 37 | mu_assert(*array_typed_at(a, 2, int) == 44, "44 != 44"); 38 | mu_assert(*array_typed_at(a, 3, int) == 45, "45 != 45"); 39 | mu_assert(*array_typed_at(a, 4, int) == 46, "46 != 46"); 40 | mu_assert(*array_typed_at(a, 5, int) == 47, "47 != 47"); 41 | mu_assert(*array_typed_at(a, 6, int) == 48, "48 != 48"); 42 | mu_assert(*array_typed_at(a, 7, int) == 49, "49 != 49"); 43 | 44 | int j = 41; 45 | array_push_front(a, &j, 1); 46 | mu_assert(*array_typed_at(a, 0, int) == 41, "push fail 41"); 47 | j--; 48 | array_push_front(a, &j, 1); 49 | mu_assert(*array_typed_at(a, 0, int) == 40, "push fail 40"); 50 | mu_assert(*array_typed_at(a, 1, int) == 41, "assert fail 41"); 51 | j--; 52 | array_push_front(a, &j, 1); 53 | mu_assert(*array_typed_at(a, 0, int) == 39, "push fail 39"); 54 | mu_assert(*array_typed_at(a, 1, int) == 40, "assert fail 40"); 55 | mu_assert(*array_typed_at(a, 2, int) == 41, "assert fail 41"); 56 | j--; 57 | array_push_front(a, &j, 1); 58 | mu_assert(*array_typed_at(a, 0, int) == 38, "push fail 38"); 59 | mu_assert(*array_typed_at(a, 1, int) == 39, "assert fail 39"); 60 | mu_assert(*array_typed_at(a, 2, int) == 40, "assert fail 40"); 61 | mu_assert(*array_typed_at(a, 3, int) == 41, "assert fail 41"); 62 | 63 | mu_assert(array_size(a) == 12, "Size should be 12"); 64 | mu_assert(array_capacity(a) == 16, "Capacity should be 16"); 65 | mu_assert(*array_typed_at(a, 0, int) == 38, "38 != 38"); 66 | mu_assert(*array_typed_at(a, 1, int) == 39, "39 != 39"); 67 | mu_assert(*array_typed_at(a, 2, int) == 40, "40 != 40"); 68 | mu_assert(*array_typed_at(a, 3, int) == 41, "41 != 41"); 69 | mu_assert(*array_typed_at(a, 4, int) == 42, "42 != 42"); 70 | mu_assert(*array_typed_at(a, 5, int) == 43, "43 != 43"); 71 | mu_assert(*array_typed_at(a, 6, int) == 44, "44 != 44"); 72 | mu_assert(*array_typed_at(a, 7, int) == 45, "45 != 45"); 73 | mu_assert(*array_typed_at(a, 8, int) == 46, "46 != 46"); 74 | mu_assert(*array_typed_at(a, 9, int) == 47, "47 != 47"); 75 | mu_assert(*array_typed_at(a, 10, int) == 48, "48 != 48"); 76 | mu_assert(*array_typed_at(a, 11, int) == 49, "49 != 49"); 77 | 78 | mu_assert(*array_typed_pop_back(a, int) == 49, "49 pop fail"); 79 | mu_assert(array_size(a) == 11, "Wrong size after popping 49"); 80 | for (int i = 10; i >= 0; --i) { 81 | array_typed_pop_back(a, int); 82 | } 83 | mu_assert(array_size(a) == 0, "Wrong size after emptying array"); 84 | mu_assert(array_pop_back(a) == NULL, "Pop from empty array must return NULL"); 85 | 86 | int i3[4] = {0, 1, 2, 3}; 87 | array_push_back(a, i3, 4); 88 | mu_assert(array_size(a) == 4, "Wrong size after refill"); 89 | mu_assert(*array_typed_pop_front(a, int) == 0, "Pop front 0 fail"); 90 | mu_assert(array_size(a) == 3, "Pop front 0 size fail"); 91 | mu_assert(*array_typed_pop_front(a, int) == 1, "Pop front 1 fail"); 92 | mu_assert(*array_typed_pop_front(a, int) == 2, "Pop front 2 fail"); 93 | mu_assert(*array_typed_pop_front(a, int) == 3, "Pop front 3 fail"); 94 | mu_assert(array_typed_pop_front(a, int) == NULL, "Pop on empty array must return NULL"); 95 | 96 | // clean up 97 | array_delete(a); 98 | return 0; 99 | } 100 | 101 | int tests_run = 0; 102 | 103 | static char *test_suite() 104 | { 105 | mu_run_test(test_array); 106 | return 0; 107 | } 108 | 109 | int main() 110 | { 111 | printf("---=[ Array tests\n"); 112 | char *result = test_suite(); 113 | if (result != 0) { 114 | printf("%s\n", result); 115 | } else { 116 | printf("ALL TESTS PASSED\n"); 117 | } 118 | printf("Tests run: %d\n", tests_run); 119 | return result != 0; 120 | } 121 | -------------------------------------------------------------------------------- /test/test_ast.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "minunit.h" 4 | 5 | #include "../src/ast.c" 6 | 7 | static char *test_ast() 8 | { 9 | // (add 5 7) 10 | char *add = malloc(4 * sizeof(char)); 11 | strcpy(add, "add"); 12 | AstSexpr *ast = 13 | ast_sexpr_from_list( 14 | ast_list_from_compound_list( 15 | ast_sexpr_from_atom( 16 | ast_atom_from_symbol(add)), 17 | ast_list_from_compound_list( 18 | ast_sexpr_from_atom( 19 | ast_atom_from_int(5)), 20 | ast_list_from_compound_list( 21 | ast_sexpr_from_atom( 22 | ast_atom_from_float(7.0)), 23 | ast_list_empty())))); 24 | 25 | mu_assert(strcmp(ast->as.list 26 | ->as.compound.sexpr 27 | ->as.atom 28 | ->as.symbol, "add") == 0, "Wrong symbol name"); 29 | mu_assert(ast->as.list 30 | ->as.compound.list 31 | ->as.compound.sexpr 32 | ->as.atom 33 | ->as.integer == 5, "Wrong LHS int"); 34 | mu_assert(ast->as.list 35 | ->as.compound.list 36 | ->as.compound.list 37 | ->as.compound.sexpr 38 | ->as.atom 39 | ->as.decimal == 7.0, "Wrong RHS float"); 40 | // ast_print(ast); 41 | ast_delete_sexpr(ast); 42 | return 0; 43 | } 44 | 45 | int tests_run = 0; 46 | 47 | static char *test_suite() 48 | { 49 | mu_run_test(test_ast); 50 | return 0; 51 | } 52 | 53 | int main() 54 | { 55 | printf("---=[ AST tests\n"); 56 | char *result = test_suite(); 57 | if (result != 0) { 58 | printf("%s\n", result); 59 | } else { 60 | printf("ALL TESTS PASSED\n"); 61 | } 62 | printf("Tests run: %d\n", tests_run); 63 | return result != 0; 64 | } 65 | -------------------------------------------------------------------------------- /test/test_djb2.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "minunit.h" 3 | 4 | #include "../src/djb2.c" 5 | 6 | 7 | static char *test_djb2() 8 | { 9 | /* Basic testing for the djb2 hash: can we call it and 10 | * does it return a reasonable result? 11 | */ 12 | unsigned long hash = djb2(""); 13 | mu_assert(hash == 5381, "djb2 implementation error"); 14 | hash = djb2("Hello World!"); 15 | mu_assert(hash != 5381, "djb2 addition failure"); 16 | return 0; 17 | } 18 | 19 | int tests_run = 0; 20 | 21 | static char *test_suite() 22 | { 23 | mu_run_test(test_djb2); 24 | return 0; 25 | } 26 | 27 | int main() 28 | { 29 | printf("---=[ djb2 tests\n"); 30 | char *result = test_suite(); 31 | if (result != 0) { 32 | printf("%s\n", result); 33 | } else { 34 | printf("ALL TESTS PASSED\n"); 35 | } 36 | printf("Tests run: %d\n", tests_run); 37 | return result != 0; 38 | } 39 | -------------------------------------------------------------------------------- /test/test_env.c: -------------------------------------------------------------------------------- 1 | #include "minunit.h" 2 | #include "value.h" 3 | 4 | #include "../src/env.c" 5 | 6 | static char *test_env() 7 | { 8 | /* 9 | * creation 10 | */ 11 | Environment *env0 = env_new(NULL); 12 | mu_assert(env_get(env0, "some_key") == NULL, "New env should be empty"); 13 | /* 14 | * get/set 15 | */ 16 | Value *val0 = value_new_int(42); 17 | env_set(env0, "key1", val0); 18 | Value *ret0 = env_get(env0, "key1"); 19 | mu_assert(ret0->type = VALUE_INT, "value type must not change"); 20 | mu_assert(42 == ret0->value.int_, "Value must not change"); 21 | /* 22 | * nesting 23 | */ 24 | Environment *env1 = env_new(env0); 25 | mu_assert(env1->parent == env0, "Failed to set parent"); 26 | Environment *env2 = env_new(env1); 27 | mu_assert(env2->parent == env1, "Failed to set parent"); 28 | ret0 = env_get(env2, "key1"); 29 | mu_assert(ret0 != NULL, "Should find key in nested env"); 30 | mu_assert(ret0->type = VALUE_INT, "Value type must not change"); 31 | mu_assert(42 == ret0->value.int_, "Value must not change"); 32 | 33 | return 0; 34 | } 35 | 36 | int tests_run = 0; 37 | 38 | static char *test_suite() 39 | { 40 | int bos; 41 | gc_start(&gc, &bos); 42 | mu_run_test(test_env); 43 | gc_stop(&gc); 44 | return 0; 45 | } 46 | 47 | int main() 48 | { 49 | printf("---=[ Environment tests\n"); 50 | char *result = test_suite(); 51 | if (result != 0) { 52 | printf("%s\n", result); 53 | } else { 54 | printf("ALL TESTS PASSED\n"); 55 | } 56 | printf("Tests run: %d\n", tests_run); 57 | return result != 0; 58 | } 59 | -------------------------------------------------------------------------------- /test/test_ir.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "minunit.h" 4 | #include "../src/ir.c" 5 | 6 | static char *test_ir() 7 | { 8 | /* 9 | * FIXME: these are not real tests 10 | */ 11 | 12 | // (add 5 7.0) 13 | char *add = malloc(4 * sizeof(char)); 14 | strcpy(add, "add"); 15 | AstSexpr *ast = 16 | ast_sexpr_from_list( 17 | ast_list_from_compound_list( 18 | ast_sexpr_from_atom( 19 | ast_atom_from_symbol(add)), 20 | ast_list_from_compound_list( 21 | ast_sexpr_from_atom( 22 | ast_atom_from_int(5)), 23 | ast_list_from_compound_list( 24 | ast_sexpr_from_atom( 25 | ast_atom_from_float(7.0)), 26 | ast_list_empty())))); 27 | value_print(ir_from_ast_sexpr(ast)); 28 | printf("\n"); 29 | 30 | // (add (quote 5) 7.0) 31 | AstSexpr *ast2 = 32 | ast_sexpr_from_list( 33 | ast_list_from_compound_list( 34 | ast_sexpr_from_atom( 35 | ast_atom_from_symbol(add)), 36 | ast_list_from_compound_list( 37 | ast_sexpr_from_quote( 38 | ast_sexpr_from_atom( 39 | ast_atom_from_int(5))), 40 | ast_list_from_compound_list( 41 | ast_sexpr_from_atom( 42 | ast_atom_from_float(7.0)), 43 | ast_list_empty())))); 44 | value_print(ir_from_ast_sexpr(ast2)); 45 | printf("\n"); 46 | return 0; 47 | } 48 | 49 | int tests_run = 0; 50 | 51 | static char *test_suite() 52 | { 53 | int bos; 54 | gc_start(&gc, &bos); 55 | mu_run_test(test_ir); 56 | gc_stop(&gc); 57 | return 0; 58 | } 59 | 60 | int main() 61 | { 62 | printf("---=[ IR tests\n"); 63 | char *result = test_suite(); 64 | if (result != 0) { 65 | printf("%s\n", result); 66 | } else { 67 | printf("ALL TESTS PASSED\n"); 68 | } 69 | printf("Tests run: %d\n", tests_run); 70 | return result != 0; 71 | } 72 | -------------------------------------------------------------------------------- /test/test_lexer.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "minunit.h" 4 | 5 | #include "../src/lexer.c" 6 | 7 | 8 | static char *type_names[] = { 9 | "ERROR", "INT", "FLOAT", "STRING", "SYMBOL", 10 | "LPAREN", "RPAREN", "QUOTE", "EOF" 11 | }; 12 | 13 | static char *input[] = {"12 ( 34.5 ) \"Hello World!\" abc 23.b (12(23))) \n" 14 | "\"this is a string\" vEryC0mplicated->NamE 'symbol ", 15 | "x ", 16 | "\"Testing \\\"n escapes\" " 17 | }; 18 | 19 | static size_t n_inputs = 3; 20 | 21 | static char *expected[] = {"INT LPAREN FLOAT RPAREN STRING SYMBOL ERROR LPAREN " 22 | "INT LPAREN INT RPAREN RPAREN RPAREN STRING SYMBOL " 23 | "QUOTE SYMBOL ", 24 | "SYMBOL ", 25 | "STRING " 26 | }; 27 | 28 | static char *eval_lexer(char *input, char *expected) 29 | { 30 | /* set up lexer to read from input file */ 31 | size_t n = strlen(input); 32 | FILE *in_fd = fmemopen(input, n, "r"); 33 | mu_assert(in_fd != NULL, "Failed to open lexer test file"); 34 | Lexer *lexer = lexer_new(in_fd); 35 | mu_assert(lexer != NULL, "Failed to create a lexer object"); 36 | 37 | /* at the same time, we'll read the expected symbols 38 | from the reference file */ 39 | n = strlen(expected); 40 | FILE *ref_fd = fmemopen(expected, n, "r"); 41 | mu_assert(ref_fd != NULL, "Failed to open lexer test reference file"); 42 | char *ref_line = NULL; 43 | size_t linecap = 0; 44 | ssize_t linelen; 45 | LexerToken *tok = lexer_get_token(lexer); 46 | linelen = getdelim(&ref_line, &linecap, ' ', ref_fd); 47 | while (tok != NULL && tok->type != LEXER_TOK_EOF && linelen > 0) { 48 | ref_line[linelen - 1] = '\0'; 49 | // printf("'%s' =?= '%s'\n", type_names[tok->type], ref_line); 50 | mu_assert(strcmp(type_names[tok->type], ref_line) == 0, 51 | "Unexpected symbol"); 52 | lexer_delete_token(tok); 53 | tok = lexer_get_token(lexer); 54 | linelen = getdelim(&ref_line, &linecap, ' ', ref_fd); 55 | } 56 | mu_assert(tok != NULL && tok->type == LEXER_TOK_EOF 57 | && linelen == -1, "Incorrect number of symbols"); 58 | lexer_delete(lexer); 59 | fclose(ref_fd); 60 | fclose(in_fd); 61 | return 0; 62 | } 63 | 64 | static char *test_escapes() 65 | { 66 | /* set up lexer to read from input file */ 67 | char *input = "\"This \\n is a \\t \\\"string\""; 68 | char *result = "This \n is a \t \"string"; 69 | size_t n = strlen(input); 70 | FILE *in_fd = fmemopen(input, n, "r"); 71 | mu_assert(in_fd != NULL, "Failed to open lexer test file"); 72 | Lexer *lexer = lexer_new(in_fd); 73 | mu_assert(lexer != NULL, "Failed to create a lexer object"); 74 | 75 | LexerToken *tok = lexer_get_token(lexer); 76 | mu_assert(tok != NULL && tok->type == LEXER_TOK_STRING, 77 | "Expect a string token for escape strings"); 78 | mu_assert(strncmp(tok->as.str, result, n) == 0, 79 | "Expect strings to be equal"); 80 | lexer_delete(lexer); 81 | fclose(in_fd); 82 | return 0; 83 | } 84 | 85 | static char *test_lexer() 86 | { 87 | for (size_t i = 0; i < n_inputs; ++i) { 88 | char *retval = eval_lexer(input[i], expected[i]); 89 | if (retval) { 90 | return retval; 91 | } 92 | } 93 | return 0; 94 | } 95 | 96 | int tests_run = 0; 97 | 98 | static char *test_suite() 99 | { 100 | mu_run_test(test_lexer); 101 | mu_run_test(test_escapes); 102 | return 0; 103 | } 104 | 105 | int main() 106 | { 107 | printf("---=[ Lexer tests\n"); 108 | char *result = test_suite(); 109 | if (result != 0) { 110 | printf("%s\n", result); 111 | } else { 112 | printf("ALL TESTS PASSED\n"); 113 | } 114 | printf("Tests run: %d\n", tests_run); 115 | return result != 0; 116 | } 117 | -------------------------------------------------------------------------------- /test/test_list.c: -------------------------------------------------------------------------------- 1 | #include "minunit.h" 2 | #include "log.h" 3 | #include "value.h" 4 | 5 | #include "../src/list.c" 6 | 7 | static char *test_list() 8 | { 9 | Value *numbers[4] = { 10 | value_new_int(1), 11 | value_new_int(2), 12 | value_new_int(3), 13 | value_new_int(4) 14 | }; 15 | 16 | const List *l = list_new(); 17 | mu_assert(list_size(l) == 0, "Empty list should have length 0"); 18 | 19 | /* empty copy */ 20 | List *l2 = list_mutable_copy(l); 21 | mu_assert(list_size(l) == list_size(l2), "Copied list must have equal length"); 22 | 23 | mu_assert(l2 != l, "Copies need to be different!"); 24 | mu_assert(l->head == NULL, "head ptr must be NULL"); 25 | mu_assert(l2->head == NULL, "head ptr must be NULL"); 26 | 27 | /* list of size 1 */ 28 | l = list_new(); 29 | for (size_t i = 0; i < 1; ++i) { 30 | l = list_append(l, numbers[i]); 31 | mu_assert(list_size(l) == i + 1, "List should grow by one in every step"); 32 | } 33 | l2 = list_mutable_copy(l); 34 | mu_assert(list_size(l) == list_size(l2), "Copied list must have equal length"); 35 | 36 | mu_assert(l2 != l, "Copies need to be different!"); 37 | mu_assert(l2->head != l->head, "head ptrs must be different"); 38 | 39 | l = list_new(); 40 | for (size_t i = 0; i < 4; ++i) { 41 | l = list_append(l, numbers[i]); 42 | mu_assert(list_size(l) == i + 1, "List should grow by one in every step"); 43 | } 44 | /* list_mutable_copy: List object and list items need to be deep copies 45 | * pointing to the same content 46 | */ 47 | l2 = list_mutable_copy(l); 48 | mu_assert(list_size(l) == list_size(l2), "Copied list must have equal length"); 49 | 50 | mu_assert(l2 != l, "Copies need to be different!"); 51 | mu_assert(l2->head != l->head, "head ptrs must be different"); 52 | 53 | ListItem *cur, *cur2; 54 | cur = l->head; 55 | cur2 = l2->head; 56 | size_t i = 0; 57 | 58 | while (cur != NULL && cur2 != NULL) { 59 | mu_assert(cur->val == numbers[i], "Wrong data reference in src"); 60 | mu_assert(cur2->val == numbers[i], "Wrong data reference in dst"); 61 | cur = cur->next; 62 | cur2 = cur2->next; 63 | ++i; 64 | } 65 | mu_assert(cur == NULL && cur2 == NULL, "copy has different length"); 66 | 67 | mu_assert(list_size(l) == 4, "Number of appended elemets should be 4"); 68 | mu_assert(list_head(l)->value.int_ == 1, "First element should be 1"); 69 | const List *tail = list_tail(l); 70 | mu_assert(list_size(tail) == 3, "Tail should have size 3"); 71 | mu_assert(list_head(tail)->value.int_ == 2, "First element of tail should be 2"); 72 | 73 | l = list_new(); 74 | for (size_t i = 0; i < 4; ++i) { 75 | l = list_prepend(l, numbers[i]); 76 | mu_assert(list_size(l) == i + 1, "List should grow by one in every step"); 77 | } 78 | mu_assert(list_size(l) == 4, "Number of prepended elemets should be 4"); 79 | mu_assert(list_head(l)->value.int_ == 4, "First element should be 4"); 80 | 81 | l2 = list_mutable_copy(l); 82 | mu_assert(list_size(l) == list_size(l2), "Copied list must have equal length"); 83 | 84 | mu_assert(l2 != l, "Copies need to be different!"); 85 | mu_assert(l2->head != l->head, "head ptrs must be different"); 86 | 87 | cur = l->head; 88 | cur2 = l2->head; 89 | i = 0; 90 | while (cur != NULL && cur2 != NULL) { 91 | mu_assert(cur->val == numbers[3 - i], "Wrong data reference in src"); 92 | mu_assert(cur2->val == numbers[3 - i], "Wrong data reference in dst"); 93 | cur = cur->next; 94 | cur2 = cur2->next; 95 | ++i; 96 | } 97 | mu_assert(cur == NULL && cur2 == NULL, "copy has different length"); 98 | 99 | l = list_new(); 100 | mu_assert(list_head(l) == NULL, "Empty list should have a NULL head"); 101 | mu_assert(list_size(list_tail(l)) == 0, "Empty list should have an empty tail"); 102 | l = list_append(l, numbers[0]); 103 | mu_assert(list_head(l)->value.int_ == 1, "Head of one-element list should be 1"); 104 | mu_assert(list_size(list_tail(l)) == 0, "One-element list should have an empty tail"); 105 | 106 | /* iterate over list using combination of head/tail calls */ 107 | const List *a = list_new(); 108 | const List *p = list_new(); 109 | // use two lists, one built w/ prepending, one with appending 110 | for (size_t i = 0; i < 10; ++i) { 111 | a = list_append(a, numbers[0]); 112 | p = list_prepend(p, numbers[0]); 113 | } 114 | const Value *head; 115 | size_t j = 10; 116 | while((head = list_head(a)) != NULL) { 117 | mu_assert(list_size(a) == j, "tail size should decrease linearly"); 118 | a = list_tail(a); 119 | j--; 120 | mu_assert(list_size(a) == j, "tail size should decrease linearly"); 121 | } 122 | mu_assert(list_size(a) == 0, "Empty tail should have size zero"); 123 | j = 10; 124 | while((head = list_head(p)) != NULL) { 125 | mu_assert(list_size(p) == j, "tail size should decrease linearly"); 126 | p = list_tail(p); 127 | j--; 128 | mu_assert(list_size(p) == j, "tail size should decrease linearly"); 129 | } 130 | mu_assert(list_size(p) == 0, "Empty tail should have size zero"); 131 | 132 | /* list_nth: standard case */ 133 | l = list_new(); 134 | for (size_t i = 0; i < 4; ++i) { 135 | l = list_append(l, numbers[i]); 136 | } 137 | mu_assert(list_nth(l, 0) == numbers[0], "Wrong index offset"); 138 | mu_assert(list_nth(l, 1) == numbers[1], "Wrong index offset"); 139 | mu_assert(list_nth(l, 2) == numbers[2], "Wrong index offset"); 140 | mu_assert(list_nth(l, 3) == numbers[3], "Wrong index offset"); 141 | mu_assert(list_nth(l, 4) == NULL, "Out of range index should return NULL"); 142 | 143 | /* list_nth: empty list */ 144 | l = list_new(); 145 | mu_assert(list_nth(l, 0) == NULL, "Out of range index should return NULL"); 146 | mu_assert(list_nth(l, 4) == NULL, "Out of range index should return NULL"); 147 | 148 | return 0; 149 | } 150 | 151 | int tests_run = 0; 152 | 153 | static char *test_suite() 154 | { 155 | int bos; 156 | gc_start(&gc, &bos); 157 | mu_run_test(test_list); 158 | gc_stop(&gc); 159 | return 0; 160 | } 161 | 162 | int main() 163 | { 164 | printf("---=[ List tests\n"); 165 | char *result = test_suite(); 166 | if (result != 0) { 167 | printf("%s\n", result); 168 | } else { 169 | printf("ALL TESTS PASSED\n"); 170 | } 171 | printf("Tests run: %d\n", tests_run); 172 | return result != 0; 173 | } 174 | 175 | -------------------------------------------------------------------------------- /test/test_map.c: -------------------------------------------------------------------------------- 1 | #include "minunit.h" 2 | 3 | #include 4 | #include "gc.h" 5 | #include "log.h" 6 | 7 | #include "../src/map.c" 8 | 9 | 10 | static char *test_map() 11 | { 12 | Map *ht = map_new(3); 13 | LOG_DEBUG("Capacity: %lu", ht->capacity); 14 | mu_assert(ht->capacity == 3, "Capacity sizing failure"); 15 | map_put(ht, "key", "value", strlen("value") + 1); 16 | // set/get item 17 | char *value = (char *) map_get(ht, "key"); 18 | mu_assert(value != NULL, "Query must find inserted key"); 19 | mu_assert(strcmp(value, "value") == 0, "Query must return inserted value"); 20 | 21 | // update item 22 | map_put(ht, "key", "other", strlen("other") + 1); 23 | value = (char *) map_get(ht, "key"); 24 | mu_assert(value != NULL, "Query must find key"); 25 | mu_assert(strcmp(value, "other") == 0, "Query must return updated value"); 26 | 27 | // delete item 28 | map_remove(ht, "key"); 29 | value = (char *) map_get(ht, "key"); 30 | mu_assert(value == NULL, "Query must NOT find deleted key"); 31 | 32 | map_delete(ht); 33 | return 0; 34 | } 35 | 36 | int tests_run = 0; 37 | 38 | static char *test_suite() 39 | { 40 | void *bos = NULL; 41 | gc_start(&gc, &bos); 42 | mu_run_test(test_map); 43 | gc_stop(&gc); 44 | return 0; 45 | } 46 | 47 | int main() 48 | { 49 | printf("---=[ map tests\n"); 50 | char *result = test_suite(); 51 | if (result != 0) { 52 | printf("%s\n", result); 53 | } else { 54 | printf("ALL TESTS PASSED\n"); 55 | } 56 | printf("Tests run: %d\n", tests_run); 57 | return result != 0; 58 | } 59 | -------------------------------------------------------------------------------- /test/test_parser.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "minunit.h" 4 | #include "parser.h" 5 | #include "../src/parser.c" 6 | 7 | static char *test_parser() 8 | { 9 | char *source[] = { 10 | "1", 11 | "\"a\"", 12 | "(fn 3 4 1)", 13 | "(lambda (a) (+ 1 a))", 14 | "(= 7 (let (b 12) (do (eval (read-string (def aa 7))) aa)))" 15 | }; 16 | for (size_t k = 0; k < 4; ++k) { 17 | size_t n = strlen(source[k]); 18 | FILE *stream = fmemopen(source[k], n, "r"); 19 | mu_assert(stream != NULL, "Failed to open lexer test file"); 20 | 21 | Value *ast = NULL; 22 | ParseResult success = parser_parse(stream, &ast); 23 | mu_assert(success == PARSER_SUCCESS, "Failed to parse"); 24 | // value_print(ast); 25 | // printf("\n"); 26 | } 27 | return 0; 28 | } 29 | 30 | int tests_run = 0; 31 | 32 | static char *test_suite() 33 | { 34 | int bos; 35 | gc_start(&gc, &bos); 36 | mu_run_test(test_parser); 37 | gc_stop(&gc); 38 | return 0; 39 | } 40 | 41 | int main() 42 | { 43 | printf("---=[ Parser tests\n"); 44 | char *result = test_suite(); 45 | if (result != 0) { 46 | printf("%s\n", result); 47 | } else { 48 | printf("ALL TESTS PASSED\n"); 49 | } 50 | printf("Tests run: %d\n", tests_run); 51 | return result != 0; 52 | } 53 | -------------------------------------------------------------------------------- /test/test_primes.c: -------------------------------------------------------------------------------- 1 | #include "minunit.h" 2 | #include 3 | #include "../src/primes.c" 4 | 5 | 6 | static char *test_primes() 7 | { 8 | /* 9 | * Test a few known cases. 10 | */ 11 | mu_assert(!is_prime(0), "Prime test failure for 0"); 12 | mu_assert(!is_prime(1), "Prime test failure for 1"); 13 | mu_assert(is_prime(2), "Prime test failure for 2"); 14 | mu_assert(is_prime(3), "Prime test failure for 3"); 15 | mu_assert(!is_prime(12742382), "Prime test failure for 12742382"); 16 | mu_assert(is_prime(611953), "Prime test failure for 611953"); 17 | mu_assert(is_prime(479001599), "Prime test failure for 479001599"); 18 | return 0; 19 | } 20 | 21 | int tests_run = 0; 22 | 23 | static char *test_suite() 24 | { 25 | mu_run_test(test_primes); 26 | return 0; 27 | } 28 | 29 | int main() 30 | { 31 | printf("---=[ Prime number tests\n"); 32 | char *result = test_suite(); 33 | if (result != 0) { 34 | printf("%s\n", result); 35 | } else { 36 | printf("ALL TESTS PASSED\n"); 37 | } 38 | printf("Tests run: %d\n", tests_run); 39 | return result != 0; 40 | } 41 | 42 | --------------------------------------------------------------------------------