├── .github └── workflows │ └── ci.yaml ├── LICENSE ├── Makefile ├── README.md ├── tcl.c ├── tcl_test.c ├── tcl_test_flow.h ├── tcl_test_lexer.h ├── tcl_test_math.h └── tcl_test_subst.h /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: Build Pipeline 2 | 3 | on: [push] 4 | 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2 10 | - name: Build 11 | run: make tcl 12 | - name: Test 13 | run: make test 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Serge Zaitsev 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | CC ?= clang 2 | CFLAGS ?= -Os -Wall -Wextra -std=c99 -pedantic 3 | LDFLAGS ?= -Os 4 | 5 | TCLBIN := tcl 6 | 7 | TEST_CC := clang 8 | TEST_CFLAGS := -O0 -g -std=c11 -pedantic -fprofile-arcs -ftest-coverage 9 | TEST_LDFLAGS := $(TEST_CFLAGS) 10 | TCLTESTBIN := tcl_test 11 | 12 | all: $(TCLBIN) test 13 | tcl: tcl.o 14 | 15 | test: $(TCLTESTBIN) 16 | ./tcl_test 17 | $(TCLTESTBIN): tcl_test.o 18 | $(TEST_CC) $(TEST_LDFLAGS) -o $@ $^ 19 | tcl_test.o: tcl_test.c tcl.c \ 20 | tcl_test_lexer.h tcl_test_subst.h tcl_test_flow.h tcl_test_math.h 21 | $(TEST_CC) $(TEST_CFLAGS) -c tcl_test.c -o $@ 22 | 23 | coverage: test 24 | gcov tcl_test.c 25 | 26 | fmt: 27 | clang-format-3.6 -i *.c *.h 28 | cloc tcl.c 29 | 30 | clean: 31 | rm -f $(TCLBIN) $(TCLTESTBIN) *.o *.gcda *.gcno 32 | 33 | .PHONY: test clean fmt 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Partcl - a minimal Tcl interpreter 2 | 3 | [![Build Status](https://img.shields.io/github/workflow/status/zserge/partcl/Build%20Pipeline)](https://github.com/zserge/partcl) 4 | 5 | ## Features 6 | 7 | * ~600 lines of "pedantic" C99 code 8 | * No external dependencies 9 | * Good test coverage 10 | * Can be extended with custom Tcl commands 11 | * Runs well on bare metal embedded MCUs (~10k of flash is required) 12 | 13 | Built-in commands: 14 | 15 | * `subst arg` 16 | * `set var ?val?` 17 | * `while cond loop` 18 | * `if cond branch ?cond? ?branch? ?other?` 19 | * `proc name args body` 20 | * `return` 21 | * `break` 22 | * `continue` 23 | * arithmetic operations: `+, -, *, /, <, >, <=, >=, ==, !=` 24 | 25 | ## Usage 26 | 27 | ```c 28 | struct tcl tcl; 29 | const char *s = "set x 4; puts [+ [* $x 10] 2]"; 30 | 31 | tcl_init(&tcl); 32 | if (tcl_eval(&tcl, s, strlen(s)) != FERROR) { 33 | printf("%.*s\n", tcl_length(tcl.result), tcl_string(tcl.result)); 34 | } 35 | tcl_destroy(&tcl); 36 | ``` 37 | 38 | ## Language syntax 39 | 40 | Tcl script is made up of _commands_ separated by semicolons or newline 41 | symbols. Commnads in their turn are made up of _words_ separated by whitespace. 42 | To make whitespace a part of the word one may use double quotes or braces. 43 | 44 | An important part of the language is _command substitution_, when the result of 45 | a command inside square braces is returned as a part of the outer command, e.g. 46 | `puts [+ 1 2]`. 47 | 48 | The only data type of the language is a string. Although it may complicate 49 | mathematical operations, it opens a broad way for building your own DSLs to 50 | enhance the language. 51 | 52 | ## Lexer 53 | 54 | Any symbol can be part of the word, except for the following special symbols: 55 | 56 | * whitespace, tab - used to delimit words 57 | * `\r`, `\n`, semicolon or EOF - used to delimit commands 58 | * Braces, square brackets, dollar sign - used for substitution and grouping 59 | 60 | Partcl has special helper functions for these char classes: 61 | 62 | ``` 63 | static int tcl_is_space(char c); 64 | static int tcl_is_end(char c); 65 | static int tcl_is_special(char c, int q); 66 | ``` 67 | 68 | `tcl_is_special` behaves differently depending on the quoting mode (`q` 69 | parameter). Inside a quoted string braces, semicolon and end-of-line symbols 70 | lose their special meaning and become regular printable characters. 71 | 72 | Partcl lexer is implemented in one function: 73 | 74 | ``` 75 | int tcl_next(const char *s, size_t n, const char **from, const char **to, int *q); 76 | ``` 77 | 78 | `tcl_next` function finds the next token in the string `s`. `from` and `to` are 79 | set to point to the token start/end, `q` denotes the quoting mode and is 80 | changed if `"` is met. 81 | 82 | A special macro `tcl_each(s, len, skip_error)` can used to iterate over all the 83 | tokens in the string. If `skip_error` is false - loop ends when string ends, 84 | otherwise loop can end earlier if a syntax error is found. It allows to 85 | "validate" input string without evaluating it and detect when a full command 86 | has been read. 87 | 88 | ## Data types 89 | 90 | Tcl uses strings as a primary data type. When Tcl script is evaluated, many of 91 | the strings are created, disposed or modified. In embedded systems memory 92 | management can be complex, so all operations with Tcl values are moved into 93 | isolated functions that can be easily rewritten to optimize certain parts (e.g. 94 | to use a pool of strings, a custom memory allocator, cache numerical or list 95 | values to increase performance etc). 96 | 97 | ``` 98 | /* Raw string values */ 99 | tcl_value_t *tcl_alloc(const char *s, size_t len); 100 | tcl_value_t *tcl_dup(tcl_value_t *v); 101 | tcl_value_t *tcl_append(tcl_value_t *v, tcl_value_t *tail); 102 | int tcl_length(tcl_value_t *v); 103 | void tcl_free(tcl_value_t *v); 104 | 105 | /* Helpers to access raw string or numeric value */ 106 | int tcl_int(tcl_value_t *v); 107 | const char *tcl_string(tcl_value_t *v); 108 | 109 | /* List values */ 110 | tcl_value_t *tcl_list_alloc(); 111 | tcl_value_t *tcl_list_append(tcl_value_t *v, tcl_value_t *tail); 112 | tcl_value_t *tcl_list_at(tcl_value_t *v, int index); 113 | int tcl_list_length(tcl_value_t *v); 114 | void tcl_list_free(tcl_value_t *v); 115 | ``` 116 | 117 | Keep in mind, that `..._append()` functions must free the tail argument. 118 | Also, the string returned by `tcl_string()` it not meant to be mutated or 119 | cached. 120 | 121 | In the default implementation lists are implemented as raw strings that add 122 | some escaping (braces) around each iterm. It's a simple solution that also 123 | reduces the code, but in some exotic cases the escaping can become wrong and 124 | invalid results will be returned. 125 | 126 | ## Environments 127 | 128 | A special type, `struct tcl_env` is used to keep the evaluation environment (a 129 | set of functions). The interpreter creates a new environment for each 130 | user-defined procedure, also there is one global environment per interpreter. 131 | 132 | There are only 3 functions related to the environment. One creates a new environment, another seeks for a variable (or creates a new one), the last one destroys the environment and all its variables. 133 | 134 | These functions use malloc/free, but can easily be rewritten to use memory pools instead. 135 | 136 | ``` 137 | static struct tcl_env *tcl_env_alloc(struct tcl_env *parent); 138 | static struct tcl_var *tcl_env_var(struct tcl_env *env, tcl_value_t *name); 139 | static struct tcl_env *tcl_env_free(struct tcl_env *env); 140 | ``` 141 | 142 | Variables are implemented as a single-linked list, each variable is a pair of 143 | values (name + value) and a pointer to the next variable. 144 | 145 | ## Interpreter 146 | 147 | Partcl interpreter is a simple structure `struct tcl` which keeps the current 148 | environment, array of available commands and a last result value. 149 | 150 | Interpreter logic is wrapped around two functions - evaluation and 151 | substitution. 152 | 153 | Substitution: 154 | 155 | - If argument starts with `$` - create a temporary command `[set name]` and 156 | evaluate it. In Tcl `$foo` is just a shortcut to `[set foo]`, which returns 157 | the value of "foo" variable in the current environment. 158 | - If argument starts with `[` - evaluate what's inside the square brackets and 159 | return the result. 160 | - If argument is a quoted string (e.g. `{foo bar}`) - return it as is, just 161 | without braces. 162 | - Otherwise return the argument as is. 163 | 164 | Evaluation: 165 | 166 | - Iterates over each token in a list 167 | - Appends words into a list 168 | - If the command end is met (semicolor, or newline, or end-of-file - our lexer 169 | has a special token type `TCMD` for them) - then find a suitable command (the 170 | first word in the list) and call it. 171 | 172 | Where the commands are taken from? Initially, a Partcl interpeter starts with 173 | no commands, but one may add the commands by calling `tcl_register()`. 174 | 175 | Each command has a name, arity (how many arguments is shall take - interpreter 176 | checks it before calling the command, use zero arity for varargs) and a C 177 | function pointer that actually implements the command. 178 | 179 | ## Builtin commands 180 | 181 | "set" - `tcl_cmd_set`, assigns value to the variable (if any) and returns the 182 | current variable value. 183 | 184 | "subst" - `tcl_cmd_subst`, does command substitution in the argument string. 185 | 186 | "puts" - `tcl_cmd_puts`, prints argument to the stdout, followed by a newline. 187 | This command can be disabled using `#define TCL_DISABLE_PUTS`, which is handy 188 | for embedded systems that don't have "stdout". 189 | 190 | "proc" - `tcl_cmd_proc`, creates a new command appending it to the list of 191 | current interpreter commands. That's how user-defined commands are built. 192 | 193 | "if" - `tcl_cmd_if`, does a simple `if {cond} {then} {cond2} {then2} {else}`. 194 | 195 | "while" - `tcl_cmd_while`, runs a while loop `while {cond} {body}`. One may use 196 | "break", "continue" or "return" inside the loop to contol the flow. 197 | 198 | Various math operations are implemented as `tcl_cmd_math`, but can be disabled, 199 | too if your script doesn't need them (if you want to use Partcl as a command 200 | shell, not as a programming language). 201 | 202 | ## Building and testing 203 | 204 | All sources are in one file, `tcl.c`. It can be used as a standalone 205 | interpreter, or included as a single-file library (you may want to rename it 206 | into tcl.h then). 207 | 208 | Tests are run with clang and coverage is calculated. Just run "make test" and 209 | you're done. 210 | 211 | Code is formatted using clang-format to keep the clean and readable coding 212 | style. Please run it for pull requests, too. 213 | 214 | ## License 215 | 216 | Code is distributed under MIT license, feel free to use it in your proprietary 217 | projects as well. 218 | 219 | 220 | -------------------------------------------------------------------------------- /tcl.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include 5 | 6 | #if 0 7 | #define DBG printf 8 | #else 9 | #define DBG(...) 10 | #endif 11 | 12 | #define MAX_VAR_LENGTH 256 13 | 14 | struct tcl; 15 | int tcl_eval(struct tcl *tcl, const char *s, size_t len); 16 | 17 | /* Token type and control flow constants */ 18 | enum { TCMD, TWORD, TPART, TERROR }; 19 | enum { FERROR, FNORMAL, FRETURN, FBREAK, FAGAIN }; 20 | 21 | static int tcl_is_special(char c, int q) { 22 | return (c == '$' || (!q && (c == '{' || c == '}' || c == ';' || c == '\r' || 23 | c == '\n')) || 24 | c == '[' || c == ']' || c == '"' || c == '\0'); 25 | } 26 | 27 | static int tcl_is_space(char c) { return (c == ' ' || c == '\t'); } 28 | 29 | static int tcl_is_end(char c) { 30 | return (c == '\n' || c == '\r' || c == ';' || c == '\0'); 31 | } 32 | 33 | int tcl_next(const char *s, size_t n, const char **from, const char **to, 34 | int *q) { 35 | unsigned int i = 0; 36 | int depth = 0; 37 | char open; 38 | char close; 39 | 40 | DBG("tcl_next(%.*s)+%d+%d|%d\n", n, s, *from - s, *to - s, *q); 41 | 42 | /* Skip leading spaces if not quoted */ 43 | for (; !*q && n > 0 && tcl_is_space(*s); s++, n--) { 44 | } 45 | *from = s; 46 | /* Terminate command if not quoted */ 47 | if (!*q && n > 0 && tcl_is_end(*s)) { 48 | *to = s + 1; 49 | return TCMD; 50 | } 51 | if (*s == '$') { /* Variable token, must not start with a space or quote */ 52 | if (tcl_is_space(s[1]) || s[1] == '"') { 53 | return TERROR; 54 | } 55 | int mode = *q; 56 | *q = 0; 57 | int r = tcl_next(s + 1, n - 1, to, to, q); 58 | *q = mode; 59 | return ((r == TWORD && *q) ? TPART : r); 60 | } 61 | 62 | if (*s == '[' || (!*q && *s == '{')) { 63 | /* Interleaving pairs are not welcome, but it simplifies the code */ 64 | open = *s; 65 | close = (open == '[' ? ']' : '}'); 66 | for (i = 0, depth = 1; i < n && depth != 0; i++) { 67 | if (i > 0 && s[i] == open) { 68 | depth++; 69 | } else if (s[i] == close) { 70 | depth--; 71 | } 72 | } 73 | } else if (*s == '"') { 74 | *q = !*q; 75 | *from = *to = s + 1; 76 | if (*q) { 77 | return TPART; 78 | } 79 | if (n < 2 || (!tcl_is_space(s[1]) && !tcl_is_end(s[1]))) { 80 | return TERROR; 81 | } 82 | *from = *to = s + 1; 83 | return TWORD; 84 | } else if (*s == ']' || *s == '}') { 85 | /* Unbalanced bracket or brace */ 86 | return TERROR; 87 | } else { 88 | while (i < n && (*q || !tcl_is_space(s[i])) && !tcl_is_special(s[i], *q)) { 89 | i++; 90 | } 91 | } 92 | *to = s + i; 93 | if (i == n) { 94 | return TERROR; 95 | } 96 | if (*q) { 97 | return TPART; 98 | } 99 | return (tcl_is_space(s[i]) || tcl_is_end(s[i])) ? TWORD : TPART; 100 | } 101 | 102 | /* A helper parser struct and macro (requires C99) */ 103 | struct tcl_parser { 104 | const char *from; 105 | const char *to; 106 | const char *start; 107 | const char *end; 108 | int q; 109 | int token; 110 | }; 111 | #define tcl_each(s, len, skiperr) \ 112 | for (struct tcl_parser p = {NULL, NULL, (s), (s) + (len), 0, TERROR}; \ 113 | p.start < p.end && \ 114 | (((p.token = tcl_next(p.start, p.end - p.start, &p.from, &p.to, \ 115 | &p.q)) != TERROR) || \ 116 | (skiperr)); \ 117 | p.start = p.to) 118 | 119 | /* ------------------------------------------------------- */ 120 | /* ------------------------------------------------------- */ 121 | /* ------------------------------------------------------- */ 122 | /* ------------------------------------------------------- */ 123 | /* ------------------------------------------------------- */ 124 | typedef char tcl_value_t; 125 | 126 | const char *tcl_string(tcl_value_t *v) { return v; } 127 | int tcl_int(tcl_value_t *v) { return atoi(v); } 128 | int tcl_length(tcl_value_t *v) { return v == NULL ? 0 : strlen(v); } 129 | 130 | void tcl_free(tcl_value_t *v) { free(v); } 131 | 132 | tcl_value_t *tcl_append_string(tcl_value_t *v, const char *s, size_t len) { 133 | size_t n = tcl_length(v); 134 | v = realloc(v, n + len + 1); 135 | memset((char *)tcl_string(v) + n, 0, len + 1); 136 | strncpy((char *)tcl_string(v) + n, s, len); 137 | return v; 138 | } 139 | 140 | tcl_value_t *tcl_append(tcl_value_t *v, tcl_value_t *tail) { 141 | v = tcl_append_string(v, tcl_string(tail), tcl_length(tail)); 142 | tcl_free(tail); 143 | return v; 144 | } 145 | 146 | tcl_value_t *tcl_alloc(const char *s, size_t len) { 147 | return tcl_append_string(NULL, s, len); 148 | } 149 | 150 | tcl_value_t *tcl_dup(tcl_value_t *v) { 151 | return tcl_alloc(tcl_string(v), tcl_length(v)); 152 | } 153 | 154 | tcl_value_t *tcl_list_alloc(void) { return tcl_alloc("", 0); } 155 | 156 | int tcl_list_length(tcl_value_t *v) { 157 | int count = 0; 158 | tcl_each(tcl_string(v), tcl_length(v) + 1, 0) { 159 | if (p.token == TWORD) { 160 | count++; 161 | } 162 | } 163 | return count; 164 | } 165 | 166 | void tcl_list_free(tcl_value_t *v) { free(v); } 167 | 168 | tcl_value_t *tcl_list_at(tcl_value_t *v, int index) { 169 | int i = 0; 170 | tcl_each(tcl_string(v), tcl_length(v) + 1, 0) { 171 | if (p.token == TWORD) { 172 | if (i == index) { 173 | if (p.from[0] == '{') { 174 | return tcl_alloc(p.from + 1, p.to - p.from - 2); 175 | } 176 | return tcl_alloc(p.from, p.to - p.from); 177 | } 178 | i++; 179 | } 180 | } 181 | return NULL; 182 | } 183 | 184 | tcl_value_t *tcl_list_append(tcl_value_t *v, tcl_value_t *tail) { 185 | if (tcl_length(v) > 0) { 186 | v = tcl_append(v, tcl_alloc(" ", 2)); 187 | } 188 | if (tcl_length(tail) > 0) { 189 | int q = 0; 190 | const char *p; 191 | for (p = tcl_string(tail); *p; p++) { 192 | if (tcl_is_space(*p) || tcl_is_special(*p, 0)) { 193 | q = 1; 194 | break; 195 | } 196 | } 197 | if (q) { 198 | v = tcl_append(v, tcl_alloc("{", 1)); 199 | } 200 | v = tcl_append(v, tcl_dup(tail)); 201 | if (q) { 202 | v = tcl_append(v, tcl_alloc("}", 1)); 203 | } 204 | } else { 205 | v = tcl_append(v, tcl_alloc("{}", 2)); 206 | } 207 | return v; 208 | } 209 | 210 | /* ----------------------------- */ 211 | /* ----------------------------- */ 212 | /* ----------------------------- */ 213 | /* ----------------------------- */ 214 | 215 | typedef int (*tcl_cmd_fn_t)(struct tcl *, tcl_value_t *, void *); 216 | 217 | struct tcl_cmd { 218 | tcl_value_t *name; 219 | int arity; 220 | tcl_cmd_fn_t fn; 221 | void *arg; 222 | struct tcl_cmd *next; 223 | }; 224 | 225 | struct tcl_var { 226 | tcl_value_t *name; 227 | tcl_value_t *value; 228 | struct tcl_var *next; 229 | }; 230 | 231 | struct tcl_env { 232 | struct tcl_var *vars; 233 | struct tcl_env *parent; 234 | }; 235 | 236 | static struct tcl_env *tcl_env_alloc(struct tcl_env *parent) { 237 | struct tcl_env *env = malloc(sizeof(*env)); 238 | env->vars = NULL; 239 | env->parent = parent; 240 | return env; 241 | } 242 | 243 | static struct tcl_var *tcl_env_var(struct tcl_env *env, tcl_value_t *name) { 244 | struct tcl_var *var = malloc(sizeof(struct tcl_var)); 245 | var->name = tcl_dup(name); 246 | var->next = env->vars; 247 | var->value = tcl_alloc("", 0); 248 | env->vars = var; 249 | return var; 250 | } 251 | 252 | static struct tcl_env *tcl_env_free(struct tcl_env *env) { 253 | struct tcl_env *parent = env->parent; 254 | while (env->vars) { 255 | struct tcl_var *var = env->vars; 256 | env->vars = env->vars->next; 257 | tcl_free(var->name); 258 | tcl_free(var->value); 259 | free(var); 260 | } 261 | free(env); 262 | return parent; 263 | } 264 | 265 | struct tcl { 266 | struct tcl_env *env; 267 | struct tcl_cmd *cmds; 268 | tcl_value_t *result; 269 | }; 270 | 271 | tcl_value_t *tcl_var(struct tcl *tcl, tcl_value_t *name, tcl_value_t *v) { 272 | DBG("var(%s := %.*s)\n", tcl_string(name), tcl_length(v), tcl_string(v)); 273 | struct tcl_var *var; 274 | for (var = tcl->env->vars; var != NULL; var = var->next) { 275 | if (strcmp(var->name, tcl_string(name)) == 0) { 276 | break; 277 | } 278 | } 279 | if (var == NULL) { 280 | var = tcl_env_var(tcl->env, name); 281 | } 282 | if (v != NULL) { 283 | tcl_free(var->value); 284 | var->value = tcl_dup(v); 285 | tcl_free(v); 286 | } 287 | return var->value; 288 | } 289 | 290 | int tcl_result(struct tcl *tcl, int flow, tcl_value_t *result) { 291 | DBG("tcl_result %.*s, flow=%d\n", tcl_length(result), tcl_string(result), 292 | flow); 293 | tcl_free(tcl->result); 294 | tcl->result = result; 295 | return flow; 296 | } 297 | 298 | int tcl_subst(struct tcl *tcl, const char *s, size_t len) { 299 | DBG("subst(%.*s)\n", (int)len, s); 300 | if (len == 0) { 301 | return tcl_result(tcl, FNORMAL, tcl_alloc("", 0)); 302 | } 303 | switch (s[0]) { 304 | case '{': 305 | if (len <= 1) { 306 | return tcl_result(tcl, FERROR, tcl_alloc("", 0)); 307 | } 308 | return tcl_result(tcl, FNORMAL, tcl_alloc(s + 1, len - 2)); 309 | case '$': { 310 | if (len >= MAX_VAR_LENGTH) { 311 | return tcl_result(tcl, FERROR, tcl_alloc("", 0)); 312 | } 313 | char buf[5 + MAX_VAR_LENGTH] = "set "; 314 | strncat(buf, s + 1, len - 1); 315 | return tcl_eval(tcl, buf, strlen(buf) + 1); 316 | } 317 | case '[': { 318 | tcl_value_t *expr = tcl_alloc(s + 1, len - 2); 319 | int r = tcl_eval(tcl, tcl_string(expr), tcl_length(expr) + 1); 320 | tcl_free(expr); 321 | return r; 322 | } 323 | default: 324 | return tcl_result(tcl, FNORMAL, tcl_alloc(s, len)); 325 | } 326 | } 327 | 328 | int tcl_eval(struct tcl *tcl, const char *s, size_t len) { 329 | DBG("eval(%.*s)->\n", (int)len, s); 330 | tcl_value_t *list = tcl_list_alloc(); 331 | tcl_value_t *cur = NULL; 332 | tcl_each(s, len, 1) { 333 | DBG("tcl_next %d %.*s\n", p.token, (int)(p.to - p.from), p.from); 334 | switch (p.token) { 335 | case TERROR: 336 | DBG("eval: FERROR, lexer error\n"); 337 | return tcl_result(tcl, FERROR, tcl_alloc("", 0)); 338 | case TWORD: 339 | DBG("token %.*s, length=%d, cur=%p (3.1.1)\n", (int)(p.to - p.from), 340 | p.from, (int)(p.to - p.from), cur); 341 | if (cur != NULL) { 342 | tcl_subst(tcl, p.from, p.to - p.from); 343 | tcl_value_t *part = tcl_dup(tcl->result); 344 | cur = tcl_append(cur, part); 345 | } else { 346 | tcl_subst(tcl, p.from, p.to - p.from); 347 | cur = tcl_dup(tcl->result); 348 | } 349 | list = tcl_list_append(list, cur); 350 | tcl_free(cur); 351 | cur = NULL; 352 | break; 353 | case TPART: 354 | tcl_subst(tcl, p.from, p.to - p.from); 355 | tcl_value_t *part = tcl_dup(tcl->result); 356 | cur = tcl_append(cur, part); 357 | break; 358 | case TCMD: 359 | if (tcl_list_length(list) == 0) { 360 | tcl_result(tcl, FNORMAL, tcl_alloc("", 0)); 361 | } else { 362 | tcl_value_t *cmdname = tcl_list_at(list, 0); 363 | struct tcl_cmd *cmd = NULL; 364 | int r = FERROR; 365 | for (cmd = tcl->cmds; cmd != NULL; cmd = cmd->next) { 366 | if (strcmp(tcl_string(cmdname), tcl_string(cmd->name)) == 0) { 367 | if (cmd->arity == 0 || cmd->arity == tcl_list_length(list)) { 368 | r = cmd->fn(tcl, list, cmd->arg); 369 | break; 370 | } 371 | } 372 | } 373 | tcl_free(cmdname); 374 | if (cmd == NULL || r != FNORMAL) { 375 | tcl_list_free(list); 376 | return r; 377 | } 378 | } 379 | tcl_list_free(list); 380 | list = tcl_list_alloc(); 381 | break; 382 | } 383 | } 384 | tcl_list_free(list); 385 | return FNORMAL; 386 | } 387 | 388 | /* --------------------------------- */ 389 | /* --------------------------------- */ 390 | /* --------------------------------- */ 391 | /* --------------------------------- */ 392 | /* --------------------------------- */ 393 | void tcl_register(struct tcl *tcl, const char *name, tcl_cmd_fn_t fn, int arity, 394 | void *arg) { 395 | struct tcl_cmd *cmd = malloc(sizeof(struct tcl_cmd)); 396 | cmd->name = tcl_alloc(name, strlen(name)); 397 | cmd->fn = fn; 398 | cmd->arg = arg; 399 | cmd->arity = arity; 400 | cmd->next = tcl->cmds; 401 | tcl->cmds = cmd; 402 | } 403 | 404 | static int tcl_cmd_set(struct tcl *tcl, tcl_value_t *args, void *arg) { 405 | (void)arg; 406 | tcl_value_t *var = tcl_list_at(args, 1); 407 | tcl_value_t *val = tcl_list_at(args, 2); 408 | int r = tcl_result(tcl, FNORMAL, tcl_dup(tcl_var(tcl, var, val))); 409 | tcl_free(var); 410 | return r; 411 | } 412 | 413 | static int tcl_cmd_subst(struct tcl *tcl, tcl_value_t *args, void *arg) { 414 | (void)arg; 415 | tcl_value_t *s = tcl_list_at(args, 1); 416 | int r = tcl_subst(tcl, tcl_string(s), tcl_length(s)); 417 | tcl_free(s); 418 | return r; 419 | } 420 | 421 | #ifndef TCL_DISABLE_PUTS 422 | static int tcl_cmd_puts(struct tcl *tcl, tcl_value_t *args, void *arg) { 423 | (void)arg; 424 | tcl_value_t *text = tcl_list_at(args, 1); 425 | puts(tcl_string(text)); 426 | putchar('\n'); 427 | return tcl_result(tcl, FNORMAL, text); 428 | } 429 | #endif 430 | 431 | static int tcl_user_proc(struct tcl *tcl, tcl_value_t *args, void *arg) { 432 | tcl_value_t *code = (tcl_value_t *)arg; 433 | tcl_value_t *params = tcl_list_at(code, 2); 434 | tcl_value_t *body = tcl_list_at(code, 3); 435 | tcl->env = tcl_env_alloc(tcl->env); 436 | for (int i = 0; i < tcl_list_length(params); i++) { 437 | tcl_value_t *param = tcl_list_at(params, i); 438 | tcl_value_t *v = tcl_list_at(args, i + 1); 439 | tcl_var(tcl, param, v); 440 | tcl_free(param); 441 | } 442 | tcl_eval(tcl, tcl_string(body), tcl_length(body) + 1); 443 | tcl->env = tcl_env_free(tcl->env); 444 | tcl_free(params); 445 | tcl_free(body); 446 | return FNORMAL; 447 | } 448 | 449 | static int tcl_cmd_proc(struct tcl *tcl, tcl_value_t *args, void *arg) { 450 | (void)arg; 451 | tcl_value_t *name = tcl_list_at(args, 1); 452 | tcl_register(tcl, tcl_string(name), tcl_user_proc, 0, tcl_dup(args)); 453 | tcl_free(name); 454 | return tcl_result(tcl, FNORMAL, tcl_alloc("", 0)); 455 | } 456 | 457 | static int tcl_cmd_if(struct tcl *tcl, tcl_value_t *args, void *arg) { 458 | (void)arg; 459 | int i = 1; 460 | int n = tcl_list_length(args); 461 | int r = FNORMAL; 462 | while (i < n) { 463 | tcl_value_t *cond = tcl_list_at(args, i); 464 | tcl_value_t *branch = NULL; 465 | if (i + 1 < n) { 466 | branch = tcl_list_at(args, i + 1); 467 | } 468 | r = tcl_eval(tcl, tcl_string(cond), tcl_length(cond) + 1); 469 | tcl_free(cond); 470 | if (r != FNORMAL) { 471 | tcl_free(branch); 472 | break; 473 | } 474 | if (tcl_int(tcl->result)) { 475 | r = tcl_eval(tcl, tcl_string(branch), tcl_length(branch) + 1); 476 | tcl_free(branch); 477 | break; 478 | } 479 | i = i + 2; 480 | tcl_free(branch); 481 | } 482 | return r; 483 | } 484 | 485 | static int tcl_cmd_flow(struct tcl *tcl, tcl_value_t *args, void *arg) { 486 | (void)arg; 487 | int r = FERROR; 488 | tcl_value_t *flowval = tcl_list_at(args, 0); 489 | const char *flow = tcl_string(flowval); 490 | if (strcmp(flow, "break") == 0) { 491 | r = FBREAK; 492 | } else if (strcmp(flow, "continue") == 0) { 493 | r = FAGAIN; 494 | } else if (strcmp(flow, "return") == 0) { 495 | r = tcl_result(tcl, FRETURN, tcl_list_at(args, 1)); 496 | } 497 | tcl_free(flowval); 498 | return r; 499 | } 500 | 501 | static int tcl_cmd_while(struct tcl *tcl, tcl_value_t *args, void *arg) { 502 | (void)arg; 503 | tcl_value_t *cond = tcl_list_at(args, 1); 504 | tcl_value_t *loop = tcl_list_at(args, 2); 505 | int r; 506 | for (;;) { 507 | r = tcl_eval(tcl, tcl_string(cond), tcl_length(cond) + 1); 508 | if (r != FNORMAL) { 509 | tcl_free(cond); 510 | tcl_free(loop); 511 | return r; 512 | } 513 | if (!tcl_int(tcl->result)) { 514 | tcl_free(cond); 515 | tcl_free(loop); 516 | return FNORMAL; 517 | } 518 | int r = tcl_eval(tcl, tcl_string(loop), tcl_length(loop) + 1); 519 | switch (r) { 520 | case FBREAK: 521 | tcl_free(cond); 522 | tcl_free(loop); 523 | return FNORMAL; 524 | case FRETURN: 525 | tcl_free(cond); 526 | tcl_free(loop); 527 | return FRETURN; 528 | case FAGAIN: 529 | continue; 530 | case FERROR: 531 | tcl_free(cond); 532 | tcl_free(loop); 533 | return FERROR; 534 | } 535 | } 536 | } 537 | 538 | #ifndef TCL_DISABLE_MATH 539 | static int tcl_cmd_math(struct tcl *tcl, tcl_value_t *args, void *arg) { 540 | (void)arg; 541 | char buf[64]; 542 | tcl_value_t *opval = tcl_list_at(args, 0); 543 | tcl_value_t *aval = tcl_list_at(args, 1); 544 | tcl_value_t *bval = tcl_list_at(args, 2); 545 | const char *op = tcl_string(opval); 546 | int a = tcl_int(aval); 547 | int b = tcl_int(bval); 548 | int c = 0; 549 | if (op[0] == '+') { 550 | c = a + b; 551 | } else if (op[0] == '-') { 552 | c = a - b; 553 | } else if (op[0] == '*') { 554 | c = a * b; 555 | } else if (op[0] == '/') { 556 | c = a / b; 557 | } else if (op[0] == '>' && op[1] == '\0') { 558 | c = a > b; 559 | } else if (op[0] == '>' && op[1] == '=') { 560 | c = a >= b; 561 | } else if (op[0] == '<' && op[1] == '\0') { 562 | c = a < b; 563 | } else if (op[0] == '<' && op[1] == '=') { 564 | c = a <= b; 565 | } else if (op[0] == '=' && op[1] == '=') { 566 | c = a == b; 567 | } else if (op[0] == '!' && op[1] == '=') { 568 | c = a != b; 569 | } 570 | 571 | char *p = buf + sizeof(buf) - 1; 572 | char neg = (c < 0); 573 | *p-- = 0; 574 | if (neg) { 575 | c = -c; 576 | } 577 | do { 578 | *p-- = '0' + (c % 10); 579 | c = c / 10; 580 | } while (c > 0); 581 | if (neg) { 582 | *p-- = '-'; 583 | } 584 | p++; 585 | 586 | tcl_free(opval); 587 | tcl_free(aval); 588 | tcl_free(bval); 589 | return tcl_result(tcl, FNORMAL, tcl_alloc(p, strlen(p))); 590 | } 591 | #endif 592 | 593 | void tcl_init(struct tcl *tcl) { 594 | tcl->env = tcl_env_alloc(NULL); 595 | tcl->result = tcl_alloc("", 0); 596 | tcl->cmds = NULL; 597 | tcl_register(tcl, "set", tcl_cmd_set, 0, NULL); 598 | tcl_register(tcl, "subst", tcl_cmd_subst, 2, NULL); 599 | #ifndef TCL_DISABLE_PUTS 600 | tcl_register(tcl, "puts", tcl_cmd_puts, 2, NULL); 601 | #endif 602 | tcl_register(tcl, "proc", tcl_cmd_proc, 4, NULL); 603 | tcl_register(tcl, "if", tcl_cmd_if, 0, NULL); 604 | tcl_register(tcl, "while", tcl_cmd_while, 3, NULL); 605 | tcl_register(tcl, "return", tcl_cmd_flow, 0, NULL); 606 | tcl_register(tcl, "break", tcl_cmd_flow, 1, NULL); 607 | tcl_register(tcl, "continue", tcl_cmd_flow, 1, NULL); 608 | #ifndef TCL_DISABLE_MATH 609 | char *math[] = {"+", "-", "*", "/", ">", ">=", "<", "<=", "==", "!="}; 610 | for (unsigned int i = 0; i < (sizeof(math) / sizeof(math[0])); i++) { 611 | tcl_register(tcl, math[i], tcl_cmd_math, 3, NULL); 612 | } 613 | #endif 614 | } 615 | 616 | void tcl_destroy(struct tcl *tcl) { 617 | while (tcl->env) { 618 | tcl->env = tcl_env_free(tcl->env); 619 | } 620 | while (tcl->cmds) { 621 | struct tcl_cmd *cmd = tcl->cmds; 622 | tcl->cmds = tcl->cmds->next; 623 | tcl_free(cmd->name); 624 | free(cmd->arg); 625 | free(cmd); 626 | } 627 | tcl_free(tcl->result); 628 | } 629 | 630 | #ifndef TEST 631 | #define CHUNK 1024 632 | 633 | int main(void) { 634 | struct tcl tcl; 635 | int buflen = CHUNK; 636 | char *buf = malloc(buflen); 637 | int i = 0; 638 | 639 | tcl_init(&tcl); 640 | while (1) { 641 | int inp = fgetc(stdin); 642 | 643 | if (i > buflen - 1) { 644 | buf = realloc(buf, buflen += CHUNK); 645 | } 646 | 647 | if (inp == 0 || inp == EOF) { 648 | break; 649 | } 650 | 651 | buf[i++] = inp; 652 | 653 | tcl_each(buf, i, 1) { 654 | if (p.token == TERROR && (p.to - buf) != i) { 655 | memset(buf, 0, buflen); 656 | i = 0; 657 | break; 658 | } else if (p.token == TCMD && *(p.from) != '\0') { 659 | int r = tcl_eval(&tcl, buf, strlen(buf)); 660 | if (r != FERROR) { 661 | printf("result> %.*s\n", tcl_length(tcl.result), 662 | tcl_string(tcl.result)); 663 | } else { 664 | printf("?!\n"); 665 | } 666 | 667 | memset(buf, 0, buflen); 668 | i = 0; 669 | break; 670 | } 671 | } 672 | } 673 | 674 | free(buf); 675 | 676 | if (i) { 677 | printf("incomplete input\n"); 678 | return -1; 679 | } 680 | 681 | return 0; 682 | } 683 | #endif 684 | -------------------------------------------------------------------------------- /tcl_test.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #define TEST 4 | #include "tcl.c" 5 | 6 | int status = 0; 7 | #define FAIL(...) \ 8 | do { \ 9 | printf("FAILED: " __VA_ARGS__); \ 10 | status = 1; \ 11 | } while (0) 12 | 13 | #include "tcl_test_lexer.h" 14 | 15 | #include "tcl_test_subst.h" 16 | 17 | #include "tcl_test_flow.h" 18 | 19 | #include "tcl_test_math.h" 20 | 21 | int main(void) { 22 | test_lexer(); 23 | test_subst(); 24 | test_flow(); 25 | test_math(); 26 | return status; 27 | } 28 | -------------------------------------------------------------------------------- /tcl_test_flow.h: -------------------------------------------------------------------------------- 1 | #ifndef TCL_TEST_FLOW_H 2 | #define TCL_TEST_FLOW_H 3 | 4 | static void test_flow(void) { 5 | printf("\n"); 6 | printf("##########################\n"); 7 | printf("### CONTROL FLOW TESTS ###\n"); 8 | printf("##########################\n"); 9 | printf("\n"); 10 | 11 | check_eval(NULL, "if {< 1 2} {puts A} {puts B}", "A"); 12 | check_eval(NULL, "if {> 1 2} {puts A} {puts B}", "B"); 13 | check_eval(NULL, "if {> 1 2} {puts A}", "0"); 14 | 15 | check_eval(NULL, 16 | "set x 0; if {== $x 0} {subst A} {== $x 1} {subst B} {subst C}", 17 | "A"); 18 | check_eval(NULL, 19 | "set x 1; if {== $x 0} {subst A} {== $x 1} {subst B} {subst C}", 20 | "B"); 21 | check_eval(NULL, 22 | "set x 2; if {== $x 0} {subst A} {== $x 1} {subst B} {subst C}", 23 | "C"); 24 | 25 | check_eval(NULL, "while {< $x 5} {set x [+ $x 1]}", "0"); 26 | check_eval(NULL, "while {== 1 1} {set x [+ $x 1]; if {== $x 5} {break}}", 27 | "break"); 28 | check_eval( 29 | NULL, 30 | "while {== 1 1} {set x [+ $x 1]; if {!= $x 5} {continue} ; return foo}", 31 | "foo"); 32 | check_eval(NULL, "proc foo {} { subst hello }; foo", "hello"); 33 | check_eval(NULL, "proc five {} { + 2 3}; five", "5"); 34 | check_eval(NULL, "proc foo {a} { subst $a }; foo hello", "hello"); 35 | check_eval(NULL, "proc foo {} { subst hello; return A; return B;}; foo", "A"); 36 | check_eval(NULL, "set x 1; proc two {} { set x 2;}; two; subst $x", "1"); 37 | /* Example from Picol */ 38 | check_eval(NULL, "proc fib {x} { if {<= $x 1} {return 1} " 39 | "{ return [+ [fib [- $x 1]] [fib [- $x 2]]]}}; fib 20", 40 | "10946"); 41 | 42 | struct tcl tcl; 43 | tcl_init(&tcl); 44 | check_eval(&tcl, "proc square {x} { * $x $x }; square 7", "49"); 45 | check_eval(&tcl, "set a 4", "4"); 46 | check_eval(&tcl, "square $a", "16"); 47 | check_eval(&tcl, "subst \"$a[]*$a ?\"", "4*4 ?"); 48 | check_eval(&tcl, "subst \"I can compute that $a[]x$a = [square $a]\"", 49 | "I can compute that 4x4 = 16"); 50 | check_eval(&tcl, "set a 1", "1"); 51 | check_eval(&tcl, "while {<= $a 10} { puts \"$a [== $a 5]\";" 52 | "if {== $a 5} { puts {Missing five!}; set a [+ $a 1]; " 53 | "continue;}; puts \"I can compute that $a[]x$a = [square " 54 | "$a]\" ; set a [+ $a 1]}", 55 | "0"); 56 | 57 | tcl_destroy(&tcl); 58 | } 59 | 60 | #endif /* TCL_TEST_FLOW_H */ 61 | -------------------------------------------------------------------------------- /tcl_test_lexer.h: -------------------------------------------------------------------------------- 1 | #ifndef TCL_TEST_LEXER_H 2 | #define TCL_TEST_LEXER_H 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | static void va_check_tokens(const char *s, size_t len, int count, va_list ap) { 9 | int j = 0; 10 | tcl_each(s, len, 1) { 11 | int type = va_arg(ap, int); 12 | char *token = va_arg(ap, char *); 13 | j++; 14 | if (p.token != type) { 15 | FAIL("Expected token #%d type %d, but found %d (%.*s)\n", j, type, 16 | p.token, (int)len, s); 17 | } else if (p.token == TERROR) { 18 | break; 19 | } else { 20 | if ((p.token == TPART || p.token == TWORD) && 21 | (strlen(token) != p.to - p.from || 22 | strncmp(p.from, token, p.to - p.from) != 0)) { 23 | FAIL("Expected %s, but found %.*s (%s)\n", token, (int)(p.to - p.from), 24 | p.from, s); 25 | } 26 | } 27 | } 28 | if (j != count) { 29 | FAIL("Expected %d tokens, but found %d (%s)\n", count, j, s); 30 | } else { 31 | printf("OK: %.*s\n", (int)len, s); 32 | } 33 | } 34 | 35 | static void check_tokens(const char *s, int count, ...) { 36 | va_list ap; 37 | va_start(ap, count); 38 | va_check_tokens(s, strlen(s) + 1, count, ap); 39 | va_end(ap); 40 | } 41 | 42 | static void check_tokens_len(const char *s, size_t len, int count, ...) { 43 | va_list ap; 44 | va_start(ap, count); 45 | va_check_tokens(s, len, count, ap); 46 | va_end(ap); 47 | } 48 | 49 | static void test_lexer(void) { 50 | printf("\n"); 51 | printf("###################\n"); 52 | printf("### LEXER TESTS ###\n"); 53 | printf("###################\n"); 54 | printf("\n"); 55 | 56 | /* Empty */ 57 | check_tokens("", 1, TCMD, ""); 58 | check_tokens(";", 2, TCMD, ";", TCMD, ""); 59 | check_tokens(";;; ;", 5, TCMD, ";", TCMD, ";", TCMD, ";", TCMD, ";", TCMD, 60 | ""); 61 | /* Regular words */ 62 | check_tokens("foo", 2, TWORD, "foo", TCMD, ""); 63 | check_tokens("foo bar", 3, TWORD, "foo", TWORD, "bar", TCMD, ""); 64 | check_tokens("foo bar baz", 4, TWORD, "foo", TWORD, "bar", TWORD, "baz", TCMD, 65 | ""); 66 | /* Imbalanced braces/brackets */ 67 | check_tokens("foo ]", 2, TWORD, "foo", TERROR, ""); 68 | check_tokens("foo }", 2, TWORD, "foo", TERROR, ""); 69 | 70 | /* Grouping */ 71 | check_tokens("foo {bar baz}", 3, TWORD, "foo", TWORD, "{bar baz}", TCMD, ""); 72 | check_tokens("foo {bar {baz} {q u x}}", 3, TWORD, "foo", TWORD, 73 | "{bar {baz} {q u x}}", TCMD, ""); 74 | check_tokens("foo {bar {baz} [q u x]}", 3, TWORD, "foo", TWORD, 75 | "{bar {baz} [q u x]}", TCMD, ""); 76 | check_tokens("foo {bar $baz [q u x]}", 3, TWORD, "foo", TWORD, 77 | "{bar $baz [q u x]}", TCMD, ""); 78 | check_tokens("foo {bar \" baz}", 3, TWORD, "foo", TWORD, "{bar \" baz}", TCMD, 79 | ""); 80 | check_tokens("foo {\n\tbar\n}", 3, TWORD, "foo", TWORD, "{\n\tbar\n}", TCMD, 81 | ""); 82 | /* Substitution */ 83 | check_tokens("foo [bar baz]", 3, TWORD, "foo", TWORD, "[bar baz]", TCMD, ""); 84 | check_tokens("foo [bar {baz}]", 3, TWORD, "foo", TWORD, "[bar {baz}]", TCMD, 85 | ""); 86 | check_tokens("foo $bar $baz", 4, TWORD, "foo", TWORD, "$bar", TWORD, "$baz", 87 | TCMD, ""); 88 | check_tokens("foo $bar$baz", 4, TWORD, "foo", TPART, "$bar", TWORD, "$baz", 89 | TCMD, ""); 90 | check_tokens("foo ${bar baz}", 3, TWORD, "foo", TWORD, "${bar baz}", TCMD, 91 | ""); 92 | check_tokens("puts hello[\n]world", 5, TWORD, "puts", TPART, "hello", TPART, 93 | "[\n]", TWORD, "world", TCMD, ""); 94 | /* Quotes */ 95 | check_tokens("\"\"", 3, TPART, "", TWORD, "", TCMD, ""); 96 | check_tokens("\"\"\"\"", 2, TPART, "", TERROR, ""); 97 | check_tokens("foo \"bar baz\"", 5, TWORD, "foo", TPART, "", TPART, "bar baz", 98 | TWORD, "", TCMD, ""); 99 | check_tokens("foo \"bar $b[a z]\" qux", 8, TWORD, "foo", TPART, "", TPART, 100 | "bar ", TPART, "$b", TPART, "[a z]", TWORD, "", TWORD, "qux", 101 | TCMD, ""); 102 | check_tokens("foo \"bar baz\" \"qux quz\"", 8, TWORD, "foo", TPART, "", TPART, 103 | "bar baz", TWORD, "", TPART, "", TPART, "qux quz", TWORD, "", 104 | TCMD, ""); 105 | check_tokens("\"{\" \"$a$b\"", 8, TPART, "", TPART, "{", TWORD, "", TPART, "", 106 | TPART, "$a", TPART, "$b", TWORD, "", TCMD, ""); 107 | 108 | check_tokens("\"{\" \"$a\"$b", 6, TPART, "", TPART, "{", TWORD, "", TPART, "", 109 | TPART, "$a", TERROR, ""); 110 | check_tokens("\"$a + $a = ?\"", 7, TPART, "", TPART, "$a", TPART, " + ", 111 | TPART, "$a", TPART, " = ?", TWORD, "", TCMD, ""); 112 | /* Variables */ 113 | check_tokens("puts $ a", 2, TWORD, "puts", TERROR, ""); 114 | check_tokens("puts $\"a b\"", 2, TWORD, "puts", TERROR, ""); 115 | check_tokens("puts $$foo", 3, TWORD, "puts", TWORD, "$$foo", TCMD, ""); 116 | check_tokens("puts ${a b}", 3, TWORD, "puts", TWORD, "${a b}", TCMD, ""); 117 | check_tokens("puts $[a b]", 3, TWORD, "puts", TWORD, "$[a b]", TCMD, ""); 118 | check_tokens("puts { ", 2, TWORD, "puts", TERROR, ""); 119 | check_tokens("set a {\n", 3, TWORD, "set", TWORD, "a", TERROR, ""); 120 | check_tokens("puts {[}", 3, TWORD, "puts", TWORD, "{[}", TCMD, ""); 121 | check_tokens("puts [{]", 3, TWORD, "puts", TWORD, "[{]", TCMD, ""); 122 | check_tokens("puts {[}{]} ", 4, TWORD, "puts", TPART, "{[}", TWORD, "{]}", 123 | TCMD, ""); 124 | 125 | /* Strings without trailing zero */ 126 | check_tokens_len("abc foo", 1, 1, TERROR, "a"); 127 | check_tokens_len("abc foo", 2, 1, TERROR, "a"); 128 | check_tokens_len("abc foo", 3, 1, TERROR, "a"); 129 | check_tokens_len("abc foo", 4, 2, TWORD, "abc", TERROR, ""); 130 | check_tokens_len("abc foo", 7, 2, TWORD, "abc", TERROR, ""); 131 | check_tokens_len("abc foo", 8, 3, TWORD, "abc", TWORD, "foo", TCMD, ""); 132 | check_tokens_len("s", 1, 1, TERROR, "s"); 133 | check_tokens_len("se", 2, 1, TERROR, "s"); 134 | check_tokens_len("set", 3, 1, TERROR, "s"); 135 | check_tokens_len("set ", 4, 2, TWORD, "set", TERROR, ""); 136 | check_tokens_len("set a", 5, 2, TWORD, "set", TERROR, ""); 137 | check_tokens_len("set a ", 6, 3, TWORD, "set", TWORD, "a", TERROR, ""); 138 | check_tokens_len("set a {", 7, 3, TWORD, "set", TWORD, "a", TERROR, ""); 139 | check_tokens_len("set a {\n", 8, 3, TWORD, "set", TWORD, "a", TERROR, ""); 140 | check_tokens_len("set a {\nh", 9, 3, TWORD, "set", TWORD, "a", TERROR, ""); 141 | check_tokens_len("set a {\nhe", 10, 3, TWORD, "set", TWORD, "a", TERROR, ""); 142 | check_tokens_len("set a {\nhel", 11, 3, TWORD, "set", TWORD, "a", TERROR, ""); 143 | check_tokens_len("set a {\nhell", 12, 3, TWORD, "set", TWORD, "a", TERROR, 144 | ""); 145 | check_tokens_len("set a {\nhello", 13, 3, TWORD, "set", TWORD, "a", TERROR, 146 | ""); 147 | check_tokens_len("set a {\nhello\n", 14, 3, TWORD, "set", TWORD, "a", TERROR, 148 | ""); 149 | check_tokens_len("set a {\nhello\n}", 15, 3, TWORD, "set", TWORD, "a", TERROR, 150 | ""); 151 | check_tokens_len("set a {\nhello\n}\n", 16, 4, TWORD, "set", TWORD, "a", 152 | TWORD, "{\nhello\n}", TCMD, ""); 153 | } 154 | 155 | #endif /* TCL_TEST_LEXER_H */ 156 | -------------------------------------------------------------------------------- /tcl_test_math.h: -------------------------------------------------------------------------------- 1 | #ifndef TCL_TEST_MATH_H 2 | #define TCL_TEST_MATH_H 3 | 4 | static void test_math(void) { 5 | printf("\n"); 6 | printf("##################\n"); 7 | printf("### MATH TESTS ###\n"); 8 | printf("##################\n"); 9 | printf("\n"); 10 | 11 | check_eval(NULL, "< 1 2", "1"); 12 | check_eval(NULL, "< 1 1", "0"); 13 | check_eval(NULL, "<= 1 1", "1"); 14 | check_eval(NULL, "> 1 2", "0"); 15 | check_eval(NULL, "> 1 1", "0"); 16 | check_eval(NULL, ">= 1 1", "1"); 17 | check_eval(NULL, "== 1 1", "1"); 18 | check_eval(NULL, "!= 1 1", "0"); 19 | 20 | check_eval(NULL, "+ 1 2", "3"); 21 | check_eval(NULL, "* 4 2", "8"); 22 | check_eval(NULL, "- 7 2", "5"); 23 | check_eval(NULL, "/ 7 2", "3"); 24 | 25 | check_eval(NULL, "set a 5;set b 7; subst [- [* 4 [+ $a $b]] 6]", "42"); 26 | } 27 | 28 | #endif /* TCL_TEST_MATH_H */ 29 | -------------------------------------------------------------------------------- /tcl_test_subst.h: -------------------------------------------------------------------------------- 1 | #ifndef TCL_TEST_SUBST_H 2 | #define TCL_TEST_SUBST_H 3 | 4 | static void check_eval(struct tcl *tcl, const char *s, char *expected) { 5 | int destroy = 0; 6 | struct tcl tmp; 7 | if (tcl == NULL) { 8 | tcl_init(&tmp); 9 | tcl = &tmp; 10 | destroy = 1; 11 | } 12 | if (tcl_eval(tcl, s, strlen(s) + 1) == FERROR) { 13 | FAIL("eval returned error: %s, (%s)\n", tcl_string(tcl->result), s); 14 | } else if (strcmp(tcl_string(tcl->result), expected) != 0) { 15 | FAIL("Expected %s, but got %s. (%s)\n", expected, tcl_string(tcl->result), 16 | s); 17 | } else { 18 | printf("OK: %s -> %s\n", s, expected); 19 | } 20 | if (destroy) { 21 | tcl_destroy(tcl); 22 | } 23 | } 24 | 25 | static void test_subst(void) { 26 | printf("\n"); 27 | printf("###################\n"); 28 | printf("### SUBST TESTS ###\n"); 29 | printf("###################\n"); 30 | printf("\n"); 31 | 32 | check_eval(NULL, "subst hello", "hello"); 33 | check_eval(NULL, "subst {hello}", "hello"); 34 | check_eval(NULL, "subst {hello world}", "hello world"); 35 | check_eval(NULL, "subst {hello {world}}", "hello {world}"); 36 | 37 | check_eval(NULL, "subst $foo", ""); 38 | 39 | struct tcl tcl; 40 | tcl_init(&tcl); 41 | tcl_var(&tcl, "foo", tcl_alloc("bar", 3)); 42 | tcl_var(&tcl, "bar", tcl_alloc("baz", 3)); 43 | tcl_var(&tcl, "baz", tcl_alloc("Hello", 5)); 44 | check_eval(&tcl, "subst $foo", "bar"); 45 | check_eval(&tcl, "subst $foo[]$foo", "barbar"); 46 | check_eval(&tcl, "subst $$foo", "baz"); 47 | check_eval(&tcl, "subst [set $foo]", "baz"); 48 | check_eval(&tcl, "subst $[set $foo]", "Hello"); 49 | check_eval(&tcl, "subst $$$foo", "Hello"); 50 | tcl_destroy(&tcl); 51 | 52 | check_eval(NULL, "subst {hello}{world}", "helloworld"); 53 | check_eval(NULL, "subst hello[subst world]", "helloworld"); 54 | check_eval(NULL, "subst hello[\n]world", "helloworld"); 55 | 56 | /* Example from Picol */ 57 | check_eval(NULL, "set a su; set b bst; $a$b Hello", "Hello"); 58 | /* This is an error in TCL, but works in Picol */ 59 | check_eval(NULL, "set foo {hello world}", "hello world"); 60 | check_eval(NULL, 61 | "set foo {hello world}; set bar \"qux $foo\"; subst $foo$bar", 62 | "hello worldqux hello world"); 63 | check_eval(NULL, "set a f; set b {o}; set $a$b$b [subst \"hello\"]; set foo", 64 | "hello"); 65 | check_eval(NULL, "set {a \"b\"} hello; subst ${a \"b\"}", "hello"); 66 | check_eval(NULL, "set \"a b\" hello; subst ${a b}", "hello"); 67 | 68 | check_eval(NULL, "set q {\"}; set msg hello; subst $q$msg$q", "\"hello\""); 69 | check_eval(NULL, "set q {\"}; subst $q[]hello[]$q", "\"hello\""); 70 | check_eval(NULL, "set x {\n\thello\n}", "\n\thello\n"); 71 | 72 | /* Some puts commands */ 73 | check_eval(NULL, "puts {[}[]hello[]{]}", "[hello]"); 74 | check_eval(NULL, "puts {{hello}}", "{hello}"); 75 | 76 | /* XXX most command involving unpaired braces (e.g. in quotes) don't work 77 | * because of the dirty list implementation */ 78 | } 79 | 80 | #endif /* TCL_TEST_SUBST_H */ 81 | --------------------------------------------------------------------------------