rendered paste body#include <stdio.h>#include <stdlib.h>#include <stdint.h>#include <string.h>#define CAT -1 /* inner should be treated normally, except continue with this el's next once it's evaluated */#define INNER -2 /* inner is a quotation */#define STACK -3 /* inner is a stack element */typedef uint_fast8_t fint;typedef struct tag_el { int_least32_t val; /* character, or a special value if negative */ size_t refcount; /* reference count from inner, next, or globals */ /* this counts the number of locations referencing, even if they're referenced multiple times themselves they only count as 1 */ struct tag_el* next; /* the element after this one */ struct tag_el* inner; /* the element inside this one, if val is negative */} el;enum {unknown, underload, underlambda} lang = unknown;int debuglevel = 0;void serialize(el* e, FILE* f, fint stackdir);void error(const char* errstr) { fprintf(stderr,"Error: %s\n",errstr); exit(EXIT_FAILURE); }el* malloc_el(void) { el* x = malloc(sizeof (el)); if(!x) error("Out of memory"); return x; }void checkfree(el* e) { if(!e) return; if(!(e->refcount)) { e->refcount=1; if(debuglevel >= 6) fprintf(stderr,"[free] "); if(debuglevel >= 6) serialize(e,stderr,1); if(debuglevel >= 6) fputc('\n',stderr); if(e->next) e->next->refcount--; checkfree(e->next); if(e->inner) e->inner->refcount--; checkfree(e->inner); free(e); }}void uniputc(int_least32_t c, FILE* f) { if (c < 0) error("Attempt to output a negative-coded character"); if (c < 0x80) putc(c,f); else if(c < 0x800) { putc(0xc0| (c>> 6),f); putc(0x80|( c &0x3f),f); } else if(c < 0x10000) { putc(0xd0| (c>>12),f); putc(0x80|((c>> 6)&0x3f),f); putc(0x80| (c &0x3f),f); } else if(c < 0x200000) { putc(0xf0| (c>>18),f); putc(0x80|((c>>12)&0x3f),f); putc(0x80|((c>> 6)&0x3f),f); putc(0x80|( c &0x3f),f); } else if(c < 0x4000000) { putc(0xf8| (c>>24),f); putc(0x80|((c>>18)&0x3f),f); putc(0x80|((c>>12)&0x3f),f); putc(0x80|((c>> 6)&0x3f),f); putc(0x80|( c &0x3f),f); } else { putc(0xfc| (c>>30),f); putc(0x80|((c>>24)&0x3f),f); putc(0x80|((c>>18)&0x3f),f); putc(0x80|((c>>12)&0x3f),f); putc(0x80|((c>> 6)&0x3f),f); putc(0x80|( c &0x3f),f); }}int_least32_t unigetc(FILE* f) { int_least32_t rv=0; int_least32_t min=0x40; fint count=0; int c=getc(f); unsigned char mask = 0xc0; if(c < 0x80) return c; while(c & mask) {count++; c &= ~mask; mask>>=1;} if(count < 1) error("UTF-8 input contains invalid first byte in character"); if(count > 1) min <<= 1; rv = c; while(count--) { rv *= 1<<6; min <<= 5; c = getc(f); if((c&0xc0) != 0x80) error("UTF-8 input contains invalid subsequent byte in character"); rv += (c & 0x3f); } if(rv < min) error("UTF-8 character has a non-shortest representation"); return rv; }el* popstack(el** stack, const char* errmsg) { el* rv; el* temp; if(!*stack) error(errmsg); if((**stack).val != STACK) error("Internal error: Stack is not a stack"); if((**stack).refcount != 1) error("Internal error: Overreferenced stack"); rv = (**stack).inner; temp = (**stack).next; free(*stack); /* temp.refcount stays the same */ *stack = temp; if(rv) rv->refcount--; return rv; }void pushstack(el** stack, el* e) { el* temp = malloc_el(); if(e) e->refcount++; temp->val = STACK; temp->refcount = 1; temp->inner = e; temp->next = *stack; /* *stack.refcount stays the same */ *stack = temp; }void serialize_underload(el* e, FILE* f, fint stackdir) {serialise_tco: /* tail-call optimisation of this function by hand */; if(!e) return; if(debuglevel >= 6) fprintf(f,"[%lu]",(unsigned long)e->refcount); switch(e->val) { case STACK: if(!stackdir) { if(debuglevel >+ 6) fprintf(f,"[z]"); if(e->inner) serialize_underload(e->inner,f,stackdir); break; } if(e->next) serialize_underload(e->next,f,stackdir); putc('{',f); if(e->inner) serialize_underload(e->inner,f,stackdir); fputs("} ",f); return; case INNER: putc('(',f); if(e->inner) serialize_underload(e->inner,f,stackdir); putc(')',f); break; case CAT: serialize_underload(e->inner,f,stackdir); break; default: uniputc(e->val,f); break; } if(debuglevel >= 5 && !e->refcount) error("Sanity check failed: This should be free by now"); e=e->next; goto serialise_tco; }void serialize(el* e, FILE* f, fint stackdir) { /* //tk: Efficient serialization for Underlambda */ serialize_underload(e, f, stackdir); }el *stack; /* the stack */el *ip; /* current point in the program we're executing */el *zerostack; /* stack of places to go if we hit null next pointers */int main(int argc, char **argv) { FILE* in; int usingstdin; el **working; el *temp, *temp2, *temp3; int_least32_t c; if(!argc||!argv[0]) error("Could not determine executable name"); char* a0 = argv[0]; if(strrchr(argv[0],'/')) a0=strrchr(argv[0],'/')+1; if(!strcmp(a0,"derlo")) lang=underload; if(!strcmp(a0,"derla")) lang=underlambda; while(argc>=2) { if(!strcmp(argv[1],"-o")) {lang=underload; argv++; argc--;} else if(!strcmp(argv[1],"-a")) {lang=underlambda; argv++; argc--;} else if(!strncmp(argv[1],"-d",2)) { debuglevel=argv[1][2]-'0'; if(debuglevel < 0 || debuglevel > 7) debuglevel = 0; argv++; argc--; } else break; } if(lang==unknown || argc > 2) { puts("Usage: derl (-o|-a) [inputfile]"); puts("Options:"); puts(" -o Interpret input as Underload"); puts(" -a Interpret input as Underlambda"); puts(" -d0 No debugging"); puts(" -d1: enable warnings"); puts(" -d2: free all used resources at program exit"); puts(" -d3: show program and stack every step"); puts(" -d5: enable internal sanity checks"); puts(" -d6: debug memory allocation"); puts(" -d7: debug internal interpreter program flow"); puts("Instead of using the -o or -a option, you can invoke this program"); puts("with the name 'derlo' or 'derla'. All -d options include all"); puts("previous -d options except -d0. -d0 is the default."); return argc==1 ? 0 : EXIT_FAILURE; } if(argc==2) { in = fopen(argv[1],"rb"); if(!in) {perror(argv[1]); return EXIT_FAILURE;} } else {in = stdin; usingstdin = 1;} stack = 0; ip = 0; zerostack = 0; working = &ip; while(((c=unigetc(in)))!=EOF) { if(c==')') { temp = popstack(&zerostack,"Unmatched )"); working = &(temp->next); continue; } if(c=='(') { *working = malloc_el(); (**working).refcount = 1; (**working).val = INNER; (**working).inner = 0; (**working).next = 0; pushstack(&zerostack,*working); working = &((**working).inner); continue; } /* //tk: string parsing for Underlambda */ /* //tk: EOF parsing for Underlambda */ *working = malloc_el(); (**working).refcount = 1; (**working).val = c; (**working).inner = 0; (**working).next = 0; working = &((**working).next); } if(zerostack) error("Expected ) at end of input"); while(ip || zerostack) { if(!ip) { if(debuglevel >= 7) fprintf(stderr,"Moving back in zerostack.\n"); ip = popstack(&zerostack,"Internal error: Zerostack disappeared"); if(ip) ip->refcount++; continue; } if(debuglevel >= 3) { putc('\t',stderr); serialize(stack,stderr,1); serialize(ip,stderr,0); serialize(zerostack,stderr,0); putc('\n',stderr); } switch(ip->val) { case STACK: error("Internal error: Stack element found in program"); case CAT: /* not a command, but an optimisation to avoid duplicating things; put ip->next on the zerostack so we can go back to it later, and continue with ip->inner */ if(debuglevel >= 7) fprintf(stderr,"Evaluating a lazy cat.\n"); if(!ip->inner) break; /* continue with ip->next */ if(debuglevel >= 7) fprintf(stderr,"The cat was nontrivial.\n"); pushstack(&zerostack,ip->next); temp = ip->inner; ip->refcount--; temp->refcount++; checkfree(ip); ip = temp; continue; case INNER: if(debuglevel >= 7) fprintf(stderr,"Pushing to the stack.\n"); if(ip->inner) pushstack(&stack,ip->inner); else pushstack(&stack,0); break; case '!': if(debuglevel >= 7) fprintf(stderr,"Popping the stack.\n"); temp = popstack(&stack,"Stack underflow in !"); checkfree(temp); break; case 'S': if(debuglevel >= 7) fprintf(stderr,"Serialising TOS.\n"); temp = popstack(&stack,"Stack underflow in S"); if(temp) temp->refcount++; serialize(temp,stdout,0); fflush(stdout); if(temp) temp->refcount--; if(debuglevel >= 3) putc('\n',stdout); checkfree(temp); break; case '~': if(debuglevel >= 7) fprintf(stderr,"Swapping stack elements.\n"); temp = popstack(&stack,"Stack underflow in ~"); temp2 = popstack(&stack,"Stack underflow in ~"); pushstack(&stack,temp); pushstack(&stack,temp2); break; case 'a': if(debuglevel >= 7) fprintf(stderr,"Wrapping the top stack element.\n"); temp = malloc_el(); temp->refcount = 0; temp->inner = popstack(&stack,"Stack underflow in a"); if(temp->inner) temp->inner->refcount++; temp->val = INNER; temp->next = 0; pushstack(&stack,temp); break; case ':': if(debuglevel >= 7) fprintf(stderr,"Duplicating the top stack element.\n"); temp = popstack(&stack,"Stack underflow in :"); pushstack(&stack,temp); pushstack(&stack,temp); break; case '*': if(debuglevel >= 7) fprintf(stderr,"Catting two stack elements.\n"); temp = popstack(&stack,"Stack underflow in *"); temp2 = popstack(&stack,"Stack underflow in *"); /* The degenerate cases of catting a null string need to be handled */ if(!temp ) {pushstack(&stack,temp2); break;} if(!temp2) {pushstack(&stack,temp ); break;} temp->refcount++; /* if temp and temp2 are aliased, this correctly prevents the optimisation happening */ if(temp2->refcount == 0) { /* Tailcat optimisation: if nothing else is using the stack element we're catting to, just change its next pointer to do the catting directly. */ if(debuglevel >= 7) fprintf(stderr,"Trying tailcat optimisation.\n"); temp3 = temp2; while(temp3->next) { if(temp3->refcount > 1) goto cantoptimise_star; temp3 = temp3->next; } if(temp3->refcount > 1) goto cantoptimise_star; if(debuglevel >= 7) fprintf(stderr,"Tailcat optimisation succeeded.\n"); temp3->next = temp; temp3 = temp2; } else { cantoptimise_star: ; temp3 = malloc_el(); temp3->refcount = 0; temp3->next = temp; temp3->inner = temp2; temp2->refcount++; temp3->val = CAT; } pushstack(&stack,temp3); break; case '^': if(debuglevel >= 7) fprintf(stderr,"Evalling the stack.\n"); temp = popstack(&stack,"Stack underflow in ^"); if(!temp) break; /* continue with ip->next */ while(ip->refcount == 1 && !(ip->next) && zerostack) { /* Tailcall optimisation. */ if(debuglevel >= 7) fprintf(stderr,"Tailcall optimisation.\n"); ip->next = popstack(&zerostack, "Internal error: Zerostack disappeared"); } if(ip->next) ip->next->refcount++; if(temp->refcount == 0) { /* Tailcat optimisation on the call stack; replace the return at the end of the called code with a goto, as long as it isn't used anywhere else */ if(debuglevel >= 7) fprintf(stderr,"Trying tailcat optimisation.\n"); temp3 = temp; while(temp3->next) { if(temp3->refcount > 1) goto cantoptimise_caret; temp3 = temp3->next; } if(temp3->refcount > 1) goto cantoptimise_caret; temp3->next = ip->next; if(debuglevel >= 7) fprintf(stderr,"Tailcat optimisation succeeded.\n"); temp2 = temp; } else { cantoptimise_caret: ; temp2 = malloc_el(); temp2->refcount = 0; temp2->next = ip->next; temp2->inner = temp; temp->refcount++; temp2->val = CAT; } ip->refcount--; if(temp2) temp2->refcount++; checkfree(ip); ip = temp2; continue; default: fprintf(stderr, "Attempt to execute unknown command %d\n",ip->val); return EXIT_FAILURE; } temp = ip->next; ip->refcount--; if(temp) temp->refcount++; checkfree(ip); ip = temp; } if(!usingstdin) fclose(in); if(debuglevel >= 1 && stack) fprintf(stderr, "Warning: Stack was not empty at program exit\n"); if(debuglevel >= 3) { serialize(stack,stderr,1); putc('\n',stderr); } if(debuglevel >= 2) while(stack) checkfree(popstack(&stack,"Internal error: Stack has inconsistent size")); return 0; }