peter
/
universalservice
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
universalservice/examples/lisp/uns_lisp.c

2486 lines
58 KiB
C
Raw Permalink Blame History

/* 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 <stdio.h>
#include <stdarg.h>
#include <string.h>
#include <stdlib.h>
#include <assert.h>
#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 <undefined>) 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 <undefined>)
* 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("<undefined>");
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;
}
Reference in New Issue View Git Blame Copy Permalink