/* Copyright (c) 2024, Peter McGoron * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1) Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2) Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #include #include #include #include #include #include "uns.h" #include "examples/string/uns_string.h" static Uns_GC gc; static struct uns_ctr empty_list; #define CAR(p) uns_get(gc, p, 1, NULL) #define CDR(p) uns_get(gc, p, 2, NULL) static void die(const char *fmt, ...) { va_list va; va_start(va, fmt); vfprintf(stderr, fmt, va); va_end(va); exit(1); } enum token_type { T_EOF, LPAREN, RPAREN, QUOTE, QUASIQUOTE, UNQUOTE, UNQUOTE_LIST, T_IDENT, T_INT, T_FLOAT, T_STRING, T_DOT, TOKEN_NUM }; static const char *token2string_repr[TOKEN_NUM] = { "'EOF", "(", ")", "quote", "quasiquote", "unquote", "unquote-list", "'ident", "'number", "'float", "'string-tok", "'dot" }; struct location { unsigned long line; unsigned long offset; }; struct file { FILE *f; struct location loc; }; struct token { enum token_type typ; struct uns_ctr dat; double f; long i; }; static int is_ws(int c) { return c == '\n' || c == '\t' || c == '\r' || c == '\v' || c == ' '; } static int get(struct file *f) { int c = getc(f->f); if (c == '\n') { f->loc.line++; f->loc.offset = 0; } else { f->loc.offset += 1; } return c; } static void unget(int c, struct file *f) { ungetc(c, f->f); } static int get_skipws(struct file *input) { int c; for (;;) { c = get(input); if (c == ';') { do { c = get(input); } while (c != '\n'); unget(c, input); continue; } if (is_ws(c)) continue; return c; } } static void tok_string(struct file *input, struct token *tok) { int c; tok->typ = T_STRING; uns_string_alloc(gc, &tok->dat, 32); for (;;) { c = get(input); switch (c) { case '\\': c = get(input); switch (c) { case ' ': case '\t': case '\r': case '\n': case '\v': do { c = get(input); } while (is_ws(c)); unget(c, input); continue; case 'r': uns_string_append_char(gc, &tok->dat, '\r'); continue; case 'n': uns_string_append_char(gc, &tok->dat, '\n'); continue; case 'v': uns_string_append_char(gc, &tok->dat, '\v'); continue; case 't': uns_string_append_char(gc, &tok->dat, '\t'); continue; case '"': uns_string_append_char(gc, &tok->dat, '"'); continue; default: uns_string_append_char(gc, &tok->dat, '\\'); uns_string_append_char(gc, &tok->dat, c); } case '"': /* " */ return; } } } static int tonum(int c) { switch (c) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': return c - '0'; default: return -1; } } static void tok_num(struct file *input, struct token *tok, int c) { int is_float = 0; uns_string_alloc(gc, &tok->dat, 32); do { if (c == '.' || c == 'e' || c == 'E' || c == '-' || c == '+') is_float = 1; uns_string_append_char(gc, &tok->dat, c); c = get(input); } while (tonum(c) >= 0 || c == '.' || c == 'e' || c == 'E' || c == '-' || c == '+'); unget(c, input); if (is_float) { tok->typ = T_FLOAT; tok->f = strtod(uns_string_cstring(gc, &tok->dat), NULL); } else { tok->typ = T_INT; tok->i = strtol(uns_string_cstring(gc, &tok->dat), NULL, 10); } tok->dat.p = NULL; } static int part_of_ident(int c) { return !is_ws(c) && c != '(' && c != ')' && c != '`' && c != '\'' && c != '\\' && c != '\"' && c != ',' && c != ';'; } static void tok_ident(struct file *input, struct token *tok, int c) { tok->typ = T_IDENT; uns_string_alloc(gc, &tok->dat, 32); do { uns_string_append_char(gc, &tok->dat, c); c = get(input); } while (part_of_ident(c)); unget(c, input); } static void tokenize(struct file *input, struct token *tok) { int c = get_skipws(input); int c2; tok->dat.p = NULL; switch (c) { case EOF: tok->typ = T_EOF; return; case '(': tok->typ = LPAREN; return; case ')': tok->typ = RPAREN; return; case '\'': tok->typ = QUOTE; return; case '`': tok->typ = QUASIQUOTE; return; case ',': c = get(input); if (c == '@') { tok->typ = UNQUOTE_LIST; } else { unget(c, input); tok->typ = UNQUOTE; } return; case '"': tok_string(input, tok); return; tok->typ = T_STRING; return; case '+': case '-': c2 = get(input); unget(c2, input); if (tonum(c2) >= 0) { tok_num(input, tok, c); return; } /* FALLTHROUGH */ default: if (c == '.') { c2 = get(input); if (tonum(c2) >= 0) { unget(c2, input); tok_num(input, tok, c); } else if (part_of_ident(c2)) { unget(c2, input); tok_ident(input, tok, c); } else { tok->typ = T_DOT; } } else if (tonum(c) >= 0) { tok_num(input, tok, c); } else { tok_ident(input, tok, c); } return; } } enum item_type { CELL, INTEGER, FLOAT, STRING, SYMBOL, EMPTY_LIST, LISP_NULL }; /* TODO: if the allocator allows for weak references, do a lookup of * the symbol in the tree, and if it exists, use that instead of the * token. * * This check should always be ignored on collectors without weak * references. */ static void alloc_of_type(struct uns_ctr *ctr, int typ) { void *p; int fields; int i; switch (typ) { case CELL: fields = 2; break; case INTEGER: fields = 1; break; case STRING: fields = 1; break; case SYMBOL: fields = 1; break; case FLOAT: fields = 1; break; case EMPTY_LIST: fields = 0; break; case LISP_NULL: fields = 0; break; default: die("Invalid type %d\n", typ); } ctr->p = uns_alloc_rec(gc, fields + 1, 0); p = uns_alloc(gc, sizeof(int), 0); memcpy(p, &typ, sizeof(int)); uns_set(gc, ctr->p, 0, UNS_POINTER, p); for (i = 0; i < fields; i++) uns_set(gc, ctr->p, i + 1, UNS_POINTER, NULL); } static void alloc_int(struct uns_ctr *ctr, long i) { struct uns_ctr p = {0}; alloc_of_type(ctr, INTEGER); p.p = uns_alloc(gc, sizeof(i), 0); memcpy(p.p, &i, sizeof(i)); uns_set(gc, ctr->p, 1, UNS_POINTER, p.p); } static enum item_type get_type(Uns_ptr p) { int typ; void *innerp; if (!p) return LISP_NULL; innerp = uns_get(gc, p, 0, NULL); memcpy(&typ, innerp, sizeof(int)); return typ; } static void alloc_symbol_from_cstring(struct uns_ctr *ctr, const char *s, size_t slen) { struct uns_ctr str = {0}; uns_root_add(gc, &str); uns_string_alloc(gc, &str, slen); uns_string_append_bytes(gc, &str, s, slen); alloc_of_type(ctr, SYMBOL); uns_set(gc, ctr->p, 1, UNS_POINTER, str.p); uns_root_remove(gc, &str); } static const char *get_string(struct uns_ctr *ctr) { struct uns_ctr s = {0}; uns_root_add(gc, &s); switch (get_type(ctr->p)) { case STRING: case SYMBOL: break; default: return NULL; } s.p = uns_get(gc, ctr->p, 1, NULL); s.p = uns_string_cstring(gc, &s); uns_root_remove(gc, &s); return s.p; } static long get_int(struct uns_ctr *ctr) { long r; switch (get_type(ctr->p)) { case INTEGER: break; default: return 0; } memcpy(&r, uns_get(gc, ctr->p, 1, NULL), sizeof(r)); return r; } #define alloc_symbol_const(ctr, s) alloc_symbol_from_cstring(ctr, s, sizeof(s) - 1) enum expr_stack_state { EXPR_STACK_INITIAL, EXPR_STACK_QUOTELIKE, EXPR_STACK_SURROUND_OTHER, EXPR_STACK_START_LIST, EXPR_STACK_IN_LIST, EXPR_STACK_IMPROPER_LIST, EXPR_STACK_IMPROPER_LIST_END, EXPR_STACK_INVALID }; enum expr_stack_fields { EXPR_FIELD_NEXT, EXPR_FIELD_PTR, EXPR_FIELD_STATE, EXPR_FIELD_NUM }; static void expr_stack_push(struct uns_ctr *stack, struct uns_ctr *loc, enum expr_stack_state state) { struct uns_ctr tmp = {0}; uns_root_add(gc, &tmp); tmp.p = stack->p; stack->p = uns_alloc_rec(gc, EXPR_FIELD_NUM, 0); uns_set(gc, stack->p, EXPR_FIELD_NEXT, UNS_POINTER, tmp.p); uns_set(gc, stack->p, EXPR_FIELD_PTR, UNS_POINTER, loc->p); tmp.p = uns_alloc(gc, sizeof(state), 0); memcpy(tmp.p, &state, sizeof(state)); uns_set(gc, stack->p, EXPR_FIELD_STATE, UNS_POINTER, tmp.p); uns_root_remove(gc, &tmp); } static enum expr_stack_state expr_stack_state(struct uns_ctr *stack) { enum expr_stack_state r; if (!stack->p) return EXPR_STACK_INVALID; memcpy(&r, uns_get(gc, stack->p, EXPR_FIELD_STATE, NULL), sizeof(r)); return r; } static void expr_stack_change_state(struct uns_ctr *stack, enum expr_stack_state newst) { memcpy(uns_get(gc, stack->p, EXPR_FIELD_STATE, NULL), &newst, sizeof(newst)); } static void expr_stack_ctr(struct uns_ctr *stack, struct uns_ctr *loc) { loc->p = uns_get(gc, stack->p, EXPR_FIELD_PTR, NULL); } static int expr_stack_pop(struct uns_ctr *stack) { if (!stack->p) return 0; stack->p = uns_get(gc, stack->p, EXPR_FIELD_NEXT, NULL); return 1; } enum parser_return { EXPR_PARSE_OK, EXPR_PARSE_EOF, EXPR_PARSE_INCOMPLETE, EXPR_PARSE_EXCESS_RPAREN, EXPR_PARSE_INVALID_EMPTY_LIST, EXPR_PARSE_IMPROPER_LIST_OVERFLOW, EXPR_PARSE_BAD_IMPROPER_LIST, EXPR_PARSE_BAD_STACK_START, EXPR_PARSE_BAD_QUOTE, EXPR_PARSE_INTERNAL_ERROR }; static int tok_to_type(enum token_type tokt) { switch (tokt) { case T_IDENT: return SYMBOL; case T_STRING: return STRING; default: return -1; } } /* Parse expressions using an explicit stack. * This is feasible to to hand-written and has the advantage that error * recovery is much easier than recursion (implicit stack). * * The stack consists of a LIFO: * [previous value][container][parser state] * * The implementation stores containers on the stack and when a container * is complete or an atom is read, it is stored in "expr" and the stack * is modified. */ static enum parser_return expr_parse(struct file *input, struct uns_ctr *expr) { struct uns_ctr stack = {0}; struct uns_ctr loc = {0}; struct uns_ctr new_cell = {0}; struct token tok = {0}; int store = 0; enum parser_return r = EXPR_PARSE_OK; uns_root_add(gc, &stack); uns_root_add(gc, &loc); uns_root_add(gc, &tok.dat); uns_root_add(gc, &new_cell); /* Allocate expr->p to be a single pointer. */ expr->p = uns_alloc_rec(gc, 1, 0); /* Initialize the stack with the final result. */ expr_stack_push(&stack, expr, EXPR_STACK_INITIAL); while (stack.p) { tokenize(input, &tok); switch (tok.typ) { case LPAREN: /* Push a new cell onto the stack and parse it later. */ alloc_of_type(expr, CELL); expr_stack_push(&stack, expr, EXPR_STACK_START_LIST); break; case QUOTE: case QUASIQUOTE: case UNQUOTE: case UNQUOTE_LIST: /* push (token-name ) onto the stack, and have * it point to the first cell. */ alloc_of_type(&loc, CELL); alloc_symbol_from_cstring(expr, token2string_repr[tok.typ], strlen(token2string_repr[tok.typ])); uns_set(gc, loc.p, 1, UNS_POINTER, expr->p); alloc_of_type(expr, CELL); uns_set(gc, loc.p, 2, UNS_POINTER, expr->p); uns_set(gc, expr->p, 2, UNS_POINTER, empty_list.p); if (tok.typ == QUOTE || tok.typ == QUASIQUOTE) expr_stack_push(&stack, &loc, EXPR_STACK_QUOTELIKE); else expr_stack_push(&stack, &loc, EXPR_STACK_SURROUND_OTHER); break; /* All atoms are allocated into "expr" and will be stored in the * container after the switch. */ case T_IDENT: case T_STRING: alloc_of_type(expr, tok_to_type(tok.typ)); uns_set(gc, expr->p, 1, UNS_POINTER, tok.dat.p); store = 1; break; case T_INT: alloc_int(expr, tok.i); store = 1; break; case T_FLOAT: alloc_of_type(expr, FLOAT); loc.p = uns_alloc(gc, sizeof(tok.f), 0); memcpy(loc.p, &tok.f, sizeof(tok.f)); uns_set(gc, expr->p, 1, UNS_POINTER, loc.p); store = 1; break; case RPAREN: switch (expr_stack_state(&stack)) { case EXPR_STACK_START_LIST: /* Empty list found. Pop the cell and discard it. * If we are not in a "surround" state, report error. * Replace the surround state with an empty list. */ expr_stack_pop(&stack); if (!stack.p) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } if (expr_stack_state(&stack) != EXPR_STACK_QUOTELIKE) { r = EXPR_PARSE_INVALID_EMPTY_LIST; goto end; } /* Discard quote/quasiquote and store the empty list instead. */ if (!expr_stack_pop(&stack)) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } expr->p = empty_list.p; store = 1; break; case EXPR_STACK_IN_LIST: /* In a list, there are two things on the stack: * first cell and last cell. * Place the empty list in the cdr of the last cell, * and then discard the last cell. Put the first cell into expr * and store it in the container in the stack before it. */ expr_stack_ctr(&stack, &loc); if (get_type(loc.p) != CELL) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } uns_set(gc, loc.p, 2, UNS_POINTER, empty_list.p); /* FALLTHROUGH */ case EXPR_STACK_IMPROPER_LIST_END: /* CDR of the list has been filled. Pop the last cell. */ expr_stack_pop(&stack); if (!stack.p) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } /* Put the first cell in expr, and read it into the next item * of the stack. */ expr_stack_ctr(&stack, expr); expr_stack_pop(&stack); store = 1; break; case EXPR_STACK_INITIAL: /* Expression is not balanced. */ r = EXPR_PARSE_EXCESS_RPAREN; goto end; case EXPR_STACK_IMPROPER_LIST: /* (values .) is an invalid expression. */ r = EXPR_PARSE_BAD_IMPROPER_LIST; goto end; case EXPR_STACK_QUOTELIKE: case EXPR_STACK_SURROUND_OTHER: /* ,) ') etc are invalid */ r = EXPR_PARSE_BAD_QUOTE; goto end; case EXPR_STACK_INVALID: r = EXPR_PARSE_INTERNAL_ERROR; goto end; } break; case T_DOT: if (expr_stack_state(&stack) != EXPR_STACK_IN_LIST) { r = EXPR_PARSE_BAD_IMPROPER_LIST; goto end; } expr_stack_change_state(&stack, EXPR_STACK_IMPROPER_LIST); break; case T_EOF: /* If EOF is encountered in the middle of an expression, repor * that. Otherwise, the parser reads nothing. */ if (expr_stack_state(&stack) != EXPR_STACK_INITIAL) { r = EXPR_PARSE_INCOMPLETE; goto end; } r = EXPR_PARSE_EOF; goto end; case TOKEN_NUM: r = EXPR_PARSE_INTERNAL_ERROR; goto end; } /* If store is true, that means "expr" contains a value to * be placed into the container at the top of the stack. * * This is a loop because some cases need to cascade values up the * stack without acting on a token. When the loop stops, further * action requires a new token to be read. */ while (store) switch (expr_stack_state(&stack)) { case EXPR_STACK_INVALID: r = EXPR_PARSE_INTERNAL_ERROR; goto end; case EXPR_STACK_START_LIST: /* The current thing on the stack is the first part of the * list. Add the expression to car of the cell, and add * push a pointer to the cell. This is the last cell in * the list. */ expr_stack_ctr(&stack, &loc); if (get_type(loc.p) != CELL) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } uns_set(gc, loc.p, 1, UNS_POINTER, expr->p); expr_stack_push(&stack, &loc, EXPR_STACK_IN_LIST); store = 0; break; case EXPR_STACK_IN_LIST: /* The pointer on the top of the stack is the end of the * list. Add a new list to it's cdr, and put expr into * the car of the new end of the list. */ expr_stack_ctr(&stack, &loc); if (get_type(loc.p) != CELL) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } alloc_of_type(&new_cell, CELL); uns_set(gc, loc.p, 2, UNS_POINTER, new_cell.p); uns_set(gc, new_cell.p, 1, UNS_POINTER, expr->p); expr_stack_pop(&stack); expr_stack_push(&stack, &new_cell, EXPR_STACK_IN_LIST); store = 0; break; case EXPR_STACK_IMPROPER_LIST: /* Add the expression to the cdr of the last element. * Set the state to expect the end of an improper list. */ expr_stack_ctr(&stack, &loc); uns_set(gc, loc.p, 2, UNS_POINTER, expr->p); if (get_type(loc.p) != CELL) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } expr_stack_change_state(&stack, EXPR_STACK_IMPROPER_LIST_END); store = 0; break; case EXPR_STACK_IMPROPER_LIST_END: r = EXPR_PARSE_IMPROPER_LIST_OVERFLOW; goto end; case EXPR_STACK_QUOTELIKE: case EXPR_STACK_SURROUND_OTHER: /* Expression at the top of the stack is * (surrouding-thing ) * Replace (car (cdr (top-of-stack)) with expr. */ expr_stack_ctr(&stack, &loc); if (get_type(loc.p) != CELL) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } loc.p = uns_get(gc, loc.p, 2, NULL); if (get_type(loc.p) != CELL) { r = EXPR_PARSE_INTERNAL_ERROR; goto end; } uns_set(gc, loc.p, 1, UNS_POINTER, expr->p); /* Get the head of the quoted value again. */ expr_stack_ctr(&stack, expr); expr_stack_pop(&stack); /* This value needs to be stored somewhere. Continue looping. */ store = 1; break; case EXPR_STACK_INITIAL: /* Finished parsing an expression at toplevel. */ expr_stack_ctr(&stack, &loc); uns_set(gc, loc.p, 0, UNS_POINTER, expr->p); /* Prepare for return. */ expr->p = loc.p; expr_stack_pop(&stack); if (stack.p) { r = EXPR_PARSE_BAD_STACK_START; goto end; } store = 0; break; } } end: uns_root_remove(gc, &stack); uns_root_remove(gc, &loc); uns_root_remove(gc, &tok.dat); uns_root_remove(gc, &new_cell); return r; } static void oom(Uns_GC gc_) { (void)gc_; die("oom\n"); } /* TODO: Make UNS_Lisp its own library and move this out. */ extern Uns_GC uns_lisp_gc_init(void); static void init(void) { gc = uns_lisp_gc_init(); uns_set_oom(gc, oom); uns_root_add(gc, &empty_list); alloc_of_type(&empty_list, EMPTY_LIST); } /* Continuation passing style translation using a stack machine. * * There are two stacks: the argument stack and the read stack. * At each step, the program reads the top of the read stack, which must * be a recognized command. It then executes it. * * A command can modify the stacks in any way, although in most cases * a command will modify the argument stack and push values to the read * stack. * * Notation: * {arg-top} {read-top} => {new-arg-top} {new-read-top} * The specified values in each stack are removed, and new values are put * in their place. Values beyond those stack locations are not modified. * * Values in parentheses are LISP data. Values in angle brackets [ ] are * meta-functions (they are modifications to LISP data implemented in C). * All caps are LISP expressions, lowercase is a symbol. Commands are also * symbols. */ static void gensym(struct uns_ctr *id) { static unsigned long l = 0; char buf[64]; int len; len = sprintf(buf, "__%08lx", l); alloc_symbol_from_cstring(id, buf, len); l++; } static void cons(struct uns_ctr *into, struct uns_ctr *car, struct uns_ctr *cdr) { alloc_of_type(into, CELL); uns_set(gc, into->p, 1, UNS_POINTER, car->p); uns_set(gc, into->p, 2, UNS_POINTER, cdr->p); } static void stack_push(struct uns_ctr *stack, struct uns_ctr *newval) { struct uns_ctr tmp = {0}; uns_root_add(gc, &tmp); tmp.p = stack->p; cons(stack, newval, &tmp); uns_root_remove(gc, &tmp); } static void stack_push_symbol(struct uns_ctr *stack, const char *s, size_t l) { struct uns_ctr tmp = {0}; uns_root_add(gc, &tmp); alloc_symbol_from_cstring(&tmp, s, l); stack_push(stack, &tmp); uns_root_remove(gc, &tmp); } #define stack_push_const(stack, s) stack_push_symbol(stack, s, sizeof(s) - 1) static int stack_pop(struct uns_ctr *stack, struct uns_ctr *into) { if (!stack->p) return 0; switch (get_type(stack->p)) { case EMPTY_LIST: return 0; case CELL: break; default: die("Invalid type in CPS stack\n"); } into->p = CAR(stack->p); stack->p = CDR(stack->p); return 1; } /* Initialize to {__toplevel EXPR} {__cps __return} */ static void cps_init(struct uns_ctr *prevstack, struct uns_ctr *readstack, struct uns_ctr *expr) { prevstack->p = empty_list.p; readstack->p = empty_list.p; stack_push_const(readstack, "return"); stack_push_const(readstack, "cps"); stack_push(prevstack, expr); stack_push_const(prevstack, "__toplevel"); } enum cps_return { CPS_CONTINUE, CPS_NOTHING_ON_STACK, CPS_DATA_ON_READ_STACK, CPS_STACK_UNDERFLOW, CPS_CANNOT_CALL_TYPE, CPS_QUOTE_UNDERFLOW, CPS_QUOTE_OVERFLOW, CPS_QUASIQUOTE_UNDERFLOW, CPS_QUASIQUOTE_OVERFLOW, CPS_LAMBDA_UNDERFLOW, CPS_LAMBDA_OVERFLOW, CPS_INVALID_LAMBDA_FORMAL, CPS_DYNAMIC_WIND_UNDERFLOW, CPS_DYNAMIC_WIND_SYMBOL, CPS_DYNAMIC_WIND_OVERFLOW, CPS_CALLCC_UNDERFLOW, CPS_CALLCC_SYMBOL, CPS_CALLCC_OVERFLOW, CPS_IF_UNDERFLOW, CPS_IF_OVERFLOW, CPS_UNQUOTE_INVALID, CPS_UNQUOTE_LIST_INVALID, CPS_NULL_EXPR, CPS_INVALID_CMD, CPS_RETURN_LEN }; static const char *cps_return_to_string[CPS_RETURN_LEN] = { "CPS_CONTINUE", "CPS_NOTHING_ON_STACK", "CPS_DATA_ON_READ_STACK", "CPS_STACK_UNDERFLOW", "CPS_CANNOT_CALL_TYPE", "CPS_QUOTE_UNDERFLOW", "CPS_QUOTE_OVERFLOW", "CPS_QUASIQUOTE_UNDERFLOW", "CPS_QUASIQUOTE_OVERFLOW", "CPS_LAMBDA_UNDERFLOW", "CPS_LAMBDA_OVERFLOW", "CPS_INVALID_LAMBDA_FORMAL", "CPS_DYNAMIC_WIND_UNDERFLOW", "CPS_DYNAMIC_WIND_SYMBOL", "CPS_DYNAMIC_WIND_OVERFLOW", "CPS_CALLCC_UNDERFLOW", "CPS_CALLCC_SYMBOL", "CPS_CALLCC_OVERFLOW", "CPS_IF_UNDERFLOW", "CPS_IF_OVERFLOW", "CPS_UNQUOTE_INVALID", "CPS_UNQUOTE_LIST_INVALID", "CPS_INVALID_CMD", "CPS_NULL_EXPR" }; /* {K (quote QUOTED)} {cps} = {(-> QUOTED K)} */ static enum cps_return cps_exec_quote(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *quoted, struct uns_ctr *readstack ) { struct uns_ctr wrapped = {0}; if (get_type(quoted->p) != CELL) return CPS_QUOTE_UNDERFLOW; if (get_type(CDR(quoted->p)) != EMPTY_LIST) return CPS_QUOTE_OVERFLOW; quoted->p = CAR(quoted->p); uns_root_add(gc, &wrapped); wrapped.p = empty_list.p; stack_push(&wrapped, K); stack_push(&wrapped, quoted); stack_push_const(&wrapped, "__->"); stack_push(prevstack, &wrapped); uns_root_remove(gc, &wrapped); return CPS_CONTINUE; } /* Start quasiquotation: * {K (quasiquote E)} {cps} = {K 1 E} {cps-quasiquote} */ static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *quoted, struct uns_ctr *readstack ) { struct uns_ctr tmp = {0}; struct uns_ctr tmpint = {0}; const long i = 1; if (get_type(quoted->p) != CELL) return CPS_QUASIQUOTE_UNDERFLOW; if (get_type(CDR(quoted->p)) != EMPTY_LIST) return CPS_QUASIQUOTE_OVERFLOW; quoted->p = CAR(quoted->p); stack_push(prevstack, quoted); uns_root_add(gc, &tmp); alloc_of_type(&tmp, INTEGER); uns_root_add(gc, &tmpint); tmpint.p = uns_alloc(gc, sizeof(i), 0); memcpy(tmpint.p, &i, sizeof(i)); uns_set(gc, tmp.p, 1, UNS_POINTER, tmpint.p); stack_push(prevstack, &tmp); stack_push(prevstack, K); stack_push_const(readstack, "__quasiquote"); uns_root_remove(gc, &tmpint); uns_root_remove(gc, &tmp); return CPS_CONTINUE; } /* {K (lambda l BODY)} {cps} = {k BODY l k K} {cps cps-lambda} {LAMBODY l k K} {cps-lambda} = {(-> (lambda l (kappa k LAMBODY))) K)} */ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *rest, struct uns_ctr *readstack ) { struct uns_ctr tmpsym = {0}; struct uns_ctr tmp = {0}; enum cps_return r = CPS_CONTINUE; if (get_type(rest->p) != CELL) { r = CPS_LAMBDA_UNDERFLOW; goto cleanup; } uns_root_add(gc, &tmpsym); uns_root_add(gc, &tmp); gensym(&tmpsym); stack_push(prevstack, K); stack_push(prevstack, &tmpsym); /* (lambda l body) \ tmp.p */ tmp.p = CAR(rest->p); switch (get_type(tmp.p)) { case SYMBOL: case LISP_NULL: case EMPTY_LIST: break; default: r = CPS_INVALID_LAMBDA_FORMAL; goto cleanup; } stack_push(prevstack, &tmp); rest->p = CDR(rest->p); if (get_type(rest->p) != CELL) { r = CPS_LAMBDA_UNDERFLOW; goto cleanup; } if (get_type(CDR(rest->p)) != EMPTY_LIST) { r = CPS_LAMBDA_OVERFLOW; goto cleanup; } tmp.p = CAR(rest->p); /* (lambda l body) tmp.p / */ stack_push(prevstack, &tmp); stack_push(prevstack, &tmpsym); stack_push_const(readstack, "cps-lambda"); cleanup: uns_root_remove(gc, &tmp); uns_root_remove(gc, &tmpsym); return r; } /* {K (dynamic-wind before thunk after)} {cps} = {(kappa/handle before after (kappa k (@ thunk '() k)) K ) } {} * (kappa/handle before after KTHUNK K) * pushes "before" and "after" to the list of dynamic-wind handlers * for the continuation in KTHUNK. Every continuation constructed with * kappa inside KTHUNK has these handlers appended, but continuations * bound outside the dynamic-wind context do not have them appended. * For instance, the "k" in the kappa form above does not have the * dynamic-wind handlers added to it. * * The result from KTHUNK is passed to K, which does not have the * handlers attached to it. */ static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *lst, struct uns_ctr *readstack ) { struct uns_ctr expr = {0}; struct uns_ctr tmp1 = {0}; struct uns_ctr bound_k = {0}; struct uns_ctr before = {0}; struct uns_ctr thunk = {0}; struct uns_ctr after = {0}; if (get_type(lst->p) != CELL) return CPS_DYNAMIC_WIND_UNDERFLOW; before.p = CAR(lst->p); if (get_type(before.p) != SYMBOL) return CPS_DYNAMIC_WIND_SYMBOL; lst->p = CDR(lst->p); if (get_type(lst->p) != CELL) return CPS_DYNAMIC_WIND_UNDERFLOW; thunk.p = CAR(lst->p); if (get_type(thunk.p) != SYMBOL) return CPS_DYNAMIC_WIND_SYMBOL; lst->p = CDR(lst->p); if (get_type(lst->p) != CELL) return CPS_DYNAMIC_WIND_UNDERFLOW; after.p = CAR(lst->p); if (get_type(after.p) != SYMBOL) return CPS_DYNAMIC_WIND_SYMBOL; if (get_type(CDR(lst->p)) != EMPTY_LIST) return CPS_DYNAMIC_WIND_OVERFLOW; uns_root_add(gc, &expr); uns_root_add(gc, &tmp1); uns_root_add(gc, &bound_k); uns_root_add(gc, &before); uns_root_add(gc, &thunk); uns_root_add(gc, &after); gensym(&bound_k); expr.p = empty_list.p; stack_push(&expr, &bound_k); stack_push(&expr, &empty_list); stack_push(&expr, &thunk); stack_push_const(&expr, "__A"); /* (__A thunk '() bound_k) */ tmp1.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp1); stack_push(&expr, &bound_k); stack_push_const(&expr, "__K"); /* (__K bound_k (__A thunk '() bound_k)) */ tmp1.p = expr.p; expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &tmp1); stack_push(&expr, &after); stack_push(&expr, &before); stack_push_const(&expr, "__K/H"); /* (__K/H before after (...) K) */ stack_push(prevstack, &expr); uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp1); uns_root_remove(gc, &bound_k); uns_root_remove(gc, &before); uns_root_remove(gc, &thunk); uns_root_remove(gc, &after); return CPS_CONTINUE; } static enum cps_return cps_exec_call_cc(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *lst, struct uns_ctr *readstack ) { struct uns_ctr f = {0}; struct uns_ctr newk = {0}; struct uns_ctr tmp = {0}; struct uns_ctr expr = {0}; if (get_type(lst->p) != CELL) return CPS_CALLCC_UNDERFLOW; f.p = CAR(lst->p); if (get_type(f.p) != SYMBOL) return CPS_CALLCC_SYMBOL; if (get_type(CDR(lst->p)) != EMPTY_LIST) return CPS_CALLCC_OVERFLOW; /* {(<- (kappa k (@ f k k)) K)} {} */ uns_root_add(gc, &tmp); uns_root_add(gc, &expr); uns_root_add(gc, &f); uns_root_add(gc, &newk); gensym(&newk); expr.p = empty_list.p; stack_push(&expr, &newk); stack_push(&expr, &newk); stack_push(&expr, &f); stack_push_const(&expr, "__A"); /* (__A f k k) */ tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &newk); stack_push_const(&expr, "kappa"); /* (kappa k (__A f k k)) */ tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &tmp); stack_push_const(&expr, "__<-"); /* (__<- (...) K) */ stack_push(prevstack, &expr); uns_root_remove(gc, &tmp); uns_root_remove(gc, &expr); uns_root_remove(gc, &f); uns_root_remove(gc, &newk); return CPS_CONTINUE; } /* {K (if E B1 B2} {cps} = {k B1 k B2 k K E} {cps swap2 cps cps-if} */ static enum cps_return cps_exec_if(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *lst, struct uns_ctr *readstack ) { struct uns_ctr newk = {0}; struct uns_ctr b1 = {0}; struct uns_ctr b2 = {0}; struct uns_ctr e = {0}; uns_root_add(gc, &newk); uns_root_add(gc, &e); uns_root_add(gc, &b1); uns_root_add(gc, &b2); gensym(&newk); if (get_type(lst->p) != CELL) return CPS_IF_UNDERFLOW; e.p = CAR(lst->p); lst->p = CDR(lst->p); if (get_type(lst->p) != CELL) return CPS_IF_UNDERFLOW; b1.p = CAR(lst->p); lst->p = CDR(lst->p); if (get_type(lst->p) != CELL) return CPS_IF_UNDERFLOW; b2.p = CAR(lst->p); if (get_type(CDR(lst->p)) != EMPTY_LIST) return CPS_IF_OVERFLOW; stack_push(prevstack, &e); stack_push(prevstack, K); stack_push(prevstack, &newk); stack_push(prevstack, &b2); stack_push(prevstack, &newk); stack_push(prevstack, &b1); stack_push(prevstack, &newk); stack_push_const(readstack, "cps-if"); stack_push_const(readstack, "cps"); stack_push_const(readstack, "swap2"); stack_push_const(readstack, "cps"); uns_root_remove(gc, &newk); uns_root_remove(gc, &e); uns_root_remove(gc, &b1); uns_root_remove(gc, &b2); return CPS_CONTINUE; } /* {K (f . L)} {cps} = {(kappa l (@ f l K)) '() L} {cps-list} */ static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *E, struct uns_ctr *readstack ) { /* CAR(E.p) is the symbol */ struct uns_ctr tmp = {0}; struct uns_ctr expr = {0}; struct uns_ctr l = {0}; uns_root_add(gc, &expr); uns_root_add(gc, &tmp); uns_root_add(gc, &l); gensym(&l); expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &l); tmp.p = CAR(E->p); stack_push(&expr, &tmp); stack_push_const(&expr, "__A"); /* (__A f l K) */ tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &l); stack_push_const(&expr, "__K"); /* (__K l (...)) */ tmp.p = CDR(E->p); stack_push(prevstack, &tmp); stack_push(prevstack, &empty_list); stack_push(prevstack, &expr); stack_push_const(readstack, "cps-list"); uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp); uns_root_remove(gc, &l); return CPS_CONTINUE; } /* {K (F . L)} {cps} = {(kappa l (@ f l K)) '() L f F} {cps-list cps-app} */ static enum cps_return cps_exec_compound_fcall(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *E, struct uns_ctr *readstack ) { struct uns_ctr f = {0}; struct uns_ctr l = {0}; struct uns_ctr tmp = {0}; struct uns_ctr expr = {0}; uns_root_add(gc, &f); uns_root_add(gc, &l); uns_root_add(gc, &tmp); uns_root_add(gc, &expr); gensym(&f); gensym(&l); tmp.p = CAR(E->p); stack_push(prevstack, &tmp); stack_push(prevstack, &f); tmp.p = CDR(E->p); stack_push(prevstack, &tmp); stack_push(prevstack, &empty_list); expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &l); stack_push(&expr, &f); stack_push_const(&expr, "__A"); /* (__A f l K) */ tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &l); stack_push_const(&expr, "__K"); /* (__K l (f l K)) */ stack_push(prevstack, &expr); stack_push_const(readstack, "cps-app"); stack_push_const(readstack, "cps-list"); uns_root_remove(gc, &f); uns_root_remove(gc, &l); uns_root_remove(gc, &tmp); uns_root_remove(gc, &expr); return CPS_CONTINUE; } static enum cps_return cps_exec_cell(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *E, struct uns_ctr *tmp, struct uns_ctr *readstack ) { const char *symb; enum cps_return r; tmp->p = CAR(E->p); switch (get_type(tmp->p)) { case INTEGER: case FLOAT: case STRING: case EMPTY_LIST: case LISP_NULL: r = CPS_CANNOT_CALL_TYPE; break; case SYMBOL: symb = get_string(tmp); if (strcmp(symb, "quote") == 0) { tmp->p = CDR(E->p); r = cps_exec_quote(prevstack, K, tmp, readstack); } else if (strcmp(symb, "quasiquote") == 0) { tmp->p = CDR(E->p); r = cps_exec_quasiquote(prevstack, K, tmp, readstack); } else if (strcmp(symb, "__lambda") == 0) { tmp->p = CDR(E->p); r = cps_exec_lambda(prevstack, K, tmp, readstack); } else if (strcmp(symb, "__call/cc") == 0) { /* {K (call/cc f)} {cps} = {(<- (kappa k (@ f k k)) K)} {} */ tmp->p = CDR(E->p); r = cps_exec_call_cc(prevstack, K, tmp, readstack); } else if (strcmp(symb, "__dynamic-wind") == 0) { tmp->p = CDR(E->p); r = cps_exec_dynamic_wind(prevstack, K, tmp, readstack); } else if (strcmp(symb, "unquote") == 0) { r = CPS_UNQUOTE_INVALID; } else if (strcmp(symb, "unquote-list") == 0) { r = CPS_UNQUOTE_LIST_INVALID; } else if (strcmp(symb, "if") == 0) { tmp->p = CDR(E->p); r = cps_exec_if(prevstack, K, tmp, readstack); } else { r = cps_exec_fcall(prevstack, K, E, readstack); } break; case CELL: r = cps_exec_compound_fcall(prevstack, K, E, readstack); } return r; } /* {K E} {cps} */ static enum cps_return cps_exec(struct uns_ctr *prevstack, struct uns_ctr *readstack) { struct uns_ctr K = {0}; struct uns_ctr E = {0}; struct uns_ctr tmp = {0}; enum cps_return r = CPS_CONTINUE; tmp.p = empty_list.p; uns_root_add(gc, &K); uns_root_add(gc, &E); uns_root_add(gc, &tmp); if (!stack_pop(prevstack, &K)) { r = CPS_STACK_UNDERFLOW; goto end; } if (!stack_pop(prevstack, &E)) { r = CPS_STACK_UNDERFLOW; goto end; } switch (get_type(E.p)) { /* {(-> atom K)} {} */ case INTEGER: case STRING: case SYMBOL: case FLOAT: case EMPTY_LIST: stack_push(&tmp, &K); stack_push(&tmp, &E); stack_push_const(&tmp, "__->"); stack_push(prevstack, &tmp); break; case CELL: r = cps_exec_cell(prevstack, &K, &E, &tmp, readstack); break; case LISP_NULL: r = CPS_NULL_EXPR; break; } end: uns_root_remove(gc, &tmp); uns_root_remove(gc, &E); uns_root_remove(gc, &K); return r; } static enum cps_return cps(struct uns_ctr *prevstack, struct uns_ctr *readstack) { struct uns_ctr top = {0}; const char *cmd; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &top); if (!stack_pop(readstack, &top)) { r = CPS_NOTHING_ON_STACK; goto end; } if (get_type(top.p) != SYMBOL) { r = CPS_DATA_ON_READ_STACK; goto end; } cmd = get_string(&top); if (strcmp(cmd, "cps") == 0) { r = cps_exec(prevstack, readstack); } else { r = CPS_INVALID_CMD; } end: uns_root_remove(gc, &top); return r; } static void display(struct uns_ctr *ctr) { long indent = 0; long list_part = 0; int add_space = 0; struct uns_ctr stack = {0}; struct uns_ctr top = {0}; struct uns_ctr ival = {0}; struct uns_ctr tmp = {0}; struct uns_ctr exprstore = {0}; long l; double f; #define SPC (add_space ? " " : "") uns_root_add(gc, &stack); uns_root_add(gc, &top); uns_root_add(gc, &ival); uns_root_add(gc, &tmp); uns_root_add(gc, &exprstore); stack.p = empty_list.p; alloc_int(&ival, 0); cons(&top, &ival, ctr); /* (0 . expr) */ stack_push(&stack, &top); while (stack_pop(&stack, &top)) { ival.p = CAR(top.p); list_part = get_int(&ival); top.p = CDR(top.p); switch(get_type(top.p)) { case INTEGER: memcpy(&l, uns_get(gc, top.p, 1, NULL), sizeof(long)); printf("%s%ld", SPC, l); break; case FLOAT: memcpy(&f, uns_get(gc, top.p, 1, NULL), sizeof(double)); printf("%s%f", SPC, f); break; case STRING: tmp.p = uns_get(gc, top.p, 1, NULL); uns_root_add(gc, &tmp); printf("%s\"%s\"", SPC, uns_string_cstring(gc, &tmp)); uns_root_remove(gc, &tmp); break; case SYMBOL: tmp.p = uns_get(gc, top.p, 1, NULL); printf("%s%s", SPC, uns_string_cstring(gc, &tmp)); break; case EMPTY_LIST: if (list_part) { printf(")"); indent--; } else { printf("%s'()", SPC); } break; case LISP_NULL: printf(""); break; case CELL: alloc_int(&ival, 1); exprstore.p = CDR(top.p); cons(&tmp, &ival, &exprstore); stack_push(&stack, &tmp); alloc_int(&ival, 0); exprstore.p = CAR(top.p); cons(&tmp, &ival, &exprstore); stack_push(&stack, &tmp); if (!list_part) { if (add_space) { printf("\n"); for (l = 0; l < indent; l++) { printf(" "); } } else { printf("%s", SPC); } indent++; printf("("); add_space = 0; } break; } if (get_type(top.p) != CELL) add_space = 1; } uns_root_remove(gc, &stack); uns_root_remove(gc, &top); uns_root_remove(gc, &ival); uns_root_remove(gc, &tmp); uns_root_remove(gc, &exprstore); printf("\n"); } static void error(struct location *loc, const char *emsg) { fprintf(stderr, "%ld:%ld: ", loc->line, loc->offset); fprintf(stderr, "%s\n", emsg); } int main(void) { struct uns_ctr expr = {0}; struct uns_ctr prevstack = {0}; struct uns_ctr readstack = {0}; struct file input = {0}; input.loc.line = 1; init(); uns_root_add(gc, &expr); uns_root_add(gc, &prevstack); uns_root_add(gc, &readstack); input.f = stdin; while (!feof(input.f)) { expr.p = NULL; switch (expr_parse(&input, &expr)) { case EXPR_PARSE_OK: fprintf(stderr, "parse finished\n"); expr.p = uns_get(gc, expr.p, 0, NULL); display(&expr); break; case EXPR_PARSE_INCOMPLETE: error(&input.loc, "EOF before expression was finished"); break; case EXPR_PARSE_EXCESS_RPAREN: error(&input.loc, "Unbalanced parentheses"); break; case EXPR_PARSE_INVALID_EMPTY_LIST: error(&input.loc, "Invalid syntax for empty list (either '() or `'())"); break; case EXPR_PARSE_BAD_QUOTE: error(&input.loc, "Invalid syntax for quotes/unquotes"); break; case EXPR_PARSE_IMPROPER_LIST_OVERFLOW: error(&input.loc, "too many values at end of improper list (must be exactly one)"); case EXPR_PARSE_BAD_IMPROPER_LIST: error(&input.loc, "Bad syntax for improper list (must be (value . value))"); break; case EXPR_PARSE_INTERNAL_ERROR: error(&input.loc, "Bug in implementation\n"); break; case EXPR_PARSE_BAD_STACK_START: error(&input.loc, "Bug: bottom of stack not correct\n"); break; case EXPR_PARSE_EOF: error(&input.loc, "EOF\n"); goto cleanup; } cps_init(&prevstack, &readstack, &expr); fprintf(stderr, "cps: %s\n", cps_return_to_string[cps(&prevstack, &readstack)]); printf("Prev: {\n"); display(&prevstack); printf("}\nRead: {\n"); display(&readstack); printf("}\n"); } cleanup: uns_root_remove(gc, &expr); uns_root_remove(gc, &prevstack); uns_root_remove(gc, &readstack); uns_deinit(gc); return 0; }