/* 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-splice", "'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; default: uns_string_append_char(gc, &tok->dat, c); } } } 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: abort(); uns_root_remove(gc, &s); 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, "__%lx", 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; } 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); printf("%s\"%s\"", SPC, uns_string_cstring(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"); } /* 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_EXEC_QUASIQUOTE_UNDERFLOW, CPS_EXEC_QUASIQUOTE_OVERFLOW, CPS_EXEC_LAMBDA_UNDERFLOW, CPS_EXEC_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_EXEC_IF_UNDERFLOW, CPS_EXEC_IF_OVERFLOW, CPS_UNQUOTE_INVALID, CPS_UNQUOTE_LIST_INVALID, CPS_NULL_EXPR, CPS_INVALID_CMD, CPS_LIST_INCONSISTENT_LIST, CPS_LIST_UNDERFLOW, CPS_LIST_IMPROPER_LIST, CPS_LIST_BAD_ALIST, CPS_EXEC_INVALID_APPL_LIST, CPS_APP_UNDERFLOW, CPS_FCALL_IMPROPER_LIST, CPS_SWAP_UNDERFLOW, CPS_IF_UNDERFLOW, CPS_LAMBDA_UNDERFLOW, CPS_QUASIQUOTE_UNQUOTE_UNDERFLOW, CPS_QUASIQUOTE_UNQUOTE_OVERFLOW, CPS_QUASIQUOTE_SPLICE_UNDERFLOW, CPS_QUASIQUOTE_SPLICE_OVERFLOW, CPS_QUASIQUOTE_UNDERFLOW, CPS_WRAP_SPLICE_UNDERFLOW, CPS_WRAP_UNDERFLOW, 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_EXEC_QUASIQUOTE_UNDERFLOW", "CPS_EXEC_QUASIQUOTE_OVERFLOW", "CPS_EXEC_LAMBDA_UNDERFLOW", "CPS_EXEC_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_EXEC_IF_UNDERFLOW", "CPS_EXEC_IF_OVERFLOW", "CPS_UNQUOTE_INVALID", "CPS_UNQUOTE_LIST_INVALID", "CPS_NULL_EXPR", "CPS_INVALID_CMD", "CPS_LIST_INCONSISTENT_LIST", "CPS_LIST_UNDERFLOW", "CPS_LIST_IMPROPER_LIST", "CPS_LIST_BAD_ALIST", "CPS_EXEC_INVALID_APPL_LIST", "CPS_APP_UNDERFLOW", "CPS_FCALL_IMPROPER_LIST", "CPS_SWAP_UNDERFLOW", "CPS_IF_UNDERFLOW", "CPS_LAMBDA_UNDERFLOW", "CPS_QUASIQUOTE_UNQUOTE_UNDERFLOW", "CPS_QUASIQUOTE_UNQUOTE_OVERFLOW", "CPS_QUASIQUOTE_SPLICE_UNDERFLOW", "CPS_QUASIQUOTE_SPLICE_OVERFLOW", "CPS_QUASIQUOTE_UNDERFLOW", "CPS_WRAP_SPLICE_UNDERFLOW", "CPS_WRAP_UNDERFLOW" }; /* {K (quote QUOTED)} {cps} = {(quote-> 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}; uns_root_add(gc, &wrapped); wrapped.p = empty_list.p; stack_push(&wrapped, K); stack_push(&wrapped, quoted); stack_push_const(&wrapped, "quote->"); stack_push(prevstack, &wrapped); uns_root_remove(gc, &wrapped); return CPS_CONTINUE; } /* {K (quasiquote E)} {cps} = {K E n} {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}; if (get_type(quoted->p) != CELL) return CPS_EXEC_QUASIQUOTE_UNDERFLOW; if (get_type(CDR(quoted->p)) != EMPTY_LIST) return CPS_EXEC_QUASIQUOTE_OVERFLOW; quoted->p = CAR(quoted->p); uns_root_add(gc, &tmp); alloc_int(&tmp, 1); stack_push(prevstack, &tmp); stack_push(prevstack, quoted); stack_push(prevstack, K); stack_push_const(readstack, "qq"); uns_root_remove(gc, &tmp); return CPS_CONTINUE; } /* {K (lambda l BODY)} {cps} = {k BODY l k K} {cps cps-lambda} */ 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 EMPTY_LIST: case CELL: 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_EXEC_LAMBDA_UNDERFLOW; goto cleanup; } if (get_type(CDR(rest->p)) != EMPTY_LIST) { r = CPS_EXEC_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"); stack_push_const(readstack, "cps"); 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; } /* {K (call/cc f)} {cps} = {(<- (kappa k (@ f k k)) K)} {} */ 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, "K"); /* (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}; enum cps_return r = CPS_CONTINUE; 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) { r = CPS_EXEC_IF_UNDERFLOW; goto end; } e.p = CAR(lst->p); lst->p = CDR(lst->p); if (get_type(lst->p) != CELL) { r = CPS_EXEC_IF_UNDERFLOW; goto end; } b1.p = CAR(lst->p); lst->p = CDR(lst->p); if (get_type(lst->p) != CELL) { r = CPS_EXEC_IF_UNDERFLOW; goto end; } b2.p = CAR(lst->p); if (get_type(CDR(lst->p)) != EMPTY_LIST) { r = CPS_EXEC_IF_OVERFLOW; goto end; } 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); end: return r; } static int reverse(struct uns_ctr *into, struct uns_ctr *from) { struct uns_ctr cell = {0}; struct uns_ctr tmp = {0}; int r = 1; into->p = empty_list.p; uns_root_add(gc, &tmp); uns_root_add(gc, &cell); if (get_type(from->p) == EMPTY_LIST) goto end; if (get_type(from->p) != CELL) { r = 0; goto end; } cell.p = from->p; while (get_type(cell.p) != EMPTY_LIST) { if (get_type(cell.p) != CELL) { r = 0; goto end; } tmp.p = CAR(cell.p); stack_push(into, &tmp); cell.p = CDR(cell.p); } end: uns_root_remove(gc, &tmp); uns_root_remove(gc, &cell); return r; } /* Push to prevstack an assocation list of (gensym . expr), where expr * is evalulated and given the name gensym. * combo_in is modified to be a list of symbols, where complex expressions * are replaced with gensyms. */ static int fcall_lists(struct uns_ctr *prevstack, struct uns_ctr *combo_in ) { struct uns_ctr revcombo = {0}; struct uns_ctr exprs = {0}; struct uns_ctr tmp = {0}; struct uns_ctr symb = {0}; struct uns_ctr alist_cell = {0}; int r = 1; uns_root_add(gc, &revcombo); uns_root_add(gc, &exprs); uns_root_add(gc, &tmp); uns_root_add(gc, &symb); uns_root_add(gc, &alist_cell); revcombo.p = exprs.p = empty_list.p; while (get_type(combo_in->p) != EMPTY_LIST) { if (get_type(combo_in->p) != CELL) { r = 0; goto end; } tmp.p = CAR(combo_in->p); if (get_type(tmp.p) == CELL) { gensym(&symb); cons(&alist_cell, &symb, &tmp); stack_push(&exprs, &alist_cell); stack_push(&revcombo, &symb); } else { stack_push(&revcombo, &tmp); } combo_in->p = CDR(combo_in->p); } if (!reverse(combo_in, &revcombo)) { r = 0; goto end; } stack_push(prevstack, &exprs); end: uns_root_remove(gc, &revcombo); uns_root_remove(gc, &exprs); uns_root_remove(gc, &tmp); uns_root_remove(gc, &symb); uns_root_remove(gc, &alist_cell); return r; } /* {K (F . L)} {cps} = {(@ (symb1 ... symbn) K) [to-eval 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 ) { struct uns_ctr tmp = {0}; struct uns_ctr expr = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &expr); uns_root_add(gc, &tmp); tmp.p = E->p; if (!fcall_lists(prevstack, &tmp)) { r = CPS_FCALL_IMPROPER_LIST; goto end; } /* tmp now has simplified combo */ expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &tmp); stack_push_const(&expr, "A"); /* (__A f l K) */ stack_push(prevstack, &expr); stack_push_const(readstack, "cps-list"); end: uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp); return r; } 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); break; } else if (strcmp(symb, "quasiquote") == 0) { tmp->p = CDR(E->p); r = cps_exec_quasiquote(prevstack, K, tmp, readstack); break; } else if (strcmp(symb, "__lambda") == 0) { tmp->p = CDR(E->p); r = cps_exec_lambda(prevstack, K, tmp, readstack); break; } else if (strcmp(symb, "__call/cc") == 0) { tmp->p = CDR(E->p); r = cps_exec_call_cc(prevstack, K, tmp, readstack); break; } else if (strcmp(symb, "__dynamic-wind") == 0) { tmp->p = CDR(E->p); r = cps_exec_dynamic_wind(prevstack, K, tmp, readstack); break; } else if (strcmp(symb, "unquote") == 0) { r = CPS_UNQUOTE_INVALID; break; } else if (strcmp(symb, "unquote-splice") == 0) { r = CPS_UNQUOTE_LIST_INVALID; break; } else if (strcmp(symb, "if") == 0) { tmp->p = CDR(E->p); r = cps_exec_if(prevstack, K, tmp, readstack); break; } /* FALLTHROUGH */ case CELL: r = cps_exec_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; } /* {K ((symb . E) . B)} {cps-list} = {(kappa symb K) E B} {cps cps-list} */ static enum cps_return cps_list_cell(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *head, struct uns_ctr *readstack ) { struct uns_ctr expr = {0}; struct uns_ctr alist_elem = {0}; struct uns_ctr tmp = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &alist_elem); uns_root_add(gc, &tmp); uns_root_add(gc, &expr); tmp.p = CDR(head->p); /* B */ stack_push(prevstack, &tmp); alist_elem.p = CAR(head->p); if (get_type(alist_elem.p) != CELL) { r = CPS_LIST_BAD_ALIST; goto end; } tmp.p = CDR(alist_elem.p); /* E */ stack_push(prevstack, &tmp); tmp.p = CAR(alist_elem.p); if (get_type(tmp.p) != SYMBOL) { r = CPS_LIST_BAD_ALIST; goto end; } expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &tmp); stack_push_const(&expr, "K"); stack_push(prevstack, &expr); stack_push_const(readstack, "cps-list"); stack_push_const(readstack, "cps"); end: uns_root_remove(gc, &alist_elem); uns_root_remove(gc, &tmp); uns_root_remove(gc, &expr); return r; } /* {K HEAD} {cps-list} */ static enum cps_return cps_list(struct uns_ctr *prevstack, struct uns_ctr *readstack ) { struct uns_ctr K = {0}; struct uns_ctr head = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &K); uns_root_add(gc, &head); if (!stack_pop(prevstack, &K) || !stack_pop(prevstack, &head)) { r = CPS_LIST_UNDERFLOW; goto end; } switch (get_type(head.p)) { case EMPTY_LIST: /* {K '()} {cps-list} = {K} */ stack_push(prevstack, &K); break; case CELL: r = cps_list_cell(prevstack, &K, &head, readstack); break; default: r = CPS_LIST_IMPROPER_LIST; break; } end: uns_root_remove(gc, &K); uns_root_remove(gc, &head); return r; } /* {E0 E1 ... Eplaces} {swap_places} = {E1 ... Eplaces E0} {} */ static enum cps_return cps_swap(struct uns_ctr *prevstack, int places, struct uns_ctr *readstack ) { struct uns_ctr top = {0}; struct uns_ctr tmp = {0}; struct uns_ctr tmpstack = {0}; enum cps_return r = CPS_CONTINUE; int i; uns_root_add(gc, &top); uns_root_add(gc, &tmp); uns_root_add(gc, &tmpstack); if (!stack_pop(prevstack, &top)) { r = CPS_SWAP_UNDERFLOW; goto end; } tmpstack.p = empty_list.p; for (i = 0; i < places; i++) { if (!stack_pop(prevstack, &tmp)) { r = CPS_SWAP_UNDERFLOW; goto end; } stack_push(&tmpstack, &tmp); } tmp.p = tmpstack.p; stack_push(prevstack, &top); for (i = 0; i < places; i++) { stack_pop(&tmpstack, &tmp); stack_push(prevstack, &tmp); } end: uns_root_remove(gc, &top); uns_root_remove(gc, &tmp); uns_root_remove(gc, &tmpstack); return r; } /* {Ktrue Kfalse k Kafter E} {cps-if} = {(kappa e (if-> e (kappa k Ktrue) (kappa k Kfalse) Kafter)) E} {cps} */ static enum cps_return cps_if(struct uns_ctr *prevstack, struct uns_ctr *readstack ) { struct uns_ctr k_true = {0}; struct uns_ctr k_false = {0}; struct uns_ctr k = {0}; struct uns_ctr k_after = {0}; struct uns_ctr expr = {0}; struct uns_ctr tmp = {0}; struct uns_ctr e_expr = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &k_true); uns_root_add(gc, &k_false); uns_root_add(gc, &k); uns_root_add(gc, &k_after); uns_root_add(gc, &expr); uns_root_add(gc, &tmp); if (!stack_pop(prevstack, &k_true) || !stack_pop(prevstack, &k_false) || !stack_pop(prevstack, &k) || !stack_pop(prevstack, &k_after)) { r = CPS_IF_UNDERFLOW; goto end; } gensym(&e_expr); expr.p = empty_list.p; stack_push(&expr, &k_after); tmp.p = empty_list.p; stack_push(&tmp, &k_false); stack_push(&tmp, &k); stack_push_const(&tmp, "K"); stack_push(&expr, &tmp); tmp.p = empty_list.p; stack_push(&tmp, &k_true); stack_push(&tmp, &k); stack_push_const(&tmp, "K"); stack_push(&expr, &tmp); gensym(&e_expr); stack_push(&expr, &e_expr); stack_push_const(&expr, "if->"); tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &e_expr); stack_push_const(&expr, "K"); stack_push(prevstack, &expr); stack_push_const(readstack, "cps"); end: uns_root_remove(gc, &k_true); uns_root_remove(gc, &k_false); uns_root_remove(gc, &k); uns_root_remove(gc, &k_after); uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp); return r; } /* {LAMBODY l k K} {cps-lambda} = {(-> (lambda-kappa l k LAMBODY)) K)} */ static enum cps_return cps_lambda(struct uns_ctr *prevstack) { struct uns_ctr lambody = {0}; struct uns_ctr l = {0}; struct uns_ctr ksymb = {0}; struct uns_ctr K = {0}; struct uns_ctr tmp = {0}; struct uns_ctr body = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &lambody); uns_root_add(gc, &l); uns_root_add(gc, &ksymb); uns_root_add(gc, &K); uns_root_add(gc, &tmp); uns_root_add(gc, &body); if (!stack_pop(prevstack, &lambody) || !stack_pop(prevstack, &l) || !stack_pop(prevstack, &ksymb) || !stack_pop(prevstack, &K)) { r = CPS_LAMBDA_UNDERFLOW; goto end; } body.p = empty_list.p; stack_push(&body, &lambody); stack_push(&body, &ksymb); stack_push(&body, &l); stack_push_const(&body, "LK"); tmp.p = body.p; body.p = empty_list.p; stack_push(&body, &K); stack_push(&body, &tmp); stack_push_const(&body, "->"); stack_push(prevstack, &body); end: uns_root_remove(gc, &lambody); uns_root_remove(gc, &l); uns_root_remove(gc, &ksymb); uns_root_remove(gc, &K); uns_root_remove(gc, &tmp); uns_root_remove(gc, &body); return r; } enum cps_quasiquote_unquote { CPS_QUASIQUOTE_NONE = 0, CPS_QUASIQUOTE_UNQUOTE = 1, CPS_QUASIQUOTE_UNQUOTE_SPLICE = 2 }; static enum cps_quasiquote_unquote is_unquote(struct uns_ctr *E) { struct uns_ctr carptr = {0}; const char *s; enum cps_quasiquote_unquote r = CPS_QUASIQUOTE_NONE; uns_root_add(gc, &carptr); carptr.p = CAR(E->p); if (get_type(carptr.p) == SYMBOL) { s = get_string(&carptr); if (!s) r = CPS_QUASIQUOTE_NONE; else if (strcmp(s, "unquote") == 0) r = CPS_QUASIQUOTE_UNQUOTE; } else if (get_type(carptr.p) == CELL) { carptr.p = CAR(carptr.p); if (get_type(carptr.p) != SYMBOL) goto end; s = get_string(&carptr); if (!s) r = CPS_QUASIQUOTE_NONE; else if (strcmp(s, "unquote-splice") == 0) r = CPS_QUASIQUOTE_UNQUOTE_SPLICE; } end: uns_root_remove(gc, &carptr); return r; } /* {K (,@A . B) 1} {qq} = {(kappa b (append-> a b K)) B 1 a A} {qq wrap cps} {K (,@A . B) n} {qq} = { (kappa b (cons-> aquote b K)) B n aquote a A [- n 1]} {qq wrap-splice qq} */ static enum cps_return cps_quasiquote_splice(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *E, struct uns_ctr *nptr, struct uns_ctr *readstack ) { struct uns_ctr A = {0}; struct uns_ctr asymb = {0}; struct uns_ctr aquote = {0}; struct uns_ctr bsymb = {0}; struct uns_ctr expr = {0}; struct uns_ctr tmp = {0}; long n; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &A); uns_root_add(gc, &asymb); uns_root_add(gc, &aquote); uns_root_add(gc, &bsymb); uns_root_add(gc, &expr); uns_root_add(gc, &tmp); A.p = CAR(E->p); if (get_type(CDR(A.p)) != CELL) { r = CPS_QUASIQUOTE_SPLICE_UNDERFLOW; goto end; } if (get_type(CDR(CDR(A.p))) != EMPTY_LIST) { r = CPS_QUASIQUOTE_SPLICE_OVERFLOW; goto end; } A.p = CAR(CDR(A.p)); n = get_int(nptr); if (n == 1) { gensym(&asymb); gensym(&bsymb); stack_push(prevstack, &A); stack_push(prevstack, &asymb); stack_push(prevstack, nptr); A.p = CDR(E->p); stack_push(prevstack, &A); expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &bsymb); stack_push(&expr, &asymb); stack_push_const(&expr, "append->"); tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &bsymb); stack_push_const(&expr, "K"); stack_push(prevstack, &expr); stack_push_const(readstack, "cps"); stack_push_const(readstack, "wrap"); stack_push_const(readstack, "qq"); } else { alloc_int(&tmp, n - 1); stack_push(prevstack, &tmp); stack_push(prevstack, &A); gensym(&asymb); gensym(&bsymb); gensym(&aquote); A.p = CDR(E->p); stack_push(prevstack, nptr); stack_push(prevstack, &aquote); stack_push(prevstack, &asymb); stack_push(prevstack, &A); expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &bsymb); stack_push(&expr, &aquote); stack_push_const(&expr, "cons->"); tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &bsymb); stack_push_const(&expr, "K"); stack_push(prevstack, &expr); stack_push_const(readstack, "qq"); stack_push_const(readstack, "wrap-splice"); stack_push_const(readstack, "qq"); } end: uns_root_remove(gc, &A); uns_root_remove(gc, &asymb); uns_root_remove(gc, &aquote); uns_root_remove(gc, &bsymb); uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp); return r; } /* {K ,A 1} {qq} = {K A} {cps} {K ,A n} {qq} = {(kappa a (unquote-> a K)) A [- n 1]} {qq} */ static enum cps_return cps_quasiquote_unquote(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *E, struct uns_ctr *nptr, struct uns_ctr *readstack ) { long n; struct uns_ctr expr = {0}; struct uns_ctr tmp = {0}; struct uns_ctr asym = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &expr); uns_root_add(gc, &tmp); uns_root_add(gc, &asym); if (get_type(CDR(E->p)) != CELL) { r = CPS_QUASIQUOTE_UNQUOTE_UNDERFLOW; goto end; } if (get_type(CDR(CDR(E->p))) != EMPTY_LIST) { r = CPS_QUASIQUOTE_UNQUOTE_OVERFLOW; goto end; } expr.p = CAR(CDR(E->p)); n = get_int(nptr); if (n == 1) { stack_push(prevstack, &expr); stack_push(prevstack, K); stack_push_const(readstack, "cps"); } else { gensym(&asym); alloc_int(nptr, n - 1); stack_push(prevstack, nptr); stack_push(prevstack, &expr); expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &asym); stack_push_const(&expr, "unquote->"); tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &asym); stack_push_const(&expr, "K"); stack_push_const(readstack, "qq"); } end: uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp); uns_root_remove(gc, &asym); return r; } /* {K (A . B) n} {qq} = {(kappa b (cons-> a b K)) B n a A n} {qq wrap qq} */ static enum cps_return cps_quasiquote_cons(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *E, struct uns_ctr *n, struct uns_ctr *readstack ) { struct uns_ctr tmp = {0}; struct uns_ctr expr = {0}; struct uns_ctr asym = {0}; struct uns_ctr bsym = {0}; uns_root_add(gc, &expr); uns_root_add(gc, &tmp); uns_root_add(gc, &asym); uns_root_add(gc, &bsym); gensym(&asym); gensym(&bsym); tmp.p = CAR(E->p); stack_push(prevstack, n); stack_push(prevstack, &tmp); stack_push(prevstack, &asym); tmp.p = CDR(E->p); stack_push(prevstack, n); stack_push(prevstack, &tmp); expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, &bsym); stack_push(&expr, &asym); stack_push_const(&expr, "cons->"); tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &bsym); stack_push_const(&expr, "K"); stack_push(prevstack, &expr); stack_push_const(readstack, "qq"); stack_push_const(readstack, "wrap"); stack_push_const(readstack, "qq"); uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp); uns_root_remove(gc, &asym); uns_root_remove(gc, &bsym); return CPS_CONTINUE; } static enum cps_return cps_quasiquote_cell(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *E, struct uns_ctr *n, struct uns_ctr *readstack ) { switch (is_unquote(E)) { case CPS_QUASIQUOTE_NONE: return cps_quasiquote_cons(prevstack, K, E, n, readstack); case CPS_QUASIQUOTE_UNQUOTE: return cps_quasiquote_unquote(prevstack, K, E, n, readstack); case CPS_QUASIQUOTE_UNQUOTE_SPLICE: return cps_quasiquote_splice(prevstack, K, E, n, readstack); } return CPS_QUASIQUOTE_UNDERFLOW; } /* {K E _} {qq} = {(quote-> E K} */ static enum cps_return cps_quasiquote_simple(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *quoted ) { struct uns_ctr expr = {0}; uns_root_add(gc, &expr); expr.p = empty_list.p; stack_push(&expr, K); stack_push(&expr, quoted); stack_push_const(&expr, "quote->"); stack_push(prevstack, &expr); uns_root_remove(gc, &expr); return CPS_CONTINUE; } static enum cps_return cps_quasiquote(struct uns_ctr *prevstack, struct uns_ctr *readstack ) { struct uns_ctr K = {0}; struct uns_ctr expr = {0}; struct uns_ctr number = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &K); uns_root_add(gc, &expr); uns_root_add(gc, &number); if (!stack_pop(prevstack, &K) || !stack_pop(prevstack, &expr) || !stack_pop(prevstack, &number)) { r = CPS_QUASIQUOTE_UNDERFLOW; goto end; } switch (get_type(expr.p)) { case CELL: r = cps_quasiquote_cell(prevstack, &K, &expr, &number, readstack); break; default: r = cps_quasiquote_simple(prevstack, &K, &expr); } end: uns_root_remove(gc, &K); uns_root_remove(gc, &expr); uns_root_remove(gc, &number); return r; } /* {K a} {wrap} = {(kappa a K)} {} */ static enum cps_return cps_wrap(struct uns_ctr *prevstack) { struct uns_ctr K = {0}; struct uns_ctr a = {0}; struct uns_ctr expr = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &K); uns_root_add(gc, &a); uns_root_add(gc, &expr); if (!stack_pop(prevstack, &K) || !stack_pop(prevstack, &a)) { r = CPS_WRAP_UNDERFLOW; goto end; } expr.p = empty_list.p; stack_push(&expr, &K); stack_push(&expr, &a); stack_push_const(&expr, "K"); stack_push(prevstack, &expr); end: uns_root_remove(gc, &K); uns_root_remove(gc, &a); uns_root_remove(gc, &expr); return r; } /* {K aquote a} {wrap-splice} = {(kappa a (unquote-splice-> a (kappa aquote K)))} */ static enum cps_return cps_wrap_splice(struct uns_ctr *prevstack) { struct uns_ctr expr = {0}; struct uns_ctr tmp = {0}; struct uns_ctr K = {0}; struct uns_ctr aquote = {0}; struct uns_ctr a = {0}; enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &expr); uns_root_add(gc, &tmp); uns_root_add(gc, &K); uns_root_add(gc, &aquote); uns_root_add(gc, &a); if (!stack_pop(prevstack, &K) || !stack_pop(prevstack, &aquote) || !stack_pop(prevstack, &a)) { r = CPS_WRAP_SPLICE_UNDERFLOW; goto end; } expr.p = empty_list.p; stack_push(&expr, &K); stack_push(&expr, &aquote); stack_push_const(&expr, "K"); tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &a); stack_push_const(&expr, "unquote-splice->"); tmp.p = expr.p; expr.p = empty_list.p; stack_push(&expr, &tmp); stack_push(&expr, &a); stack_push_const(&expr, "K"); end: uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp); uns_root_remove(gc, &K); uns_root_remove(gc, &aquote); uns_root_remove(gc, &a); 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 if (strcmp(cmd, "cps-list") == 0) { r = cps_list(prevstack, readstack); } else if (strcmp(cmd, "swap2") == 0) { r = cps_swap(prevstack, 2, readstack); } else if (strcmp(cmd, "cps-if") == 0) { r = cps_if(prevstack, readstack); } else if (strcmp(cmd, "cps-lambda") == 0) { r = cps_lambda(prevstack); } else if (strcmp(cmd, "qq") == 0) { r = cps_quasiquote(prevstack, readstack); } else if (strcmp(cmd, "wrap") == 0) { r = cps_wrap(prevstack); } else if (strcmp(cmd, "wrap-splice") == 0) { r = cps_wrap_splice(prevstack); } else { r = CPS_INVALID_CMD; } end: uns_root_remove(gc, &top); return r; } 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}; enum cps_return r; 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: 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); do { printf("Prev: {\n"); display(&prevstack); printf("}\nRead: {\n"); display(&readstack); printf("}\n"); r = cps(&prevstack, &readstack); } while (r == CPS_CONTINUE); printf("%s\n", cps_return_to_string[r]); } cleanup: uns_root_remove(gc, &expr); uns_root_remove(gc, &prevstack); uns_root_remove(gc, &readstack); uns_root_remove(gc, &empty_list); uns_collect(gc); uns_deinit(gc); return 0; }