#include "version.h" #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include jmp_buf interactive_checkpoint; bool is_interactive; size_t max_rec_depth = 1000; size_t rec_depth = 0; void *malloc_checked(size_t size) { void *p; if (!(p = GC_MALLOC(size))) abort(); memset(p, 0, size); return p; } void *malloc_checked_atomic(size_t size) { void *p; if (!(p = GC_malloc_atomic(size))) abort(); memset(p, 0, size); return p; } void *malloc_checked_uncollectable(size_t size) { void *p; if (!(p = GC_malloc_uncollectable(size))) abort(); memset(p, 0, size); return p; } void *realloc_checked(void *p, size_t size) { if (!(p = GC_REALLOC(p, size))) abort(); return p; } char *strdup_checked(char *s) { char *p = GC_strdup(s); if (!p) abort(); return p; } typedef struct { void **data; size_t length; } list_t; list_t *list_new(void) { list_t *list = malloc_checked(sizeof(list_t)); list->data = NULL; list->length = 0; return list; } list_t *list_newk(size_t k) { list_t *list = malloc_checked(sizeof(list_t)); list->data = malloc_checked(k * sizeof(void *)); list->length = k; return list; } list_t *list_copy(list_t *l) { list_t *list = list_newk(l->length); for (size_t i = 0; i < l->length; i++) list->data[i] = l->data[i]; return list; } void list_push(list_t *l, void *v) { size_t i = l->length++; l->data = realloc_checked(l->data, l->length * sizeof(void *)); l->data[i] = v; } void *list_pop(list_t *l) { if (!l->data) return NULL; size_t i = --l->length; void *v = l->data[i]; l->data[i] = NULL; if (!l->length) { GC_FREE(l->data); l->data = NULL; } else l->data = realloc_checked(l->data, l->length * sizeof(void *)); return v; } void *list_index(list_t *l, ssize_t index) { if (!l->data) return NULL; if (index < 0) index += ((ssize_t)l->length); if (index < 0 || index >= l->length) return NULL; return l->data[index]; } void list_set(list_t *l, ssize_t index, void *v) { if (!l->data) return; if (index < 0) index += ((ssize_t)l->length); if (index < 0 || index >= l->length) return; l->data[index] = v; } typedef struct { char *str; size_t size; } buffer_t; buffer_t *buffer_new(void) { buffer_t *buf = malloc_checked(sizeof(buffer_t)); buf->str = NULL; buf->size = 0; return buf; } void buffer_append(buffer_t *buf, char c) { buf->size++; void *p = malloc_checked_atomic(sizeof(char) * buf->size); if (buf->str) { memcpy(p, buf->str, buf->size - 1); GC_FREE(buf->str); } buf->str = p; buf->str[buf->size - 1] = c; } char *buffer_read(buffer_t *buf) { if (buf->size == 0 || buf->str[buf->size - 1]) buffer_append(buf, 0); char *str = buf->str; GC_FREE(buf); return str; } void buffer_append_str(buffer_t *buf, char *s) { for (size_t i = 0; i < strlen(s); i++) buffer_append(buf, s[i]); } typedef struct { enum token_tag_t { T_PUNCT, T_LPAR, T_RPAR, T_NAME, T_NUMBER, T_BNUMBER, T_QUOTE } tag; char *text; } token_t; typedef struct { char *source; size_t len; size_t pos; list_t *tokens; } lexer_t; lexer_t *lexer_new(void) { lexer_t *lexer = malloc_checked(sizeof(lexer_t)); return lexer; } char lexer_lookahead(lexer_t *lexer, size_t offset) { size_t pos = lexer->pos + offset; if (pos >= lexer->len) return 0; return lexer->source[pos]; } char lexer_eat(lexer_t *lexer) { if (lexer->pos >= lexer->len) return 0; return lexer->source[lexer->pos++]; } void lexer_push_token(lexer_t *lexer, enum token_tag_t tag, char *text) { token_t *token = malloc_checked(sizeof(token_t)); token->tag = tag; token->text = text; list_push(lexer->tokens, token); } list_t *guards; typedef struct { jmp_buf lb; size_t rec_depth; } guard_t; guard_t *guard() { guard_t *g = malloc_checked_atomic(sizeof(guard_t)); g->rec_depth = rec_depth; list_push(guards, g); return g; } guard_t *guarding() { return list_index(guards, -1); } void unguard() { GC_FREE(list_pop(guards)); } void fatal(char *s) { guard_t *g = guarding(); if (g) { rec_depth = g->rec_depth; longjmp(g->lb, 1); } fprintf(stderr, "|%s error\n", s); if (is_interactive) { rec_depth = 0; longjmp(interactive_checkpoint, 1); } exit(1); } void lexer_error(lexer_t *lexer, char *s) { fatal(s); } void lexer_lex_number(lexer_t *lexer, bool is_negative) { buffer_t *buf = buffer_new(); if (is_negative) buffer_append(buf, '-'); if (lexer_lookahead(lexer, 0) == '.') { buffer_append(buf, lexer_eat(lexer)); if (!(isdigit(lexer_lookahead(lexer, 0)))) lexer_error(lexer, "trailing-dot"); } do { buffer_append(buf, lexer_eat(lexer)); if (lexer_lookahead(lexer, 0) == '`' && isdigit(lexer_lookahead(lexer, 1))) lexer_eat(lexer); } while (isdigit(lexer_lookahead(lexer, 0))); if (lexer_lookahead(lexer, 0) == '.') { buffer_append(buf, lexer_eat(lexer)); if (!(isdigit(lexer_lookahead(lexer, 0)))) lexer_error(lexer, "trailing-dot"); do { buffer_append(buf, lexer_eat(lexer)); } while (isdigit(lexer_lookahead(lexer, 0))); } lexer_push_token(lexer, T_NUMBER, buffer_read(buf)); } void lexer_lex(lexer_t *lexer, char *s) { lexer->source = s; lexer->len = strlen(s); lexer->pos = 0; lexer->tokens = list_new(); while (lexer->pos < lexer->len) { char c = lexer_lookahead(lexer, 0); if (c == '/' && !lexer->tokens->data) break; if (isspace(c)) { lexer_eat(lexer); if (lexer_lookahead(lexer, 0) == '/') break; } else if (c == '0' && (lexer_lookahead(lexer, 1) == 'x' || lexer_lookahead(lexer, 1) == 'b' || lexer_lookahead(lexer, 1) == 'o')) { lexer_eat(lexer); buffer_t *buf = buffer_new(); char b = lexer_eat(lexer); buffer_append(buf, b); const char *base = b == 'x' ? "0123456789abcdefABCDEF" : b == 'b' ? "01" : "01234567"; while (strchr(base, lexer_lookahead(lexer, 0)) != NULL) buffer_append(buf, lexer_eat(lexer)); lexer_push_token(lexer, T_BNUMBER, buffer_read(buf)); } else if (isdigit(c) || c == '.') { lexer_lex_number(lexer, false); } else if (isalpha(c)) { buffer_t *buf = buffer_new(); do { buffer_append(buf, lexer_eat(lexer)); } while (isalpha(lexer_lookahead(lexer, 0))); if (buf->size == 1 && lexer_lookahead(lexer, 0) == '.') { buffer_append(buf, lexer_eat(lexer)); lexer_push_token(lexer, T_PUNCT, buffer_read(buf)); } else lexer_push_token(lexer, T_NAME, buffer_read(buf)); } else if (c == '(' || c == ')') { lexer_eat(lexer); lexer_push_token(lexer, c == '(' ? T_LPAR : T_RPAR, NULL); } else if (c == '\'') { buffer_t *buf = buffer_new(); lexer_eat(lexer); for (;;) { if (lexer->pos >= lexer->len) lexer_error(lexer, "unmatched-quote"); if (lexer_lookahead(lexer, 0) == '\'') { if (lexer_lookahead(lexer, 1) == '\'') { buffer_append(buf, lexer_eat(lexer)); lexer_eat(lexer); continue; } lexer_eat(lexer); break; } buffer_append(buf, lexer_eat(lexer)); } lexer_push_token(lexer, T_QUOTE, buffer_read(buf)); } else if (ispunct(c)) { char buf[3]; buf[0] = lexer_eat(lexer); buf[1] = 0; if (lexer_lookahead(lexer, 0) == '.' || lexer_lookahead(lexer, 0) == ':') { buf[1] = lexer_eat(lexer); buf[2] = 0; } if (strcmp(buf, "-") == 0 && isdigit(lexer_lookahead(lexer, 0))) { lexer_lex_number(lexer, true); continue; } lexer_push_token(lexer, T_PUNCT, strdup_checked(buf)); } else lexer_error(lexer, "lex"); } } typedef struct _table_t table_t; typedef struct _table_entry_t table_entry_t; struct _table_entry_t { char *key; void *value; bool is_deleted; }; struct _table_t { table_entry_t *entries; size_t used; size_t capacity; }; #define TABLE_MIN_SIZE 32 table_t *table_new(void) { table_t *table = malloc_checked(sizeof(table_t)); table->used = 0; table->capacity = TABLE_MIN_SIZE; table->entries = malloc_checked(table->capacity * sizeof(table_entry_t)); return table; } size_t table_length(table_t *table) { return table->used; } bool table_empty(table_t *table) { return table->used == 0; } static uint64_t MM86128(void *key, const int len, uint32_t seed) { #define ROTL32(x, r) ((x << r) | (x >> (32 - r))) #define FMIX32(h) \ h ^= h >> 16; \ h *= 0x85ebca6b; \ h ^= h >> 13; \ h *= 0xc2b2ae35; \ h ^= h >> 16; const uint8_t *data = (const uint8_t *)key; const int nblocks = len / 16; uint32_t h1 = seed; uint32_t h2 = seed; uint32_t h3 = seed; uint32_t h4 = seed; uint32_t c1 = 0x239b961b; uint32_t c2 = 0xab0e9789; uint32_t c3 = 0x38b34ae5; uint32_t c4 = 0xa1e38b93; const uint32_t *blocks = (const uint32_t *)(data + nblocks * 16); for (int i = -nblocks; i; i++) { uint32_t k1 = blocks[i * 4 + 0]; uint32_t k2 = blocks[i * 4 + 1]; uint32_t k3 = blocks[i * 4 + 2]; uint32_t k4 = blocks[i * 4 + 3]; k1 *= c1; k1 = ROTL32(k1, 15); k1 *= c2; h1 ^= k1; h1 = ROTL32(h1, 19); h1 += h2; h1 = h1 * 5 + 0x561ccd1b; k2 *= c2; k2 = ROTL32(k2, 16); k2 *= c3; h2 ^= k2; h2 = ROTL32(h2, 17); h2 += h3; h2 = h2 * 5 + 0x0bcaa747; k3 *= c3; k3 = ROTL32(k3, 17); k3 *= c4; h3 ^= k3; h3 = ROTL32(h3, 15); h3 += h4; h3 = h3 * 5 + 0x96cd1c35; k4 *= c4; k4 = ROTL32(k4, 18); k4 *= c1; h4 ^= k4; h4 = ROTL32(h4, 13); h4 += h1; h4 = h4 * 5 + 0x32ac3b17; } const uint8_t *tail = (const uint8_t *)(data + nblocks * 16); uint32_t k1 = 0; uint32_t k2 = 0; uint32_t k3 = 0; uint32_t k4 = 0; switch (len & 15) { case 15: k4 ^= tail[14] << 16; case 14: k4 ^= tail[13] << 8; case 13: k4 ^= tail[12] << 0; k4 *= c4; k4 = ROTL32(k4, 18); k4 *= c1; h4 ^= k4; case 12: k3 ^= tail[11] << 24; case 11: k3 ^= tail[10] << 16; case 10: k3 ^= tail[9] << 8; case 9: k3 ^= tail[8] << 0; k3 *= c3; k3 = ROTL32(k3, 17); k3 *= c4; h3 ^= k3; case 8: k2 ^= tail[7] << 24; case 7: k2 ^= tail[6] << 16; case 6: k2 ^= tail[5] << 8; case 5: k2 ^= tail[4] << 0; k2 *= c2; k2 = ROTL32(k2, 16); k2 *= c3; h2 ^= k2; case 4: k1 ^= tail[3] << 24; case 3: k1 ^= tail[2] << 16; case 2: k1 ^= tail[1] << 8; case 1: k1 ^= tail[0] << 0; k1 *= c1; k1 = ROTL32(k1, 15); k1 *= c2; h1 ^= k1; } h1 ^= len; h2 ^= len; h3 ^= len; h4 ^= len; h1 += h2; h1 += h3; h1 += h4; h2 += h1; h3 += h1; h4 += h1; FMIX32(h1); FMIX32(h2); FMIX32(h3); FMIX32(h4); h1 += h2; h1 += h3; h1 += h4; h2 += h1; h3 += h1; h4 += h1; return (((uint64_t)h2) << 32) | h1; } static uint32_t HASH_SEED = 0; void *table_get(table_t *table, char *key) { if (table_empty(table)) return NULL; uint64_t hash = MM86128(key, strlen(key), HASH_SEED); size_t index = hash % table->capacity; size_t i = index; while (table->entries[i].key) { if (!table->entries[i].is_deleted && strcmp(table->entries[i].key, key) == 0) return table->entries[i].value; i++; if (i >= table->capacity) i = 0; if (i == index) break; } return NULL; } bool table_has(table_t *table, char *key) { if (table_empty(table)) return false; uint64_t hash = MM86128(key, strlen(key), HASH_SEED); size_t index = hash % table->capacity; size_t i = index; while (table->entries[i].key) { if (!table->entries[i].is_deleted && strcmp(table->entries[i].key, key) == 0) return true; i++; if (i >= table->capacity) i = 0; if (i == index) break; } return false; } static void table_entry_set(table_entry_t *entries, char *key, void *value, size_t capacity, size_t *used) { uint64_t hash = MM86128(key, strlen(key), HASH_SEED); size_t index = hash % capacity; size_t i = index; while (entries[i].key) { if (strcmp(entries[i].key, key) == 0) { entries[i].value = value; if (entries[i].is_deleted) { if (used) (*used)++; entries[i].is_deleted = false; } return; } else if (entries[i].is_deleted) break; i++; if (i >= capacity) i = 0; if (i == index) break; } if (used) (*used)++; entries[i].key = key; entries[i].value = value; entries[i].is_deleted = false; } table_t *table_set(table_t *table, char *key, void *value) { if (table->used >= table->capacity) { size_t capacity = table->capacity + TABLE_MIN_SIZE; table_entry_t *entries = malloc_checked(capacity * sizeof(table_entry_t)); for (size_t i = 0; i < table->capacity; i++) { table_entry_t entry = table->entries[i]; if (entry.key && !entry.is_deleted) table_entry_set(entries, entry.key, entry.value, capacity, NULL); } GC_FREE(table->entries); table->entries = entries; table->capacity = capacity; } table_entry_set(table->entries, key, value, table->capacity, &table->used); return table; } bool table_delete(table_t *table, char *key) { uint64_t hash = MM86128(key, strlen(key), HASH_SEED); size_t index = hash % table->capacity; size_t i = index; while (table->entries[i].key) { if (!table->entries[i].is_deleted && strcmp(table->entries[i].key, key) == 0) { table->entries[i].value = NULL; table->entries[i].is_deleted = true; table->used--; if (table->capacity > TABLE_MIN_SIZE && table->used <= table->capacity - TABLE_MIN_SIZE) { size_t capacity = table->capacity - TABLE_MIN_SIZE; table_entry_t *entries = malloc_checked(capacity * sizeof(table_entry_t)); for (size_t i = 0; i < table->capacity; i++) { table_entry_t entry = table->entries[i]; if (entry.key && !entry.is_deleted) table_entry_set(entries, entry.key, entry.value, capacity, NULL); } GC_FREE(table->entries); table->entries = entries; table->capacity = capacity; } return true; } i++; if (i >= table->capacity) i = 0; if (i == index) break; } return false; } typedef struct _value_t value_t; typedef struct _interpreter_t interpreter_t; typedef struct _verb_t verb_t; struct _interpreter_t { table_t *env; list_t *args; list_t *selfrefs; value_t *nil; value_t *udf; value_t *unit; verb_t *at; bool bn; }; struct _verb_t { char *name; unsigned int rank[3]; list_t *bonds; bool mark; bool is_fun; value_t *(*monad)(interpreter_t *, verb_t *, value_t *); value_t *(*dyad)(interpreter_t *, verb_t *, value_t *, value_t *); }; typedef struct { char *name; verb_t *(*adverb)(interpreter_t *, value_t *); verb_t *(*conjunction)(interpreter_t *, value_t *, value_t *); } adverb_t; struct _value_t { enum value_tag_t { ARRAY, VERB, SYMBOL, NUMBER, CHAR, NIL, UDF } tag; union { list_t *array; verb_t *verb; char *symbol; double number; unsigned char _char; } val; }; verb_t *verb_new() { verb_t *verb = malloc_checked(sizeof(verb_t)); return verb; } value_t *value_new(enum value_tag_t tag) { value_t *val; if (tag > SYMBOL) val = malloc_checked_atomic(sizeof(value_t)); else val = malloc_checked(sizeof(value_t)); val->tag = tag; return val; } value_t *value_new_const(enum value_tag_t tag) { value_t *val = malloc_checked_uncollectable(sizeof(value_t)); val->tag = tag; return val; } value_t *_UNIT; value_t *value_new_array(list_t *array) { if (!array->data) { GC_FREE(array); return _UNIT; } value_t *val = value_new(ARRAY); val->val.array = array; return val; } table_t *VCACHE; value_t *value_new_verb(verb_t *verb) { value_t *val; if ((val = table_get(VCACHE, verb->name))) return val; val = value_new(VERB); val->val.verb = verb; return val; } table_t *SCACHE; value_t *value_new_symbol(char *symbol) { value_t *val; if ((val = table_get(SCACHE, symbol))) return val; val = value_new_const(SYMBOL); val->val.symbol = symbol; table_set(SCACHE, symbol, val); return val; } value_t *_NAN, *INF, *NINF; value_t *NNUMS[8]; value_t *NUMS[256]; value_t *CHARS[256]; value_t *value_new_number(double number) { if (isnan(number)) return _NAN; else if (number == INFINITY) return INF; else if (number == -INFINITY) return NINF; else if (number >= 0 && number < 256 && number == (double)((size_t)number)) return NUMS[(size_t)number]; else if (number < 0 && number >= -8 && fabs(number) == (double)((size_t)fabs(number))) return NNUMS[((size_t)fabs(number)) - 1]; value_t *val = value_new(NUMBER); val->val.number = number; return val; } value_t *value_new_char(unsigned char _char) { return CHARS[_char]; } bool value_equals(value_t *x, value_t *y) { if (x->tag != y->tag) return false; switch (x->tag) { case ARRAY: { list_t *tx = x->val.array; list_t *ty = y->val.array; if (tx->length == 0 && ty->length == 0) break; if (tx->length != ty->length) return false; for (size_t i = 0; i < tx->length; i++) if (!value_equals(tx->data[i], ty->data[i])) return false; } case VERB: return strcmp(x->val.verb->name, x->val.verb->name) == 0; case SYMBOL: return strcmp(x->val.symbol, y->val.symbol) == 0; case NUMBER: if (isnan(x->val.number) && isnan(y->val.number)) break; return x->val.number == y->val.number; case CHAR: return x == y; case NIL: case UDF: break; } return true; } bool is_char_array(list_t *a) { for (size_t i = 0; i < a->length; i++) { value_t *v = a->data[i]; if (v->tag != CHAR || !isprint(v->val._char)) return false; } return true; } bool is_bytes_array(list_t *a) { for (size_t i = 0; i < a->length; i++) { value_t *v = a->data[i]; if (v->tag != CHAR) return false; } return true; } bool is_arrays_array(list_t *a) { for (size_t i = 0; i < a->length; i++) { value_t *v = a->data[i]; if (v->tag != ARRAY) return false; } return true; } bool is_not_arrays_array(list_t *a) { if (!a->data) return true; for (size_t i = 1; i < a->length; i++) { value_t *v = a->data[i]; if (v->tag == ARRAY) return false; } return true; } bool is_matrix(list_t *a) { if (a->length < 2) return false; size_t rwl = ((value_t *)a->data[0])->val.array->length; if (rwl < 1) return false; for (size_t i = 0; i < a->length; i++) { value_t *v = a->data[i]; if (v->tag != ARRAY || v->val.array->length != rwl || !is_not_arrays_array(v->val.array) || is_char_array(v->val.array)) return false; } return true; } char *value_show(value_t *v); char *show_array(value_t *v) { if (v->tag != ARRAY) return value_show(v); list_t *t = v->val.array; if (!t->data) return strdup_checked("()"); buffer_t *buf = buffer_new(); if (t->length == 1) { buffer_append(buf, ','); char *ts = value_show(t->data[0]); buffer_append_str(buf, ts); GC_FREE(ts); return buffer_read(buf); } if (is_char_array(t)) { for (size_t i = 0; i < t->length; i++) buffer_append(buf, ((value_t *)t->data[i])->val._char); return buffer_read(buf); } if (!is_arrays_array(t)) for (size_t i = 0; i < t->length; i++) { char *ts = value_show(t->data[i]); buffer_append_str(buf, ts); GC_FREE(ts); if (i != t->length - 1) buffer_append(buf, ' '); } else if (is_matrix(t)) { size_t rwl = 0; size_t pad = 0; size_t padl = 0; list_t *ss = list_new(); for (size_t i = 0; i < t->length; i++) { value_t *rw = t->data[i]; list_t *rwt = rw->val.array; if (rwl < 1) rwl = rwt->length; for (size_t j = 0; j < rwt->length; j++) { char *s = value_show(rwt->data[j]); size_t z = strlen(s); if (z > pad) pad = z; if (j == 0 && z > padl) padl = z; list_push(ss, s); } } size_t k = 0; for (size_t i = 0; i < ss->length; i++) { char *s = ss->data[i]; size_t mp = (k == 0 ? padl : pad) - strlen(s); while (mp--) buffer_append(buf, ' '); buffer_append_str(buf, s); GC_FREE(s); if (i != ss->length - 1) { if (k == rwl - 1) { k = 0; buffer_append(buf, '\n'); } else { buffer_append(buf, ' '); k++; } } } GC_FREE(ss->data); GC_FREE(ss); } else for (size_t i = 0; i < t->length; i++) { value_t *rw = t->data[i]; char *ts = show_array(rw); buffer_append_str(buf, ts); GC_FREE(ts); if (i != t->length - 1) buffer_append(buf, '\n'); } return buffer_read(buf); } char *value_show(value_t *v) { switch (v->tag) { case ARRAY: return show_array(v); case VERB: return strdup_checked(v->val.verb->name); case SYMBOL: return strdup_checked(v->val.symbol); case NUMBER: { char buf[128]; snprintf(buf, sizeof(buf), "%.15g", v->val.number); return strdup_checked(buf); } case CHAR: { if (!isprint(v->val._char)) { char buf[16]; snprintf(buf, sizeof(buf), "4t.%d", v->val._char); return strdup_checked(buf); } char buf[2]; buf[0] = v->val._char; buf[1] = 0; return strdup_checked(buf); } case NIL: return strdup_checked("nil"); case UDF: return strdup_checked("udf"); } return strdup_checked(""); } char *value_str(value_t *v) { if (v->tag == ARRAY && v->val.array->length == 1 && ((value_t *)v->val.array->data[0])->tag == CHAR) return value_show(v->val.array->data[0]); else if (v->tag == ARRAY && is_bytes_array(v->val.array)) { buffer_t *buf = buffer_new(); for (size_t i = 0; i < v->val.array->length; i++) buffer_append(buf, ((value_t *)v->val.array->data[i])->val._char); return buffer_read(buf); } return value_show(v); } double get_numeric(value_t *v) { if (v->tag == CHAR) return v->val._char; return v->val.number; } bool value_is_truthy(value_t *x) { switch (x->tag) { case ARRAY: return x->val.array->length != 0; case NUMBER: case CHAR: return get_numeric(x) != 0; case NIL: case UDF: return false; default: return true; } } verb_t *find_verb(char *s); interpreter_t *interpreter_new(void) { interpreter_t *state = malloc_checked(sizeof(interpreter_t)); state->env = table_new(); state->args = list_new(); state->selfrefs = list_new(); state->nil = value_new(NIL); state->udf = value_new(UDF); state->unit = _UNIT; state->at = find_verb("@"); return state; } value_t *each_rank(interpreter_t *state, verb_t *f, value_t *x, unsigned int d, unsigned int rm) { if (!f->monad) return state->udf; if (rec_depth >= max_rec_depth) fatal("recursion-depth"); rec_depth++; if (d >= rm || x->tag != ARRAY) { if (f->mark) list_push(state->selfrefs, f); value_t *r = f->monad(state, f, x); if (f->mark) list_pop(state->selfrefs); if (rec_depth > 0) rec_depth--; return r; } list_t *t = x->val.array; if (!t->data) { if (rec_depth > 0) rec_depth--; return x; } list_t *l = list_newk(t->length); for (size_t i = 0; i < t->length; i++) l->data[i] = each_rank(state, f, t->data[i], d + 1, rm); if (rec_depth > 0) rec_depth--; return value_new_array(l); } value_t *verb_at(interpreter_t *state, verb_t *self, value_t *x, value_t *y); value_t *apply_monad(interpreter_t *state, value_t *f, value_t *x) { if (f->tag == ARRAY) return verb_at(state, NULL, f, x); if (f->tag != VERB) return state->udf; if (!f->val.verb->monad) return state->udf; return each_rank(state, f->val.verb, x, 0, f->val.verb->rank[0]); } value_t *together(interpreter_t *state, verb_t *f, value_t *x, value_t *y, unsigned int dl, unsigned int dr, unsigned int rl, unsigned int rr) { if (!f->dyad) return state->udf; if (rec_depth >= max_rec_depth) fatal("recursion-depth"); rec_depth++; if (dl >= rl && dr >= rr) { if (f->mark) list_push(state->selfrefs, f); value_t *r = f->dyad(state, f, x, y); if (f->mark) list_pop(state->selfrefs); if (rec_depth > 0) rec_depth--; return r; } if (dl < rl && dr < rr && x->tag == ARRAY && y->tag == ARRAY) { list_t *tx = x->val.array; list_t *ty = y->val.array; if (!tx->data || !ty->data) { if (rec_depth > 0) rec_depth--; return !tx->data ? x : y; } list_t *t = list_newk(ty->length < tx->length ? ty->length : tx->length); for (size_t i = 0; i < tx->length; i++) { if (i >= ty->length) break; t->data[i] = together(state, f, tx->data[i], ty->data[i], dl + 1, dr + 1, rl, rr); } if (rec_depth > 0) rec_depth--; return value_new_array(t); } else if ((x->tag != ARRAY || dl >= rl) && y->tag == ARRAY && dr < rr) { list_t *ty = y->val.array; if (!ty->data) { if (rec_depth > 0) rec_depth--; return y; } list_t *t = list_newk(ty->length); for (size_t i = 0; i < ty->length; i++) t->data[i] = together(state, f, x, ty->data[i], dl, dr + 1, rl, rr); return value_new_array(t); } else if ((y->tag != ARRAY || dr >= rr) && x->tag == ARRAY && dl < rl) { list_t *tx = x->val.array; if (!tx->data) { if (rec_depth > 0) rec_depth--; return x; } list_t *t = list_newk(tx->length); for (size_t i = 0; i < tx->length; i++) t->data[i] = together(state, f, tx->data[i], y, dl + 1, dr, rl, rr); if (rec_depth > 0) rec_depth--; return value_new_array(t); } if (f->mark) list_push(state->selfrefs, f); value_t *r = f->dyad(state, f, x, y); if (f->mark) list_pop(state->selfrefs); if (rec_depth > 0) rec_depth--; return r; } value_t *apply_dyad(interpreter_t *state, value_t *f, value_t *x, value_t *y) { if (f->tag == ARRAY) return verb_at(state, NULL, verb_at(state, NULL, f, x), y); if (f->tag != VERB) return state->nil; return together(state, f->val.verb, x, y, 0, 0, f->val.verb->rank[1], f->val.verb->rank[2]); } typedef struct _node_t node_t; struct _node_t { enum node_tag_t { N_STRAND, N_LITERAL, N_INDEX1, N_INDEX2, N_FUN, N_MONAD, N_DYAD, N_ADV, N_CONJ, N_PARTIAL_CONJ, N_FORK, N_HOOK, N_BOND, N_OVER, N_BIND } tag; adverb_t *av; value_t *v; list_t *l; node_t *a; node_t *b; node_t *c; size_t dp; }; char *node_show(node_t *n) { switch (n->tag) { case N_STRAND: { buffer_t *buf = buffer_new(); for (size_t i = 0; i < n->l->length; i++) { if (i != 0) buffer_append_str(buf, ",:"); char *s = node_show(n->l->data[i]); buffer_append_str(buf, s); GC_FREE(s); } return buffer_read(buf); } case N_LITERAL: return value_show(n->v); case N_INDEX1: { char *s; buffer_t *buf = buffer_new(); s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); buffer_append(buf, ' '); s = node_show(n->b); buffer_append_str(buf, s); GC_FREE(s); return buffer_read(buf); } case N_INDEX2: { char *s; buffer_t *buf = buffer_new(); s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); buffer_append(buf, ' '); s = node_show(n->b); buffer_append_str(buf, s); GC_FREE(s); buffer_append(buf, ' '); s = node_show(n->c); buffer_append_str(buf, s); GC_FREE(s); return buffer_read(buf); } case N_FUN: { buffer_t *buf = buffer_new(); buffer_append(buf, ':'); char *s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); return buffer_read(buf); } case N_MONAD: case N_HOOK: case N_BOND: case N_OVER: { char *s; buffer_t *buf = buffer_new(); s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); s = node_show(n->b); buffer_append_str(buf, s); GC_FREE(s); return buffer_read(buf); } case N_DYAD: { char *s; buffer_t *buf = buffer_new(); s = node_show(n->b); buffer_append_str(buf, s); GC_FREE(s); s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); s = node_show(n->c); buffer_append_str(buf, s); GC_FREE(s); return buffer_read(buf); } case N_ADV: case N_PARTIAL_CONJ: { buffer_t *buf = buffer_new(); char *s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); buffer_append_str(buf, n->av->name); return buffer_read(buf); } case N_CONJ: { char *s; buffer_t *buf = buffer_new(); s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); buffer_append_str(buf, n->av->name); s = node_show(n->b); buffer_append_str(buf, s); GC_FREE(s); return buffer_read(buf); } case N_FORK: { char *s; buffer_t *buf = buffer_new(); s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); s = node_show(n->b); buffer_append_str(buf, s); GC_FREE(s); s = node_show(n->c); buffer_append_str(buf, s); GC_FREE(s); return buffer_read(buf); } case N_BIND: { char *s; buffer_t *buf = buffer_new(); s = node_show(n->a); buffer_append_str(buf, s); GC_FREE(s); buffer_append(buf, ':'); s = node_show(n->b); buffer_append_str(buf, s); GC_FREE(s); return buffer_read(buf); } } return strdup_checked(""); } value_t *_fork_monad(interpreter_t *state, verb_t *self, value_t *x) { verb_t *f = list_index(self->bonds, 0); verb_t *g = list_index(self->bonds, 1); verb_t *h = list_index(self->bonds, 2); value_t *l = each_rank(state, f, x, 0, f->rank[0]); value_t *r = each_rank(state, h, x, 0, f->rank[0]); return together(state, g, l, r, 0, 0, g->rank[1], g->rank[2]); } value_t *_fork_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { verb_t *f = list_index(self->bonds, 0); verb_t *g = list_index(self->bonds, 1); verb_t *h = list_index(self->bonds, 2); value_t *l = each_rank(state, f, x, 0, f->rank[0]); value_t *r = each_rank(state, h, y, 0, f->rank[0]); return together(state, g, l, r, 0, 0, g->rank[1], g->rank[2]); } value_t *_hook_monad(interpreter_t *state, verb_t *self, value_t *x) { verb_t *f = list_index(self->bonds, 0); verb_t *g = list_index(self->bonds, 1); value_t *r = each_rank(state, g, x, 0, g->rank[0]); return each_rank(state, f, r, 0, f->rank[0]); } value_t *_hook_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { verb_t *f = list_index(self->bonds, 0); verb_t *g = list_index(self->bonds, 1); value_t *r = together(state, g, x, y, 0, 0, g->rank[1], g->rank[2]); return each_rank(state, f, r, 0, f->rank[0]); } value_t *_bond_monad(interpreter_t *state, verb_t *self, value_t *x) { verb_t *f = list_index(self->bonds, 0); value_t *g = list_index(self->bonds, 1); return together(state, f, g, x, 0, 0, f->rank[1], f->rank[2]); } value_t *_bond_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { verb_t *f = list_index(self->bonds, 0); value_t *g = list_index(self->bonds, 1); value_t *r = together(state, f, x, y, 0, 0, f->rank[1], f->rank[2]); return together(state, f, g, r, 0, 0, f->rank[1], f->rank[2]); } value_t *_over_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *f = list_index(self->bonds, 0); verb_t *g = list_index(self->bonds, 1); verb_t *h = list_index(self->bonds, 2); value_t *l = each_rank(state, h, x, 0, h->rank[0]); return together(state, g, f, l, 0, 0, g->rank[1], g->rank[2]); } value_t *_over_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *f = list_index(self->bonds, 0); verb_t *g = list_index(self->bonds, 1); verb_t *h = list_index(self->bonds, 2); value_t *l = together(state, h, x, y, 0, 0, h->rank[1], h->rank[2]); return together(state, g, f, l, 0, 0, g->rank[1], g->rank[2]); } bool function_collect_args(node_t *node, unsigned int *argc) { if (!node) return false; if (node->tag == N_LITERAL && node->v->tag == SYMBOL && strcmp(node->v->val.symbol, "y") == 0) { *argc = 2; return true; } else if (node->tag == N_LITERAL && node->v->tag == SYMBOL && strcmp(node->v->val.symbol, "x") == 0) { if (*argc < 2) *argc = 1; } else if (node->tag == N_MONAD || node->tag == N_CONJ || node->tag == N_HOOK || node->tag == N_BOND || node->tag == N_INDEX1) { if (function_collect_args(node->a, argc)) return true; if (function_collect_args(node->b, argc)) return true; } else if (node->tag == N_DYAD || node->tag == N_FORK || node->tag == N_OVER || node->tag == N_INDEX2) { if (function_collect_args(node->a, argc)) return true; if (function_collect_args(node->b, argc)) return true; if (function_collect_args(node->c, argc)) return true; } else if (node->tag == N_ADV) { if (function_collect_args(node->a, argc)) return true; } else if (node->tag == N_STRAND) { list_t *t = node->l; for (size_t i = 0; i < t->length; i++) if (function_collect_args(t->data[i], argc)) return true; } else if (node->tag == N_BIND) { if (function_collect_args(node->b, argc)) return true; } return false; } value_t *interpreter_walk(interpreter_t *state, node_t *node); value_t *_const_monad(interpreter_t *state, verb_t *self, value_t *x) { return interpreter_walk(state, self->bonds->data[0]); } value_t *_const_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return interpreter_walk(state, self->bonds->data[0]); } value_t *_constv_monad(interpreter_t *state, verb_t *self, value_t *x) { return self->bonds->data[0]; } value_t *_constv_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return self->bonds->data[0]; } value_t *_fun_monad(interpreter_t *state, verb_t *self, value_t *x) { list_t *args = list_new(); list_push(args, x); list_push(args, self); list_push(state->args, args); value_t *r = interpreter_walk(state, self->bonds->data[0]); list_pop(state->args); GC_FREE(args); return r; } value_t *_fun_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { list_t *args = list_new(); list_push(args, x); list_push(args, y); list_push(args, self); list_push(state->args, args); value_t *r = interpreter_walk(state, self->bonds->data[1]); list_pop(state->args); GC_FREE(args); return r; } value_t *_partial_conjunction(interpreter_t *state, verb_t *self, value_t *x) { adverb_t *av = self->bonds->data[0]; value_t *a = self->bonds->data[1]; return value_new_verb(av->conjunction(state, a, x)); } node_t *node_new1(enum node_tag_t tag, node_t *a); value_t *interpreter_walk(interpreter_t *state, node_t *node) { if (!node) return state->nil; switch (node->tag) { case N_STRAND: { list_t *t = list_copy(node->l); for (size_t i = 0; i < t->length; i++) t->data[i] = interpreter_walk(state, t->data[i]); return value_new_array(t); } case N_LITERAL: { value_t *v = node->v; value_t *t = NULL; if (v->tag == SYMBOL) { char *n = v->val.symbol; if (state->args->data) { list_t *args = list_index(state->args, -1); size_t argc = args->length - 1; if (argc == 2 && strcmp(n, "y") == 0) return args->data[1]; else if (strcmp(n, "x") == 0) return args->data[0]; } if ((t = table_get(state->env, n))) return t; if (strcmp(n, "T") == 0) return value_new_number(time(NULL)); } return v; } case N_INDEX1: return together(state, state->at, interpreter_walk(state, node->a), interpreter_walk(state, node->b), 0, 0, state->at->rank[1], state->at->rank[2]); case N_INDEX2: return together(state, state->at, together(state, state->at, interpreter_walk(state, node->a), interpreter_walk(state, node->b), 0, 0, state->at->rank[1], state->at->rank[2]), interpreter_walk(state, node->c), 0, 0, state->at->rank[1], state->at->rank[2]); case N_FUN: { unsigned int argc = 0; function_collect_args(node->a, &argc); verb_t *nv = verb_new(); if (argc > 0) nv->is_fun = true; nv->bonds = list_new(); char *s = node_show(node->a); size_t z = strlen(s) + 2; nv->name = malloc_checked_atomic(z); snprintf(nv->name, z, ":%s", s); GC_FREE(s); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; if (argc == 0) { list_push(nv->bonds, node->a); nv->monad = _const_monad; nv->dyad = _const_dyad; } else if (argc == 1) { list_push(nv->bonds, node->a); nv->monad = _fun_monad; nv->dyad = NULL; } else { nv->monad = NULL; list_push(nv->bonds, state->udf); list_push(nv->bonds, node->a); nv->dyad = _fun_dyad; } return value_new_verb(nv); } case N_MONAD: return apply_monad(state, interpreter_walk(state, node->a), interpreter_walk(state, node->b)); case N_DYAD: return apply_dyad(state, interpreter_walk(state, node->a), interpreter_walk(state, node->b), interpreter_walk(state, node->c)); case N_ADV: { value_t *v = interpreter_walk(state, node->a); verb_t *nv = node->av->adverb(state, v); if (node->dp < 2) nv->mark = true; return value_new_verb(nv); } case N_CONJ: { value_t *v1 = interpreter_walk(state, node->a); value_t *v2 = interpreter_walk(state, node->b); verb_t *nv = node->av->conjunction(state, v1, v2); if (node->dp < 2) nv->mark = true; return value_new_verb(nv); } case N_PARTIAL_CONJ: { verb_t *nv = verb_new(); value_t *a = interpreter_walk(state, node->a); char *r = value_show(a); size_t l = strlen(r) + strlen(node->av->name) + 1; nv->name = malloc_checked_atomic(l); snprintf(nv->name, l, "%s%s", r, node->av->name); GC_FREE(r); nv->bonds = list_new(); list_push(nv->bonds, node->av); list_push(nv->bonds, a); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = _partial_conjunction; nv->dyad = NULL; if (node->dp < 2) nv->mark = true; return value_new_verb(nv); } case N_FORK: { value_t *_f = interpreter_walk(state, node->a); if (_f->tag != VERB) return state->udf; value_t *_g = interpreter_walk(state, node->b); if (_g->tag != VERB) return state->udf; value_t *_h = interpreter_walk(state, node->c); if (_h->tag != VERB) return state->udf; verb_t *f = _f->val.verb; verb_t *g = _g->val.verb; verb_t *h = _h->val.verb; verb_t *nv = verb_new(); nv->bonds = list_newk(3); nv->bonds->data[0] = f; nv->bonds->data[1] = g; nv->bonds->data[2] = h; size_t l = strlen(f->name) + strlen(g->name) + strlen(h->name) + 1; nv->name = malloc_checked_atomic(l); snprintf(nv->name, l, "%s%s%s", f->name, g->name, h->name); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = _fork_monad; nv->dyad = _fork_dyad; if (node->dp < 2) nv->mark = true; return value_new_verb(nv); } case N_HOOK: { value_t *_f = interpreter_walk(state, node->a); if (_f->tag != VERB) return state->udf; value_t *_g = interpreter_walk(state, node->b); if (_g->tag != VERB) return state->udf; verb_t *f = _f->val.verb; verb_t *g = _g->val.verb; verb_t *nv = verb_new(); nv->bonds = list_newk(2); nv->bonds->data[0] = f; nv->bonds->data[1] = g; size_t l = strlen(f->name) + strlen(g->name) + 1; nv->name = malloc_checked_atomic(l); snprintf(nv->name, l, "%s%s", f->name, g->name); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = _hook_monad; nv->dyad = _hook_dyad; if (node->dp < 2) nv->mark = true; return value_new_verb(nv); } case N_BOND: { value_t *_f = interpreter_walk(state, node->a); if (_f->tag != VERB) return state->udf; value_t *g = interpreter_walk(state, node->b); verb_t *f = _f->val.verb; verb_t *nv = verb_new(); nv->bonds = list_newk(2); nv->bonds->data[0] = f; nv->bonds->data[1] = g; char *r = value_show(g); size_t l = strlen(r) + strlen(f->name) + 1; nv->name = malloc_checked_atomic(l); snprintf(nv->name, l, "%s%s", r, f->name); GC_FREE(r); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = _bond_monad; nv->dyad = _bond_dyad; if (node->dp < 2) nv->mark = true; return value_new_verb(nv); } case N_OVER: { value_t *f = interpreter_walk(state, node->a); value_t *_g = interpreter_walk(state, node->b); if (_g->tag != VERB) return state->udf; value_t *_h = interpreter_walk(state, node->c); if (_h->tag != VERB) return state->udf; verb_t *g = _g->val.verb; verb_t *h = _h->val.verb; verb_t *nv = verb_new(); nv->bonds = list_newk(3); nv->bonds->data[0] = f; nv->bonds->data[1] = g; nv->bonds->data[2] = h; char *r = value_show(f); size_t l = strlen(r) + strlen(g->name) + strlen(h->name) + 1; nv->name = malloc_checked_atomic(l); snprintf(nv->name, l, "%s%s%s", r, g->name, h->name); GC_FREE(r); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = _over_monad; nv->dyad = _over_dyad; if (node->dp < 2) nv->mark = true; return value_new_verb(nv); } case N_BIND: { value_t *l = node->a->v; node_t *b = node->b; if (state->bn || state->args->data || node->dp != 0) { table_set(state->env, l->val.symbol, interpreter_walk(state, b)); break; } unsigned int argc = 0; function_collect_args(b, &argc); if (argc != 0) b = node_new1(N_FUN, b); bool t = state->bn; state->bn = true; value_t *r = interpreter_walk(state, b); state->bn = t; if (argc != 0) { GC_FREE(r->val.verb->name); r->val.verb->name = l->val.symbol; } if (r->tag == VERB && argc == 0) r->val.verb->mark = true; value_t *ov = table_get(state->env, l->val.symbol); if (ov && ov->tag == VERB && ov->val.verb->is_fun && r->tag == VERB && r->val.verb->is_fun) { if (!ov->val.verb->monad && r->val.verb->monad) { list_set(ov->val.verb->bonds, 0, r->val.verb->bonds->data[0]); ov->val.verb->monad = r->val.verb->monad; break; } if (!ov->val.verb->dyad && r->val.verb->dyad) { list_push(ov->val.verb->bonds, r->val.verb->bonds->data[1]); ov->val.verb->dyad = r->val.verb->dyad; break; } } table_set(state->env, l->val.symbol, r); } break; } return state->nil; } value_t *verb_const(interpreter_t *state, verb_t *self, value_t *x) { verb_t *nv = verb_new(); nv->bonds = list_newk(1); nv->bonds->data[0] = x; char *r = value_show(x); size_t l = strlen(r) + 2; nv->name = malloc_checked_atomic(l); snprintf(nv->name, l, ":%s", r); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = _constv_monad; nv->dyad = _constv_dyad; return value_new_verb(nv); } value_t *verb_bind(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == SYMBOL) { if (y->tag == VERB) y->val.verb->mark = true; table_set(state->env, x->val.symbol, y); } return state->udf; } table_t *Inverses; value_t *verb_unbind(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == SYMBOL) { table_delete(state->env, x->val.symbol); return state->nil; } return state->udf; } value_t *verb_obverse(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == VERB && y->tag == VERB) { verb_t *vx = x->val.verb; if (!y->val.verb->monad) return state->udf; if (vx->is_fun) return state->udf; if (table_has(Inverses, vx->name)) return state->udf; table_set(Inverses, vx->name, y->val.verb); return state->nil; } return state->udf; } value_t *verb_flip(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || !x->val.array->data) return state->udf; if (!is_arrays_array(x->val.array)) return state->udf; list_t *r = list_new(); value_t *c0 = x->val.array->data[0]; list_t *c0t = c0->val.array; size_t c0l = c0t->length; for (size_t i = 0; i < c0l; i++) { list_t *nc = list_new(); for (size_t j = 0; j < x->val.array->length; j++) { value_t *rw = x->val.array->data[j]; list_t *rwt = rw->val.array; if (!rwt->data) return state->udf; value_t *v = list_index(rwt, i); if (!v) v = rwt->data[0]; list_push(nc, v); } list_push(r, value_new_array(nc)); } return value_new_array(r); } value_t *verb_plus(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (x->tag == CHAR || y->tag == CHAR) return value_new_char(get_numeric(x) + get_numeric(y)); return value_new_number(get_numeric(x) + get_numeric(y)); } return _NAN; } value_t *verb_sign(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return x->val.number < 0 ? NNUMS[0] : x->val.number > 0 ? NUMS[1] : NUMS[0]; return _NAN; } double gcd(double a, double b) { if (b != 0) return gcd(b, fmod(a, b)); else return fabs(a); } value_t *verb_gcd(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(gcd(x->val.number, y->val.number)); return _NAN; } value_t *verb_sin(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(sin(x->val.number)); return _NAN; } value_t *verb_square(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(x->val.number * x->val.number); return _NAN; } value_t *verb_negate(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(-x->val.number); return _NAN; } value_t *verb_minus(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (x->tag == CHAR || y->tag == CHAR) return value_new_char(get_numeric(x) - get_numeric(y)); return value_new_number(get_numeric(x) - get_numeric(y)); } return _NAN; } value_t *verb_atan(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(atan(x->val.number)); return _NAN; } value_t *verb_atan2(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(atan2(x->val.number, y->val.number)); return _NAN; } value_t *verb_first(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) return x; if (!x->val.array->data) return state->udf; return x->val.array->data[0]; } value_t *verb_times(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (x->tag == CHAR || y->tag == CHAR) return value_new_char(get_numeric(x) * get_numeric(y)); return value_new_number(get_numeric(x) * get_numeric(y)); } return _NAN; } double lcm(double a, double b) { return (a * b) / gcd(a, b); } uint64_t factorial(uint64_t n) { uint64_t r = 1; while (n > 0) r *= n--; return r; } value_t *verb_factorial(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(factorial((uint64_t)fabs(x->val.number))); return _NAN; } value_t *verb_lcm(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(lcm(x->val.number, y->val.number)); return _NAN; } value_t *verb_double(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(x->val.number * 2); return _NAN; } value_t *verb_replicate(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER) { size_t k = fabs(x->val.number); list_t *r = list_new(); while (k--) list_push(r, y); return value_new_array(r); } return state->udf; } value_t *verb_reciprocal(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(1 / x->val.number); return _NAN; } value_t *verb_divide(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) { double ny = y->val.number; if (ny == 0) return INF; return value_new_number(x->val.number / ny); } return _NAN; } double npower(double base, int n) { if (n < 0) return npower(1 / base, -n); else if (n == 0) return 1.0; else if (n == 1) return base; else if (n % 2) return base * npower(base * base, n / 2); else return npower(base * base, n / 2); } double nroot(double base, int n) { if (n == 1) return base; else if (n <= 0 || base < 0) return NAN; else { double delta, x = base / n; do { delta = (base / npower(x, n - 1) - x) / n; x += delta; } while (fabs(delta) >= 1e-8); return x; } } value_t *verb_sqrt(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(sqrt(x->val.number)); return _NAN; } value_t *verb_root(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(nroot(y->val.number, x->val.number)); return _NAN; } value_t *verb_halve(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(x->val.number / 2); return _NAN; } value_t *verb_idivide(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { double a = get_numeric(x); double b = get_numeric(y); if (x->tag == CHAR || y->tag == CHAR) return b == 0 ? state->udf : value_new_char(fabs(trunc(a / b))); if (b == 0) return INF; return value_new_number(trunc(a / b)); } return _NAN; } value_t *verb_enlist(interpreter_t *state, verb_t *self, value_t *x); value_t *verb_pred(interpreter_t *state, verb_t *self, value_t *x); value_t *verb_range(interpreter_t *state, verb_t *self, value_t *x, value_t *y); value_t *verb_enum(interpreter_t *state, verb_t *self, value_t *x) { if (value_equals(x, NUMS[1])) return verb_enlist(state, NULL, NUMS[0]); else if (value_equals(x, NUMS[0])) return state->unit; return verb_range(state, self, NUMS[0], verb_pred(state, self, x)); } value_t *verb_mod(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) { double ny = y->val.number; if (ny == 0) return _NAN; return value_new_number(fmod(x->val.number, ny)); } return _NAN; } value_t *verb_take(interpreter_t *state, verb_t *self, value_t *x, value_t *y); value_t *verb_drop(interpreter_t *state, verb_t *self, value_t *x, value_t *y); bool is_bad_num(double v) { return isnan(v) || v == INFINITY || v == -INFINITY; } value_t *verb_odometer(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (x->val.array->length < 2) return state->udf; size_t p = 1; size_t xl = x->val.array->length; for (size_t i = 0; i < xl; i++) { value_t *it = x->val.array->data[i]; if (it->tag != NUMBER || is_bad_num(it->val.number)) return state->udf; p *= (size_t)(it->val.number); } if (p < 1) return state->unit; uint64_t *lims = malloc_checked_atomic(sizeof(uint64_t) * xl); for (size_t i = 0; i < xl; i++) lims[i] = (size_t)(((value_t *)x->val.array->data[i])->val.number); uint64_t **z = malloc_checked(sizeof(uint64_t *) * p); for (size_t i = 0; i < p; i++) z[i] = malloc_checked_atomic(sizeof(uint64_t) * xl); for (size_t i = 0; i < p - 1; i++) { uint64_t *r = z[i]; uint64_t *s = z[i + 1]; bool carry = true; for (size_t j = 0; j < xl; j++) { uint64_t a = xl - 1 - j; s[a] = r[a]; if (carry) { s[a]++; carry = false; } if (s[a] >= lims[a]) { s[a] = 0; carry = true; } } } GC_FREE(lims); list_t *r = list_newk(p); for (size_t i = 0; i < p; i++) { list_t *rw = list_newk(xl); for (size_t j = 0; j < xl; j++) rw->data[j] = value_new_number(z[i][j]); r->data[i] = value_new_array(rw); GC_FREE(z[i]); } GC_FREE(z); return value_new_array(r); } value_t *verb_chunks(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != NUMBER) return state->udf; if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); else if (!y->val.array->data) return y; list_t *r = list_new(); size_t cl = fabs(x->val.number); for (size_t i = 0; i < y->val.array->length; i += cl) list_push(r, verb_take(state, NULL, value_new_number(cl), verb_drop(state, NULL, value_new_number(i), y))); return value_new_array(r); } value_t *verb_exp(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(exp(x->val.number)); return _NAN; } value_t *verb_power(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(pow(x->val.number, y->val.number)); return _NAN; } value_t *verb_nlog(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(log(x->val.number)); return _NAN; } value_t *verb_log(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(log(y->val.number) / log(x->val.number)); return _NAN; } int bits_needed(uint32_t value) { int bits = 0; for (int bit_test = 16; bit_test > 0; bit_test >>= 1) { if (value >> bit_test != 0) { bits += bit_test; value >>= bit_test; } } return bits + value; } value_t *verb_bits(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) { int n = x->val.number; int bk = bits_needed(n); list_t *r = list_newk(bk); for (int i = 0; i < bk; i++) if ((n & (1 << i)) >> i) r->data[i] = NUMS[1]; else r->data[i] = NUMS[0]; return value_new_array(r); } return state->udf; } value_t *verb_reverse(interpreter_t *state, verb_t *self, value_t *x); value_t *verb_base(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) { size_t v = fabs(y->val.number); size_t b = fabs(x->val.number); if (b < 2) return state->udf; list_t *r = list_new(); while (v > 0) { list_push(r, value_new_number(v % b)); v /= b; } return verb_reverse(state, NULL, value_new_array(r)); } return state->udf; } ssize_t indexOf(list_t *l, value_t *x) { if (!l->data) return -1; for (size_t i = 0; i < l->length; i++) if (value_equals(l->data[i], x)) return i; return -1; } value_t *verb_group(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return x; list_t *r = list_new(); list_t *is = list_new(); for (size_t i = 0; i < x->val.array->length; i++) { value_t *v = x->val.array->data[i]; ssize_t n = indexOf(is, v); if (n < 0) { list_push(r, verb_enlist(state, NULL, value_new_number(i))); list_push(is, v); } else { value_t *tmp = list_index(r, n); list_push(tmp->val.array, value_new_number(i)); } } GC_FREE(is->data); GC_FREE(is); return value_new_array(r); } value_t *verb_buckets(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return y; if (y->tag != ARRAY) y = verb_enlist(state, NULL, x); else if (!y->val.array->data) return y; list_t *r = list_new(); size_t mx = 0; for (size_t i = 0; i < x->val.array->length; i++) { value_t *v = x->val.array->data[i]; if (v->tag != NUMBER) break; ssize_t j = v->val.number; if (j >= 0 && j > mx) mx = j; } for (size_t i = 0; i < mx + 1; i++) list_push(r, list_new()); if (!r->data) { GC_FREE(r); return state->unit; } for (size_t i = 0; i < x->val.array->length; i++) { if (i >= y->val.array->length) break; value_t *v = x->val.array->data[i]; if (v->tag != NUMBER) break; ssize_t j = v->val.number; if (j >= 0) { list_t *b = list_index(r, j); if (b) list_push(b, y->val.array->data[i]); } } if (x->val.array->length < y->val.array->length) { list_t *lb = list_new(); for (size_t i = x->val.array->length; i < y->val.array->length; i++) list_push(lb, y->val.array->data[i]); list_push(r, lb); } for (size_t i = 0; i < r->length; i++) r->data[i] = value_new_array(r->data[i]); return value_new_array(r); } value_t *verb_equals(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return value_equals(x, y) ? NUMS[1] : NUMS[0]; } value_t *verb_permute(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || x->val.array->length < 2) return x; list_t *permutation = list_copy(x->val.array); size_t length = permutation->length; list_t *result = list_new(); list_push(result, list_copy(permutation)); list_t *c = list_new(); for (size_t i = 0; i < length; i++) { size_t *n = malloc_checked_atomic(sizeof(size_t)); list_push(c, n); } size_t k; list_t *p; size_t i = 0; while (i < length) { size_t *n = list_index(c, i); if ((*n) < i) { k = i % 2 && (*n); p = list_index(permutation, i); list_set(permutation, i, list_index(permutation, k)); list_set(permutation, k, p); *n = (*n) + 1; i = 1; list_push(result, list_copy(permutation)); } else { *n = 0; i++; } } for (size_t i = 0; i < c->length; i++) GC_FREE(c->data[i]); GC_FREE(c->data); GC_FREE(c); GC_FREE(permutation->data); GC_FREE(permutation); for (size_t i = 0; i < result->length; i++) result->data[i] = value_new_array(result->data[i]); return value_new_array(result); } value_t *verb_occurences(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return x; list_t *table = list_new(); list_t *r = list_new(); for (size_t i = 0; i < x->val.array->length; i++) { bool f = false; value_t *it = x->val.array->data[i]; for (size_t j = 0; j < table->length; j++) { list_t *p = table->data[j]; if (value_equals(p->data[0], it)) { size_t *n = p->data[1]; *n = (*n) + 1; list_push(r, value_new_number(*n)); f = true; break; } } if (!f) { list_t *p = list_newk(2); p->data[0] = it; size_t *n = malloc_checked_atomic(sizeof(size_t)); p->data[1] = n; list_push(table, p); list_push(r, NUMS[0]); } } for (size_t i = 0; i < table->length; i++) { list_t *p = table->data[i]; GC_FREE(p->data[1]); GC_FREE(p->data); GC_FREE(p); } GC_FREE(table->data); GC_FREE(table); return value_new_array(r); } value_t *verb_mask(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return x; if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); list_t *r = list_new(); value_t *l = value_new_number(y->val.array->length); size_t n = 0; size_t k = x->val.array->length; for (size_t i = 0; i < k; i++) { value_t *s = verb_take(state, NULL, l, verb_drop(state, NULL, value_new_number(i), x)); if (value_equals(s, y)) { n++; for (size_t j = 0; j < l->val.number; j++, i++) list_push(r, value_new_number(n)); i--; } else list_push(r, NUMS[0]); } return value_new_array(r); } value_t *verb_classify(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return x; list_t *table = list_new(); list_t *r = list_new(); for (size_t i = 0; i < x->val.array->length; i++) { bool f = false; value_t *it = x->val.array->data[i]; for (size_t j = 0; j < table->length; j++) { list_t *p = table->data[j]; if (value_equals(p->data[0], it)) { size_t *n = p->data[1]; list_push(r, value_new_number(*n)); f = true; break; } } if (!f) { list_t *p = list_newk(2); p->data[0] = it; size_t *n = malloc_checked_atomic(sizeof(size_t)); *n = i++; p->data[1] = n; list_push(table, p); list_push(r, value_new_number(*n)); } } for (size_t i = 0; i < table->length; i++) { list_t *p = table->data[i]; GC_FREE(p->data[1]); GC_FREE(p->data); GC_FREE(p); } GC_FREE(table->data); GC_FREE(table); return value_new_array(r); } value_t *verb_unbits(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); int n = 0; for (size_t i = 0; i < x->val.array->length; i++) { if (value_is_truthy(x->val.array->data[i])) n |= (int)1 << (int)i; else n &= ~((int)1 << (int)i); } return value_new_number(n); } value_t *verb_unbase(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER) { size_t b = fabs(x->val.number); if (b < 2) return state->udf; if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); size_t n = 0; if (!y->val.array->data) return state->udf; for (size_t i = 0; i < y->val.array->length; i++) { value_t *v = y->val.array->data[i]; if (v->tag != NUMBER) break; size_t k = fabs(v->val.number); n = n * b + k; } return value_new_number(n); } return state->udf; } value_t *verb_not(interpreter_t *state, verb_t *self, value_t *x) { return value_is_truthy(x) ? NUMS[0] : NUMS[1]; } value_t *verb_not_equals(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return !value_equals(x, y) ? NUMS[1] : NUMS[0]; } value_t *verb_pred(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(x->val.number - 1); else if (x->tag == CHAR) return value_new_char(x->val._char - 1); return _NAN; } value_t *verb_less(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) < get_numeric(y)) return NUMS[1]; return NUMS[0]; } return _NAN; } value_t *verb_floor(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(floor(x->val.number)); return _NAN; } int _compare_up(const void *a, const void *b) { value_t *x = (*(list_t **)a)->data[0]; value_t *y = (*(list_t **)b)->data[0]; if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) > get_numeric(y)) return 1; else if (get_numeric(x) < get_numeric(y)) return -1; return 0; } return 0; } int _compare_down(const void *a, const void *b) { value_t *x = (*(list_t **)a)->data[0]; value_t *y = (*(list_t **)b)->data[0]; if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) > get_numeric(y)) return -1; else if (get_numeric(x) < get_numeric(y)) return 1; return 0; } return 0; } value_t *_grade(value_t *x, bool down) { if (x->tag != ARRAY || x->val.array->length < 2) return x; list_t *ps = list_newk(x->val.array->length); for (size_t i = 0; i < x->val.array->length; i++) { list_t *p = list_newk(2); p->data[0] = x->val.array->data[i]; p->data[1] = value_new_number(i); ps->data[i] = p; } qsort(ps->data, ps->length, sizeof(void *), down ? _compare_down : _compare_up); for (size_t i = 0; i < ps->length; i++) { list_t *p = ps->data[i]; ps->data[i] = p->data[1]; GC_FREE(p->data); GC_FREE(p); } return value_new_array(ps); } value_t *verb_gradedown(interpreter_t *state, verb_t *self, value_t *x) { return _grade(x, true); } value_t *verb_nudge_left(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) return verb_enlist(state, NULL, x); else if (!y->val.array->data) return y; else if (y->val.array->length < 2) return verb_enlist(state, NULL, x); list_t *r = list_new(); for (size_t i = 1; i < y->val.array->length; i++) list_push(r, y->val.array->data[i]); list_push(r, x); return value_new_array(r); } value_t *verb_lesseq(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (value_equals(x, y)) return NUMS[1]; if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) < get_numeric(y)) return NUMS[1]; return NUMS[0]; } return _NAN; } value_t *verb_succ(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(x->val.number + 1); else if (x->tag == CHAR) return value_new_char(x->val._char + 1); return _NAN; } value_t *verb_ceil(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(ceil(x->val.number)); return _NAN; } value_t *verb_greater(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) > get_numeric(y)) return NUMS[1]; return NUMS[0]; } return _NAN; } value_t *verb_greatereq(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (value_equals(x, y)) return NUMS[1]; if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) > get_numeric(y)) return NUMS[1]; return NUMS[0]; } return _NAN; } value_t *verb_gradeup(interpreter_t *state, verb_t *self, value_t *x) { return _grade(x, false); } value_t *verb_nudge_right(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) return verb_enlist(state, NULL, x); else if (!y->val.array->data) return y; else if (y->val.array->length < 2) return verb_enlist(state, NULL, x); list_t *r = list_new(); list_push(r, x); for (size_t i = 0; i < y->val.array->length - 1; i++) list_push(r, y->val.array->data[i]); return value_new_array(r); } value_t *verb_enlist(interpreter_t *state, verb_t *self, value_t *x) { list_t *l = list_new(); list_push(l, x); return value_new_array(l); } value_t *verb_enpair(interpreter_t *state, verb_t *self, value_t *x, value_t *y); value_t *verb_join(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { list_t *l; if (x->tag == ARRAY && y->tag == ARRAY) { if (!x->val.array->data && !y->val.array->data) return state->unit; else if (!x->val.array->data) return y; else if (!y->val.array->data) return x; l = list_newk(x->val.array->length + y->val.array->length); size_t lp = 0; for (size_t i = 0; i < x->val.array->length; i++) l->data[lp++] = x->val.array->data[i]; for (size_t i = 0; i < y->val.array->length; i++) l->data[lp++] = y->val.array->data[i]; } else if (x->tag == ARRAY && y->tag != ARRAY) { if (!x->val.array->data) return verb_enlist(state, NULL, y); l = list_newk(x->val.array->length + 1); size_t lp = 0; for (size_t i = 0; i < x->val.array->length; i++) l->data[lp++] = x->val.array->data[i]; l->data[lp++] = y; } else if (x->tag != ARRAY && y->tag == ARRAY) { if (!y->val.array->data) return verb_enlist(state, NULL, x); l = list_newk(y->val.array->length + 1); size_t lp = 0; l->data[lp++] = x; for (size_t i = 0; i < y->val.array->length; i++) l->data[lp++] = y->val.array->data[i]; } else return verb_enpair(state, NULL, x, y); return value_new_array(l); } value_t *verb_enpair(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { list_t *l = list_newk(2); l->data[0] = x; l->data[1] = y; return value_new_array(l); } value_t *verb_selfref1(interpreter_t *state, verb_t *self, value_t *x) { verb_t *v; if (state->args->data) v = list_index(list_index(state->args, -1), -1); else if (state->selfrefs->data) v = list_index(state->selfrefs, -1); else return state->udf; return each_rank(state, v, x, 0, v->rank[0]); } value_t *verb_selfref2(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { verb_t *v; if (state->args->data) v = list_index(list_index(state->args, -1), -1); else if (state->selfrefs->data) v = list_index(state->selfrefs, -1); else return state->udf; return together(state, v, x, y, 0, 0, v->rank[1], v->rank[2]); } value_t *verb_take(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER) { if (y->tag != ARRAY) { if (x->val.number == 0) return state->unit; else return x; } if (x->val.number == 0 || !y->val.array->data) return state->unit; bool rev = x->val.number < 0; size_t k = (size_t)fabs(x->val.number); list_t *r = list_newk(y->val.array->length < k ? y->val.array->length : k); size_t p = 0; if (rev) for (ssize_t i = k; i > 0; i--) { value_t *v = list_index(y->val.array, -i); if (!v) continue; r->data[p++] = v; } else for (size_t i = 0; i < y->val.array->length && k; i++, k--) r->data[p++] = y->val.array->data[i]; return value_new_array(r); } return state->udf; } value_t *verb_where(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return x; list_t *r = list_new(); for (size_t i = 0; i < x->val.array->length; i++) { value_t *a = x->val.array->data[i]; if (a->tag != NUMBER) break; size_t k = fabs(a->val.number); for (size_t j = 0; j < k; j++) list_push(r, value_new_number(i)); } return value_new_array(r); } value_t *verb_copy(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); list_t *tx = x->val.array; list_t *ty = y->val.array; if (!tx->data || !ty->data) return state->unit; list_t *r = list_new(); for (size_t i = 0; i < tx->length; i++) { value_t *a = tx->data[i]; value_t *b = ty->data[i >= ty->length ? ty->length - 1 : i]; if (b->tag != NUMBER) break; size_t k = fabs(b->val.number); for (size_t i = 0; i < k; i++) list_push(r, a); } return value_new_array(r); } value_t *verb_nub(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || !x->val.array->data) return x; list_t *n = list_newk(x->val.array->length); list_t *r = list_new(); for (size_t i = 0; i < x->val.array->length; i++) { bool u = true; for (size_t j = 0; j < r->length; j++) if (value_equals(x->val.array->data[i], r->data[j])) { u = false; break; } if (u) list_push(r, x->val.array->data[i]); n->data[i] = u ? NUMS[1] : NUMS[0]; } GC_FREE(r->data); GC_FREE(r); return value_new_array(n); } value_t *verb_drop(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER) { if (y->tag != ARRAY) { if (x->val.number == 0) return y; else return state->unit; } if (x->val.number == 0) return y; if (!y->val.array->data) return state->unit; bool rev = x->val.number < 0; size_t k = (size_t)fabs(x->val.number); if (k >= y->val.array->length) return state->unit; if (rev) { size_t l = y->val.array->length; if (k >= l) return state->unit; return verb_take(state, NULL, value_new_number(l - k), y); } list_t *r = list_newk(y->val.array->length - k); size_t rp = 0; for (size_t i = k; i < y->val.array->length; i++) r->data[rp++] = y->val.array->data[i]; return value_new_array(r); } return state->udf; } value_t *verb_unique(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || !x->val.array->data) return x; list_t *r = list_new(); for (size_t i = 0; i < x->val.array->length; i++) { bool u = true; for (size_t j = 0; j < r->length; j++) if (value_equals(x->val.array->data[i], r->data[j])) { u = false; break; } if (u) list_push(r, x->val.array->data[i]); } return value_new_array(r); } value_t *verb_find(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, self, y); else if (!y->val.array->data) return state->unit; list_t *r = list_new(); for (size_t i = 0; i < y->val.array->length; i++) if (value_equals(y->val.array->data[i], x)) list_push(r, value_new_number(i)); return value_new_array(r); } value_t *verb_indexof(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, self, y); else if (!y->val.array->data) return state->unit; ssize_t n = indexOf(y->val.array, x); if (n < 0) n = y->val.array->length; return value_new_number(n); } value_t *verb_count(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) return NUMS[1]; return value_new_number(x->val.array->length); } void flatten(value_t *x, list_t *r) { if (x->tag == ARRAY) for (size_t i = 0; i < x->val.array->length; i++) flatten(x->val.array->data[i], r); else list_push(r, x); } value_t *verb_flatten(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || !x->val.array->data) return x; list_t *r = list_new(); flatten(x, r); return value_new_array(r); } value_t *verb_minand(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) < get_numeric(y)) return x; return y; } return _NAN; } value_t *verb_reverse(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) return x; if (x->val.array->length < 2) return x; list_t *r = list_newk(x->val.array->length); size_t rp = 0; for (ssize_t i = x->val.array->length - 1; i >= 0; i--) r->data[rp++] = x->val.array->data[i]; return value_new_array(r); } value_t *verb_maxor(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) > get_numeric(y)) return x; return y; } return _NAN; } value_t *verb_rotate(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY || y->val.array->length < 2) return x; if (x->tag != NUMBER) return state->udf; bool rev = x->val.number < 0; size_t k = fabs(x->val.number); list_t *r = list_copy(y->val.array); for (size_t i = 0; i < k; i++) { value_t *v; if (rev) { v = r->data[0]; for (size_t j = 0; j < r->length - 1; j++) r->data[j] = r->data[j + 1]; r->data[r->length - 1] = v; } else { v = r->data[r->length - 1]; for (size_t j = r->length - 1; j > 0; j--) r->data[j] = r->data[j - 1]; r->data[0] = v; } } return value_new_array(r); } value_t *verb_windows(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); else if (!y->val.array->data) return y; size_t k = fabs(x->val.number); size_t l = y->val.array->length; list_t *r = list_new(); for (size_t i = 0; i < l; i++) { if (i + k > l) break; list_push(r, verb_take(state, NULL, value_new_number(k), verb_drop(state, NULL, value_new_number(i), y))); } return value_new_array(r); } size_t depthOf(value_t *x, size_t d) { if (x->tag == ARRAY) { if (!x->val.array->data) return 0; for (size_t i = 0; i < x->val.array->length; i++) { size_t d2 = depthOf(x->val.array->data[i], d + 1); if (d2 > d) d = d2; } return d; } return 0; } value_t *verb_depth(interpreter_t *state, verb_t *self, value_t *x) { return value_new_number(depthOf(x, 1)); } value_t *verb_round(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(round(x->val.number)); return _NAN; } value_t *verb_abs(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(fabs(x->val.number)); return _NAN; } value_t *verb_tail(interpreter_t *state, verb_t *self, value_t *x); value_t *verb_at(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != NUMBER) return state->udf; if (x->tag != ARRAY) { if (y->val.number > -1 && y->val.number < 1) return x; else return state->udf; } if (!x->val.array->data) return state->nil; value_t *v = list_index(x->val.array, (ssize_t)y->val.number); if (!v) return state->udf; return v; } value_t *verb_member(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, self, y); else if (!y->val.array->data) return NUMS[0]; for (size_t i = 0; i < y->val.array->length; i++) if (value_equals(y->val.array->data[i], x)) return NUMS[1]; return NUMS[0]; } value_t *verb_shuffle(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, self, x); else if (!x->val.array->data) return x; list_t *r = list_copy(x->val.array); for (size_t i = 0; i < r->length; i++) { size_t j = rand() % r->length; value_t *tmp = r->data[i]; r->data[i] = r->data[j]; r->data[j] = tmp; } return value_new_array(r); } value_t *verb_head(interpreter_t *state, verb_t *self, value_t *x) { return verb_take(state, NULL, NUMS[2], x); } value_t *verb_bin(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != ARRAY) x = verb_enlist(state, self, x); else if (!x->val.array->data) return x; if (y->tag != ARRAY) y = verb_enlist(state, self, x); else if (!y->val.array->data) return y; size_t xl = x->val.array->length; list_t *bins = list_new(); for (size_t i = 0; i < xl; i++) { double s; double e; value_t *vs = x->val.array->data[i]; if (vs->tag == NUMBER) s = vs->val.number; else if (vs->tag == CHAR) s = vs->val._char; else return state->udf; value_t *ve = i == xl - 1 ? value_new_number(s + 1) : x->val.array->data[i + 1]; if (ve->tag == NUMBER) e = fabs(ve->val.number); else if (ve->tag == CHAR) e = ve->val._char; else return state->udf; if (bins->data) { list_t *pp = list_index(bins, -1); double *pe = pp->data[0]; if (s <= (*pe)) return state->udf; } double *sn = malloc_checked(sizeof(double)); *sn = s; double *en = malloc_checked(sizeof(double)); *en = e; list_t *p = list_new(); list_push(p, sn); list_push(p, en); list_push(bins, p); } size_t bl = bins->length; list_t *r = list_new(); size_t yl = y->val.array->length; for (size_t i = 0; i < yl; i++) { value_t *it = y->val.array->data[i]; double itv; if (it->tag == NUMBER) itv = it->val.number; else if (it->tag == CHAR) itv = it->val._char; else return state->udf; list_t *b = bins->data[0]; double *s = b->data[0]; if (itv < (*s)) { list_push(r, NNUMS[0]); continue; } b = list_index(bins, -1); s = b->data[1]; if (itv >= (*s)) { list_push(r, value_new_number(bl - 1)); continue; } double v = NAN; for (size_t j = 0; j < bl; j++) { b = bins->data[j]; double *s = b->data[0]; double *e = b->data[1]; if (itv >= (*s) && itv < (*e)) { v = j; break; } } if (!isnan(v)) list_push(r, value_new_number(v)); } for (size_t j = 0; j < bl; j++) { list_t *b = bins->data[j]; GC_FREE(b->data[0]); GC_FREE(b->data[1]); GC_FREE(b->data); GC_FREE(b); } GC_FREE(bins->data); GC_FREE(bins); return value_new_array(r); } value_t *verb_tail(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) return x; if (!x->val.array->data) return state->udf; return list_index(x->val.array, -1); } value_t *verb_cut(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != ARRAY) x = verb_enlist(state, self, x); else if (!x->val.array->data) return x; if (y->tag != ARRAY) y = verb_enlist(state, self, x); else if (!y->val.array->data) return x; if (x->val.array->length != 2) return state->udf; value_t *vs = x->val.array->data[0]; value_t *ve = x->val.array->data[1]; if (vs->tag != NUMBER || ve->tag != NUMBER) return state->udf; size_t s = fabs(vs->val.number); size_t e = fabs(ve->val.number); list_t *r = list_new(); size_t l = y->val.array->length; list_t *pa = list_new(); for (size_t i = s; i < e && i < l; i++) { value_t *v = list_index(y->val.array, i); if (!v) break; list_push(pa, v); } list_t *pb = list_new(); for (size_t i = e; i < l; i++) { value_t *v = list_index(y->val.array, i); if (!v) break; list_push(pb, v); } list_push(r, value_new_array(pa)); list_push(r, value_new_array(pb)); return value_new_array(r); } value_t *verb_prefixes(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); list_t *r = list_new(); for (size_t i = 0; i < x->val.array->length; i++) list_push(r, verb_take(state, NULL, value_new_number(i), x)); list_push(r, x); return value_new_array(r); } value_t *verb_behead(interpreter_t *state, verb_t *self, value_t *x) { return verb_drop(state, NULL, NUMS[1], x); } value_t *verb_curtail(interpreter_t *state, verb_t *self, value_t *x) { return verb_drop(state, NULL, NNUMS[0], x); } value_t *verb_suffixes(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); list_t *r = list_new(); for (size_t i = 0; i < x->val.array->length; i++) list_push(r, verb_drop(state, NULL, value_new_number(i), x)); list_push(r, state->unit); return value_new_array(r); } value_t *verb_left(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return x; } value_t *verb_same(interpreter_t *state, verb_t *self, value_t *x) { return x; } value_t *verb_right(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return y; } value_t *verb_symbol(interpreter_t *state, verb_t *self, value_t *x) { char *s = value_str(x); return value_new_symbol(s); } value_t *verb_apply1(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return apply_monad(state, x, y); } value_t *verb_apply2(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY || y->val.array->length < 2) return state->udf; return apply_dyad(state, x, y->val.array->data[0], y->val.array->data[1]); } value_t *verb_shape(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || !x->val.array->data) return state->unit; if (!is_arrays_array(x->val.array)) return verb_enlist(state, NULL, verb_count(state, NULL, x)); if (x->val.array->length < 2) return verb_enlist(state, NULL, verb_shape(state, NULL, x->val.array->data[0])); return verb_enpair(state, NULL, verb_count(state, NULL, x), verb_count(state, NULL, x->val.array->data[0])); } value_t *verb_reshape(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); else if (!y->val.array->data) return y; if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return state->unit; list_t *r; if (x->val.array->length < 2) { value_t *a = x->val.array->data[0]; if (a->tag != NUMBER) return state->udf; size_t k = fabs(a->val.number); list_t *t = list_new(); flatten(y, t); r = list_newk(k); for (size_t i = 0; i < k; i++) r->data[i] = t->data[i % t->length]; } else if (x->val.array->length > 1) { value_t *a = x->val.array->data[0]; if (a->tag != NUMBER) return state->udf; value_t *b = x->val.array->data[1]; if (b->tag != NUMBER) return state->udf; size_t k = fabs(a->val.number); size_t l = fabs(b->val.number); y = verb_reshape(state, self, verb_enlist(state, NULL, value_new_number(k * l)), y); r = list_new(); size_t yp = 0; while (k--) { list_t *rw = list_new(); for (size_t i = 0; i < l; i++) list_push(rw, y->val.array->data[yp++]); list_push(r, value_new_array(rw)); } } else return state->udf; return value_new_array(r); } value_t *verb_repr(interpreter_t *state, verb_t *self, value_t *x) { char *s = value_show(x); list_t *r = list_new(); for (size_t i = 0; i < strlen(s); i++) list_push(r, value_new_char(s[i])); GC_FREE(s); return value_new_array(r); } char *format(char *template, list_t *replaces) { buffer_t *text = buffer_new(); bool skip = false; size_t ri = 0; size_t tl = strlen(template); size_t rl = replaces->length; for (size_t i = 0; i < tl; i++) { char c = template[i]; if (skip) { buffer_append(text, c); skip = false; continue; } if (c == '_') { char *s = value_show(list_index(replaces, ri)); buffer_append_str(text, s); GC_FREE(s); if (ri < rl - 1) ri++; continue; } else if (c == '{') { size_t bi = i; buffer_t *n = buffer_new(); i++; while (i < tl && template[i] != '}') buffer_append(n, template[i++]); if (i >= tl || template[i] != '}') { GC_FREE(buffer_read(n)); buffer_append(text, '{'); i = bi; continue; } char *s = buffer_read(n); ssize_t ind = atoi(s); GC_FREE(s); value_t *v = list_index(replaces, ind); if (!v) continue; s = value_show(v); buffer_append_str(text, s); GC_FREE(s); continue; } else if (c == '~') { skip = true; continue; } buffer_append(text, c); } return buffer_read(text); } value_t *verb_format(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, NULL, x); else if (!y->val.array->data) return y; char *fmt = value_show(x); char *s = format(fmt, y->val.array); GC_FREE(fmt); size_t z = strlen(s); list_t *r = list_newk(z); for (size_t i = 0; i < z; i++) r->data[i] = CHARS[(int)s[i]]; return value_new_array(r); } value_t *verb_insert(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); else if (!y->val.array->data) return y; list_t *r = list_newk(y->val.array->length * 2 - 1); size_t rp = 0; for (size_t i = 0; i < y->val.array->length; i++) { r->data[rp++] = y->val.array->data[i]; if (i != y->val.array->length - 1) r->data[rp++] = x; } return value_new_array(r); } uint64_t fibonacci(uint64_t n) { uint64_t a = 0; uint64_t b = 1; while (n-- > 1) { uint64_t t = a; a = b; b += t; } return b; } value_t *verb_fibonacci(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(fibonacci((uint64_t)fabs(x->val.number))); return _NAN; } value_t *verb_iota(interpreter_t *state, verb_t *self, value_t *x) { if (value_equals(x, NUMS[1])) return verb_enlist(state, NULL, NUMS[1]); else if (value_equals(x, NUMS[0])) return state->unit; return verb_range(state, self, NUMS[1], x); } value_t *verb_range(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (x->tag == NUMBER && is_bad_num(x->val.number)) return state->udf; if (y->tag == NUMBER && is_bad_num(y->val.number)) return state->udf; ssize_t s = get_numeric(x); ssize_t e = get_numeric(y); if (s == e) return verb_enlist(state, NULL, x); size_t p = 0; list_t *r = list_newk((s > e ? s - e : e - s) + 1); if (s > e) for (ssize_t i = s; i >= e; i--) { if (x->tag == CHAR || y->tag == CHAR) r->data[p++] = CHARS[i]; else r->data[p++] = value_new_number(i); } else for (ssize_t i = s; i <= e; i++) { if (x->tag == CHAR || y->tag == CHAR) r->data[p++] = CHARS[i]; else r->data[p++] = value_new_number(i); } return value_new_array(r); } return _NAN; } value_t *verb_deal(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) return x; if (!x->val.array->data) return state->udf; return x->val.array->data[rand() % x->val.array->length]; } value_t *verb_roll(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) { size_t k = fabs(x->val.number); size_t d = fabs(y->val.number); list_t *r = list_newk(k); for (size_t i = 0; i < k; i++) r->data[i] = value_new_number(rand() % d); return value_new_array(r); } return state->udf; } value_t *verb_type(interpreter_t *state, verb_t *self, value_t *x) { return NUMS[x->tag]; } value_t *verb_cast(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER) { int t = fabs(x->val.number); if (y->tag == t) return y; switch (t) { case ARRAY: if (y->tag == SYMBOL) { char *s = y->val.symbol; size_t z = strlen(s); list_t *r = list_newk(z); for (size_t i = 0; i < z; i++) r->data[i] = CHARS[(int)s[i]]; return value_new_array(r); } break; case NUMBER: if (y->tag == CHAR) return value_new_number(y->val._char); else if (y->tag == ARRAY && y->val.array->data && is_char_array(y->val.array)) { buffer_t *buf = buffer_new(); for (size_t i = 0; i < y->val.array->length; i++) buffer_append(buf, ((value_t *)y->val.array->data[i])->val._char); char *s = buffer_read(buf); double r = strtod(s, NULL); GC_FREE(s); return value_new_number(r); } break; case CHAR: if (y->tag == NUMBER) return value_new_char(y->val.number); break; } } return state->udf; } value_t *verb_print(interpreter_t *state, verb_t *self, value_t *x) { char *s = value_str(x); fprintf(stdout, "%s", s); GC_FREE(s); return state->nil; } value_t *verb_println(interpreter_t *state, verb_t *self, value_t *x) { char *s = value_str(x); fprintf(stdout, "%s\n", s); GC_FREE(s); return state->nil; } value_t *verb_putch(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != CHAR) return state->udf; fputc(x->val._char, stdout); return state->nil; } value_t *verb_exit(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != NUMBER) return state->udf; int code = x->val.number; exit(code); return state->nil; } value_t *verb_read(interpreter_t *state, verb_t *self, value_t *x) { if (x == NUMS[0]) { buffer_t *buf = buffer_new(); size_t size = 0; for (;;) { int c = fgetc(stdin); if (c < 0) break; buffer_append(buf, c); size++; } char *s = buffer_read(buf); list_t *r = list_newk(size); for (size_t i = 0; i < size; i++) r->data[i] = CHARS[(int)s[i]]; GC_FREE(s); return value_new_array(r); } else if (x == NUMS[1]) return value_new_char((unsigned char)fgetc(stdin)); else if (x == NUMS[2]) { char line[512]; if (!fgets(line, sizeof(line), stdin)) return state->udf; size_t z = strlen(line); list_t *r = list_newk(z); for (size_t i = 0; i < z; i++) r->data[i] = CHARS[(int)line[i]]; return value_new_array(r); } char *path = value_str(x); FILE *fd = fopen(path, "rb"); if (!fd) { GC_FREE(path); return state->udf; } fseek(fd, 0, SEEK_END); size_t size = ftell(fd); fseek(fd, 0, SEEK_SET); unsigned char *buf = malloc_checked(size + 1); size = fread(buf, sizeof(unsigned char), size, fd); fclose(fd); GC_FREE(path); list_t *r = list_newk(size); for (size_t i = 0; i < size; i++) r->data[i] = CHARS[buf[i]]; GC_FREE(buf); return value_new_array(r); } value_t *verb_write(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { FILE *fd; char *path = NULL; if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); if (y == NUMS[0]) fd = stderr; else { path = value_str(y); fd = fopen(path, "wb"); if (!fd) { GC_FREE(path); return NNUMS[0]; } } size_t k = 0; for (size_t i = 0; i < x->val.array->length; i++) { unsigned char c; value_t *v = x->val.array->data[i]; if (v->tag == NUMBER) c = fabs(v->val.number); else if (v->tag == CHAR) c = v->val._char; else break; fputc(c, fd); k++; } fclose(fd); if (path) GC_FREE(path); return value_new_number(k); } value_t *verb_system(interpreter_t *state, verb_t *self, value_t *x) { char *cmd = value_str(x); FILE *pd; pd = popen(cmd, "r"); if (!pd) { GC_FREE(cmd); return state->udf; } unsigned char *buffer = NULL; size_t buffer_size = 0; size_t buffer_allocated = 0; size_t bytes_received; unsigned char chunk[1024]; for (;;) { bytes_received = fread(chunk, 1, 1024, pd); if (bytes_received == 0) break; size_t head = buffer_size; buffer_size += bytes_received; if (buffer_size > buffer_allocated) { buffer_allocated = buffer_size; buffer = realloc_checked(buffer, buffer_allocated); } for (size_t i = 0; i < bytes_received; i++) buffer[head + i] = chunk[i]; if (feof(pd)) break; } pclose(pd); GC_FREE(cmd); list_t *r = list_newk(buffer_size); for (size_t i = 0; i < buffer_size; i++) r->data[i] = CHARS[buffer[i]]; GC_FREE(buffer); return value_new_array(r); } struct files_t { FILE *in; FILE *out; }; typedef struct files_t files_t; struct files_chain_t { files_t files; pid_t pid; struct files_chain_t *next; }; typedef struct files_chain_t files_chain_t; static files_chain_t *files_chain; void _cleanup_pipe(int *pipe) { close(pipe[0]); close(pipe[1]); } static int _do_popen2(files_chain_t *link, const char *command) { int child_in[2]; int child_out[2]; if (0 != pipe(child_in)) return -1; if (0 != pipe(child_out)) { _cleanup_pipe(child_in); return -1; } pid_t cpid = link->pid = fork(); if (0 > cpid) { _cleanup_pipe(child_in); _cleanup_pipe(child_out); return -1; } if (0 == cpid) { if (0 > dup2(child_in[0], 0) || 0 > dup2(child_out[1], 1)) _Exit(127); _cleanup_pipe(child_in); _cleanup_pipe(child_out); for (files_chain_t *p = files_chain; p; p = p->next) { int fd_in = fileno(p->files.in); if (fd_in != 0) close(fd_in); int fd_out = fileno(p->files.out); if (fd_out != 1) close(fd_out); } execl("/bin/sh", "sh", "-c", command, (char *)NULL); _Exit(127); } close(child_in[0]); close(child_out[1]); link->files.in = fdopen(child_in[1], "w"); link->files.out = fdopen(child_out[0], "r"); return 0; } files_t *popen2(const char *command) { files_chain_t *link = (files_chain_t *)malloc(sizeof(files_chain_t)); if (NULL == link) return NULL; if (0 > _do_popen2(link, command)) { free(link); return NULL; } link->next = files_chain; files_chain = link; return (files_t *)link; } int pclose2(files_t *fp) { files_chain_t **p = &files_chain; int found = 0; while (*p) { if (*p == (files_chain_t *)fp) { *p = (*p)->next; found = 1; break; } p = &(*p)->next; } if (!found) return -1; if (0 > fclose(fp->out)) { free((files_chain_t *)fp); return -1; } int status = -1; pid_t wait_pid; do { wait_pid = waitpid(((files_chain_t *)fp)->pid, &status, 0); } while (-1 == wait_pid && EINTR == errno); free((files_chain_t *)fp); if (wait_pid == -1) return -1; return status; } value_t *verb_system2(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { char *cmd = value_str(y); files_t *pd; pd = popen2(cmd); if (pd == NULL) { GC_FREE(cmd); return state->udf; } for (size_t i = 0; i < x->val.array->length; i++) { unsigned char c; value_t *v = x->val.array->data[i]; if (v->tag == NUMBER) c = fabs(v->val.number); else if (v->tag == CHAR) c = v->val._char; else break; fputc(c, pd->in); } fflush(pd->in); fclose(pd->in); unsigned char *buffer = NULL; size_t buffer_size = 0; size_t buffer_allocated = 0; size_t bytes_received; unsigned char chunk[1024]; for (;;) { bytes_received = fread(chunk, 1, 1024, pd->out); if (bytes_received == 0) break; size_t head = buffer_size; buffer_size += bytes_received; if (buffer_size > buffer_allocated) { buffer_allocated = buffer_size; buffer = realloc_checked(buffer, buffer_allocated); } for (size_t i = 0; i < bytes_received; i++) buffer[head + i] = chunk[i]; if (feof(pd->out)) break; } pclose2(pd); GC_FREE(cmd); list_t *r = list_newk(buffer_size); for (size_t i = 0; i < buffer_size; i++) r->data[i] = CHARS[buffer[i]]; GC_FREE(buffer); return value_new_array(r); } value_t *verb_shl(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(((int)x->val.number) << ((int)y->val.number)); return _NAN; } value_t *verb_shr(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(((int)x->val.number) >> ((int)y->val.number)); return _NAN; } value_t *verb_xor(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(((int)x->val.number) ^ ((int)y->val.number)); return _NAN; } value_t *verb_band(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(((int)x->val.number) & ((int)y->val.number)); return _NAN; } list_t *find_primes(uint64_t limit) { bool sieve[limit + 1]; for (uint64_t i = 0; i <= limit; i++) sieve[i] = false; if (limit > 2) sieve[2] = true; if (limit > 3) sieve[3] = true; for (uint64_t x = 1; x * x <= limit; x++) for (uint64_t y = 1; y * y <= limit; y++) { uint64_t n = (4 * x * x) + (y * y); if (n <= limit && (n % 12 == 1 || n % 12 == 5)) sieve[n] ^= true; n = (3 * x * x) + (y * y); if (n <= limit && n % 12 == 7) sieve[n] ^= true; n = (3 * x * x) - (y * y); if (x > y && n <= limit && n % 12 == 11) sieve[n] ^= true; } for (uint64_t r = 5; r * r <= limit; r++) if (sieve[r]) for (int i = r * r; i <= limit; i += r * r) sieve[i] = false; list_t *r = list_new(); for (uint64_t a = 1; a <= limit; a++) if (sieve[a]) list_push(r, value_new_number(a)); return r; } value_t *verb_primes(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER && !is_bad_num(x->val.number)) return value_new_array(find_primes(fabs(x->val.number) + 1)); return state->udf; } value_t *verb_parts(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != NUMBER) return state->udf; if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); else if (!y->val.array->data) return y; if (is_bad_num(x->val.number) || x->val.number < 1) return y; size_t np = fabs(x->val.number); list_t *r = list_newk(np); size_t rp = 0; for (ssize_t i = np; i > 0; i--) { size_t k = ceil(((double)y->val.array->length) / (double)i); r->data[rp++] = verb_take(state, NULL, value_new_number(k), y); y = verb_drop(state, NULL, value_new_number(k), y); } return value_new_array(r); } value_t *verb_bor(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) return value_new_number(((int)x->val.number) | ((int)y->val.number)); return _NAN; } value_t *verb_bnot(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) return value_new_number(~(int)x->val.number); return _NAN; } list_t *prime_factors(double n) { list_t *factors = list_new(); double divisor = 2; while (n >= 2) { if (fmod(n, divisor) == 0) { list_push(factors, value_new_number(divisor)); n /= divisor; } else divisor++; } return factors; } value_t *verb_factors(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER && !is_bad_num(x->val.number)) return value_new_array(prime_factors(x->val.number)); return state->udf; } value_t *verb_combine(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER && !is_bad_num(x->val.number) && !is_bad_num(y->val.number)) { x = verb_base(state, NULL, NUMS[10], x); y = verb_base(state, NULL, NUMS[10], y); value_t *n = verb_join(state, NULL, x, y); return verb_unbase(state, NULL, NUMS[10], n); } return _NAN; } value_t *verb_outof(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER && !is_bad_num(x->val.number) && !is_bad_num(y->val.number)) { uint64_t a = (uint64_t)fabs(x->val.number); uint64_t b = (uint64_t)fabs(y->val.number); if (a == 0) return NUMS[1]; if (b == 0) return NUMS[0]; return value_new_number((double)factorial(b) / (factorial(a) * (a >= b ? 1 : factorial(b - a)))); } return _NAN; } value_t *verb_sort(interpreter_t *state, verb_t *self, value_t *x) { value_t *i = verb_gradeup(state, NULL, x); return together(state, state->at, x, i, 0, 0, state->at->rank[1], state->at->rank[2]); } value_t *verb_unsort(interpreter_t *state, verb_t *self, value_t *x) { value_t *i = verb_gradedown(state, NULL, x); return together(state, state->at, x, i, 0, 0, state->at->rank[1], state->at->rank[2]); } value_t *interpreter_run(interpreter_t *state, char *program); value_t *verb_eval(interpreter_t *state, verb_t *self, value_t *x) { char *s = value_str(x); guard_t *g = guard(); if (setjmp(g->lb)) { unguard(); GC_FREE(s); return state->udf; } value_t *v = interpreter_run(state, s); GC_FREE(s); unguard(); return v; } void jkexec(interpreter_t *state, FILE *fd, bool isrepl, char **s); value_t *verb_import(interpreter_t *state, verb_t *self, value_t *x) { char *path = value_str(x); FILE *fd = fopen(path, "rb"); if (!fd) { GC_FREE(path); return state->udf; } char *s = NULL; jkexec(state, fd, false, &s); if (s) GC_FREE(s); fclose(fd); GC_FREE(path); return state->nil; } value_t *verb_foreign(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); char *pth = value_str(y); char *lib; char *sig; char *fun; lib = strtok(pth, ":"); if (!lib) return state->udf; sig = strtok(NULL, ":"); if (!sig) return state->udf; fun = strtok(NULL, ":"); if (!fun) return state->udf; size_t argc = strlen(sig); if (argc < 1) return state->udf; argc--; if (argc != x->val.array->length) return state->udf; ffi_cif cif; ffi_type *ret; ffi_type *args[argc]; void *values[argc]; void *pool[argc]; size_t fc = 0; void *retv = NULL; char rett; size_t retvsz = 0; for (int i = 0; i < strlen(sig); i++) { ffi_type *t; void *v; switch (sig[i]) { case '$': t = &ffi_type_pointer; break; case 'p': t = &ffi_type_pointer; break; case 'v': if (i != 0) goto cleanup; t = &ffi_type_void; break; case 'i': t = &ffi_type_sint; break; case 'l': t = &ffi_type_slong; break; case 'f': t = &ffi_type_float; break; case 'd': t = &ffi_type_double; break; case 'c': t = &ffi_type_uchar; break; default: goto cleanup; } if (i == 0) { rett = sig[0]; ret = t; switch (rett) { case '$': case '@': retvsz = sizeof(char *); break; case 'p': retvsz = sizeof(void *); break; case 'v': retvsz = 0; break; case 'i': retvsz = sizeof(int); break; case 'l': retvsz = sizeof(long); break; case 'f': retvsz = sizeof(float); break; case 'd': retvsz = sizeof(double); break; case 'c': retvsz = sizeof(unsigned char); break; } } else { switch (sig[i]) { case '$': case '@': { value_t *vt = x->val.array->data[i - 1]; pool[i - 1] = value_str(vt); v = pool[i - 1]; fc++; } break; case 'p': { void *_pv; value_t *vt = x->val.array->data[i - 1]; if (vt->tag != NUMBER) goto cleanup; _pv = (void *)(size_t)fabs(vt->val.number); pool[i - 1] = malloc_checked(sizeof(void *)); memcpy(pool[i - 1], &_pv, sizeof(void *)); v = pool[i - 1]; fc++; } break; case 'i': { int _iv; value_t *vt = x->val.array->data[i - 1]; if (vt->tag != NUMBER) goto cleanup; _iv = (int)vt->val.number; pool[i - 1] = malloc_checked(sizeof(int)); memcpy(pool[i - 1], &_iv, sizeof(int)); v = pool[i - 1]; fc++; } break; case 'l': { long _lv; value_t *_vt = x->val.array->data[i - 1]; if (_vt->tag != NUMBER) goto cleanup; _lv = (long)_vt->val.number; pool[i - 1] = malloc_checked(sizeof(long)); memcpy(pool[i - 1], &_lv, sizeof(long)); v = pool[i - 1]; fc++; } break; case 'f': { float _fv; value_t *_vt = x->val.array->data[i - 1]; if (_vt->tag != NUMBER) goto cleanup; _fv = (float)_vt->val.number; pool[i - 1] = malloc_checked(sizeof(float)); memcpy(pool[i - 1], &_fv, sizeof(float)); v = pool[i - 1]; fc++; } break; case 'd': { double _dv; value_t *_vt = x->val.array->data[i - 1]; if (_vt->tag != NUMBER) goto cleanup; _dv = (double)_vt->val.number; pool[i - 1] = malloc_checked(sizeof(double)); memcpy(pool[i - 1], &_dv, sizeof(double)); v = pool[i - 1]; fc++; } break; case 'c': { unsigned char _cv; value_t *_vt = x->val.array->data[i - 1]; if (_vt->tag != CHAR) goto cleanup; _cv = (unsigned char)_vt->val._char; pool[i - 1] = malloc_checked(sizeof(unsigned char)); memcpy(pool[i - 1], &_cv, sizeof(unsigned char)); v = pool[i - 1]; fc++; } break; } args[i - 1] = t; values[i - 1] = v; } } void *dlh = dlopen(lib, RTLD_LAZY); if (!dlh) goto cleanup; void *exfn = dlsym(dlh, fun); char *e = dlerror(); if (!exfn || e) goto cleanup; if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, argc, ret, args) != FFI_OK) goto cleanup; if (retvsz) retv = malloc_checked(retvsz); ffi_call(&cif, exfn, retv, values); dlclose(dlh); value_t *rv = state->nil; switch (rett) { case 'v': break; case '$': { char *s = *(char **)retv; size_t z = strlen(s); list_t *l = list_newk(z); for (size_t i = 0; i < z; i++) l->data[i] = CHARS[(int)s[i]]; rv = value_new_array(l); } break; case '@': { char *s = *(char **)retv; size_t z = strlen(s); list_t *l = list_newk(z); for (size_t i = 0; i < z; i++) l->data[i] = CHARS[(int)s[i]]; rv = value_new_array(l); free(s); } break; case 'p': rv = value_new_number((size_t)*(void **)retv); break; case 'i': rv = value_new_number(*(int *)retv); break; case 'l': rv = value_new_number(*(long *)retv); break; case 'f': rv = value_new_number(*(float *)retv); break; case 'd': rv = value_new_number(*(double *)retv); break; case 'c': rv = value_new_char(*(unsigned char *)retv); break; } GC_FREE(retv); for (size_t i = 0; i < fc; i++) GC_FREE(pool[i]); return rv; cleanup: for (size_t i = 0; i < fc; i++) GC_FREE(pool[i]); return state->udf; } value_t *verb_explode(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { char *del = value_show(x); char *s = value_str(y); size_t dell = strlen(del); size_t sl = strlen(s); list_t *r = list_new(); list_t *t = list_new(); for (size_t i = 0; i < sl; i++) { if (strncmp(&s[i], del, dell) == 0) { list_push(r, value_new_array(t)); t = list_new(); i += dell - 1; continue; } list_push(t, CHARS[(int)s[i]]); } GC_FREE(s); GC_FREE(del); list_push(r, value_new_array(t)); return value_new_array(r); } value_t *verb_implode(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY || !y->val.array->data) return y; char *del = value_show(x); list_t *r = list_new(); for (size_t i = 0; i < y->val.array->length; i++) { char *s = value_show(y->val.array->data[i]); char *_s = s; while (*_s) list_push(r, CHARS[(int)(*_s++)]); GC_FREE(s); if (i != y->val.array->length - 1) { char *s = del; while (*s) list_push(r, CHARS[(int)(*s++)]); } } GC_FREE(del); return value_new_array(r); } value_t *verb_tackleft(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); list_t *r = list_newk(y->val.array->length + 1); r->data[0] = x; for (size_t i = 0; i < y->val.array->length; i++) r->data[i + 1] = y->val.array->data[i]; return value_new_array(r); } value_t *verb_setrecdepth(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != NUMBER) return state->udf; size_t ov = max_rec_depth; size_t v = (size_t)fabs(x->val.number); if (v < 1) v = 1; max_rec_depth = v; return value_new_number(ov); } value_t *verb_tackright(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); list_t *r = list_newk(y->val.array->length + 1); for (size_t i = 0; i < y->val.array->length; i++) r->data[i] = y->val.array->data[i]; r->data[y->val.array->length] = x; return value_new_array(r); } value_t *verb_eye(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER && !is_bad_num(x->val.number)) { size_t k = fabs(x->val.number); list_t *r = list_newk(k); for (size_t i = 0; i < k; i++) { list_t *rw = list_newk(k); for (size_t j = 0; j < k; j++) rw->data[j] = NUMS[i == j]; r->data[i] = value_new_array(rw); } return value_new_array(r); } return state->udf; } value_t *verb_infix(interpreter_t *state, verb_t *self, value_t *x) { return verb_behead(state, NULL, verb_prefixes(state, NULL, x)); } value_t *verb_value(interpreter_t *state, verb_t *self, value_t *x) { char *s = value_str(x); value_t *r = table_get(state->env, s); GC_FREE(s); return r ? r : state->udf; } value_t *verb_hex(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag == NUMBER) { char buf[64]; snprintf(buf, sizeof(buf), "%lx", (long)x->val.number); list_t *r = list_new(); for (size_t i = 0; i < strlen(buf); i++) list_push(r, value_new_char(buf[i])); return value_new_array(r); } return state->udf; } value_t *verb_lines(interpreter_t *state, verb_t *self, value_t *x) { char *s = value_str(x); size_t sl = strlen(s); list_t *r = list_new(); list_t *t = list_new(); for (size_t i = 0; i < sl; i++) { if (s[i] == '\n') { list_push(r, value_new_array(t)); t = list_new(); continue; } list_push(t, CHARS[(int)s[i]]); } GC_FREE(s); list_push(r, value_new_array(t)); return value_new_array(r); } list_t *list_delete(list_t *l, ssize_t index) { size_t z = l->length; if (index < 0) index += ((ssize_t)z); if (index < 0 || index >= z) return l; list_t *r = list_newk(z - 1); size_t ri = 0; for (size_t i = 0; i < z; i++) if (i == index) continue; else r->data[ri++] = l->data[i]; return r; } value_t *verb_delete(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != NUMBER) return state->udf; if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); else if (!y->val.array->data) return y; return value_new_array(list_delete(y->val.array, trunc(x->val.number))); } value_t *verb_deleteInplace(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != NUMBER) return state->udf; if (y->tag != ARRAY) return state->udf; else if (!y->val.array->data) return y; y->val.array = list_delete(y->val.array, trunc(x->val.number)); return y; } value_t *verb_rematch(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { char *pat = value_str(x); char *s = value_str(y); pcre *re; const char *e; int eo; if (!(re = pcre_compile(pat, 0, &e, &eo, NULL))) goto fail; int rc = pcre_exec(re, NULL, s, strlen(s), 0, 0, NULL, 0); pcre_free(re); GC_FREE(pat); GC_FREE(s); return NUMS[rc >= 0]; fail: GC_FREE(pat); GC_FREE(s); return state->udf; } value_t *verb_show(interpreter_t *state, verb_t *self, value_t *x) { char *s = value_str(x); list_t *r = list_new(); for (size_t i = 0; i < strlen(s); i++) list_push(r, value_new_char(s[i])); GC_FREE(s); return value_new_array(r); } value_t *verb_extract(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { char *pat = value_str(x); char *s = value_str(y); size_t len = strlen(s); pcre *re; const char *e; int eo; if (!(re = pcre_compile(pat, 0, &e, &eo, NULL))) goto fail; int ov[128 * 3]; int rc; list_t *r = list_new(); unsigned int of = 0; while (of < len && (rc = pcre_exec(re, 0, s, len, of, 0, ov, sizeof(ov))) >= 0) { if (rc == 0) rc = sizeof(ov) / 3; for (int i = 1; i < rc; i++) { char *ss = s + ov[2 * i]; int sl = ov[2 * i + 1] - ov[2 * i]; if (sl == 0) { list_push(r, _UNIT); continue; } list_t *l = list_newk(sl); for (int j = 0; j < sl; j++) l->data[j] = CHARS[(int)ss[j]]; list_push(r, value_new_array(l)); } of = ov[1]; } pcre_free(re); GC_FREE(pat); GC_FREE(s); return value_new_array(r); fail: GC_FREE(pat); GC_FREE(s); return state->udf; } value_t *verb_udf1(interpreter_t *state, verb_t *self, value_t *x) { return state->udf; } value_t *verb_udf2(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return state->udf; } #define X UINT_MAX #define DEFVERB(__symb, __rm, __rl, __rr, __monad, __dyad) \ {__symb, {__rm, __rl, __rr}, NULL, false, false, verb_##__monad, verb_##__dyad} #define DEFVERBD(__symb, __rm, __rl, __rr, __monad, __dyad) \ {__symb ".", {__rm, __rl, __rr}, NULL, false, false, verb_##__monad, verb_##__dyad} #define DEFVERBC(__symb, __rm, __rl, __rr, __monad, __dyad) \ {__symb ":", {__rm, __rl, __rr}, NULL, false, false, verb_##__monad, verb_##__dyad} verb_t VERBS[] = {DEFVERB(":", 0, 0, 0, const, bind), DEFVERBC(":", X, 0, 0, unbind, obverse), DEFVERB("+", 0, X, X, flip, plus), DEFVERBD("+", X, X, X, fibonacci, gcd), DEFVERBC("+", X, X, X, sin, combine), DEFVERB("-", X, X, X, negate, minus), DEFVERBD("-", X, X, X, atan, atan2), DEFVERB("*", 0, X, X, first, times), DEFVERBD("*", X, X, X, factorial, lcm), DEFVERBC("*", X, X, 0, double, replicate), DEFVERB("%", X, X, X, reciprocal, divide), DEFVERBD("%", X, X, X, sqrt, root), DEFVERBC("%", X, X, X, halve, idivide), DEFVERB("!", X, X, X, enum, mod), DEFVERBD("!", X, X, X, iota, range), DEFVERBC("!", 0, X, 0, odometer, chunks), DEFVERB("^", X, X, X, exp, power), DEFVERBD("^", X, X, X, nlog, log), DEFVERB("=", 0, X, X, permute, equals), DEFVERBD("=", 0, 0, 0, occurences, mask), DEFVERBC("=", 0, 0, 0, classify, equals), DEFVERB("~", X, X, X, not, not_equals), DEFVERBD("~", X, 0, 0, sign, insert), DEFVERBC("~", 0, 0, 0, not, not_equals), DEFVERB("<", X, X, X, pred, less), DEFVERBD("<", X, X, X, floor, lesseq), DEFVERBC("<", 0, X, 0, gradedown, nudge_left), DEFVERB(">", X, X, X, succ, greater), DEFVERBD(">", X, X, X, ceil, greatereq), DEFVERBC(">", 0, X, 0, gradeup, nudge_right), DEFVERB(",", 0, 0, 0, enlist, join), DEFVERBD(",", X, 0, 0, enlist, enpair), DEFVERB("#", 0, X, 0, count, take), DEFVERBD("#", 0, 0, 0, where, copy), DEFVERBC("#", 0, 0, 0, group, buckets), DEFVERB("_", 0, X, 0, nub, drop), DEFVERBD("_", 0, X, 0, unbits, unbase), DEFVERBC("_", X, X, X, bits, base), DEFVERB("?", 0, 0, 0, unique, find), DEFVERB("&", 0, X, X, flatten, minand), DEFVERB("|", 0, X, X, reverse, maxor), DEFVERBD("|", X, X, 0, round, rotate), DEFVERBC("|", 0, X, 0, depth, windows), DEFVERB("@", X, 0, X, abs, at), DEFVERBD("@", 0, 0, 0, shuffle, member), DEFVERBC("@", 0, 0, 0, infix, indexof), DEFVERB("{", 0, 0, 0, head, bin), DEFVERBD("{", 0, 0, 0, tail, cut), DEFVERBC("{", 0, X, X, prefixes, shl), DEFVERB("}", 0, X, X, behead, xor), DEFVERBD("}", 0, 0, 0, curtail, band), DEFVERBC("}", 0, X, X, suffixes, shr), DEFVERB("[", X, 0, 0, factors, left), DEFVERBD("[", X, X, X, bnot, bor), DEFVERBC("[", X, X, 0, primes, parts), DEFVERB("]", 0, 0, 0, same, right), DEFVERBD("]", 0, X, X, sort, outof), DEFVERBC("]", 0, 0, 0, unsort, explode), DEFVERBD("`", 0, 0, 0, symbol, apply1), DEFVERBC("`", 0, 0, 0, square, apply2), DEFVERB("$", 0, 0, 0, shape, reshape), DEFVERBD("$", 0, 0, 0, repr, format), DEFVERBC("$", X, 0, 0, eye, implode), DEFVERBD("d", 0, X, 0, udf1, delete), DEFVERBD("D", 0, X, 0, udf1, deleteInplace), DEFVERBD("p", 0, 0, 0, print, udf2), DEFVERBD("P", 0, 0, 0, println, udf2), DEFVERBD("c", X, 0, 0, putch, udf2), DEFVERBD("s", 0, 0, 0, selfref1, selfref2), DEFVERBD("F", 0, 0, 0, read, write), DEFVERBD("r", 0, X, X, deal, roll), DEFVERBD("t", 0, 0, 0, type, cast), DEFVERBD("E", 0, 0, 0, exit, udf2), DEFVERBD("y", 0, 0, 0, system, system2), DEFVERBD("e", 0, 0, 0, eval, udf2), DEFVERBD("i", 0, 0, 0, import, foreign), DEFVERBD("L", 0, 0, 0, lines, tackleft), DEFVERBD("R", X, 0, 0, setrecdepth, tackright), DEFVERBD("v", 0, 0, 0, value, udf2), DEFVERBD("h", X, 0, 0, hex, udf2), DEFVERBD("x", 0, 0, 0, show, rematch), DEFVERBD("X", 0, 0, 0, udf1, extract)}; value_t *_adverb_fold_monad(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || !x->val.array->data) return x; value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; value_t *t = x->val.array->data[0]; list_t *tx = x->val.array; for (size_t i = 1; i < tx->length; i++) t = together(state, v, t, tx->data[i], 0, 0, v->rank[1], v->rank[2]); return t; } value_t *_adverb_fold_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); else if (!y->val.array->data) return x; value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; value_t *t = x; list_t *ty = y->val.array; for (size_t i = 0; i < ty->length; i++) t = together(state, v, t, ty->data[i], 0, 0, v->rank[1], v->rank[2]); return t; } value_t *_adverb_scan_monad(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || !x->val.array->data) return x; value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; list_t *r = list_new(); value_t *t = x->val.array->data[0]; list_t *tx = x->val.array; list_push(r, t); for (size_t i = 1; i < tx->length; i++) { t = together(state, v, t, tx->data[i], 0, 0, v->rank[1], v->rank[2]); list_push(r, t); } return value_new_array(r); } value_t *_adverb_scan_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY || !y->val.array->data) return y; value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; list_t *r = list_new(); value_t *t = x; list_t *ty = y->val.array; list_push(r, t); for (size_t i = 1; i < ty->length; i++) { t = together(state, v, t, ty->data[i], 0, 0, v->rank[1], v->rank[2]); list_push(r, t); } return value_new_array(r); } value_t *_adverb_each_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; if (x->tag != ARRAY) return each_rank(state, v, x, 0, 1); if (!x->val.array->data) return x; return each_rank(state, v, x, 0, 1); } value_t *_adverb_each_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); list_t *r = list_new(); list_t *tx = x->val.array; list_t *ty = y->val.array; for (size_t i = 0; i < tx->length && i < ty->length; i++) list_push(r, together(state, v, tx->data[i], ty->data[i], 0, 0, v->rank[1], v->rank[2])); return value_new_array(r); } value_t *_adverb_converge_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; value_t *t; for (;;) { t = x; x = each_rank(state, v, x, 0, v->rank[0]); if (value_equals(x, t)) break; } return x; } verb_t *conjunction_bond(interpreter_t *state, value_t *x, value_t *y); value_t *_adverb_converge_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; if (y->tag != ARRAY) return together(state, v, y, x, 0, 0, v->rank[1], v->rank[2]); if (!y->val.array->data) return x; v = conjunction_bond(state, value_new_verb(v), x); return each_rank(state, v, y, 0, 1); } value_t *_adverb_converges_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; list_t *r = list_new(); value_t *t; list_push(r, x); for (;;) { t = x; x = apply_monad(state, _v, x); if (value_equals(x, t)) break; list_push(r, x); } return value_new_array(r); } value_t *_adverb_converges_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; if (y->tag != ARRAY) return together(state, v, y, x, 0, 0, v->rank[1], v->rank[2]); if (!y->val.array->data) return x; v = conjunction_bond(state, x, value_new_verb(v)); return each_rank(state, v, y, 0, 1); } value_t *_adverb_eachprior_monad(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || x->val.array->length < 2) return x; value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; list_t *r = list_new(); for (size_t i = 1; i < x->val.array->length; i++) list_push(r, together(state, v, x->val.array->data[i], x->val.array->data[i - 1], 0, 0, v->rank[1], v->rank[2])); return value_new_array(r); } value_t *_adverb_eachprior_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY || !y->val.array->data) return y; value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; list_t *r = list_new(); for (size_t i = 0; i < y->val.array->length; i++) list_push(r, together(state, v, y->val.array->data[i], i == 0 ? x : y->val.array->data[i - 1], 0, 0, v->rank[1], v->rank[2])); return value_new_array(r); } value_t *_adverb_reflex_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; return together(state, v, x, x, 0, 0, v->rank[1], v->rank[2]); } value_t *_adverb_reflex_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; return together(state, v, y, x, 0, 0, v->rank[1], v->rank[2]); } value_t *_adverb_amend_monad(interpreter_t *state, verb_t *self, value_t *x) { return state->udf; } value_t *_adverb_amend_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); value_t *v = self->bonds->data[0]; if (v->tag != ARRAY && v->tag != VERB) v = verb_enlist(state, NULL, v); if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); list_t *r = list_copy(y->val.array); size_t l = x->val.array->length; if (v->tag == VERB) { list_t *t = x->val.array; for (size_t i = 0; i < t->length; i++) { value_t *n = t->data[i]; if (n->tag != NUMBER) break; value_t *e = list_index(r, n->val.number); if (!e) continue; list_set(r, n->val.number, apply_monad(state, v, e)); } } else { list_t *t = v->val.array; for (size_t i = 0; i < t->length; i++) { value_t *n = t->data[i]; if (n->tag != NUMBER) break; list_set(r, n->val.number, list_index(x->val.array, i < l ? i : l - 1)); } } return value_new_array(r); } value_t *_adverb_filter_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return x; verb_t *v = _v->val.verb; list_t *r = list_new(); for (size_t i = 0; i < x->val.array->length; i++) { value_t *b = each_rank(state, v, x->val.array->data[i], 0, v->rank[0]); if (value_is_truthy(b)) list_push(r, x->val.array->data[i]); } return value_new_array(r); } value_t *_adverb_filter_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return state->udf; } value_t *_adverb_span_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v = self->bonds->data[0]; if (v->tag != VERB) return state->udf; if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (!x->val.array->data) return x; list_t *r = list_new(); list_t *p = list_new(); for (size_t i = 0; i < x->val.array->length; i++) { value_t *b = apply_monad(state, v, x->val.array->data[i]); if (value_is_truthy(b)) { list_push(r, value_new_array(p)); p = list_new(); } else list_push(p, x->val.array->data[i]); } list_push(r, value_new_array(p)); return value_new_array(r); } value_t *_adverb_span_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; value_t *r = verb_windows(state, NULL, x, y); return each_rank(state, v, r, 0, 1); } value_t *_adverb_inverse_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; verb_t *iv = table_get(Inverses, v->name); if (!iv) return state->udf; return each_rank(state, iv, x, 0, iv->rank[0]); } value_t *_adverb_inverse_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *_v = self->bonds->data[0]; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; verb_t *iv = table_get(Inverses, v->name); if (!iv) return state->udf; value_t *a = each_rank(state, iv, x, 0, iv->rank[0]); value_t *b = each_rank(state, iv, y, 0, iv->rank[0]); return apply_dyad(state, _v, a, b); } #define ADVERB(__name, __symb) \ verb_t *adverb_##__name(interpreter_t *state, value_t *v) \ { \ verb_t *nv = verb_new(); \ nv->bonds = list_newk(1); \ nv->bonds->data[0] = v; \ char *r = value_show(v); \ size_t l = strlen(r) + strlen(__symb) + 1; \ nv->name = malloc_checked_atomic(l); \ snprintf(nv->name, l, "%s" __symb, r); \ GC_FREE(r); \ nv->rank[0] = 0; \ nv->monad = _adverb_##__name##_monad; \ nv->dyad = _adverb_##__name##_dyad; \ return nv; \ } ADVERB(fold, "/"); ADVERB(converge, "/."); ADVERB(scan, "\\"); ADVERB(converges, "\\."); ADVERB(each, "\""); ADVERB(eachprior, "\"."); ADVERB(reflex, ";."); ADVERB(amend, "`"); ADVERB(filter, "&."); ADVERB(span, "/:"); ADVERB(inverse, "-:"); adverb_t ADVERBS[] = { {"/", adverb_fold, NULL}, {"/.", adverb_converge, NULL}, {"\\", adverb_scan, NULL}, {"\\.", adverb_converges, NULL}, {"\"", adverb_each, NULL}, {"\".", adverb_eachprior, NULL}, {";.", adverb_reflex, NULL}, {"`", adverb_amend, NULL}, {"&.", adverb_filter, NULL}, {"/:", adverb_span, NULL}, {"-:", adverb_inverse, NULL}}; value_t *_conjunction_bond_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag == VERB && v2->tag == VERB) return apply_monad(state, v1, apply_monad(state, v2, x)); else if (v1->tag == VERB) return apply_dyad(state, v1, x, v2); else if (v2->tag == VERB) return apply_dyad(state, v2, v1, x); else return state->udf; } value_t *_conjunction_bond_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag == VERB && v2->tag == VERB) return apply_monad(state, v1, apply_dyad(state, v2, x, y)); else if (v1->tag == VERB) return apply_dyad(state, v1, apply_dyad(state, v1, x, y), v2); else if (v2->tag == VERB) return apply_dyad(state, v2, v1, apply_dyad(state, v2, x, y)); else return state->udf; } value_t *_conjunction_pick_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag != VERB || v2->tag != ARRAY) return state->udf; value_t *n = apply_monad(state, v1, x); value_t *f = verb_at(state, NULL, v2, n); return apply_monad(state, f, x); } value_t *_conjunction_pick_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag != VERB || v2->tag != ARRAY) return state->udf; value_t *n = apply_dyad(state, v1, x, y); value_t *f = verb_at(state, NULL, v2, n); return apply_dyad(state, f, x, y); } value_t *_conjunction_while_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag == VERB) { for (;;) { if (!value_is_truthy(apply_monad(state, v1, x))) break; x = apply_monad(state, v2, x); } } else if (v1->tag == NUMBER) { size_t k = (size_t)fabs(v1->val.number); for (size_t i = 0; i < k; i++) x = apply_monad(state, v2, x); } return x; } value_t *_conjunction_while_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag == VERB) { for (;;) { if (!value_is_truthy(apply_dyad(state, v1, x, y))) break; x = apply_dyad(state, v2, x, y); } } else if (v1->tag == NUMBER) { size_t k = (size_t)fabs(v1->val.number); for (size_t i = 0; i < k; i++) x = apply_dyad(state, v2, x, y); } return x; } value_t *_conjunction_rank_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag != VERB || v2->tag != NUMBER) return state->udf; unsigned int rank = v2->val.number == INFINITY ? UINT_MAX : fabs(v2->val.number); return each_rank(state, v1->val.verb, x, 0, rank); } value_t *_conjunction_rank_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag != VERB) return state->udf; unsigned int rl; unsigned int rr; if (v2->tag == NUMBER) rl = rr = v2->val.number == INFINITY ? UINT_MAX : fabs(v2->val.number); else if (v2->tag == ARRAY && v2->val.array->length == 2) { value_t *a = v2->val.array->data[0]; value_t *b = v2->val.array->data[1]; if (a->tag != NUMBER) return state->udf; rl = a->val.number == INFINITY ? UINT_MAX : fabs(a->val.number); if (b->tag != NUMBER) return state->udf; rr = b->val.number == INFINITY ? UINT_MAX : fabs(b->val.number); } else return state->udf; return together(state, v1->val.verb, x, y, 0, 0, rl, rr); } value_t *_conjunction_monaddyad_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v = self->bonds->data[0]; if (v->tag != VERB) return state->udf; return each_rank(state, v->val.verb, x, 0, v->val.verb->rank[0]); } value_t *_conjunction_monaddyad_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v = self->bonds->data[1]; if (v->tag != VERB) return state->udf; return together(state, v->val.verb, x, y, 0, 0, v->val.verb->rank[1], v->val.verb->rank[2]); } value_t *_conjunction_if_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag != VERB || v2->tag != VERB) return state->udf; value_t *b = apply_monad(state, v2, x); if (value_is_truthy(b)) return x; return apply_monad(state, v1, x); } value_t *_conjunction_if_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag != VERB || v2->tag != VERB) return state->udf; value_t *b = apply_dyad(state, v2, x, y); if (value_is_truthy(b)) return y; return apply_dyad(state, v1, x, y); } value_t *_conjunction_under_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag != VERB || v2->tag != VERB) return state->udf; verb_t *iv = table_get(Inverses, v2->val.verb->name); if (!iv) return state->udf; value_t *v = apply_monad(state, v2, x); v = apply_monad(state, v1, v); return each_rank(state, iv, v, 0, iv->rank[0]); } value_t *_conjunction_under_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; if (v1->tag != VERB || v2->tag != VERB) return state->udf; verb_t *iv = table_get(Inverses, v2->val.verb->name); if (!iv) return state->udf; value_t *a = apply_monad(state, v2, x); value_t *b = apply_monad(state, v2, y); value_t *v = apply_dyad(state, v1, a, b); return each_rank(state, iv, v, 0, iv->rank[0]); } value_t *_conjunction_collect_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; list_t *r = list_new(); if (v1->tag == VERB) { for (;;) { if (!value_is_truthy(apply_monad(state, v1, x))) break; list_push(r, x); x = apply_monad(state, v2, x); } } else if (v1->tag == NUMBER) { size_t k = (size_t)fabs(v1->val.number); for (size_t i = 0; i < k; i++) { list_push(r, x); x = apply_monad(state, v2, x); } } return value_new_array(r); } value_t *_conjunction_collect_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v1 = self->bonds->data[0]; value_t *v2 = self->bonds->data[1]; list_t *r = list_new(); if (v1->tag == VERB) { for (;;) { if (!value_is_truthy(apply_dyad(state, v1, x, y))) break; list_push(r, x); x = apply_dyad(state, v2, x, y); } } else if (v1->tag == NUMBER) { size_t k = (size_t)fabs(v1->val.number); for (size_t i = 0; i < k; i++) { list_push(r, x); x = apply_dyad(state, v2, x, y); } } return x; } #define CONJUNCTION(__name, __symb) \ verb_t *conjunction_##__name(interpreter_t *state, value_t *x, value_t *y) \ { \ verb_t *nv = verb_new(); \ nv->bonds = list_newk(2); \ nv->bonds->data[0] = x; \ nv->bonds->data[1] = y; \ char *rx = value_show(x); \ char *ry = value_show(y); \ size_t l = strlen(rx) + strlen(ry) + strlen(__symb) + 1; \ nv->name = malloc_checked_atomic(l); \ snprintf(nv->name, l, "%s" __symb "%s", rx, ry); \ GC_FREE(rx); \ GC_FREE(ry); \ nv->rank[0] = 0; \ nv->rank[1] = 0; \ nv->rank[1] = 0; \ nv->monad = _conjunction_##__name##_monad; \ nv->dyad = _conjunction_##__name##_dyad; \ return nv; \ } CONJUNCTION(bond, ";"); CONJUNCTION(pick, "?."); CONJUNCTION(while, "?:"); CONJUNCTION(rank, "\":"); CONJUNCTION(monaddyad, ";:"); CONJUNCTION(if, "&:"); CONJUNCTION(under, "^:"); CONJUNCTION(collect, "\\:"); adverb_t CONJUNCTIONS[] = { {";", NULL, conjunction_bond}, {"?.", NULL, conjunction_pick}, {"?:", NULL, conjunction_while}, {"\":", NULL, conjunction_rank}, {";:", NULL, conjunction_monaddyad}, {"&:", NULL, conjunction_if}, {"^:", NULL, conjunction_under}, {"\\:", NULL, conjunction_collect}}; #define countof(x) (sizeof(x) / sizeof((x)[0])) #define FINDER(kind, rname, table) \ kind *find_##rname(char *s) \ { \ for (size_t i = 0; i < countof(table); i++) \ { \ if (strcmp(table[i].name, s) == 0) \ return &table[i]; \ } \ return NULL; \ } FINDER(verb_t, verb, VERBS); FINDER(adverb_t, adverb, ADVERBS); FINDER(adverb_t, conjunction, CONJUNCTIONS); node_t *node_new(enum node_tag_t tag) { node_t *node = malloc_checked(sizeof(node_t)); node->tag = tag; return node; } node_t *node_new_strand(list_t *l) { node_t *node = malloc_checked(sizeof(node_t)); node->tag = N_STRAND; node->l = l; return node; } node_t *node_new_literal(value_t *v) { node_t *node = malloc_checked(sizeof(node_t)); node->tag = N_LITERAL; node->v = v; return node; } node_t *node_new1(enum node_tag_t tag, node_t *a) { node_t *node = malloc_checked(sizeof(node_t)); node->tag = tag; node->a = a; return node; } node_t *node_new2(enum node_tag_t tag, node_t *a, node_t *b) { node_t *node = malloc_checked(sizeof(node_t)); node->tag = tag; node->a = a; node->b = b; return node; } node_t *node_new3(enum node_tag_t tag, node_t *a, node_t *b, node_t *c) { node_t *node = malloc_checked(sizeof(node_t)); node->tag = tag; node->a = a; node->b = b; node->c = c; return node; } typedef struct { lexer_t *lexer; interpreter_t *state; size_t pos; size_t end; size_t dp; bool bn; } parser_t; parser_t *parser_new(interpreter_t *state) { parser_t *parser = malloc_checked(sizeof(parser_t)); parser->state = state; return parser; } void parser_error(parser_t *parser, char *s) { fatal(s); } bool parser_done(parser_t *parser) { return parser->pos >= parser->end; } token_t *parser_lookahead(parser_t *parser, size_t offset) { size_t pos = parser->pos + offset; if (pos >= parser->end) return NULL; return list_index(parser->lexer->tokens, pos); } bool parser_stop(parser_t *parser) { token_t *tok = parser_lookahead(parser, 0); if (!tok) return true; return tok->tag == T_RPAR; } void parser_eat(parser_t *parser) { if (!parser_done(parser)) parser->pos++; } node_t *parser_parse_expr(parser_t *parser); node_t *parser_parse_verb(parser_t *parser) { token_t *tok = parser_lookahead(parser, 0); if (!tok || tok->tag != T_PUNCT) return NULL; verb_t *verb = find_verb(tok->text); if (!verb) return NULL; return node_new_literal(value_new_verb(verb)); } value_t *_adverb_wrapper_monad(interpreter_t *state, verb_t *self, value_t *x) { adverb_t *av = self->bonds->data[0]; if (x->tag != VERB) return state->udf; return value_new_verb(av->adverb(state, x)); } value_t *_adverb_wrapper_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { adverb_t *av = self->bonds->data[0]; if (x->tag != VERB) return state->udf; verb_t *v = av->adverb(state, x); return each_rank(state, v, y, 0, v->rank[0]); } node_t *parser_parse_adverb_atom(parser_t *parser) { token_t *tok = parser_lookahead(parser, 0); if (!tok || tok->tag != T_PUNCT) return NULL; adverb_t *adverb = find_adverb(tok->text); if (!adverb) return NULL; verb_t *nv = verb_new(); nv->name = strdup_checked(tok->text); nv->bonds = list_newk(1); nv->bonds->data[0] = adverb; nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = _adverb_wrapper_monad; nv->dyad = _adverb_wrapper_dyad; return node_new_literal(value_new_verb(nv)); } value_t *_conjunction_wrapper_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { adverb_t *av = self->bonds->data[0]; return value_new_verb(av->conjunction(state, x, y)); } node_t *parser_parse_conjunction_atom(parser_t *parser) { token_t *tok = parser_lookahead(parser, 0); if (!tok || tok->tag != T_PUNCT) return NULL; adverb_t *adverb = find_conjunction(tok->text); if (!adverb) return NULL; verb_t *nv = verb_new(); nv->name = strdup_checked(tok->text); nv->bonds = list_newk(1); nv->bonds->data[0] = adverb; nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = NULL; nv->dyad = _conjunction_wrapper_dyad; return node_new_literal(value_new_verb(nv)); } node_t *parser_parse_atom(parser_t *parser) { token_t *tok = parser_lookahead(parser, 0); node_t *node = NULL; switch (tok->tag) { case T_RPAR: parser_error(parser, "unmatched"); case T_LPAR: parser_eat(parser); tok = parser_lookahead(parser, 0); if (tok && tok->tag == T_RPAR) { node = node_new_literal(parser->state->unit); break; } parser->dp++; node = parser_parse_expr(parser); if (!node) parser_error(parser, "unmatched"); if (parser->bn) node->dp = 2; else node->dp = parser->dp; parser->dp--; tok = parser_lookahead(parser, 0); if (!tok || tok->tag != T_RPAR) parser_error(parser, "unmatched"); break; case T_PUNCT: node = parser_parse_verb(parser); if (!node) node = parser_parse_adverb_atom(parser); if (!node) node = parser_parse_conjunction_atom(parser); if (!node) parser_error(parser, "parse"); break; case T_NUMBER: node = node_new_literal(value_new_number(strtod(tok->text, NULL))); break; case T_BNUMBER: { if (!tok->text[1]) parser_error(parser, "trailing-base"); int base = tok->text[0] == 'x' ? 16 : tok->text[0] == 'b' ? 2 : 8; node = node_new_literal(value_new_number(strtol(tok->text + 1, NULL, base))); } break; case T_NAME: node = node_new_literal(value_new_symbol(strdup_checked(tok->text))); break; case T_QUOTE: if (!*tok->text) node = node_new_literal(parser->state->unit); else if (!*(tok->text + 1)) node = node_new_literal(value_new_char(tok->text[0])); else { size_t z = strlen(tok->text); list_t *r = list_newk(z); for (size_t i = 0; i < z; i++) r->data[i] = CHARS[(int)tok->text[i]]; node = node_new_literal(value_new_array(r)); } break; } if (!node) parser_error(parser, "parse"); parser_eat(parser); return node; } bool is_unbound(interpreter_t *state, char *s) { if (state->args->data) { list_t *args = list_index(state->args, -1); size_t argc = args->length - 1; if (argc == 2 && strcmp(s, "y") == 0) return false; else if (strcmp(s, "x") == 0) return false; } else if (table_has(state->env, s)) return false; return true; } node_t *parser_parse_sequence(parser_t *parser, node_t *a, enum token_tag_t tag) { token_t *tok; if ((tok = parser_lookahead(parser, 0)) && (tok->tag == tag || (tag == T_NUMBER && tok->tag == T_BNUMBER))) { if (tag == T_NAME && !is_unbound(parser->state, tok->text)) return NULL; list_t *as = list_new(); list_push(as, a->v); do { if (tag == T_NAME && tok->tag == T_NAME && !is_unbound(parser->state, tok->text)) break; a = parser_parse_atom(parser); list_push(as, a->v); } while ((tok = parser_lookahead(parser, 0)) && (tok->tag == tag || (tag == T_NUMBER && tok->tag == T_BNUMBER))); return node_new_literal(value_new_array(as)); } return NULL; } node_t *_parser_parse_noun(parser_t *parser) { node_t *n; node_t *a = parser_parse_atom(parser); if (a->tag == N_LITERAL && a->v->tag == NUMBER && (n = parser_parse_sequence(parser, a, T_NUMBER))) return n; else if (a->tag == N_LITERAL && a->v->tag == SYMBOL && is_unbound(parser->state, a->v->val.symbol) && (n = parser_parse_sequence(parser, a, T_NAME))) return n; else if (a->tag == N_LITERAL && ((a->v->tag == ARRAY && is_char_array(a->v->val.array)) || a->v->tag == CHAR) && (n = parser_parse_sequence(parser, a, T_QUOTE))) return n; return a; } node_t *parser_parse_noun(parser_t *parser, bool flat) { node_t *a = flat ? parser_parse_atom(parser) : _parser_parse_noun(parser); token_t *tok; if ((tok = parser_lookahead(parser, 0)) && tok->tag == T_PUNCT && strcmp(tok->text, ",:") == 0) { parser_eat(parser); list_t *l = list_new(); list_push(l, a); for (;;) { if (parser_stop(parser)) parser_error(parser, "trailing-strand"); a = flat ? parser_parse_atom(parser) : _parser_parse_noun(parser); list_push(l, a); if (!((tok = parser_lookahead(parser, 0)) && tok->tag == T_PUNCT && strcmp(tok->text, ",:") == 0)) break; parser_eat(parser); } return node_new_strand(l); } return a; } bool parser_node_is_verbal(parser_t *parser, node_t *n) { value_t *v; if (n->tag == N_FUN) return true; else if (n->tag == N_ADV || n->tag == N_CONJ || n->tag == N_PARTIAL_CONJ) return true; else if (n->tag == N_FORK || n->tag == N_HOOK || n->tag == N_BOND || n->tag == N_OVER) return true; else if (n->tag == N_LITERAL && n->v->tag == VERB) return true; else if (n->tag == N_LITERAL && n->v->tag == SYMBOL && (v = table_get(parser->state->env, n->v->val.symbol)) && v->tag == VERB) return true; return false; } node_t *parser_parse_adverb(parser_t *parser, node_t *v, bool *flag) { token_t *tok; adverb_t *adv; node_t *t; for (;;) { tok = parser_lookahead(parser, 0); if (!tok || tok->tag != T_PUNCT) break; if ((adv = find_adverb(tok->text))) { if (flag) *flag = true; parser_eat(parser); t = node_new(N_ADV); t->av = adv; t->a = v; v = t; } else break; } return v; } node_t *parser_parse_conjunction(parser_t *parser, node_t *v, bool *flag) { token_t *tok; adverb_t *adv; node_t *t; for (;;) { tok = parser_lookahead(parser, 0); if (!tok || tok->tag != T_PUNCT) break; if ((adv = find_conjunction(tok->text))) { if (flag) *flag = true; parser_eat(parser); if (parser_stop(parser)) { t = node_new(N_PARTIAL_CONJ); t->av = adv; t->a = v; } else { t = node_new(N_CONJ); t->av = adv; t->a = v; t->b = parser_parse_noun(parser, true); } v = t; } else break; } return v; } bool is_apply(node_t *n) { return n->tag == N_LITERAL && n->v->tag == VERB && (strcmp(n->v->val.verb->name, "`.") == 0 || strcmp(n->v->val.verb->name, "`:") == 0); } bool is_obverse(node_t *n) { return n->tag == N_LITERAL && n->v->tag == VERB && strcmp(n->v->val.verb->name, "::") == 0; } node_t *parser_parse_expr(parser_t *parser) { token_t *tmp; list_t *ns = list_new(); while (!parser_stop(parser)) { if (!ns->data && (tmp = parser_lookahead(parser, 0)) && tmp->tag == T_PUNCT && strcmp(tmp->text, ":") == 0) { parser_eat(parser); node_t *r = parser_parse_expr(parser); if (!r) r = node_new_literal(parser->state->nil); return node_new1(N_FUN, r); } node_t *n = parser_parse_noun(parser, false); if (!ns->data && n->tag == N_LITERAL && n->v->tag == SYMBOL && (tmp = parser_lookahead(parser, 0)) && tmp->tag == T_PUNCT && strcmp(tmp->text, ":") == 0) { parser_eat(parser); bool t = parser->bn; parser->bn = true; node_t *r = parser_parse_expr(parser); parser->bn = t; return node_new2(N_BIND, n, r); } for (;;) { bool flag = false; n = parser_parse_adverb(parser, n, &flag); n = parser_parse_conjunction(parser, n, &flag); if (!flag) break; } list_push(ns, n); } size_t len; node_t *l, *m, *r; for (;;) { len = ns->length; if (len < 2) break; if (len >= 3 && (is_apply(list_index(ns, -2)) || is_obverse(list_index(ns, -2))) && parser_node_is_verbal(parser, list_index(ns, -3))) { r = list_pop(ns); m = list_pop(ns); l = list_pop(ns); list_push(ns, node_new3(N_DYAD, m, l, r)); } else if (len >= 3 && !parser_node_is_verbal(parser, list_index(ns, -1)) && parser_node_is_verbal(parser, list_index(ns, -2)) && !parser_node_is_verbal(parser, list_index(ns, -3))) { r = list_pop(ns); m = list_pop(ns); l = list_pop(ns); list_push(ns, node_new3(N_DYAD, m, l, r)); } else if (len >= 3 && parser_node_is_verbal(parser, list_index(ns, -1)) && parser_node_is_verbal(parser, list_index(ns, -2)) && parser_node_is_verbal(parser, list_index(ns, -3))) { r = list_pop(ns); m = list_pop(ns); l = list_pop(ns); list_push(ns, node_new3(N_FORK, l, m, r)); } else if (len >= 3 && parser_node_is_verbal(parser, list_index(ns, -1)) && parser_node_is_verbal(parser, list_index(ns, -2)) && !parser_node_is_verbal(parser, list_index(ns, -3))) { r = list_pop(ns); m = list_pop(ns); l = list_pop(ns); list_push(ns, node_new3(N_OVER, l, m, r)); } else if (len >= 2 && is_apply(list_index(ns, -1))) { r = list_pop(ns); l = list_pop(ns); list_push(ns, node_new2(N_BOND, r, l)); } else if (len >= 2 && !parser_node_is_verbal(parser, list_index(ns, -1)) && parser_node_is_verbal(parser, list_index(ns, -2))) { r = list_pop(ns); l = list_pop(ns); list_push(ns, node_new2(N_MONAD, l, r)); } else if (len >= 2 && parser_node_is_verbal(parser, list_index(ns, -1)) && parser_node_is_verbal(parser, list_index(ns, -2))) { r = list_pop(ns); l = list_pop(ns); list_push(ns, node_new2(N_HOOK, l, r)); } else if (len >= 2 && parser_node_is_verbal(parser, list_index(ns, -1)) && !parser_node_is_verbal(parser, list_index(ns, -2))) { r = list_pop(ns); l = list_pop(ns); list_push(ns, node_new2(N_BOND, r, l)); } else if (len >= 3) { r = list_pop(ns); m = list_pop(ns); l = list_pop(ns); list_push(ns, node_new3(N_INDEX2, m, l, r)); } else if (len >= 2) { r = list_pop(ns); l = list_pop(ns); list_push(ns, node_new2(N_INDEX1, l, r)); } } return ns->data ? ns->data[0] : NULL; } node_t *parser_parse(parser_t *parser, lexer_t *lexer) { parser->lexer = lexer; parser->pos = 0; parser->end = parser->lexer->tokens->length; node_t *node = parser_parse_expr(parser); if (!parser_done(parser)) { token_t *tok = parser_lookahead(parser, 0); if (tok && tok->tag == T_RPAR) parser_error(parser, "unmatched"); parser_error(parser, "parse"); } return node; } value_t *interpreter_run(interpreter_t *state, char *program) { lexer_t *lexer = lexer_new(); lexer_lex(lexer, program); parser_t *parser = parser_new(state); node_t *node = parser_parse(parser, lexer); list_t *t = lexer->tokens; for (size_t i = 0; i < t->length; i++) { token_t *tok = t->data[i]; if (tok->text) GC_FREE(tok->text); GC_FREE(tok); } GC_FREE(t->data); GC_FREE(t); value_t *r = interpreter_walk(state, node); GC_FREE(parser); return r; } #define HELP_SIZE 7 static const struct { const char *key; const char *text; } HELP[HELP_SIZE] = { {"+", ": monadic const create a function that always yields x" "\n" ": dyadic bind bind y to symbol x" "\n" ":: monadic unbind unbind symbol x" "\n" ":: dyadic obverse insert inverse for x" "\n" "+ monadic flip transpose matrix" "\n" "+ dyadic plus add numbers" "\n" "+. monadic fibonacci compute xth fibonacci number" "\n" "+. dyadic gcd compute gcd(x, y)" "\n" "+: monadic sin compute sin(x)" "\n" "+: dyadic combine combine digits of x and y, same as 10_.(10_:),(10_:)" "\n" "- monadic negate negate number" "\n" "- dyadic minus subtract numbers" "\n" "* monadic first yield first element of x" "\n" "* dyadic times multiply numbers" "\n" "*. monadic factorial x!" "\n" "*. dyadic lcm compute lcm(x, y)" "\n" "*: monadic double x * 2" "\n" "*: dyadic replicate repeat y x times" "\n" "% monadic reciprocal 1 / x" "\n" "% dyadic divide divide numbers" "\n" "%. monadic sqrt compute square root of x" "\n" "%. dyadic root compute xth root of y" "\n" "%: monadic halve x % 2" "\n" "%: dyadic idivide same as % divide, but result is always integer" "\n" "! monadic enum [0, x)" "\n" "! dyadic mod modulo of numbers" "\n" "!. monadic iota [1, x]" "\n" "!. dyadic range [x, y] (also works for chars and even if x > y)" "\n" "!: monadic odometer !:10 10 is 0 0,:0 1,: ... 1 0,:1 1,: ... 9 8,:9 9" "\n" "!: dyadic chunks split y into x-sized chunks" "\n" "^ monadic exp e^x" "\n" "^ dyadic power raise number to a power" "\n" "^. monadic nlog ln(x)" "\n" "^. dyadic log log(y)/log(x)" "\n" "= monadic permute generate permutations of x" "\n" "= dyadic equals test whether x and y are equal" "\n" "=. monadic occurences count occurences of elts, =.'Hello World!' is 0 0 0 1 0 0 0 1 0 2 0 0" "\n" "=. dyadic mask mask one array in another, 'abxyzabayxxyabxyk'=.'xy' is 0 0 1 1 0 0 0 0 0 0 2 2 0 0 3 3 0" "\n" "=: monadic classify assign unique index to each unique elt, =:'Hello World!' is 0 1 2 2 3 4 5 3 6 2 7 8" "\n" "=: dyadic match same as = equals, but rank 0, so compares x and y as whole" "\n" "~ monadic not logical not, nil udf () 0 4t.0 are not truthy, everything else is truthy" "\n" "~ dyadic notequals test whether x and y are not equal" "\n" "~. monadic sign sign of x, -1 for negative, 0 for 0, 1 for positive" "\n" "~. dyadic insert insert x between elts of y, 0~.1 2 3 is 1 0 2 0 3" "\n" "~: dyadic notmatch rank 0 version of ~ notequals" "\n" "< monadic pred x - 1" "\n" "< dyadic less test whether x is lesser than y" "\n" "<. monadic floor round x down" "\n" "<. dyadic lesseq test whether x is equal or lesser than y" "\n" "<: monadic gradedown indices of array sorted descending" "\n" "<: dyadic nudgeleft shift elts of y to the left filling gap with x" "\n" "> monadic succ x + 1" "\n" "> dyadic greater test whether x is greater than y" "\n" ">. monadic ceil round x up" "\n" ">. dyadic greatereq test whether x is equal or greater than y" "\n" ">: monadic gradeup indices of array sorted ascending" "\n" ">: dyadic nudgeright shift elts of y to the right filling gap with x" "\n" ", monadic enlist put x into 1-elt array" "\n" ", dyadic join concat x and y" "\n" ",. monadic enfile same as , enlist but with infinite rank, ,.1 2 3 is (,1),:(,2),:(,3)" "\n" ",. dyadic enpair put x and y into 2-elt array" "\n" "# monadic count yield count of elts of x" "\n" "# dyadic take take x first elts of y (or last if x < 0)" "\n" "#. monadic where #.0 0 1 0 1 0 is 2 4" "\n" "#. dyadic copy repeat each elt of x by corresponding number in y, 5 2 3 3#.0 2 2 1 is 2 2 3 3 3" "\n" "#: monadic group #:'mississippi' is (,0),:1 4 7 10,:2 3 5 6,:8 9" "\n" "#: dyadic buckets group elts of y into buckets according to x, e.g. 0 -1 -1 2 0#:a b c d e is (a,.e),:(),:(,d)" "\n" "_ monadic nub mark all unique elts of x, e.g. _'abracadabra' yields 1 1 1 0 1 0 1 0 0 0 0" "\n" "_ dyadic drop remove first x elts of y (or last if x < 0)" "\n" "_. monadic unbits _.1 0 1 is 5" "\n" "_. dyadic unbase 10_.4 5 6 is 456" "\n" "_: monadic bits _:5 is 1 0 1" "\n" "_: dyadic base 10_:4242 is 4 2 4 2" "\n" "? monadic unique distinct elts of x, same as ]#._" "\n" "? dyadic find find all indices of x in y" "\n" "& monadic flatten flatten an array, same as ,//." "\n" "& dyadic minand get min of two numbers (logical and for 0/1s)" "\n" "| monadic reverse reverse an array" "\n" "| dyadic maxor get max of two numbers (for 0/1s is same as logical or)" "\n" "|. monadic round round x" "\n" "|. dyadic rotate rotate array x times clockwise (-x for counterclockwise)" "\n" "|: monadic depth find max depth of x, |:,,,y yields 3" "\n" "|: dyadic windows yields all contiguous x-sized subarrays of y" "\n" "@ monadic abs |x|" "\n" "@ dyadic at pick elts from x by indices from y" "\n" "@. monadic shuffle shuffle elts of x" "\n" "@. dyadic member check whether x is in y" "\n" "@: monadic infix shortcut for }{:" "\n" "@: dyadic indexof yield index of x in y or #y if x not in y" "\n" "{ monadic head first two elts of x, same as 2#" "\n" "{ dyadic bin bin search, e.g. 1 3 5 7 9{8 9 0 yields 3 4 -1" "\n" "{. monadic tail last elt of x" "\n" "{. dyadic cut 1 3{.!.5 yields 2 3,:4 5" "\n" "{: monadic prefixes prefixes of x, same as |}.\\." "\n" "{: dyadic shl x << y" "\n" "} monadic behead all elts of x except first, same as 1_" "\n" "} dyadic xor x ^ y" "\n" "}. monadic curtail all elts of x except last, same as -1_" "\n" "}. dyadic band x & y" "\n" "}: monadic suffixes suffixes of x, same as }.\\." "\n" "}: dyadic shr x >> y" "\n" "[ monadic factors compute prime factors of x" "\n" "[ dyadic left yield x" "\n" "[. monadic bnot ~x" "\n" "[. dyadic bor x | y" "\n" "[: monadic primes find primes in range [2, x]" "\n" "[: dyadic parts split y into x parts" "\n" "] monadic same yield x (i.e. identity)" "\n" "] dyadic right yield y (i.e. right argument)" "\n" "]. monadic sort sort x ascending, shortcut for ]@>:" "\n" "]. dyadic outof the number of ways of picking x balls from a bag of y balls, e.g. 5].10 is 252" "\n" "]: monadic unsort sort x descending, shortcut for ]@<:" "\n" "]: dyadic explode split y by delim x" "\n" "`. monadic symbol cast x to a symbol" "\n" "`. dyadic apply1 apply x to y" "\n" "`: monadic square x ^ 2" "\n" "`: dyadic apply2 apply x to y (y is 2-elt array of args)" "\n" "$ monadic shape yield shape of x" "\n" "$ dyadic reshape reshape y to shape x" "\n" "$. monadic repr yield string repr of x" "\n" "$. dyadic format format y by template x, e.g. '{0}+{1}*{-1}+_'$.1 2 3 4 is 1+2*4+1" "\n" "$: monadic eye identity matrix of size x" "\n" "$: dyadic implode join y inserting x between" "\n"}, {"a", "d. dyadic delete delete elt from y by index x" "\n" "D. dyadic deleteInplace delete elt from y by index x (in-place)" "\n" "p. monadic print print x" "\n" "P. monadic println print x and a \\n" "\n" "c. monadic putch print char x" "\n" "s. monadic selfref1 monadic reference to current function or rhs of bind" "\n" "s. dyadic selfref2 dyadic reference to current function or rhs of bind" "\n" "F. monadic read read file (x=0 to read stdin)" "\n" "F. dyadic write write file (y=0 to write to stderr)" "\n" "t. dyadic cast cast y to type x" "\n" "t. monadic type type of x, array=0, verb=1, symbol=2, number=3, char=4, nil=5, udf=6" "\n" "r. monadic deal yield random elt of x" "\n" "r. dyadic roll roll xdy (note: y is 0-based, so >xr.y for 1-based)" "\n" "e. monadic eval eval expression, yields udf on parse error" "\n" "i. monadic import load and eval source file" "\n" "i. dyadic foreign call external function (lhs is array of arguments), e.g. .5i.'libm.so:dd:sin'" "\n" "y. monadic system exec system command (yields output)" "\n" "y. dyadic system2 exec system command with input" "\n" "E. monadic exit exit with exit code" "\n" "L. monadic lines shortcut for (4t.10)]:" "\n" "L. dyadic tackleft prepend x to y" "\n" "R. monadic setrecdepth set max recursion depth" "\n" "R. dyadic tackright append x to y" "\n" "v. monadic value get value of var x (udf if not defined)" "\n" "h. monadic hex yield hexadecimal representation of num x" "x. monadic show identity for strings, same as $ repr for other" "\n" "x. dyadic rematch match str y with regex (PCRE) x" "\n" "X. dyadic extract extract all matches of regex x from y" "\n"}, {"\"", "f\" each >\"1 2 3 yields 2 3 4" "\n" "xf\" merge 1 2 3,\"a b c yields (1,.a),:(2,.b),:(3,.c)" "\n" "f\". eachprior -\".1 2 2 3 5 6 yields 1 0 1 2 1" "\n" "xf\". eachpriorwith 0-\".1 2 2 3 5 6 yields 1 1 0 1 2 1" "\n" "f/ fold +/1 2 3 yields 6" "\n" "xf/ foldwith 1+/1 2 3 yields 7" "\n" "f\\ scan +\\1 2 3 yields 1 3 6" "\n" "xf\\ scanwith 1+\\1 2 3 yields 1 2 4 7" "\n" "f/. converge 1;_/.1 2 3 yields ()" "\n" "f\\. converges 1;_\\.1 2 3 yields 1 2 3,:2 3,:(,3),:()" "\n" "xf/. eachright 1-/.1 2 3 yields 0 1 2" "\n" "xf\\. eachleft 1-\\.1 2 3 yields 0 -1 -2" "\n" "f\": rank #\":1 2 3$1 yields 3 3, #\":inf 2 3$1 yields 1 1 1,:1 1 1" "\n" "xf\": rank2 1 2 3 *:\":1 1 2 3 yields (,1),:2 2,:3 3 3" "\n" "n` amend 'gw'0 3`'cross' yields 'grows', 1 0 -1(1+)`!.5 yields 2 3 3 4 6" "\n" "f&. filter >;0&.-2!.2 yields 1 2, basically shortcut for ]#.f" "\n" "f/: span =;' '/:'x y z' yields (,'x'),:(,'y'),:(,'z')" "\n" "xf/: stencil 3+//:!10 yields 3 6 9 12 15 18 21 24, shortcut for f\"x|:" "\n" "f;. reflex *;.5 yields 25, 5%;.2 yields 0.4" "\n"}, {";", "f;g bond */;!.5 yields 120, +;1 5 yields 6, 5;- 1 yields 4" "\n" "f?.x pick >;5?.((2*),:<)\"3 6 yields 6 5" "\n" "f?:F while <;5?:>0 yields 5" "\n" "n?:f repeat 5?:*;2 1 yields 32" "\n" "a\\:f collect same as while/repeat, but yields array of intermediate iterations" "\n" "f&:F if 1+&:+2 yields 2" "\n" "f;:F monaddyad -;:+5 yields -5, 1-;:+5 yields 6" "\n"}, {"-:", "inverse of a function f is a function ~f that undoes the effect of f" "\n" "\n" "f::~f obverse define inverse ~f for f" "\n" "\n" "f-:x inverse ~fx" "\n" "xf-:y inverse2 (~fx)~f~fx" "\n" "f^:Fx under ~FfFx" "\n" "xf^:Fx under2 ~F(Fx)f(Fx)" "\n"}, {"0", "/ comment" "\n" "5+5 / also comment" "\n" "5+5/not comment (no whitespace before /)" "\n" "abc foo bar f g x y z / symbols" "\n" "nil udf / special, nil and undefined" "\n" "'a'%2 / = nan, nan used to denote illegal numeric operation" "\n" "+1 2 3 / = udf, attempt to transpose flat vector, udf/undefined used to denote illegal operation" "\n" "5 5.5 -5 42 / number (double-precision floats)" "\n" "1`000 1`000`000 /" "\n" ".5 .429 /" "\n" "0xff 0o4 0b0101 /" "\n" "nan inf /" "\n" "'a' 'b' 'g' / chars (bytes)" "\n" "4t.0 / 0 NUL byte" "\n" "(4t.0),:(4t.16),:(4t.22) /" "\n" "1 2 3 / numbers array" "\n" "'hello world!' 'bla''bla' / quote, array of chars" "\n" ",'a' / 1-char string" "\n" ",1 / 1-elt array" "\n" "() / unit, empty array" "\n" "1,:(5+5),:1 2 3 / strand, mixed array literal" "\n" "-1 / negative num literal" "\n" "- 1 / application of - negate to 1" "\n" "-1 -2 -3 / array of negative nums" "\n" "- 1 2 3 / application of - negate to an array of nums" "\n" "5-5 / array of numbers 5 and -5" "\n" "5- 5 / 5 minus 5" "\n" "+ / verb" "\n" "5+5 / dyadic expr" "\n" "#1 2 3 / monadic expr (no left side)" "\n" "+/ *;. / adverb" "\n" "+;1 -;* +^:^. / conjunction" "\n" ":x+y / function literal" "\n" ":1 / function that always yields 1" "\n" "x:123 / bind name (symbol)" "\n" "sq:*;. /" "\n" "fac:*/1+! / bind function" "\n" "f:x+y /" "\n" "f:-x / overload function by arity" "\n" "f 5 / = -5" "\n" "5 f 5 / = 10" "\n" "*/!. / hook, fgx -> f(g(x)), xfgy -> f(g(x, y))" "\n" "+/%# / fork, fghx -> g(f(x), h(x)), xfghy -> g(f(x), h(y))" "\n" "1+! / over, nfgx -> f(n, g(x)), xnfgy -> f(n, g(x, y))" "\n" "1+ / bond, nfx -> f(n, x), xnfy -> f(n, f(x, y))" "\n"}, {"", "\\0\thelp on syntax\n" "\\+\thelp on verbs\n" "\\a\thelp on additional verbs\n" "\\\"\thelp on adverbs\n" "\\;\thelp on conjunctions\n" "\\-:\thelp on inverses\n"}}; const char *VSTR = VER " " __DATE__; void jkexec(interpreter_t *state, FILE *fd, bool isrepl, char **s) { value_t *v = NULL; list_t *r; if (!isrepl) r = list_new(); for (;;) { buffer_t *buffer; char line[256]; buffer = buffer_new(); if (isrepl) putc('\t', stdout); if (!fgets(line, sizeof(line), fd)) break; if (isrepl) { if (strcmp(line, "\\\\\n") == 0) break; if (line[0] == '\\') { char tmp[4]; memset(tmp, 0, sizeof(tmp)); for (size_t i = 1; i < strlen(line) && line[i] != '\n'; i++) tmp[i-1] = line[i]; size_t ti = HELP_SIZE; for (size_t i = 0; i < HELP_SIZE; i++) { if (strcmp(tmp, HELP[i].key) == 0) { ti = i; break; } } if (ti < HELP_SIZE) { printf("%s", HELP[ti].text); continue; } } } while (strlen(line) > 2 && strcmp(line + strlen(line) - 3, "..\n") == 0) { line[strlen(line) - 3] = 0; buffer_append_str(buffer, line); if (isrepl) putc('\t', stdout); if (!fgets(line, sizeof(line), fd)) return; } buffer_append_str(buffer, line); *s = buffer_read(buffer); v = interpreter_run(state, *s); GC_FREE(*s); *s = NULL; if (isrepl && v->tag != NIL) { table_set(state->env, "it", v); char *s = value_show(v); fputs(s, stdout); GC_FREE(s); if (isrepl) putc('\n', stdout); } else if (!isrepl && v && v->tag != NIL) list_push(r, v); } if (!isrepl && r->data) { char *s = value_show(list_index(r, -1)); fputs(s, stdout); GC_FREE(s); } } int main(int argc, char **argv) { GC_INIT(); guards = list_new(); is_interactive = isatty(0); HASH_SEED = time(NULL); srand(HASH_SEED); VCACHE = table_new(); SCACHE = table_new(); for (size_t i = 0; i < countof(VERBS); i++) { value_t *v = value_new_const(VERB); v->val.verb = &VERBS[i]; table_set(VCACHE, VERBS[i].name, v); } _UNIT = value_new(ARRAY); _UNIT->val.array = list_new(); interpreter_t *state = interpreter_new(); for (int i = 1; i <= 8; i++) { NNUMS[i - 1] = value_new_const(NUMBER); NNUMS[i - 1]->val.number = -i; } for (int i = 0; i < 256; i++) { NUMS[i] = value_new_const(NUMBER); NUMS[i]->val.number = i; } list_t *cs = list_newk(256); for (int i = 0; i < 256; i++) { CHARS[i] = value_new_const(CHAR); CHARS[i]->val._char = i; cs->data[i] = CHARS[i]; } _NAN = value_new_const(NUMBER); _NAN->val.number = NAN; INF = value_new_const(NUMBER); INF->val.number = INFINITY; NINF = value_new_const(NUMBER); NINF->val.number = -INFINITY; list_t *vs = list_new(); for (size_t i = 0; i < strlen(VSTR); i++) list_push(vs, CHARS[(int)VSTR[i]]); table_set(state->env, "A", value_new_array(cs)); table_set(state->env, "JKV", value_new_array(vs)); table_set(state->env, "E", value_new_number(exp(1))); table_set(state->env, "pi", value_new_number(M_PI)); table_set(state->env, "tau", value_new_number(M_PI * 2)); table_set(state->env, "nan", _NAN); table_set(state->env, "inf", INF); table_set(state->env, "nil", state->nil); table_set(state->env, "udf", state->udf); Inverses = table_new(); table_set(Inverses, "+", find_verb("+")); table_set(Inverses, "-", find_verb("-")); table_set(Inverses, "|", find_verb("|")); table_set(Inverses, "~", find_verb("~")); table_set(Inverses, "%", find_verb("%")); table_set(Inverses, "]", find_verb("]")); table_set(Inverses, "*:", find_verb("%:")); table_set(Inverses, "%:", find_verb("*:")); table_set(Inverses, ">", find_verb("<")); table_set(Inverses, "<", find_verb(">")); table_set(Inverses, "_.", find_verb("_:")); table_set(Inverses, "_:", find_verb("_.")); table_set(Inverses, "^.", find_verb("^")); table_set(Inverses, "^", find_verb("^.")); table_set(Inverses, "+;.", find_verb("%:")); table_set(Inverses, "*/", find_verb("[")); table_set(Inverses, "[", interpreter_run(state, "*/")->val.verb); table_set(Inverses, "!", interpreter_run(state, ">|/")->val.verb); table_set(Inverses, "!.", interpreter_run(state, "|/")->val.verb); table_set(Inverses, "]@>:", interpreter_run(state, "]@<:")->val.verb); table_set(Inverses, "]@<:", interpreter_run(state, "]@>:")->val.verb); list_t *args = list_new(); for (int i = 1; i < argc; i++) { list_t *arg = list_new(); char *s = argv[i]; while (*s) list_push(arg, CHARS[(int)(*s++)]); list_push(args, value_new_array(arg)); } table_set(state->env, "args", value_new_array(args)); if (is_interactive) printf("jk\t\\\\ to exit \\ for help\n"); char *s = NULL; if (is_interactive) setjmp(interactive_checkpoint); if (s) { GC_FREE(s); s = NULL; } jkexec(state, stdin, is_interactive, &s); }