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

922 lines
22 KiB
C
Raw 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 <string.h>
#include <stdlib.h>
#include "uns.h"
#include "examples/string/uns_string.h"
static Uns_GC gc;
static struct uns_ctr empty_list;
enum token_type {
T_EOF,
LPAREN,
RPAREN,
QUOTE,
QUASIQUOTE,
UNQUOTE,
UNQUOTE_LIST,
T_IDENT,
T_INT,
T_FLOAT,
T_STRING,
T_DOT,
TOKEN_NUM
};
static const char *token2string_repr[TOKEN_NUM] = {
"'EOF",
"(",
")",
"quote",
"quasiquote",
"unquote",
"unquote-list",
"'ident",
"'number",
"'float",
"'string-tok",
"'dot"
};
struct location {
unsigned long line;
unsigned long offset;
};
struct file {
FILE *f;
struct location loc;
};
struct token {
enum token_type typ;
struct uns_ctr dat;
double f;
long i;
};
static int is_ws(int c)
{
return c == '\n' || c == '\t' || c == '\r' || c == '\v' || c == ' ';
}
static int get(struct file *f)
{
int c = getc(f->f);
if (c == '\n') {
f->loc.line++;
f->loc.offset = 0;
} else {
f->loc.offset += 1;
}
return c;
}
static void unget(int c, struct file *f)
{
ungetc(c, f->f);
}
static int get_skipws(struct file *input)
{
int c;
for (;;) {
c = get(input);
if (c == ';') {
do { c = get(input); } while (c != '\n');
unget(c, input);
continue;
}
if (is_ws(c))
continue;
return c;
}
}
static void tok_string(struct file *input, struct token *tok)
{
int c;
tok->typ = T_STRING;
uns_string_alloc(gc, &tok->dat, 32);
for (;;) {
c = get(input);
switch (c) {
case '\\':
c = get(input);
switch (c) {
case ' ': case '\t': case '\r': case '\n': case '\v':
do {
c = get(input);
} while (is_ws(c));
unget(c, input);
continue;
case 'r':
uns_string_append_char(gc, &tok->dat, '\r');
continue;
case 'n':
uns_string_append_char(gc, &tok->dat, '\n');
continue;
case 'v':
uns_string_append_char(gc, &tok->dat, '\v');
continue;
case 't':
uns_string_append_char(gc, &tok->dat, '\t');
continue;
case '"':
uns_string_append_char(gc, &tok->dat, '"');
continue;
default:
uns_string_append_char(gc, &tok->dat, '\\');
uns_string_append_char(gc, &tok->dat, c);
}
case '"': /* " */
return;
}
}
}
static int tonum(int c)
{
switch (c) {
case '0': case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9':
return c - '0';
default:
return -1;
}
}
static void tok_num(struct file *input, struct token *tok, int c)
{
int is_float = 0;
uns_string_alloc(gc, &tok->dat, 32);
do {
if (c == '.' || c == 'e' || c == 'E' || c == '-' || c == '+')
is_float = 1;
uns_string_append_char(gc, &tok->dat, c);
c = get(input);
} while (tonum(c) >= 0 || c == '.' || c == 'e' || c == 'E' || c == '-' || c == '+');
unget(c, input);
if (is_float) {
tok->typ = T_FLOAT;
tok->f = strtod(uns_string_cstring(gc, &tok->dat), NULL);
} else {
tok->typ = T_INT;
tok->i = strtol(uns_string_cstring(gc, &tok->dat), NULL, 10);
}
tok->dat.p = NULL;
}
static int part_of_ident(int c)
{
return !is_ws(c) && c != '(' && c != ')' && c != '`'
&& c != '\'' && c != '\\' && c != '\"' && c != ','
&& c != ';';
}
static void tok_ident(struct file *input, struct token *tok, int c)
{
tok->typ = T_IDENT;
uns_string_alloc(gc, &tok->dat, 32);
do {
uns_string_append_char(gc, &tok->dat, c);
c = get(input);
} while (part_of_ident(c));
unget(c, input);
}
static void tokenize(struct file *input, struct token *tok)
{
int c = get_skipws(input);
int c2;
tok->dat.p = NULL;
switch (c) {
case EOF:
tok->typ = T_EOF;
return;
case '(':
tok->typ = LPAREN;
return;
case ')':
tok->typ = RPAREN;
return;
case '\'':
tok->typ = QUOTE;
return;
case '`':
tok->typ = QUASIQUOTE;
return;
case ',':
c = get(input);
if (c == '@') {
tok->typ = UNQUOTE_LIST;
} else {
unget(c, input);
tok->typ = UNQUOTE;
}
return;
case '"':
tok_string(input, tok);
return;
tok->typ = T_STRING;
return;
case '+': case '-':
c2 = get(input);
unget(c2, input);
if (tonum(c2) >= 0) {
tok_num(input, tok, c);
return;
}
/* FALLTHROUGH */
default:
if (c == '.') {
c2 = get(input);
if (tonum(c2) >= 0) {
unget(c2, input);
tok_num(input, tok, c);
} else if (part_of_ident(c2)) {
unget(c2, input);
tok_ident(input, tok, c);
} else {
tok->typ = T_DOT;
}
} else if (tonum(c) >= 0) {
tok_num(input, tok, c);
} else {
tok_ident(input, tok, c);
}
return;
}
}
enum item_type {
CELL,
LAMBDA,
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 LAMBDA: 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: abort();
}
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 int 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);
}
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_root_remove(gc, &tmp);
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);
}
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_of_type(expr, INTEGER);
loc.p = uns_alloc(gc, sizeof(tok.i), 0);
memcpy(loc.p, &tok.i, sizeof(tok.i));
uns_set(gc, expr->p, 1, UNS_POINTER, loc.p);
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_;
printf("oom\n");
abort();
}
/* 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);
}
static void display(struct uns_ctr *ctr, long indent)
{
struct uns_ctr tmp = {0};
long l;
double f;
if (!ctr->p) {
printf("<undefined>");
return;
}
switch (get_type(ctr->p)) {
case CELL:
uns_root_add(gc, &tmp);
printf("(");
tmp.p = uns_get(gc, ctr->p, 1, NULL);
display(&tmp, indent);
ctr->p = uns_get(gc, ctr->p, 2, NULL);
while (get_type(ctr->p) == CELL) {
tmp.p = uns_get(gc, ctr->p, 1, NULL);
if (get_type(tmp.p) == CELL) {
printf("\n");
for (l = 0; l < indent; l++)
printf(" ");
display(&tmp, indent + 1);
} else {
printf(" ");
display(&tmp, indent);
}
ctr->p = uns_get(gc, ctr->p, 2, NULL);
}
switch (get_type(ctr->p)) {
case EMPTY_LIST:
printf(")");
break;
default:
printf(" . ");
display(ctr, indent);
printf(")");
break;
}
uns_root_remove(gc, &tmp);
return;
case INTEGER:
memcpy(&l, uns_get(gc, ctr->p, 1, NULL), sizeof(long));
printf("%ld", l);
return;
case FLOAT:
memcpy(&f, uns_get(gc, ctr->p, 1, NULL), sizeof(double));
printf("%f", f);
return;
case STRING:
tmp.p = uns_get(gc, ctr->p, 1, NULL);
uns_root_add(gc, &tmp);
printf("\"%s\"", uns_string_cstring(gc, &tmp));
uns_root_remove(gc, &tmp);
return;
case SYMBOL:
tmp.p = uns_get(gc, ctr->p, 1, NULL);
uns_root_add(gc, &tmp);
printf("%s", uns_string_cstring(gc, &tmp));
uns_root_remove(gc, &tmp);
return;
case EMPTY_LIST:
printf("'()");
return;
default:
abort();
}
}
/* Contination passing style.
* Continuation passing IR uses explicit statements instead of
* shorthand (i.e. (__pass K atom) instead of (K atom)).
*
* CPS primitives:
* (__pass k e): Pass e to continuation k. e must be an atom.
* (__apply f l k): Pass the argument list "l" to "f", and pass
* the result to "k". "f" must be a "__klambda".
* (__konstruct e body): Construct a continuation that takes a
* single argument. This is shortened to "\e body" below.
* (__klambda l k body): Constructs a function that takes a single
* value along with a continuation.
* (__primitive-> args...) The primitive, but the last argument is a
* continuation.
* cps{atom, K} = (__pass K atom)
* cps{(__lambda l E), K} = (__pass K (__klambda l k cps{E,k}))
* cps{(F A1 ... AN), K} =
* cps{F, \f cps_list{'(), (A1 ... AN), \l (__apply f l K)}}
* cps_list{L, '(), K} = (__pass K L)
* cps_list{L, (A . B), K} =
* cps{A, \a cps_list{append{L,a}, B, K}}
* cps{(if E B1 B2), K} =
* cps{E, \e (__if* e (\K' cps{B1,K'}) (\K' cps{B1,K'}) K)}
*
* cps{(__define symb E}, K} = cps{E, \e (__define-> symb e K)}
* cps{(set! symb E), K} = cps{E, \e (__set!-> symb e K)}
*/
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 file input = {0};
input.loc.line = 1;
init();
uns_root_add(gc, &expr);
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, 1);
printf("\n");
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");
break;
}
}
uns_root_remove(gc, &expr);
uns_deinit(gc);
return 0;
}
Reference in New Issue View Git Blame Copy Permalink