|
996
|
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; } |
