lambda calculus parser
#include #include #include #include #include int debugdisp; int debugatlas; int debugparen; int debugparse; struct node { struct node *next, *prev, *parent, *list; int depth; enum {sub, lambda, term, dbterm, lterm} type; char value; int index; int noparen; }; struct var; struct ref { struct ref *prev, *next; struct var *var; struct node *ref; }; struct var { struct var **atlas; struct var *prev, *next; char value; struct node *binding; struct ref *terms; }; int leftwidth(struct node *tree) { int left, right; if(!tree) return 0; left = leftwidth(tree->list) + 1; right = leftwidth(tree->next) - 1; return left > right ? left : right; } int rightwidth(struct node *tree) { int left, right; if(!tree) return 0; left = rightwidth(tree->list) - 1; right = rightwidth(tree->next) + 1; return left > right ? left : right; } int height(struct node *tree) { if(!tree) return 0; if(tree->prev) return 1 + height(tree->prev); if(tree->parent) return 1 + height(tree->parent); return 0; } void dispwidths(struct node *tree) { if(!tree) return; dispwidths(tree->list); printf("%d/%c%d[%p]%d:%d%c%c\\%d\n", leftwidth(tree), tree->list ? '-' : ' ', height(tree), tree, tree->type, tree->index, tree->value ? tree->value : '-', tree->next ? '-' : ' ', rightwidth(tree)); dispwidths(tree->next); } int tallywidths(struct node *tree, int depth, int textlen) { if(!tree) return 0; return tallywidths(tree->list, depth, textlen) + tallywidths(tree->next, depth, textlen) + (depth == height(tree) ? leftwidth(tree) + rightwidth(tree) + textlen : 0); } void dispdepthsub(struct node *tree, int d, int w, int cols, char *buf) { if(!tree) return; dispdepthsub(tree->list, d, w, cols, buf); if(height(tree) == d) { int left, right, length, textlen; left = leftwidth(tree); right = rightwidth(tree); length = cols * (left + right + 3) / w; if(debugdisp) { printf("%p:L%d,R%d (tally%d) [%dcol]: fieldsize %d\n", tree, left, right, w, cols, length); } snprintf(buf, cols + 1, "%d:%c", tree->type, tree->value ? tree->value : '-'); buf[cols] = '\0'; textlen = strlen(buf); if(debugdisp) { printf("%d ch: '%s'\n", textlen, buf); } length = length / 2 - textlen; if(debugdisp) { printf("offset %d -> ", length); } length -= length < 0 ? length - 1 : 0; if(debugdisp) { printf("%d -> ", length); } if(textlen + 2 * length >= cols) { length -= length + (textlen - cols / 2) + textlen % 2; } if(debugdisp) { printf("%d\n", length); } if(debugdisp) { printf("move %d by %d\n", textlen, length); } memmove(buf + length, buf, textlen); if(debugdisp) { printf("fill %d\n", length); } memset(buf, ' ', length); if(debugdisp) { printf("fill %d at %d\n", length, length + textlen); } memset(buf + length + textlen, ' ', length); buf[cols] = '\0'; fputs(buf, stdout); } dispdepthsub(tree->next, d, w, cols, buf); } void dispdepth(struct node *tree, int depth, int columns, char *buf) { int width; width = tallywidths(tree, depth, 3); dispdepthsub(tree, depth, width, columns, buf); fputc('\n', stdout); } void disptree(struct node *tree) { int max, depth, columns; char *colstr, *buf; max = maxheight(tree); colstr = getenv("COLUMNS"); if(colstr) { if(debugdisp) { printf("env:%s\n", colstr); } colstr = strchr(colstr, '='); if(colstr) { if(debugdisp) { printf("atoi(%s)=", colstr); } columns = atoi(colstr); if(debugdisp) { printf("%d\n", columns); } if(!columns) columns = 72; } else columns = 72; } else columns = 72; buf = (char *) malloc(columns + 1); if(!buf) return; for(depth = 0; depth <= max; ++depth) { dispdepth(tree, depth, columns, buf); } free(buf); } int maxdepth(struct node *tree) { int left, right; if(!tree) return 0; left = maxdepth(tree->list); right = maxdepth(tree->next); return left ? (right ? (left > right ? left : right) : left) : (right ? right : tree->depth); } int maxheight(struct node *tree) { int left, right; if(!tree) return 0; left = maxheight(tree->list); right = maxheight(tree->next); return 1 + (left > right ? left : right); } void addref(struct var **atlas, struct node *term) { struct var *var; struct node *binding; struct ref *ref; if(!term || !atlas) return; for(binding = term; binding; binding = binding->parent) { if(binding->type == lambda && binding->list && binding->list->type == lterm && binding->list->value == term->value) { break; } } for(var = *atlas; var && var->next; var = var->next) { if(var->next->value >= term->value) break; } if(!var) { if(debugatlas) { printf("start with %p=%d:%c\n", term, term->type, term->value); } var = (struct var *) malloc(sizeof(struct var)); if(!var) return; var->next = NULL; var->prev = NULL; var->value = 0; } else if(var->value < term->value && !var->next) { if(debugatlas) { printf("appending %p=%d:%c\n", term, term->type, term->value); } var->next = (struct var *) malloc(sizeof(struct var)); if(!var->next) return; var->next->next = NULL; var->next->prev = var; var->next->value = 0; var = var->next; } else if(var->value > term->value && !var->next) { struct var *insert; if(debugatlas) { printf("prepending %p=%d:%c\n", term, term->type, term->value); } insert = (struct var *) malloc(sizeof(struct var)); if(!insert) return; insert->next = var; insert->prev = var->prev; var->prev = insert; insert->value = 0; var = insert; } else if(var->value == term->value && !var->next) { if(var->binding != binding) { struct var *insert; if(debugatlas) { printf("b-appending %p=%d:%c\n", term, term->type, term->value); } insert = (struct var *) malloc(sizeof(struct var)); if(!insert) return; insert->next = var->next; var->next = insert; insert->prev = var; insert->value = 0; var = insert; } else if(debugatlas) { printf("head has [%p]%c\n", binding, term->value); } } else if(var->next->value > term->value) { struct var *insert; if(debugatlas) { printf("inserting %p=%d:%c\n", term, term->type, term->value); } insert = (struct var *) malloc(sizeof(struct var)); if(!insert) return; insert->next = var->next; var->next->prev = insert; insert->prev = var; insert->value = 0; var->next = insert; var = insert; } else { if(var->next->binding != binding) { struct var *insert; if(debugatlas) { printf("b-inserting %p=%d:%c\n", term, term->type, term->value); } insert = (struct var *) malloc(sizeof(struct var)); if(!insert) return; insert->next = var->next; var->next->prev = insert; insert->prev = var; insert->value = 0; var->next = insert; var = insert; } else if(debugatlas) { printf("found [%p]%c\n", binding, term->value); } } if(!*atlas) *atlas = var; var->binding = binding; if(!var->value) { var->atlas = atlas; var->value = term->value; } ref = (struct ref *) malloc(sizeof(struct ref)); if(!ref) return; ref->prev = NULL; ref->next = var->terms; if(var->terms) { if(debugatlas) { printf("new ref [%p]%d:%c\n", binding, term->type, term->value); } var->terms->prev = ref; } else if(debugatlas) { printf("1st ref [%p]%d:%c\n", binding, term->type, term->value); } var->terms = ref; ref->var = var; ref->ref = term; } void buildatlassub(struct var **atlas, struct node *tree) { if(!tree || !atlas) return; if(tree->type == term || tree->type == lterm || tree->type == dbterm) { printf("atlas %p: adding %p=%d:%c\n", atlas, tree, tree->type, tree->value); addref(atlas, tree); } buildatlassub(atlas, tree->list); buildatlassub(atlas, tree->next); } void displayatlas(struct var *atlas) { struct var *var; struct ref *ref; for(var = atlas; var; var = var->next) { printf("[%p]%c:\n", var->binding, var->value); for(ref = var->terms; ref; ref = ref->next) { printf("* [%p]%d:%c\n", ref->ref, ref->ref ? ref->ref->type : -1, ref->ref ? ref->ref->value : '-'); } } } struct node *newchild(struct node *parent) { struct node *rv; rv = (struct node *) malloc(sizeof(struct node)); if(rv) { rv->list = NULL; rv->noparen = 0; rv->type = sub; rv->value = 0; rv->prev = NULL; rv->next = NULL; rv->index = -1; if(parent) { rv->depth = 1 + parent->depth; rv->parent = parent; parent->list = rv; } else { rv->depth = 0; rv->parent = NULL; } } return rv; } struct node *newnode(struct node *prev) { struct node *rv; if(prev && (prev->type != term && prev->type != dbterm) && !prev->list) return newchild(prev); rv = (struct node *) malloc(sizeof(struct node)); if(rv) { rv->list = NULL; rv->noparen = 0; rv->type = sub; rv->value = 0; rv->index = -1; if(prev) { rv->prev = prev; rv->depth = prev->depth; rv->parent = prev->parent; rv->next = prev->next; prev->next = rv; } else { rv->prev = NULL; rv->depth = 0; rv->parent = NULL; rv->next = NULL; } } return rv; } void display(struct node *tree) { if(tree) { printf("[%d]", tree->depth); if(tree->type == term) printf("T:%c", tree->value); else if(tree->type == lterm) printf("LT:%c", tree->value); else if(tree->type == dbterm) printf("T=%d:%c", tree->index, tree->value); else { if(!tree->noparen) { printf("%c(", tree->type == sub ? 's' : 'L'); display(tree->list); fputc(')', stdout); } else { fputc(tree->type == sub ? 's' : 'L', stdout); display(tree->list); } } if(tree->next) { fputs(", ", stdout); display(tree->next); } } } void fdisplay(struct node *tree) { if(tree) { if(tree->type == term) printf("%c", tree->value); else if(tree->type == lterm) { if(debugdisp) { printf("{%dP%d}", tree->parent ? tree->parent->type : -1, tree->parent ? tree->parent->noparen : -1); } if(!tree->parent || tree->parent->type != lambda || tree->parent && tree->parent->type == lambda && !tree->parent->noparen) printf("%c.[", tree->value); else printf("%c.", tree->value); } else if(tree->type == dbterm) printf("%c", tree->value); else if(tree->type == sub) { if(!tree->noparen) { fputc('(', stdout); fdisplay(tree->list); fputc(')', stdout); } else fdisplay(tree->list); } else if(tree->type == lambda) { fputc('\\', stdout); if(debugdisp) { printf("{%d}", tree->noparen); } fdisplay(tree->list); if(!tree->noparen) fputc(']', stdout); } if(tree->next) { fdisplay(tree->next); } } } void dbdisplay(struct node *tree) { if(tree) { if(tree->type == term) printf("%c", tree->value); else if(tree->type == lterm) { if(!tree->parent || tree->parent->type != lambda || tree->parent && tree->parent->type == lambda && !tree->parent->noparen) fputc('[', stdout); } else if(tree->type == dbterm) printf("%d", tree->index); else if(tree->type == sub) { if(!tree->noparen) { fputc('(', stdout); dbdisplay(tree->list); fputc(')', stdout); } else dbdisplay(tree->list); } else if(tree->type == lambda) { fputc('\\', stdout); dbdisplay(tree->list); if(!tree->noparen) fputc(']', stdout); } if(tree->next) { dbdisplay(tree->next); } } } void displaynl(struct node *tree) { display(tree); fputc('\n', stdout); } void fdisplaynl(struct node *tree) { fdisplay(tree); fputc('\n', stdout); } void dbdisplaynl(struct node *tree) { dbdisplay(tree); fputc('\n', stdout); } void debruijn(struct node *tree) { if(tree) { if(term == tree->type) { int levels; struct node *pursuit; levels = 0; if(debugparse) { printf("?db:%c\n", tree->value); } for(pursuit = tree->parent; pursuit; pursuit = pursuit->parent) { if(pursuit->type == lambda) ++levels; if(debugparse) { printf("lv%d %c vs. %d,%d:%c\n", levels, tree->value, pursuit->type, pursuit->list ? pursuit->list->type : -1, pursuit->list ? (term == pursuit->list->type || lterm == pursuit->list->type ? pursuit->list->value : '-') : '*'); } if(pursuit->type == lambda && pursuit->list && (pursuit->list->type == term || pursuit->list->type == lterm) && pursuit->list->value == tree->value) { if(pursuit->list != tree) { tree->index = levels; tree->type = dbterm; if(debugparse) { printf("%d=db:%c\n", levels, tree->value); } } else { if(debugparse) { printf("lt:%c\n", tree->value); } tree->type = lterm; } break; } } } if(tree->list) debruijn(tree->list); if(tree->next) debruijn(tree->next); } } int ldepth(struct node *node) { int depth = 0; struct node *walk; for(walk = node; node; walk = walk->parent) { if(lambda == walk->type) ++depth; } return depth; } void remparens(struct node *node) { if(!node) return; if(debugparen) { fdisplay(node); printf(" %c->P\n", node->type == sub ? 's' : (node->type == lambda ? 'L' : '-')); } if(node->type == sub || node->type == lambda) { if(!node->prev && (!node->next || node->next && node->next->type != sub) && (!node->list || node->list->type != lambda)) { struct node *child; for(child = node->list; child; child = child->next) if(child->type == lambda) break; if(!child) { node->noparen = 1; if(debugparen) { fputs("1:", stdout); fdisplaynl(node); } } } if(node->next && !node->next->next && node->next->type != sub) { struct node *child; for(child = node->list; child; child = child->next) if(child->type == lambda || (child != node->list && child->type == sub)) break; if(!child) { node->noparen = 1; if(debugparen) { fputs("2:", stdout); fdisplaynl(node); } } } if(node->type == sub && node->list && !node->list->next && (node->list->type != lambda || !node->next)) { node->noparen = 1; if(debugparen) { fputs("3:", stdout); fdisplaynl(node); } } if(node->type == lambda && !node->next) { node->noparen = 1; if(debugparen) { fputs("4:", stdout); fdisplaynl(node); } } } remparens(node->list); remparens(node->next); if(node->next && (node->next->type == sub || node->next->type == lambda) && !node->next->noparen) { struct node *child; for(child = node->list; child; child = child->next) if(child->type == lambda) return; if(node->list && node->list->next && node->list->type != sub) return; if(debugparen) { printf("<-%c ", node->type == sub ? 's' : (node->type == lambda ? 'L' : '-')); fdisplay(node); } node->noparen = 1; if(debugparen) { fputs(" ->P 5:", stdout); fdisplaynl(node); } } } void topremparens(struct node *tree) { if(!tree) return; if(!tree->next && (tree->type == sub || tree->type == lambda)) tree->noparen = 1; remparens(tree); } int haslambda(struct node *node) { struct node *walk; for(walk = node; walk; walk = walk->next) if(walk->type == lambda) return 1; return 0; } void remparens2(struct node *tree) { if(!tree) return; if(tree->type == lambda && !tree->next) { if(debugparen) { fdisplay(tree); fputs(" L.extends: ", stdout); } tree->noparen = 1; if(debugparen) { fdisplaynl(tree); } } if(tree->type == sub && tree->list && tree->list->type == lambda && !tree->next) { if(debugparen) { fdisplay(tree); fputs(" sLextends: ", stdout); } tree->noparen = 1; if(debugparen) { fdisplaynl(tree); } } if(tree->type == sub && tree->list && tree->list->type != lambda && !tree->list->next) { if(debugparen) { fdisplay(tree); fputs(" singleton: ", stdout); } tree->noparen = 1; if(debugparen) { fdisplaynl(tree); } } if(tree->type == sub && !tree->prev && !haslambda(tree->list)) { if(debugparen) { fdisplay(tree); fputs(" leftassoc: ", stdout); } tree->noparen = 1; if(debugparen) { fdisplaynl(tree); } } remparens2(tree->next); remparens2(tree->list); } struct node *clonechild(struct node *src, struct node *parent) { struct node *clonenext(struct node *, struct node *); struct node *dst; dst = newchild(NULL); dst->parent = parent; dst->prev = NULL; dst->type = src->type; dst->index = src->index; dst->value = src->value; dst->depth = src->depth; dst->noparen = src->noparen; if(src->next) dst->next = clonenext(src->next, dst); if(src->list) dst->list = clonechild(src->list, dst); return dst; } struct node *clonenext(struct node *src, struct node *prev) { struct node *dst; dst = newnode(NULL); dst->prev = prev; dst->parent = prev ? prev->parent : NULL; dst->type = src->type; dst->index = src->index; dst->value = src->value; dst->depth = src->depth; dst->noparen = src->noparen; if(src->next) dst->next = clonenext(src->next, dst); if(src->list) dst->list = clonechild(src->list, dst); return dst; } struct node *clone(struct node *src) { struct node *dst; if(!src) return NULL; dst = clonenext(src, src->prev); dst->parent = src->parent; return dst; } int isbound(struct node *tree, char var) { if(!tree) return 0; if(tree->type == lterm) return tree->value == var || isbound(tree->list, var) || isbound(tree->next, var); else return isbound(tree->list, var) || isbound(tree->next, var); } int isfree(struct node *tree, char var) { if(!tree) return 1; if(tree->type == lterm) return tree->value != var && isfree(tree->list, var) && isfree(tree->next, var); else return isfree(tree->list, var) && isfree(tree->next, var); } int inexpr(struct node *tree, char var) { if(!tree) return 0; if(tree->type == lterm || tree->type == dbterm || tree->type == term) return tree->value == var || inexpr(tree->list, var) || inexpr(tree->next, var); else return inexpr(tree->list, var) || inexpr(tree->next, var); } void dbshift(struct node *tree, int shift) { if(!tree) return; if(dbterm == tree->type) tree->index += shift; dbshift(tree->next, shift); dbshift(tree->list, shift); } struct node *parse(const char *expr) { enum {exp, lambda, var} expect; struct node *root, *current; root = NULL; current = NULL; expect = exp; while(expr && *expr) { if(debugparse) { printf("%d %c: ", expect, *expr); } switch(expect) { case exp: switch(*expr) { case ')': if(current && current->parent) do { current = current->parent; } while(current->type != sub && current->parent); else fprintf(stderr, "Unmatched ')' at \"%s\"\n", expr); break; case '(': current = newnode(current); break; case '\\': current = newnode(current); current->type = lambda; expect = var; break; case '.': fprintf(stderr, "Expected expr, found '.' at \"%s\"\n", expr); break; default: if(isalpha(*expr)) { current = newnode(current); current->type = term; current->value = *expr; } else if(!isspace(*expr)) { if(isprint(*expr)) fprintf(stderr, "Expected term, found '%c' at \"%s\"\n", *expr, expr); else fprintf(stderr, "Expected term, found \\%03o before \"%s\"\n", (int) *expr, 1 + expr); } } break; case var: if(!isspace(*expr)) { if(isalpha(*expr)) { current = newnode(current); current->type = term; current->value = *expr; expect = lambda; } else if(isprint(*expr)) fprintf(stderr, "Expected var binding, found '%c' at \"%s\"\n", *expr, expr); else fprintf(stderr, "Expected var binding, found \\%03o before \"%s\"\n", (int) *expr, 1 + expr); } break; case lambda: switch(*expr) { case '.': expect = exp; break; case '\\': current = newnode(current); current->type = lambda; expect = var; break; case '(': case ')': fprintf(stderr, "Expected '.', found '%c' at \"%s\"\n", *expr, expr); break; default: if(!isspace(*expr)) { if(isalpha(*expr)) { current = newnode(current); current->type = lambda; current->value = *expr; } else if(isprint(*expr)) fprintf(stderr, "Expected '.', found '%c' at \"%s\"\n", *expr, expr); else fprintf(stderr, "Expected '.', found \\%03o before \"%s\"\n", (int) *expr, 1 + expr); } } } ++expr; if(!root && current) root = current; if(debugparse) { printf("%d %d %d\n", current ? current->type : -1, expect, current ? ((dbterm == current->type || term == current->type) ? current->value : (current->list ? 256 : 0)) : -1); } display(root); } return root; } void buildatlas(struct var **a, struct node *n) { *a=NULL; buildatlassub(a,n); } int main(int argc, char **argv) { struct node *tree, *tree2, *treenext, *treelist; struct var *atlas, *atlas2; char var; int arg, clonetests, disptests, parsetests, vartests, atlastests, parentests; debugdisp = 0; debugatlas = 0; debugparse = 0; debugparen = 0; parentests = 0; clonetests = 0; disptests = 0; parsetests = 0; vartests = 0; atlastests = 0; if(argc >= 2) { struct node *tree3; struct var *atlas3; for(arg = 1; arg < argc && *argv[arg] == '-' ; ++arg) { if (!strcmp(argv[arg], "-help")) { fputs("-debugparse debug output from parser\n" "-debugparen debug output during parenthesis removal\n" "-debugatlas debug output from creating atlas of vars\n" "-debugdisp debug output from display routines\n" "-parentests test extraneous-parenthesis-removal routines\n" "-clonetests test partial cloning of parser tree\n" "-atlastests test variables atlas creation\n" "-disptests test of parser tree display\n" "-vartests test of bound/free variable classifier\n", stdout); } else if(!strcmp(argv[arg], "-debugdisp")) { debugdisp = 1; } else if(!strcmp(argv[arg], "-debugatlas")) { debugatlas = 1; } else if(!strcmp(argv[arg], "-debugparse")) { debugparse = 1; } else if(!strcmp(argv[arg], "-debugparen")) { debugparen = 1; } else if(!strcmp(argv[arg], "-clonetests")) { clonetests = 1; } else if(!strcmp(argv[arg], "-atlastests")) { atlastests = 1; } else if(!strcmp(argv[arg], "-parentests")) { parentests = 1; } else if(!strcmp(argv[arg], "-disptests")) { disptests = 1; } else if(!strcmp(argv[arg], "-vartests")) { vartests = 1; } else { fprintf(stderr, "unknown option %s\n", argv[arg]); } } if(arg == argc) { fputs("missing expression\n", stderr); } tree = parse(argv[arg]); if(parsetests) { displaynl(tree); } debruijn(tree); if(parsetests) { displaynl(tree); } printf("M%d\n", maxdepth(tree)); if(parentests) { tree2 = clone(tree); } fdisplaynl(tree); dbdisplaynl(tree); if(parentests) { tree3 = clone(tree2); topremparens(tree); remparens2(tree2); fdisplaynl(tree3); dbdisplaynl(tree3); fdisplaynl(tree); dbdisplaynl(tree); fdisplaynl(tree2); dbdisplaynl(tree2); } if(atlastests) { buildatlas(&atlas, tree); if(parentests) { buildatlas(&atlas2, tree2); buildatlas(&atlas3, tree3); } displayatlas(atlas); if(parentests) { displayatlas(atlas2); displayatlas(atlas3); } } if(disptests) { dispwidths(tree); disptree(tree); } if(clonetests) { treenext = clone(tree->next); treelist = clone(tree->list); displaynl(tree2); fdisplaynl(tree2); dbdisplaynl(tree2); displaynl(treenext); fdisplaynl(treenext); dbdisplaynl(treenext); displaynl(treelist); fdisplaynl(treelist); dbdisplaynl(treelist); dbshift(tree2, -2); displaynl(tree2); fdisplaynl(tree2); dbdisplaynl(tree2); } if(vartests) { var = CHAR_MIN; do { if(isalpha(var)) { printf("%c %d %d %d\n", var, inexpr(tree, var), isbound(tree, var), isfree(tree, var)); } } while (var++ < CHAR_MAX); } } else { fprintf(stderr, "usage: %s [opts] lambda-expr\nfor list of opts: %s -help\n", argv[0], argv[0]); exit(1); } exit(0); }