#include "version.h" #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(); 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 _list_t list_t; struct _list_t { void *value; list_t *next; }; list_t *list_new(void) { list_t *list = malloc_checked(sizeof(list_t)); list->value = NULL; list->next = NULL; return list; } bool list_empty(list_t *list) { return (!(list)->value); } size_t list_length(list_t *list) { size_t length = 0; if (list_empty(list)) return length; do { list = list->next, length++; } while (list); return length; } void *list_index(list_t *list, ssize_t index) { size_t length; if (list_empty(list)) return NULL; if (index == 0) return list->value; length = list_length(list); if (index < 0) index += ((ssize_t)length); if (index < 0 || index >= length) return NULL; for (size_t i = 0; i < ((size_t)index); i++) list = list->next; return list->value; } list_t *list_push(list_t *list, void *value) { list_t *head = list; if (list_empty(list)) { list->value = value; return head; } while (list->next) list = list->next; list = list->next = list_new(); list->value = value; return head; } list_t *list_copy(list_t *l) { list_t *r = list_new(); if (!list_empty(l)) while (l) { list_push(r, l->value); l = l->next; } return r; } void *list_pop(list_t *list) { if (list_empty(list)) return NULL; if (!list->next) { void *value = list->value; list->value = NULL; return value; } list_t *head = list; while (list) { if (!list->next) { void *value = list->value; list->value = NULL; head->next = NULL; return value; } head = list; list = list->next; } return NULL; } void *list_set(list_t *list, ssize_t index, void *value) { size_t length = list_length(list); if (index < 0) index += ((ssize_t)length); if (index == ((ssize_t)length)) { list_push(list, value); return value; } if (index < 0 || index >= length) return NULL; for (size_t i = 0; i < ((size_t)index); i++) list = list->next; list->value = value; return value; } list_t *list_insert(list_t **list, ssize_t index, void *value) { list_t *head = *list; if (index == -1) return list_push(head, value); size_t length = list_length(head); if (index < 0) index += (ssize_t)length; if (index < 0 || index > length) return NULL; if (index == -1) return list_push(head, value); if (index == 0) { if (list_empty(head)) return list_push(head, value); list_t *temp = list_new(); temp->value = value; temp->next = head; *list = temp; return temp; } list_t *temp0 = *list; for (size_t i = 0; i < ((size_t)index) - 1; i++) temp0 = temp0->next; list_t *temp = temp0->next; temp0->next = list_new(); temp0->next->value = value; temp0->next->next = temp; return head; } list_t *list_delete(list_t **list, ssize_t index) { list_t *head = *list; if (list_empty(head)) return NULL; size_t length = list_length(head); if (index < 0) index += (ssize_t)length; if (index < 0 || index >= length) return NULL; if (index == 0) { head->value = NULL; if (!head->next) return head; *list = head->next; return *list; } list_t *temp0 = *list; for (size_t i = 0; i < ((size_t)index) - 1; i++) temp0 = temp0->next; list_t *temp = temp0->next; temp->value = NULL; temp0->next = temp->next; return head; } list_t *list_sort(list_t *list, bool (*cmp)(void *, void *)) { size_t l = list_length(list); bool s; for (size_t i = 0; i < l; i++) { list_t *t = list; list_t *p = list; s = false; while (t->next) { list_t *n = t->next; if (cmp(t->value, n->value)) { s = true; if (t == list) { t->next = n->next; n->next = t; p = n; list = p; } else { t->next = n->next; n->next = t; p->next = n; p = n; } continue; } p = t; t = t->next; } if (!s) break; } return list; } typedef struct { char *str; size_t used; size_t allocated; } buffer_t; buffer_t *buffer_new(void) { buffer_t *buf = malloc_checked(sizeof(buffer_t)); buf->str = NULL; buf->used = buf->allocated = 0; return buf; } void buffer_append(buffer_t *buf, char c) { buf->used++; if (buf->used > buf->allocated) { buf->allocated++; buf->str = realloc_checked(buf->str, sizeof(char) * buf->allocated); } buf->str[buf->used - 1] = c; } char *buffer_read(buffer_t *buf) { if (buf->used == 0 || buf->str[buf->used - 1]) buffer_append(buf, 0); char *str = buf->str; GC_FREE(buf); return str; } void buffer_append_str(buffer_t *buf, char *s) { while (*s) buffer_append(buf, *s++); } typedef struct { enum token_tag_t { T_PUNCT, T_LPAR, T_RPAR, T_NAME, T_NUMBER, 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)); } 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 == '/' && list_empty(lexer->tokens)) break; if (isspace(c)) { lexer_eat(lexer); if (lexer_lookahead(lexer, 0) == '/') break; } 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->used == 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; } 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; }; 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 (list_empty(array)) { 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 (list_empty(tx) && list_empty(ty)) break; if (list_empty(tx) && !list_empty(ty)) return false; if (!list_empty(tx) && list_empty(ty)) return false; while (tx) { if (!ty) return false; if (!value_equals(tx->value, ty->value)) return false; tx = tx->next; ty = ty->next; } if (ty) 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) { if (list_empty(a)) return false; while (a) { value_t *v = a->value; if (v->tag != CHAR || !isprint(v->val._char)) return false; a = a->next; } return true; } bool is_arrays_array(list_t *a) { if (list_empty(a)) return false; while (a) { value_t *v = a->value; if (v->tag != ARRAY) return false; a = a->next; } 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 (list_empty(t)) return strdup_checked("()"); buffer_t *buf = buffer_new(); if (!t->next) { buffer_append(buf, ','); char *ts = value_show(t->value); buffer_append_str(buf, ts); GC_FREE(ts); return buffer_read(buf); } if (is_char_array(t)) { while (t) { value_t *c = t->value; buffer_append(buf, c->val._char); t = t->next; } return buffer_read(buf); } if (!is_arrays_array(t)) { while (t) { char *ts = value_show(t->value); buffer_append_str(buf, ts); GC_FREE(ts); t = t->next; if (t) buffer_append(buf, ' '); } } else { unsigned int rwk = 0; unsigned int rwl = list_length(t->value); while (t) { char *ts = show_array(t->value); buffer_append_str(buf, ts); GC_FREE(ts); t = t->next; if (t) buffer_append(buf, ' '); rwk++; if (rwk >= rwl && t) { rwk = 0; 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(""); } 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 !list_empty(x->val.array); 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; } void interpreter_error(interpreter_t *state, char *e) { fprintf(stderr, "%s error\n", e); exit(1); } 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 (list_empty(t)) return x; list_t *l = list_new(); while (t) { list_push(l, each_rank(state, f, t->value, d + 1, rm)); t = t->next; } 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->value || !ty->value) return !tx->value ? x : y; list_t *t = list_new(); while (tx) { if (!ty) break; list_push( t, together(state, f, tx->value, ty->value, dl + 1, dr + 1, rl, rr)); tx = tx->next; ty = ty->next; } 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->value) return y; list_t *t = list_new(); while (ty) { list_push(t, together(state, f, x, ty->value, dl, dr + 1, rl, rr)); ty = ty->next; } 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->value) return x; list_t *t = list_new(); while (tx) { list_push(t, together(state, f, tx->value, y, dl + 1, dr, rl, rr)); tx = tx->next; } 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; }; 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, x, 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; while (t) { if (function_collect_args(t->value, argc)) return true; t = t->next; } } 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 self->bonds->value; } value_t *_const_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { return self->bonds->value; } 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->value); 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->next->value); 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->value; value_t *a = self->bonds->next->value; 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 = node->l; while (t) { t->value = interpreter_walk(state, t->value); t = t->next; } return value_new_array(node->l); } case N_LITERAL: { value_t *v = node->v; value_t *t = NULL; if (v->tag == SYMBOL) { char *n = v->val.symbol; if (!list_empty(state->args)) { list_t *args = list_index(state->args, -1); size_t argc = list_length(args) - 1; if (argc == 2 && strcmp(n, "y") == 0) return args->next->value; else if (strcmp(n, "x") == 0) return args->value; } if ((t = table_get(state->env, n))) return t; } 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(); nv->name = strdup_checked(argc == 0 ? ":..." : argc == 1 ? ":x" : ":xy"); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; if (argc == 0) { list_push(nv->bonds, interpreter_walk(state, 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); return value_new_verb(node->av->adverb(state, v)); } case N_CONJ: { value_t *v1 = interpreter_walk(state, node->a); value_t *v2 = interpreter_walk(state, node->b); return value_new_verb(node->av->conjunction(state, v1, v2)); } 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(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; 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_new(); list_push(nv->bonds, f); list_push(nv->bonds, g); list_push(nv->bonds, h); size_t l = strlen(f->name) + strlen(g->name) + strlen(h->name) + 1; nv->name = malloc_checked(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; 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_new(); list_push(nv->bonds, f); list_push(nv->bonds, g); size_t l = strlen(f->name) + strlen(g->name) + 1; nv->name = malloc_checked(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; 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_new(); list_push(nv->bonds, f); list_push(nv->bonds, g); char *r = value_show(g); size_t l = strlen(r) + strlen(f->name) + 1; nv->name = malloc_checked(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; 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_new(); list_push(nv->bonds, f); list_push(nv->bonds, g); list_push(nv->bonds, h); char *r = value_show(f); size_t l = strlen(r) + strlen(g->name) + strlen(h->name) + 1; nv->name = malloc_checked(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; return value_new_verb(nv); } case N_BIND: { value_t *l = node->a->v; node_t *b = node->b; unsigned int argc = 0; function_collect_args(b, &argc); if (argc != 0) b = node_new1(N_FUN, b); value_t *r = interpreter_walk(state, b); 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->value); 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->next->value); ov->val.verb->dyad = r->val.verb->dyad; break; } } table_set(state->env, l->val.symbol, r); } } return state->nil; } value_t *verb_const(interpreter_t *state, verb_t *self, value_t *x) { verb_t *nv = verb_new(); nv->bonds = list_new(); list_push(nv->bonds, x); char *r = value_show(x); size_t l = strlen(r) + 2; nv->name = malloc_checked(l); snprintf(nv->name, l, ":%s", r); nv->rank[0] = 0; nv->rank[1] = 0; nv->rank[2] = 0; nv->monad = _const_monad; nv->dyad = _const_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_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 (strcmp(vx->name, ":...") == 0 || strcmp(vx->name, ":x") == 0 || strcmp(vx->name, ":xy") == 0) 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 || list_empty(x->val.array)) return state->udf; list_t *t = x->val.array; if (!is_arrays_array(t)) return state->udf; list_t *r = list_new(); value_t *c0 = t->value; list_t *c0t = c0->val.array; size_t c0l = list_length(c0t); for (size_t i = 0; i < c0l; i++) { list_t *nc = list_new(); list_t *t2 = t; while (t2) { value_t *rw = t2->value; list_t *rwt = rw->val.array; if (list_empty(rwt)) return state->udf; value_t *v = list_index(rwt, i); if (!v) v = rwt->value; list_push(nc, v); t2 = t2->next; } 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 (list_empty(x->val.array)) return state->udf; return x->val.array->value; } 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 && y->tag == NUMBER) { double ny = y->val.number; if (ny == 0) return INF; return value_new_number(trunc(x->val.number / ny)); } 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 (list_empty(x->val.array) || !x->val.array->next) return state->udf; size_t p = 1; size_t xl = 0; list_t *t = x->val.array; while (t) { value_t *it = t->value; if (it->tag != NUMBER || is_bad_num(it->val.number)) return state->udf; p *= (size_t)(it->val.number); t = t->next; xl++; } if (p < 1) return state->unit; t = x->val.array; uint64_t *lims = malloc_checked_atomic(sizeof(uint64_t) * xl); for (size_t i = 0; i < xl; i++) { lims[i] = (size_t)(((value_t *)t->value)->val.number); t = t->next; } 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_new(); for (size_t i = 0; i < p; i++) { list_t *rw = list_new(); for (size_t j = 0; j < xl; j++) list_push(rw, value_new_number(z[i][j])); list_push(r, 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 (list_empty(y->val.array)) return y; list_t *r = list_new(); size_t l = list_length(y->val.array); size_t cl = fabs(x->val.number); for (size_t i = 0; i < l; 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_new(); for (int i = 0; i < bk; i++) if ((n & (1 << i)) >> i) list_push(r, NUMS[1]); else list_push(r, NUMS[0]); return value_new_array(r); } return state->udf; } 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) { r = list_insert(&r, 0, value_new_number(v % b)); v /= b; } return value_new_array(r); } return state->udf; } ssize_t indexOf(list_t *l, value_t *x) { if (list_empty(l)) return -1; size_t i = 0; while (l) { if (value_equals(l->value, x)) return i; l = l->next; 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 (list_empty(x->val.array)) return x; list_t *r = list_new(); list_t *is = list_new(); size_t i = 0; list_t *t = x->val.array; while (t) { value_t *v = t->value; 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)); } t = t->next; i++; } while (is) { list_t *tmp = is->next; GC_FREE(is); is = tmp; } 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 (list_empty(x->val.array)) return y; if (y->tag != ARRAY) y = verb_enlist(state, NULL, x); else if (list_empty(y->val.array)) return y; list_t *r = list_new(); list_t *t = x->val.array; size_t mx = 0; while (t) { value_t *v = t->value; if (v->tag != NUMBER) break; ssize_t i = v->val.number; if (i >= 0 && i > mx) mx = i; t = t->next; } for (size_t i = 0; i < mx + 1; i++) list_push(r, list_new()); if (list_empty(r)) { GC_FREE(r); return state->unit; } list_t *ty = y->val.array; t = x->val.array; while (t && ty) { value_t *v = t->value; if (v->tag != NUMBER) break; ssize_t i = v->val.number; if (i >= 0) { list_t *b = list_index(r, i); if (b) list_push(b, ty->value); } t = t->next; ty = ty->next; } if (ty) { list_t *lb = list_new(); while (ty) { list_push(lb, ty->value); ty = ty->next; } list_push(r, lb); } t = r; while (t) { t->value = value_new_array(t->value); t = t->next; } 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 || list_empty(x->val.array) || !x->val.array->next) return x; list_t *permutation = list_copy(x->val.array); size_t length = list_length(permutation); 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++; } } while (c) { list_t *tmp = c->next; GC_FREE(c->value); GC_FREE(c); c = tmp; } while (permutation) { list_t *tmp = permutation->next; GC_FREE(permutation); permutation = tmp; } list_t *t = result; while (t) { t->value = value_new_array(t->value); t = t->next; } 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 (list_empty(x->val.array)) return x; list_t *table = list_new(); list_t *r = list_new(); list_t *t = x->val.array; while (t) { bool f = false; value_t *it = t->value; list_t *tt = table; if (!list_empty(tt)) while (tt) { list_t *p = tt->value; if (value_equals(p->value, it)) { size_t *n = p->next->value; *n = (*n) + 1; list_push(r, value_new_number(*n)); f = true; break; } tt = tt->next; } if (!f) { list_t *p = list_new(); list_push(p, it); size_t *n = malloc_checked_atomic(sizeof(size_t)); list_push(p, n); list_push(table, p); list_push(r, NUMS[0]); } t = t->next; } if (!list_empty(table)) { t = table; while (t) { list_t *tmp = t->next; list_t *p = t->value; GC_FREE(p->next->value); GC_FREE(p->next); GC_FREE(p); GC_FREE(t); t = tmp; } } 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 (list_empty(x->val.array)) return x; if (y->tag != ARRAY) y = verb_enlist(state, NULL, y); list_t *r = list_new(); value_t *l = value_new_number(list_length(y->val.array)); size_t n = 0; size_t k = list_length(x->val.array); 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 (list_empty(x->val.array)) return x; list_t *table = list_new(); list_t *r = list_new(); list_t *t = x->val.array; size_t i = 0; while (t) { bool f = false; value_t *it = t->value; list_t *tt = table; if (!list_empty(tt)) while (tt) { list_t *p = tt->value; if (value_equals(p->value, it)) { size_t *n = p->next->value; list_push(r, value_new_number(*n)); f = true; break; } tt = tt->next; } if (!f) { list_t *p = list_new(); list_push(p, it); size_t *n = malloc_checked_atomic(sizeof(size_t)); *n = i++; list_push(p, n); list_push(table, p); list_push(r, value_new_number(*n)); } t = t->next; } if (!list_empty(table)) { t = table; while (t) { list_t *tmp = t->next; list_t *p = t->value; GC_FREE(p->next->value); GC_FREE(p->next); GC_FREE(p); GC_FREE(t); t = tmp; } } 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; int i = 0; list_t *t = x->val.array; while (t) { if (value_is_truthy(t->value)) n |= (int)1 << i; else n &= ~((int)1 << i); t = t->next; 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; list_t *t = y->val.array; if (list_empty(t)) return state->udf; while (t) { value_t *v = t->value; if (v->tag != NUMBER) break; size_t k = fabs(v->val.number); n = n * b + k; t = t->next; } 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; } bool _compare_up(void *a, void *b) { value_t *x = ((list_t *)a)->value; value_t *y = ((list_t *)b)->value; if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) > get_numeric(y)) return true; return false; } return false; } bool _compare_down(void *a, void *b) { value_t *x = ((list_t *)a)->value; value_t *y = ((list_t *)b)->value; if ((x->tag == NUMBER || x->tag == CHAR) && (y->tag == NUMBER || y->tag == CHAR)) { if (get_numeric(x) < get_numeric(y)) return true; return false; } return false; } value_t *_grade(value_t *x, bool down) { if (x->tag != ARRAY || list_empty(x->val.array) || !x->val.array->next) return x; size_t i = 0; list_t *ps = list_new(); list_t *t = x->val.array; while (t) { list_t *p = list_new(); list_push(p, t->value); list_push(p, value_new_number(i++)); list_push(ps, p); t = t->next; } ps = list_sort(ps, down ? _compare_down : _compare_up); t = ps; while (t) { list_t *p = t->value; t->value = p->next->value; GC_FREE(p->next); GC_FREE(p); t = t->next; } 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 (list_empty(y->val.array)) return y; else if (!y->val.array->next) return verb_enlist(state, NULL, x); list_t *r = list_new(); list_t *t = y->val.array->next; while (t) { list_push(r, t->value); t = t->next; } 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 (list_empty(y->val.array)) return y; else if (!y->val.array->next) return verb_enlist(state, NULL, x); list_t *r = list_new(); list_push(r, x); list_t *t = y->val.array; while (t->next) { list_push(r, t->value); t = t->next; } 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_join(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { list_t *l = list_new(); if (x->tag == ARRAY && !list_empty(x->val.array)) { list_t *t = x->val.array; while (t) { list_push(l, t->value); t = t->next; } } else list_push(l, x); if (y->tag == ARRAY && !list_empty(y->val.array)) { list_t *t = y->val.array; while (t) { list_push(l, t->value); t = t->next; } } else list_push(l, 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_new(); list_push(l, x); list_push(l, y); return value_new_array(l); } value_t *verb_selfref1(interpreter_t *state, verb_t *self, value_t *x) { verb_t *v; if (!list_empty(state->args)) v = list_index(list_index(state->args, -1), -1); else if (!list_empty(state->selfrefs)) 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 (!list_empty(state->args)) v = list_index(list_index(state->args, -1), -1); else if (!list_empty(state->selfrefs)) 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 || list_empty(y->val.array)) return state->unit; bool rev = x->val.number < 0; size_t k = (size_t)fabs(x->val.number); list_t *t = y->val.array; list_t *r = list_new(); if (rev) for (ssize_t i = k; i > 0; i--) { value_t *v = list_index(t, -i); if (!v) continue; list_push(r, v); } else while (t && k) { list_push(r, t->value); t = t->next; k--; } 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 (list_empty(x->val.array)) return x; list_t *r = list_new(); list_t *t = x->val.array; size_t i = 0; while (t) { value_t *a = t->value; 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)); t = t->next; 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 (list_empty(tx) || list_empty(ty)) return state->unit; list_t *r = list_new(); while (tx) { value_t *a = tx->value; value_t *b = ty->value; if (b->tag != NUMBER) break; size_t k = fabs(b->val.number); for (size_t i = 0; i < k; i++) list_push(r, a); tx = tx->next; if (ty->next) ty = ty->next; } return value_new_array(r); } value_t *verb_nub(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || list_empty(x->val.array)) return x; list_t *n = list_new(); list_t *r = list_new(); list_t *t = x->val.array; while (t) { bool u = true; list_t *t2 = r; if (!list_empty(t2)) while (t2) { if (value_equals(t->value, t2->value)) { u = false; break; } t2 = t2->next; } if (u) list_push(r, t->value); list_push(n, u ? NUMS[1] : NUMS[0]); t = t->next; } while (r) { list_t *tmp = r->next; GC_FREE(r); r = tmp; } 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 (list_empty(y->val.array)) return state->unit; bool rev = x->val.number < 0; size_t k = (size_t)fabs(x->val.number); list_t *t = y->val.array; if (rev) { size_t l = list_length(t); if (k >= l) return state->unit; return verb_take(state, NULL, value_new_number(l - k), y); } list_t *r = list_new(); while (t && k) { t = t->next; k--; } while (t) { list_push(r, t->value); t = t->next; } 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 || list_empty(x->val.array)) return x; list_t *r = list_new(); list_t *t = x->val.array; while (t) { bool u = true; list_t *t2 = r; if (!list_empty(t2)) while (t2) { if (value_equals(t->value, t2->value)) { u = false; break; } t2 = t2->next; } if (u) list_push(r, t->value); t = t->next; } 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 (list_empty(y->val.array)) return state->unit; size_t i = 0; list_t *r = list_new(); list_t *t = y->val.array; while (t) { if (value_equals(t->value, x)) list_push(r, value_new_number(i)); t = t->next; i++; } return value_new_array(r); } value_t *verb_count(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY) return NUMS[1]; return value_new_number(list_length(x->val.array)); } void flatten(value_t *v, list_t *r) { if (v->tag == ARRAY) { list_t *t = v->val.array; while (t) { flatten(t->value, r); t = t->next; } } else list_push(r, v); } value_t *verb_flatten(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || list_empty(x->val.array)) 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; list_t *t = x->val.array; if (list_empty(t)) return x; list_t *r = list_new(); for (ssize_t i = list_length(t) - 1; i >= 0; i--) list_push(r, list_index(t, 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 || list_empty(y->val.array) || !y->val.array->next) 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_new(); list_t *t = y->val.array; while (t) { list_push(r, t->value); t = t->next; } for (size_t i = 0; i < k; i++) { value_t *v; if (rev) { v = r->value; r = r->next; list_push(r, v); } else { v = list_pop(r); r = list_insert(&r, 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 (list_empty(y->val.array)) return y; size_t k = fabs(x->val.number); size_t l = list_length(y->val.array); 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) { list_t *t = x->val.array; if (list_empty(t)) return 0; while (t) { size_t d2 = depthOf(t->value, d + 1); if (d2 > d) d = d2; t = t->next; } 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 (list_empty(x->val.array)) 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 (list_empty(y->val.array)) return NUMS[0]; list_t *t = y->val.array; while (t) { if (value_equals(t->value, x)) return NUMS[1]; t = t->next; } 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 (list_empty(x->val.array)) return x; list_t *t = x->val.array; size_t l = 0; list_t *r = list_new(); while (t) { list_push(r, t->value); t = t->next; l++; } for (size_t i = 0; i < l; i++) { size_t j = rand() % l; value_t *tmp = list_index(r, i); list_set(r, i, list_index(r, j)); list_set(r, 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 (list_empty(x->val.array)) return x; if (y->tag != ARRAY) y = verb_enlist(state, self, x); else if (list_empty(y->val.array)) return y; size_t xl = list_length(x->val.array); list_t *bins = list_new(); for (size_t i = 0; i < xl; i++) { double s; double e; value_t *vs = list_index(x->val.array, 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) : list_index(x->val.array, 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 (list_length(bins) > 0) { list_t *pp = list_index(bins, -1); double *pe = pp->value; 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 = list_length(bins); list_t *r = list_new(); size_t yl = list_length(y->val.array); for (size_t i = 0; i < yl; i++) { value_t *it = list_index(y->val.array, 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->value; double *s = b->value; if (itv < (*s)) { list_push(r, NNUMS[0]); continue; } b = list_index(bins, -1); s = b->next->value; if (itv >= (*s)) { list_push(r, value_new_number(bl - 1)); continue; } double v = NAN; for (size_t j = 0; j < bl; j++) { b = list_index(bins, j); double *s = b->value; double *e = b->next->value; if (itv >= (*s) && itv < (*e)) { v = j; break; } } if (!isnan(v)) list_push(r, value_new_number(v)); } while (bins) { list_t *tmp = bins->next; list_t *b = bins->value; GC_FREE(b->next->value); GC_FREE(b->next); GC_FREE(b->value); GC_FREE(b); GC_FREE(bins); bins = tmp; } 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 (list_empty(x->val.array)) 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 (list_empty(x->val.array)) return x; if (y->tag != ARRAY) y = verb_enlist(state, self, x); else if (list_empty(y->val.array)) return x; if (list_length(x->val.array) != 2) return state->udf; value_t *vs = x->val.array->value; value_t *ve = x->val.array->next->value; 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 = list_length(y->val.array); 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(); size_t i = 0; list_t *t = x->val.array; while (t) { list_push(r, verb_take(state, NULL, value_new_number(i), x)); t = t->next; i++; } 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(); size_t i = 0; list_t *t = x->val.array; while (t) { list_push(r, verb_drop(state, NULL, value_new_number(i), x)); t = t->next; i++; } 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_show(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 || list_empty(y->val.array) || !y->val.array->next) return state->udf; return apply_dyad(state, x, y->val.array->value, y->val.array->next->value); } value_t *verb_shape(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || list_empty(x->val.array)) return state->unit; if (!is_arrays_array(x->val.array)) return verb_enlist(state, NULL, verb_count(state, NULL, x)); if (!x->val.array->next) return verb_enlist(state, NULL, verb_shape(state, NULL, x->val.array->value)); return verb_enpair(state, NULL, verb_count(state, NULL, x), verb_count(state, NULL, x->val.array->value)); } 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 (list_empty(y->val.array)) return y; if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (list_empty(x->val.array)) return state->unit; list_t *r; if (!x->val.array->next) { value_t *a = x->val.array->value; if (a->tag != NUMBER) return state->udf; size_t k = fabs(a->val.number); list_t *t = list_new(); flatten(y, t); r = list_new(); while (k) { list_push(r, t->value); if (t->next) t = t->next; k--; } } else if (x->val.array->next) { value_t *a = x->val.array->value; if (a->tag != NUMBER) return state->udf; value_t *b = x->val.array->next->value; 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); list_t *t = y->val.array; r = list_new(); while (k--) { list_t *rw = list_new(); for (size_t i = 0; i < l; i++) { list_push(rw, t->value); t = t->next; } 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 = list_length(replaces); 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 (list_empty(y->val.array)) return y; char *fmt = value_show(x); char *s = format(fmt, y->val.array); GC_FREE(fmt); list_t *r = list_new(); while (*s) list_push(r, value_new_char(*s++)); 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); list_t *r = list_new(); list_t *t = y->val.array; while (t) { list_push(r, t->value); if (t->next) list_push(r, x); t = t->next; } 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); list_t *r = list_new(); if (s > e) for (ssize_t i = s; i >= e; i--) { if (x->tag == CHAR || y->tag == CHAR) list_push(r, value_new_char(i)); else list_push(r, value_new_number(i)); } else for (ssize_t i = s; i <= e; i++) { if (x->tag == CHAR || y->tag == CHAR) list_push(r, value_new_char(i)); else list_push(r, 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; list_t *t = x->val.array; if (list_empty(t)) return state->udf; size_t i = rand() % list_length(t); return list_index(t, i); } value_t *verb_roll(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (x->tag == NUMBER && y->tag == NUMBER) { list_t *r = list_new(); size_t k = fabs(x->val.number); size_t d = fabs(y->val.number); for (size_t i = 0; i < k; i++) list_push(r, 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; list_t *r = list_new(); while (*s) list_push(r, value_new_char(*s++)); return value_new_array(r); } break; case NUMBER: if (y->tag == CHAR) return value_new_number(y->val._char); else if (y->tag == ARRAY && is_char_array(y->val.array)) { buffer_t *buf = buffer_new(); list_t *t = y->val.array; while (t) { buffer_append(buf, ((value_t *)t->value)->val._char); t = t->next; } 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_show(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_show(x); fprintf(stdout, "%s\n", s); GC_FREE(s); 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_new(); for (size_t i = 0; i < size; i++) list_push(r, value_new_char(s[i])); GC_FREE(s); return value_new_array(r); } else if (x == NUMS[1]) { char line[512]; if (!fgets(line, sizeof(line), stdin)) return state->udf; list_t *r = list_new(); for (size_t i = 0; i < strlen(line); i++) list_push(r, value_new_char(line[i])); return value_new_array(r); } char *path = value_show(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); if (!buf) return state->udf; size = fread(buf, sizeof(unsigned char), size, fd); fclose(fd); GC_FREE(path); list_t *r = list_new(); for (size_t i = 0; i < size; i++) list_push(r, value_new_char(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_show(y); fd = fopen(path, "wb"); if (!fd) { GC_FREE(path); return NNUMS[0]; } } size_t k = 0; list_t *t = x->val.array; while (t) { unsigned char c; value_t *v = t->value; if (v->tag == NUMBER) c = fabs(v->val.number); else if (v->tag == CHAR) c = v->val._char; else break; fputc(c, fd); t = t->next; 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_show(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; if (!buffer) buffer = malloc_checked(buffer_allocated); else buffer = realloc_checked(buffer, buffer_allocated); if (!buffer) { GC_FREE(cmd); pclose(pd); return state->udf; } } 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_new(); for (size_t i = 0; i < buffer_size; i++) list_push(r, value_new_char(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_show(y); files_t *pd; pd = popen2(cmd); if (pd == NULL) { GC_FREE(cmd); return state->udf; } list_t *t = x->val.array; while (t) { unsigned char c; value_t *v = t->value; if (v->tag == NUMBER) c = fabs(v->val.number); else if (v->tag == CHAR) c = v->val._char; else break; fputc(c, pd->in); t = t->next; } 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; if (!buffer) buffer = malloc_checked(buffer_allocated); else buffer = realloc_checked(buffer, buffer_allocated); if (!buffer) { GC_FREE(cmd); pclose2(pd); return state->udf; } } 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_new(); for (size_t i = 0; i < buffer_size; i++) list_push(r, value_new_char(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 (list_empty(y->val.array)) return y; list_t *r = list_new(); size_t l = list_length(y->val.array); size_t k = fabs(x->val.number); while (y->tag == ARRAY && !list_empty(y->val.array)) { list_push(r, 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)) { value_t *n = verb_enpair(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) && x->val.number > 0 && y->val.number > 0) { uint64_t a = (uint64_t)fabs(x->val.number); uint64_t b = (uint64_t)fabs(y->val.number); 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_show(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; } value_t *verb_import(interpreter_t *state, verb_t *self, value_t *x) { char *path = value_show(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); if (!buf) return state->udf; size = fread(buf, sizeof(unsigned char), size, fd); fclose(fd); GC_FREE(path); value_t *v = interpreter_run(state, (char *)buf); GC_FREE(buf); return v; } value_t *verb_explode(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { char *del = value_show(x); char *s = value_show(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[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 || list_empty(y->val.array)) return y; char *del = value_show(x); list_t *r = list_new(); list_t *t = y->val.array; while (t) { char *s = value_show(t->value); char *_s = s; while (*_s) list_push(r, CHARS[*_s++]); GC_FREE(s); if (t->next) { char *s = del; while (*s) list_push(r, CHARS[*s++]); } t = t->next; } GC_FREE(del); 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_new(); for (size_t i = 0; i < k; i++) { list_t *rw = list_new(); for (size_t j = 0; j < k; j++) list_push(rw, NUMS[i == j]); list_push(r, value_new_array(rw)); } return value_new_array(r); } 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(":", 0, 0, 0, udf1, 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), 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("p", 0, 0, 0, print, udf2), DEFVERBD("P", 0, 0, 0, println, udf2), DEFVERBD("f", 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, udf2)}; value_t *_adverb_fold_monad(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || list_empty(x->val.array)) return x; value_t *_v = self->bonds->value; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; value_t *t = x->val.array->value; list_t *tx = x->val.array->next; while (tx) { t = together(state, v, t, tx->value, 0, 0, v->rank[1], v->rank[2]); tx = tx->next; } return t; } value_t *_adverb_fold_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { if (y->tag != ARRAY || list_empty(y->val.array)) return y; value_t *_v = self->bonds->value; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; value_t *t = x; list_t *ty = y->val.array; while (ty) { t = together(state, v, t, ty->value, 0, 0, v->rank[1], v->rank[2]); ty = ty->next; } return t; } value_t *_adverb_scan_monad(interpreter_t *state, verb_t *self, value_t *x) { if (x->tag != ARRAY || list_empty(x->val.array)) return x; value_t *_v = self->bonds->value; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; list_t *r = list_new(); value_t *t = x->val.array->value; list_t *tx = x->val.array->next; list_push(r, t); while (tx) { t = together(state, v, t, tx->value, 0, 0, v->rank[1], v->rank[2]); list_push(r, t); tx = tx->next; } 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 || list_empty(y->val.array)) return y; value_t *_v = self->bonds->value; 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); while (ty) { t = together(state, v, t, ty->value, 0, 0, v->rank[1], v->rank[2]); list_push(r, t); ty = ty->next; } return value_new_array(r); } value_t *_adverb_each_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->value; 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 (list_empty(x->val.array)) 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->value; 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; while (tx && ty) { list_push(r, together(state, v, tx->value, ty->value, 0, 0, v->rank[1], v->rank[2])); tx = tx->next; ty = ty->next; } return value_new_array(r); } value_t *_adverb_converge_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->value; 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->value; 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 (list_empty(y->val.array)) 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->value; 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->value; 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 (list_empty(y->val.array)) 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 || list_empty(x->val.array) || !x->val.array->next) return x; value_t *_v = self->bonds->value; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; list_t *r = list_new(); list_t *p = x->val.array; list_t *t = x->val.array->next; while (t) { list_push(r, together(state, v, t->value, p->value, 0, 0, v->rank[1], v->rank[2])); p = t; t = t->next; } 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 || list_empty(y->val.array)) return y; value_t *_v = self->bonds->value; if (_v->tag != VERB) return state->udf; verb_t *v = _v->val.verb; list_t *r = list_new(); list_t *p = NULL; list_t *t = y->val.array; while (t) { list_push(r, together(state, v, t->value, !p ? x : p->value, 0, 0, v->rank[1], v->rank[2])); p = t; t = t->next; } return value_new_array(r); } value_t *_adverb_reflex_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->value; 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->value; 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->value; 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 i = 0; size_t l = list_length(x->val.array); list_t *t = v->val.array; while (t) { value_t *n = t->value; if (n->tag != NUMBER) break; list_set(r, n->val.number, list_index(x->val.array, i < l ? i : l - 1)); t = t->next; i++; } return value_new_array(r); } value_t *_adverb_filter_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *_v = self->bonds->value; if (_v->tag != VERB) return state->udf; if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (list_empty(x->val.array)) return x; verb_t *v = _v->val.verb; list_t *r = list_new(); list_t *t = x->val.array; while (t) { value_t *b = each_rank(state, v, t->value, 0, v->rank[0]); if (value_is_truthy(b)) list_push(r, t->value); t = t->next; } 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->value; if (v->tag != VERB) return state->udf; if (x->tag != ARRAY) x = verb_enlist(state, NULL, x); else if (list_empty(x->val.array)) return x; list_t *r = list_new(); list_t *t = x->val.array; list_t *p = list_new(); while (t) { value_t *b = apply_monad(state, v, t->value); if (value_is_truthy(b)) { list_push(r, value_new_array(p)); p = list_new(); } else list_push(p, t->value); t = t->next; } 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->value; 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->value; 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->value; 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_new(); \ list_push(nv->bonds, v); \ char *r = value_show(v); \ size_t l = strlen(r) + strlen(__symb) + 1; \ nv->name = malloc_checked(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->value; value_t *v2 = self->bonds->next->value; 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->nil; } value_t *_conjunction_bond_dyad(interpreter_t *state, verb_t *self, value_t *x, value_t *y) { value_t *v1 = self->bonds->value; value_t *v2 = self->bonds->next->value; 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->nil; } value_t *_conjunction_pick_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v1 = self->bonds->value; value_t *v2 = self->bonds->next->value; if (v1->tag != VERB || v2->tag != ARRAY) return state->nil; 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->value; value_t *v2 = self->bonds->next->value; if (v1->tag != VERB || v2->tag != ARRAY) return state->nil; 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->value; value_t *v2 = self->bonds->next->value; 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->value; value_t *v2 = self->bonds->next->value; 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->value; value_t *v2 = self->bonds->next->value; 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->value; value_t *v2 = self->bonds->next->value; if (v1->tag != VERB || v2->tag != NUMBER) return state->udf; unsigned int rank = v2->val.number == INFINITY ? UINT_MAX : fabs(v2->val.number); return together(state, v1->val.verb, x, y, 0, 0, rank, rank); } value_t *_conjunction_monaddyad_monad(interpreter_t *state, verb_t *self, value_t *x) { value_t *v = self->bonds->value; 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->next->value; 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->value; value_t *v2 = self->bonds->next->value; 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->value; value_t *v2 = self->bonds->next->value; 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->value; value_t *v2 = self->bonds->next->value; 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->value; value_t *v2 = self->bonds->next->value; 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]); } #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_new(); \ list_push(nv->bonds, x); \ list_push(nv->bonds, 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(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, "^:"); adverb_t CONJUNCTIONS[] = { {";", NULL, conjunction_bond}, {"?.", NULL, conjunction_pick}, {"?:", NULL, conjunction_while}, {"\":", NULL, conjunction_rank}, {";:", NULL, conjunction_monaddyad}, {"&:", NULL, conjunction_if}, {"^:", NULL, conjunction_under}}; #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; } 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->value; if (x->tag != VERB) return state->nil; 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->value; if (x->tag != VERB) return state->nil; 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_new(); list_push(nv->bonds, 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->value; 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_new(); list_push(nv->bonds, 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; } node = parser_parse_expr(parser); 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_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 { list_t *list = list_new(); for (size_t i = 0; i < strlen(tok->text); i++) list_push(list, value_new_char(tok->text[i])); node = node_new_literal(value_new_array(list)); } break; } if (!node) parser_error(parser, "parse"); parser_eat(parser); return node; } 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) { list_t *as = list_new(); list_push(as, a->v); do { a = parser_parse_atom(parser); list_push(as, a->v); } while ((tok = parser_lookahead(parser, 0)) && tok->tag == tag); 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 && (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) && (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 (;;) { 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 (list_empty(ns) && (tmp = parser_lookahead(parser, 0)) && tmp->tag == T_PUNCT && strcmp(tmp->text, ":") == 0 && (parser_lookahead(parser, 1))) { parser_eat(parser); return node_new1(N_FUN, parser_parse_expr(parser)); } node_t *n = parser_parse_noun(parser, false); if (list_empty(ns) && n->tag == N_LITERAL && n->v->tag == SYMBOL && (tmp = parser_lookahead(parser, 0)) && tmp->tag == T_PUNCT && strcmp(tmp->text, ":") == 0) { parser_eat(parser); return node_new2(N_BIND, n, parser_parse_expr(parser)); } 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 = list_length(ns); if (len < 2) break; if (len >= 3 && is_apply(list_index(ns, -2)) || is_obverse(list_index(ns, -2))) { 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->value; } node_t *parser_parse(parser_t *parser, lexer_t *lexer) { parser->lexer = lexer; parser->pos = 0; parser->end = list_length(parser->lexer->tokens); 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; if (t->value) while (t) { list_t *tmp = t->next; token_t *tok = t->value; if (tok->text) GC_FREE(tok->text); GC_FREE(tok); GC_FREE(t); t = tmp; } value_t *r = interpreter_walk(state, node); GC_FREE(parser); return r; } #include "help.h" const char *VSTR = VER " " __DATE__; 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; } for (int i = 0; i < 256; i++) { CHARS[i] = value_new_const(CHAR); CHARS[i]->val._char = 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[VSTR[i]]); 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[*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; } for (;;) { buffer_t *buffer; char line[256]; buffer = buffer_new(); if (is_interactive) putc('\t', stdout); if (!fgets(line, sizeof(line), stdin)) break; if (is_interactive) { 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 (is_interactive) putc('\t', stdout); if (!fgets(line, sizeof(line), stdin)) return 0; } buffer_append_str(buffer, line); s = buffer_read(buffer); value_t *v = interpreter_run(state, s); GC_FREE(s); s = NULL; if (v->tag != NIL) { table_set(state->env, "it", v); char *s = value_show(v); fputs(s, stdout); if (is_interactive) putc('\n', stdout); } } }