#include "version.h" #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include jmp_buf interactive_checkpoint; bool is_interactive; 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; jmp_buf *guard() { jmp_buf *lb = malloc_checked_atomic(sizeof(jmp_buf)); list_push(guards, lb); return lb; } jmp_buf *guarding() { return list_index(guards, -1); } void unguard() { jmp_buf *lb = list_pop(guards); GC_FREE(lb); } void fatal(char *s) { jmp_buf *lb; if ((lb = guarding())) longjmp(*lb, 1); fprintf(stderr, "|%s error\n", s); if (is_interactive) 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 nonar(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 matp(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 || !nonar(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 (matp(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 (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); return r; } list_t *t = x->val.array; if (!t->data) 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); return value_new_array(l); } value_t *apply_monad(interpreter_t *state, value_t *f, value_t *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 (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); 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) 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); } 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) 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) 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); 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); return r; } value_t *apply_dyad(interpreter_t *state, value_t *f, value_t *x, value_t *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 (a->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(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); jmp_buf *lb = guard(); if (setjmp(*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_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_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); } 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; size_t z = y->val.array->length; ssize_t index = trunc(x->val.number); if (index < 0) index += ((ssize_t)z); if (index < 0 || index >= z) return y; 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++] = y->val.array->data[i]; return value_new_array(r); } 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("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", 0, 0, 0, udf1, tackright), DEFVERBD("v", 0, 0, 0, value, 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 = 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; 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 (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 isunb(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 && !isunb(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 && !isunb(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 && isunb(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, -1))) { 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; } #include "help.h" 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; else if (strcmp(line, "\\\n") == 0) { printf("%s", HELP); continue; } else if (strcmp(line, "\\0\n") == 0) { printf("%s", SHELP); continue; } else if (strcmp(line, "\\+\n") == 0) { printf("%s", VHELP); continue; } else if (strcmp(line, "\\a\n") == 0) { printf("%s", V2HELP); continue; } else if (strcmp(line, "\\\"\n") == 0) { printf("%s", AHELP); continue; } else if (strcmp(line, "\\;\n") == 0) { printf("%s", CHELP); continue; } else if (strcmp(line, "\\-:\n") == 0) { printf("%s", IHELP); 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(); GC_enable_incremental(); 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); }