Mercurial > repo

comparison interps/underload/underload.c @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <stdint.h>
4 #include <string.h>
5
6 #define CAT -1 /* inner should be treated normally, except continue with
7 this el's next once it's evaluated */
8 #define INNER -2 /* inner is a quotation */
9 #define STACK -3 /* inner is a stack element */
10
11 typedef uint_fast8_t fint;
12
13 typedef struct tag_el {
14 int_least32_t val; /* character, or a special value if negative */
15 size_t refcount; /* reference count from inner, next, or globals */
16 /* this counts the number of locations referencing, even if they're
17 referenced multiple times themselves they only count as 1 */
18 struct tag_el* next; /* the element after this one */
19 struct tag_el* inner; /* the element inside this one, if val is negative */
20 } el;
21
22 enum {unknown, underload, underlambda} lang = unknown;
23
24 int debuglevel = 0;
25
26 void serialize(el* e, FILE* f, fint stackdir);
27
28 void error(const char* errstr) {
29 fprintf(stderr,"Error: %s\n",errstr);
30 exit(EXIT_FAILURE); }
31
32 el* malloc_el(void) {
33 el* x = malloc(sizeof (el));
34 if(!x) error("Out of memory");
35 return x; }
36 void checkfree(el* e) {
37 if(!e) return;
38 if(!(e->refcount)) {
39 e->refcount=1;
40 if(debuglevel >= 6) fprintf(stderr,"[free] ");
41 if(debuglevel >= 6) serialize(e,stderr,1);
42 if(debuglevel >= 6) fputc('\n',stderr);
43 if(e->next) e->next->refcount--;
44 checkfree(e->next);
45 if(e->inner) e->inner->refcount--;
46 checkfree(e->inner);
47 free(e); }}
48
49 void uniputc(int_least32_t c, FILE* f) {
50 if (c < 0)
51 error("Attempt to output a negative-coded character");
52 if (c < 0x80)
53 putc(c,f);
54 else if(c < 0x800) {
55 putc(0xc0| (c>> 6),f);
56 putc(0x80|( c &0x3f),f); }
57 else if(c < 0x10000) {
58 putc(0xd0| (c>>12),f);
59 putc(0x80|((c>> 6)&0x3f),f);
60 putc(0x80| (c &0x3f),f); }
61 else if(c < 0x200000) {
62 putc(0xf0| (c>>18),f);
63 putc(0x80|((c>>12)&0x3f),f);
64 putc(0x80|((c>> 6)&0x3f),f);
65 putc(0x80|( c &0x3f),f); }
66 else if(c < 0x4000000) {
67 putc(0xf8| (c>>24),f);
68 putc(0x80|((c>>18)&0x3f),f);
69 putc(0x80|((c>>12)&0x3f),f);
70 putc(0x80|((c>> 6)&0x3f),f);
71 putc(0x80|( c &0x3f),f); }
72 else {
73 putc(0xfc| (c>>30),f);
74 putc(0x80|((c>>24)&0x3f),f);
75 putc(0x80|((c>>18)&0x3f),f);
76 putc(0x80|((c>>12)&0x3f),f);
77 putc(0x80|((c>> 6)&0x3f),f);
78 putc(0x80|( c &0x3f),f); }}
79 int_least32_t unigetc(FILE* f) {
80 int_least32_t rv=0;
81 int_least32_t min=0x40;
82 fint count=0;
83 int c=getc(f);
84 unsigned char mask = 0xc0;
85 if(c < 0x80) return c;
86 while(c & mask) {count++; c &= ~mask; mask>>=1;}
87 if(count < 1) error("UTF-8 input contains invalid first byte in character");
88 if(count > 1) min <<= 1;
89 rv = c;
90 while(count--) {
91 rv *= 1<<6;
92 min <<= 5;
93 c = getc(f);
94 if((c&0xc0) != 0x80)
95 error("UTF-8 input contains invalid subsequent byte in character");
96 rv += (c & 0x3f); }
97 if(rv < min) error("UTF-8 character has a non-shortest representation");
98 return rv; }
99
100 el* popstack(el** stack, const char* errmsg) {
101 el* rv;
102 el* temp;
103 if(!*stack) error(errmsg);
104 if((**stack).val != STACK) error("Internal error: Stack is not a stack");
105 if((**stack).refcount != 1) error("Internal error: Overreferenced stack");
106 rv = (**stack).inner;
107 temp = (**stack).next;
108 free(*stack);
109 /* temp.refcount stays the same */
110 *stack = temp;
111 if(rv) rv->refcount--;
112 return rv; }
113 void pushstack(el** stack, el* e) {
114 el* temp = malloc_el();
115 if(e) e->refcount++;
116 temp->val = STACK;
117 temp->refcount = 1;
118 temp->inner = e;
119 temp->next = *stack;
120 /* *stack.refcount stays the same */
121 *stack = temp; }
122
123 void serialize_underload(el* e, FILE* f, fint stackdir) {
124 serialise_tco: /* tail-call optimisation of this function by hand */;
125 if(!e) return;
126 if(debuglevel >= 6) fprintf(f,"[%lu]",(unsigned long)e->refcount);
127 switch(e->val) {
128 case STACK:
129 if(!stackdir) {
130 if(debuglevel >+ 6) fprintf(f,"[z]");
131 if(e->inner) serialize_underload(e->inner,f,stackdir);
132 break; }
133 if(e->next) serialize_underload(e->next,f,stackdir);
134 putc('{',f);
135 if(e->inner) serialize_underload(e->inner,f,stackdir);
136 fputs("} ",f);
137 return;
138 case INNER:
139 putc('(',f);
140 if(e->inner) serialize_underload(e->inner,f,stackdir);
141 putc(')',f);
142 break;
143 case CAT:
144 serialize_underload(e->inner,f,stackdir); break;
145 default:
146 uniputc(e->val,f); break; }
147 if(debuglevel >= 5 && !e->refcount)
148 error("Sanity check failed: This should be free by now");
149 e=e->next; goto serialise_tco; }
150 void serialize(el* e, FILE* f, fint stackdir) {
151 /* //tk: Efficient serialization for Underlambda */
152 serialize_underload(e, f, stackdir); }
153
154 el *stack; /* the stack */
155 el *ip; /* current point in the program we're executing */
156 el *zerostack; /* stack of places to go if we hit null next pointers */
157 int main(int argc, char **argv) {
158 FILE* in;
159 int usingstdin;
160 el **working;
161 el *temp, *temp2, *temp3;
162 int_least32_t c;
163 if(!argc||!argv[0]) error("Could not determine executable name");
164 char* a0 = argv[0];
165 if(strrchr(argv[0],'/')) a0=strrchr(argv[0],'/')+1;
166 if(!strcmp(a0,"derlo")) lang=underload;
167 if(!strcmp(a0,"derla")) lang=underlambda;
168 while(argc>=2) {
169 if(!strcmp(argv[1],"-o")) {lang=underload; argv++; argc--;}
170 else if(!strcmp(argv[1],"-a")) {lang=underlambda; argv++; argc--;}
171 else if(!strncmp(argv[1],"-d",2)) {
172 debuglevel=argv[1][2]-'0';
173 if(debuglevel < 0 || debuglevel > 7) debuglevel = 0;
174 argv++; argc--; }
175 else break; }
176 if(lang==unknown || argc > 2) {
177 puts("Usage: derl (-o|-a) [inputfile]");
178 puts("Options:");
179 puts(" -o Interpret input as Underload");
180 puts(" -a Interpret input as Underlambda");
181 puts(" -d0 No debugging");
182 puts(" -d1: enable warnings");
183 puts(" -d2: free all used resources at program exit");
184 puts(" -d3: show program and stack every step");
185 puts(" -d5: enable internal sanity checks");
186 puts(" -d6: debug memory allocation");
187 puts(" -d7: debug internal interpreter program flow");
188 puts("Instead of using the -o or -a option, you can invoke this program");
189 puts("with the name 'derlo' or 'derla'. All -d options include all");
190 puts("previous -d options except -d0. -d0 is the default.");
191 return argc==1 ? 0 : EXIT_FAILURE; }
192 if(argc==2) {
193 in = fopen(argv[1],"rb");
194 if(!in) {perror(argv[1]); return EXIT_FAILURE;}
195 } else {in = stdin; usingstdin = 1;}
196 stack = 0;
197 ip = 0;
198 zerostack = 0;
199 working = &ip;
200 while(((c=unigetc(in)))!=EOF) {
201 if(c==')') {
202 temp = popstack(&zerostack,"Unmatched )");
203 working = &(temp->next);
204 continue; }
205 if(c=='(') {
206 *working = malloc_el();
207 (**working).refcount = 1;
208 (**working).val = INNER;
209 (**working).inner = 0;
210 (**working).next = 0;
211 pushstack(&zerostack,*working);
212 working = &((**working).inner);
213 continue; }
214 /* //tk: string parsing for Underlambda */
215 /* //tk: EOF parsing for Underlambda */
216 *working = malloc_el();
217 (**working).refcount = 1;
218 (**working).val = c;
219 (**working).inner = 0;
220 (**working).next = 0;
221 working = &((**working).next); }
222 if(zerostack) error("Expected ) at end of input");
223
224 while(ip || zerostack) {
225 if(!ip) {
226 if(debuglevel >= 7) fprintf(stderr,"Moving back in zerostack.\n");
227 ip = popstack(&zerostack,"Internal error: Zerostack disappeared");
228 if(ip) ip->refcount++;
229 continue; }
230 if(debuglevel >= 3) {
231 putc('\t',stderr);
232 serialize(stack,stderr,1);
233 serialize(ip,stderr,0);
234 serialize(zerostack,stderr,0);
235 putc('\n',stderr); }
236 switch(ip->val) {
237 case STACK:
238 error("Internal error: Stack element found in program");
239 case CAT:
240 /* not a command, but an optimisation to avoid duplicating things;
241 put ip->next on the zerostack so we can go back to it later, and
242 continue with ip->inner */
243 if(debuglevel >= 7) fprintf(stderr,"Evaluating a lazy cat.\n");
244 if(!ip->inner) break; /* continue with ip->next */
245 if(debuglevel >= 7) fprintf(stderr,"The cat was nontrivial.\n");
246 pushstack(&zerostack,ip->next);
247 temp = ip->inner;
248 ip->refcount--;
249 temp->refcount++;
250 checkfree(ip);
251 ip = temp;
252 continue;
253 case INNER:
254 if(debuglevel >= 7) fprintf(stderr,"Pushing to the stack.\n");
255 if(ip->inner)
256 pushstack(&stack,ip->inner);
257 else
258 pushstack(&stack,0);
259 break;
260 case '!':
261 if(debuglevel >= 7) fprintf(stderr,"Popping the stack.\n");
262 temp = popstack(&stack,"Stack underflow in !");
263 checkfree(temp);
264 break;
265 case 'S':
266 if(debuglevel >= 7) fprintf(stderr,"Serialising TOS.\n");
267 temp = popstack(&stack,"Stack underflow in S");
268 if(temp) temp->refcount++;
269 serialize(temp,stdout,0);
270 fflush(stdout);
271 if(temp) temp->refcount--;
272 if(debuglevel >= 3) putc('\n',stdout);
273 checkfree(temp);
274 break;
275 case '~':
276 if(debuglevel >= 7) fprintf(stderr,"Swapping stack elements.\n");
277 temp = popstack(&stack,"Stack underflow in ~");
278 temp2 = popstack(&stack,"Stack underflow in ~");
279 pushstack(&stack,temp);
280 pushstack(&stack,temp2);
281 break;
282 case 'a':
283 if(debuglevel >= 7) fprintf(stderr,"Wrapping the top stack element.\n");
284 temp = malloc_el();
285 temp->refcount = 0;
286 temp->inner = popstack(&stack,"Stack underflow in a");
287 if(temp->inner) temp->inner->refcount++;
288 temp->val = INNER;
289 temp->next = 0;
290 pushstack(&stack,temp);
291 break;
292 case ':':
293 if(debuglevel >= 7) fprintf(stderr,"Duplicating the top stack element.\n");
294 temp = popstack(&stack,"Stack underflow in :");
295 pushstack(&stack,temp);
296 pushstack(&stack,temp);
297 break;
298 case '*':
299 if(debuglevel >= 7) fprintf(stderr,"Catting two stack elements.\n");
300 temp = popstack(&stack,"Stack underflow in *");
301 temp2 = popstack(&stack,"Stack underflow in *");
302 /* The degenerate cases of catting a null string need to be handled */
303 if(!temp ) {pushstack(&stack,temp2); break;}
304 if(!temp2) {pushstack(&stack,temp ); break;}
305 temp->refcount++; /* if temp and temp2 are aliased, this correctly
306 prevents the optimisation happening */
307 if(temp2->refcount == 0) {
308 /* Tailcat optimisation: if nothing else is using the stack
309 element we're catting to, just change its next pointer to do
310 the catting directly. */
311 if(debuglevel >= 7) fprintf(stderr,"Trying tailcat optimisation.\n");
312 temp3 = temp2;
313 while(temp3->next) {
314 if(temp3->refcount > 1) goto cantoptimise_star;
315 temp3 = temp3->next; }
316 if(temp3->refcount > 1) goto cantoptimise_star;
317 if(debuglevel >= 7) fprintf(stderr,"Tailcat optimisation succeeded.\n");
318 temp3->next = temp;
319 temp3 = temp2; }
320 else {
321 cantoptimise_star: ;
322 temp3 = malloc_el();
323 temp3->refcount = 0;
324 temp3->next = temp;
325 temp3->inner = temp2;
326 temp2->refcount++;
327 temp3->val = CAT; }
328 pushstack(&stack,temp3);
329 break;
330 case '^':
331 if(debuglevel >= 7) fprintf(stderr,"Evalling the stack.\n");
332 temp = popstack(&stack,"Stack underflow in ^");
333 if(!temp) break; /* continue with ip->next */
334 while(ip->refcount == 1 && !(ip->next) && zerostack) {
335 /* Tailcall optimisation. */
336 if(debuglevel >= 7) fprintf(stderr,"Tailcall optimisation.\n");
337 ip->next = popstack(&zerostack,
338 "Internal error: Zerostack disappeared"); }
339 if(ip->next) ip->next->refcount++;
340 if(temp->refcount == 0) {
341 /* Tailcat optimisation on the call stack; replace the return at
342 the end of the called code with a goto, as long as it isn't
343 used anywhere else */
344 if(debuglevel >= 7) fprintf(stderr,"Trying tailcat optimisation.\n");
345 temp3 = temp;
346 while(temp3->next) {
347 if(temp3->refcount > 1) goto cantoptimise_caret;
348 temp3 = temp3->next; }
349 if(temp3->refcount > 1) goto cantoptimise_caret;
350 temp3->next = ip->next;
351 if(debuglevel >= 7) fprintf(stderr,"Tailcat optimisation succeeded.\n");
352 temp2 = temp; }
353 else {
354 cantoptimise_caret: ;
355 temp2 = malloc_el();
356 temp2->refcount = 0;
357 temp2->next = ip->next;
358 temp2->inner = temp;
359 temp->refcount++;
360 temp2->val = CAT; }
361 ip->refcount--;
362 if(temp2) temp2->refcount++;
363 checkfree(ip);
364 ip = temp2;
365 continue;
366 default:
367 fprintf(stderr, "Attempt to execute unknown command %d\n",ip->val);
368 return EXIT_FAILURE; }
369 temp = ip->next;
370 ip->refcount--;
371 if(temp) temp->refcount++;
372 checkfree(ip);
373 ip = temp; }
374 if(!usingstdin) fclose(in);
375 if(debuglevel >= 1 && stack)
376 fprintf(stderr, "Warning: Stack was not empty at program exit\n");
377 if(debuglevel >= 3) {
378 serialize(stack,stderr,1);
379 putc('\n',stderr); }
380 if(debuglevel >= 2)
381 while(stack)
382 checkfree(popstack(&stack,"Internal error: Stack has inconsistent size"));
383 return 0; }