?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
generate platform_ops.h from platform_ops.proto, and reduce dependencies
[proto.git] / src / compiler / compiler.cpp
blob8690633e4b9533a9e60b0cf8f823db943fcb5643
1 /* Proto compiler
2 Copyright (C) 2005-2008, Jonathan Bachrach, Jacob Beal, and contributors
3 listed in the AUTHORS file in the MIT Proto distribution's top directory.
4
5 This file is part of MIT Proto, and is distributed under the terms of
6 the GNU General Public License, with a linking exception, as described
7 in the file LICENSE in the MIT Proto distribution's top directory. */
8
9 #include "config.h"
10 #include <stdlib.h>
11 #include <stdio.h>
12 #include <math.h>
13 #include <string.h>
14 #include <inttypes.h>
15 #include <stdarg.h>
16 #include <unistd.h>
17 #include <string>
18 #include <list>
19 #include <map>
20 #include "lisp.h"
21 #include "reader.h"
22 #include "compiler.h"
23
24 using namespace std; // allow c-strings, etc; note: shadows 'pair'
25
26 int is_optimizing_lets = 1;
27
28 Path* proto_path;
29 string srcdir;
30
31 struct TYPE; struct AST_FUN; struct AST_OP; struct AST_GOP;
32 struct AST;
33
34 /****** VARIABLES ******/
35 struct VAR {
36 char *name;
37 TYPE *type;
38 int n_refs;
39 AST *ast;
40
41 VAR(char* name, TYPE *type) {
42 this->name=name; this->type=type; n_refs=0; ast=NULL;
43 }
44 };
45
46 /****** SCRIPT ******/
47 // This is the output target
48
49 struct Script {
50 list<uint8_t> contents;
51
52 Script() {}
53 Script(int n, ...) {
54 va_list v; va_start(v,n);
55 for(int i=0;i<n;i++) { contents.push_back(va_arg(v,int)); }
56 va_end(v);
57 };
58 ~Script() {}
59
60 int size() { return contents.size(); }
61
62 void add(uint8_t v1) { contents.push_back(v1); }
63 void add(uint8_t v1,uint8_t v2) {addN(2,v1,v2);}
64 void add(uint8_t v1,uint8_t v2,uint8_t v3) {addN(3,v1,v2,v3);}
65 void add(uint8_t v1,uint8_t v2,uint8_t v3,uint8_t v4) {addN(4,v1,v2,v3,v4);}
66 void add_op16(OPCODE op,uint16_t v) { addN(3, op, v >> 8, v & 0xff); }
67 void addN(int n, ...) {
68 va_list v; va_start(v,n);
69 for(int i=0;i<n;i++) { contents.push_back(va_arg(v,int)); }
70 va_end(v);
71 }
72 void append(Script* tail) {contents.splice(contents.end(),tail->contents);}
73 void prepend(Script* head){contents.splice(contents.begin(),head->contents);}
74 // for extracting script afterward
75 uint8_t pop() {uint8_t v=contents.front(); contents.pop_front(); return v; }
76 };
77
78 /****** PROTO TYPES ******/
79 typedef enum {
80 NUL_KIND, ANY_KIND, NUM_KIND, VEC_KIND, TUP_KIND, FUN_KIND,
81 ONE_NUM_KIND, ONE_FUN_KIND, ONE_OP_KIND, ONE_GOP_KIND,
82 NUM_TYPE_KINDS
83 } TYPE_KIND;
84 char* type_kind_name[NUM_TYPE_KINDS]={"NUL","ANY","NUM","VEC","TUP","FUN","ONE_NUM","ONE_FUN","ONE_OP","ONE_GOP"};
85
86 struct TYPE {
87 TYPE_KIND kind;
88
89 TYPE(TYPE_KIND kind) { this->kind = kind; }
90 virtual const char* name() { return type_kind_name[kind]; }
91 virtual int size() {
92 if(kind==NUL_KIND || kind==ANY_KIND)
93 uerror("ILLEGAL SIZE OF ABSTRACT TYPE %d", kind);
94 return 1;
95 }
96 virtual bool subtype(TYPE* parent) {
97 if(parent->kind==ANY_KIND) return true;
98 if(parent->kind==kind) {
99 if(kind==ONE_OP_KIND || kind==ONE_GOP_KIND || kind==ONE_FUN_KIND)
100 uerror("UNKNOWN TYPE RULE");
101 return true;
102 }
103 return false;
104 }
105 };
106
107 TYPE num_type(NUM_KIND), nul_type(NUL_KIND), any_type(ANY_KIND);
108 TYPE vec_type(VEC_KIND), fun_type(FUN_KIND);
109
110 struct ONE_FUN_TYPE : public TYPE {
111 AST_FUN *value;
112 ONE_FUN_TYPE(AST_FUN *fun) : TYPE(ONE_FUN_KIND) { value=fun; }
113 };
114 struct ONE_OP_TYPE : public TYPE {
115 AST_OP *op;
116 ONE_OP_TYPE(AST_OP *op) : TYPE(ONE_OP_KIND) { this->op=op; }
117 };
118 struct ONE_GOP_TYPE : public TYPE {
119 AST_GOP *gop;
120 ONE_GOP_TYPE(AST_GOP *gop) : TYPE(ONE_GOP_KIND) { this->gop=gop; }
121 };
122 struct ONE_NUM_TYPE : public TYPE {
123 flo num;
124 ONE_NUM_TYPE(flo num) : TYPE(ONE_NUM_KIND) { this->num=num; }
125 string namestr;
126 virtual const char* name() {
127 namestr=""; namestr=namestr+"(ONE_NUM "+flo2str(num)+")";
128 return namestr.c_str();
129 }
130 virtual bool subtype(TYPE* parent) {
131 if(parent->kind==ONE_NUM_KIND) return num==((ONE_NUM_TYPE*)parent)->num;
132 return parent->kind==NUM_KIND || TYPE::subtype(parent);
133 }
134 };
135
136 TYPE* blur_type(TYPE* t);
137
138 struct TUP_TYPE : public TYPE {
139 int len; TYPE **elt_types;
140 TUP_TYPE() : TYPE(TUP_KIND) { // initializer for generic topmost tuple
141 len=-1; elt_types = new TYPE*[1]; elt_types[0]=&any_type;
142 }
143 TUP_TYPE(int len, TYPE** types) : TYPE(TUP_KIND) {
144 this->len = len;
145 elt_types = new TYPE*[len];
146 for(int i=0;i<len;i++) { elt_types[i]=types[i]; }
147 }
148 string namestr;
149 virtual const char* name() {
150 namestr="(TUP";
151 for(int i=0;i<len;i++) { namestr=namestr+" "+elt_types[i]->name(); }
152 if(len==-1) namestr+=" *";
153 namestr+=")";
154 return namestr.c_str();
155 }
156
157 virtual int size() {
158 int sum=TYPE::size();
159 if(sum<0 || len<0)
160 uerror("COMPILER INTERNAL ERROR: TUPLE MUST HAVE NON-NEGATIVE SIZE");
161 for(int i=0;i<len;i++) {
162 if(elt_types[i]->size()<1)
163 uerror("COMPILER INTERNAL ERROR: TUPLE ELT MUST HAVE POSITIVE SIZE");
164 sum += elt_types[i]->size();
165 }
166 return sum;
167 }
168 virtual bool subtype(TYPE* parent) {
169 if(parent->kind==TUP_KIND) {
170 TUP_TYPE* p = (TUP_TYPE*)parent;
171 if(p->len==-1) return true; // generic tuple is an "any tuple" match
172 if(len != p->len) return false;
173 for(int i=0;i<len;i++)
174 if(!elt_types[i]->subtype(p->elt_types[i])) return false;
175 return true;
176 } else {
177 return TYPE::subtype(parent);
178 }
179 }
180 };
181
182 struct VEC_TYPE : public TYPE {
183 int len; TYPE *elt_type;
184 VEC_TYPE(int len, TYPE* elt_type) : TYPE(VEC_KIND)
185 { this->len=len; this->elt_type=elt_type; }
186
187 string namestr;
188 virtual const char* name() {
189 namestr=""; namestr=namestr+"(VEC "+elt_type->name()+" "+int2str(len)+")";
190 return namestr.c_str();
191 }
192 virtual int size() { return TYPE::size() + (len * elt_type->size()); }
193 virtual bool subtype(TYPE* parent) {
194 if(parent->kind==VEC_KIND) { // for vectors, length doesn't matter
195 return elt_type->subtype(((VEC_TYPE*)parent)->elt_type);
196 } else if(parent->kind==TUP_KIND) {
197 TUP_TYPE* p = (TUP_TYPE*)parent;
198 return (p->len==-1 && elt_type->subtype(p->elt_types[0]));
199 } else {
200 return TYPE::subtype(parent);
201 }
202 }
203 };
204
205 TUP_TYPE tup_type; // the generic tuple type
206 VEC_TYPE num_vec_type(-1,&num_type);
207 VEC_TYPE num_vec3_type(3,&num_type);
208
209 struct FUN_TYPE : public TYPE {
210 TYPE *result_type;
211 int arity;
212 int is_nary;
213 TYPE **param_types;
214
215 FUN_TYPE(int arity, int is_nary) : TYPE(FUN_KIND) {
216 this->arity=arity; this->is_nary = is_nary;
217 result_type = &any_type;
218 param_types = new TYPE*[arity];
219 for(int i=0;i<arity;i++) { param_types[i]=&any_type; }
220 }
221 FUN_TYPE(vector<TYPE*> *types) : TYPE(FUN_KIND) {
222 this->result_type = (*types)[0];
223 arity = types->size()-1;
224 param_types = new TYPE*[arity];
225 is_nary=false;
226 for(int i=0;i<arity;i++) param_types[i] = (*types)[i+1];
227 }
228 FUN_TYPE(TYPE* result_type, ...) : TYPE(FUN_KIND) {
229 int i;
230 TYPE* types[32];
231 va_list ap;
232 va_start(ap, result_type);
233 for (i = 0; ; i++) {
234 types[i] = va_arg(ap, TYPE*);
235 if (types[i] == (TYPE*)0) {
236 is_nary = 0; break;
237 } else if (types[i] == (TYPE*)1) {
238 is_nary = 1; break;
239 }
240 }
241 va_end(ap);
242 arity = i;
243 this->result_type = result_type;
244 param_types = new TYPE*[arity];
245 for (i = 0; i < arity; i++)
246 param_types[i] = types[i];
247 }
248 virtual ~FUN_TYPE() { delete param_types; }
249 string namestr;
250 virtual const char* name() {
251 namestr = "(FUN (";
252 for(int i=0;i<arity;i++)
253 { if(i) namestr+=" "; namestr+=param_types[i]->name(); }
254 if(is_nary) namestr+=" ...";
255 namestr=namestr+") "+result_type->name()+")";
256 return namestr.c_str();
257 }
258 virtual bool subtype(TYPE* parent) {
259 if(parent->kind==FUN_KIND) {
260 FUN_TYPE* p = (FUN_TYPE*)parent;
261 if(arity!=p->arity || is_nary!=p->is_nary) return false;
262 if(!result_type->subtype(p->result_type)) return false;
263 for(int i=0;i<arity;i++)
264 if(!param_types[i]->subtype(p->param_types[i])) return false;
265 return true;
266 } else { return TYPE::subtype(parent);
267 }
268 }
269 };
270
271 #define NUMT (&num_type)
272 #define NUM_VEC_TYPE ((TYPE*)&num_vec_type)
273 #define VECT NUM_VEC_TYPE
274 #define NUM_VEC3_TYPE ((TYPE*)&num_vec3_type)
275 #define VEC3T NUM_VEC3_TYPE
276 #define TUPT ((TYPE*)&tup_type)
277 #define FUNT (&fun_type)
278 #define ANYT (&any_type)
279
280
281 /****** AST ZONE ******/
282 typedef enum {
283 LIFT_WALK,
284 LET_WALK,
285 N_WALKERS
286 } AST_WALKER_KIND;
287
288 typedef AST* (*AST_WALKER)(AST_WALKER_KIND walker, AST* val, void* arg);
289
290 AST *default_walk (AST_WALKER_KIND action, AST *ast, void *arg) { return ast; }
291
292 typedef enum {
293 AST_BASE_CLASS, AST_LIT_CLASS, AST_REF_CLASS, AST_GLO_REF_CLASS,
294 AST_OP_CLASS, AST_GOP_CLASS, AST_FUN_CLASS, AST_LET_CLASS,
295 AST_OP_CALL_CLASS, AST_CALL_CLASS
296 } AST_CLASS;
297
298 template<class T>
299 T& list_nth(list<T> *lst, int n) {
300 typeof(lst->begin()) it = lst->begin();
301 while(n--) it++;
302 return *it;
303 }
304
305 // ASTs are program elements ("abstract syntax tree")
306 // They need to be renamed at some point, because AST isn't quite right
307 struct AST {
308 char* name;
309 TYPE *type;
310 AST_WALKER walkers[N_WALKERS];
311
312 AST() {
313 walkers[0]=walkers[1]=&default_walk;
314 type = &nul_type; // is this still needed?
315 }
316
317 virtual void print() {}
318 virtual void emit(Script* script) = 0; // turn prog. elt into bytecodes
319 virtual int stack_size() { return 1; }
320 virtual int env_size() { return 1; } // for ast_zero_size; it's a mystery why
321 virtual AST_CLASS ast_class() { return AST_BASE_CLASS; }
322 };
323
324 // to be phased out
325 AST *ast_walk (AST_WALKER_KIND action, AST *ast, void *arg) {
326 return ast->walkers[action](action, ast, arg);
327 }
328
329 typedef struct {
330 list<VAR*> *env;
331 list<AST*> *glos;
332 int n_state;
333 int n_exports;
334 int export_len;
335 int n_channels;
336 BOOL is_fun_lift;
337 } LIFT_DATA;
338
339 AST *ast_lift (AST *ast, LIFT_DATA *data) {
340 return ast_walk(LIFT_WALK, ast, data);
341 }
342
343 AST *ast_optimize_lets (AST *ast) {
344 return ast_walk(LET_WALK, ast, NULL);
345 }
346
347 /******* ERROR REPORTING *******/
348 bool test_mode = false;
349 extern FILE* dump_target; // declared later
350 inline FILE* error_log() { return (test_mode ? dump_target : stderr); }
351
352 void cerror (AST* ast, char* message, ...) {
353 va_list ap;
354 ast->print(); fprintf(error_log(),"\n");
355 va_start(ap, message);
356 vfprintf(error_log(),message, ap); fprintf(error_log(),"\n");
357 va_end(ap);
358 exit(test_mode ? 0 : 1);
359 return;
360 }
361
362 void clerror (char* name, list<AST*> *args, char* message, ...) {
363 va_list ap;
364 fprintf(error_log(),"(%s", name);
365 for (typeof(args->begin()) it = args->begin();
366 it != args->end(); it++) {
367 fprintf(error_log()," ");
368 (*it)->print();
369 }
370 fprintf(error_log(),")\n");
371 va_start(ap, message);
372 vfprintf(error_log(), message, ap);
373 fprintf(error_log(),"\n");
374 va_end(ap);
375 exit(test_mode ? 0 : 1);
376 return;
377 }
378
379
380 /**** AST_LIT ****/
381 typedef enum { LIT_INT8, LIT_INT16, LIT_FLO, LIT_TUP, LIT_VEC } LIT_KIND;
382 typedef union { flo val; uint8_t bytes[4]; } FLO_BYTES;
383
384 struct AST_LIT : public AST{
385 flo val;
386 LIT_KIND kind;
387
388 AST_LIT(flo num) {
389 val = num; name="LIT";
390 type = new ONE_NUM_TYPE(num);
391 int n = (int)num;
392 kind = (n == num && (n >= 0 && n < 128)) ? LIT_INT8 : LIT_FLO;
393 }
394
395 void print() { fprintf(error_log(),"%.1f", val); }
396 AST_CLASS ast_class() { return AST_LIT_CLASS; }
397
398 void emit(Script* script) {
399 // post("EMIT LIT %d %f\n", ast->kind, num);
400 switch (kind) {
401 case LIT_INT8: {
402 if (val >= 0 && val < MAX_LIT_OPS) { script->add(LIT_0_OP+(uint8_t)val);
403 } else if (val >= 0 && val < 128) { script->add(LIT8_OP,(uint8_t)val);
404 } else cerror(this,"Number %d cannot be a LIT_INT8",val);
405 break; }
406 case LIT_FLO: {
407 FLO_BYTES f; f.val=val;
408 script->addN(5,LIT_FLO_OP,f.bytes[0],f.bytes[1],f.bytes[2],f.bytes[3]);
409 break; }
410 // case LIT_TUP: {
411 // *bytes = PAIR(new_num(num), PAIR(new_num(DEF_TUP_OP), *bytes));
412 // break; }
413 // case LIT_VEC: {
414 // *bytes = PAIR(new_num(DEF_VEC_OP), *bytes);
415 // break; }
416 default:
417 cerror(this, "UNKNOWN LIT KIND %d", kind);
418 }
419 }
420 };
421
422 /**** AST_REF ****/
423 struct AST_REF : public AST {
424 VAR *var;
425 int offset;
426 list<VAR*> *env;
427
428 AST_REF(VAR *var, list<VAR*> *env);
429 void print() { fprintf(error_log(),"%s", var->name); }
430 void emit(Script* script);
431 AST_CLASS ast_class() { return AST_REF_CLASS; }
432 };
433
434 AST *ast_ref_lift_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
435 // TODO: RIP OUT
436 AST_REF *ast = (AST_REF*)ast_;
437 LIFT_DATA *data = (LIFT_DATA*)arg;
438 ast->env = data->env;
439 return ast_;
440 }
441
442 extern AST_CLASS ast_fun_class;
443 int is_inlining_var (VAR *var) {
444 return is_optimizing_lets && var->ast != NULL &&
445 ((var->n_refs == 1) || (var->ast->ast_class() == AST_FUN_CLASS));
446 }
447
448 AST *ast_ref_let_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
449 AST_REF *ast = (AST_REF*)ast_;
450 VAR *var = ast->var;
451 // post("WALKING %s %lx\n", var->name, var->ast);
452 if (is_inlining_var(var)) {
453 // post(" INLINING %s\n", var->name);
454 return ast_walk(action, ast->var->ast, arg);
455 } else
456 return ast_;
457 }
458
459 AST_REF::AST_REF(VAR *var, list<VAR*> *env) {
460 walkers[0]=&ast_ref_lift_walk; walkers[1]=&ast_ref_let_walk;
461 this->var=var; offset=-1; this->env=env; name="REF";
462 // post("NEW REF %s AT %d ", var->name, lookup_index(var, env)); env_print(env); post("\n");
463 type = var->type;
464 }
465
466 int lookup_index (VAR *var, list<VAR*> *env) {
467 int j;
468 typeof(env->begin()) it;
469 for (j = 0, it = env->begin(); it != env->end(); it++, j++) {
470 if (*it == var)
471 return j;
472 }
473 return -1;
474 }
475
476 void AST_REF::emit(Script* script) {
477 int n = lookup_index(var, env);
478 // post("EMIT VAR %s AT %d %d %lx\n", var->name, n, lst_len(env), env);
479 if (n < MAX_REF_OPS) script->add(REF_OP+n+1);
480 else script->add(REF_OP,n);
481 }
482
483 /**** AST_GLO_REF ****/
484 struct AST_GLO_REF : public AST {
485 AST *dat;
486 int offset; // Note: offset is always positive
487
488 AST_GLO_REF(AST *dat, int offset) {
489 this->dat=dat; this->offset=offset;
490 type = dat->type; name="REF";
491 }
492
493 void print() {
494 fprintf(error_log(),"REF("); dat->print();
495 fprintf(error_log()," %d)", offset);
496 }
497 void emit(Script* script);
498 AST_CLASS ast_class() { return AST_GLO_REF_CLASS; }
499 };
500
501 void AST_GLO_REF::emit(Script* script) {
502 if(offset < MAX_GLO_REF_OPS) script->add(GLO_REF_OP+offset+1);
503 else if(offset < 256) script->add(GLO_REF_OP,offset);
504 else script->add_op16(GLO_REF16_OP,offset);
505 }
506
507 /**** AST_OP, AST_GOP ****/
508 typedef TYPE* (*TYPE_INFER)(AST* ast);
509 struct AST_OP_CALL;
510
511 typedef void (*AST_EMIT)(AST_OP_CALL* val, Script* script);
512 extern void default_ast_op_call_emit(AST_OP_CALL* ast, Script* script);
513
514 struct AST_OP : public AST {
515 char *name;
516 char *opname;
517 OPCODE code;
518 int arity;
519 int is_nary;
520 TYPE_INFER type_infer;
521 AST_EMIT emit_fn; // this is a leftover of some sort...
522
523 AST_OP(char *name, char *opname, OPCODE code, int arity, int is_nary, TYPE *type, TYPE_INFER type_infer) {
524 AST::name="OP";
525 this->name=name; this->opname=opname; this->code=code;
526 this->arity=arity; this->is_nary=is_nary; this->type=type;
527 this->type_infer=type_infer;
528 emit_fn=&default_ast_op_call_emit;
529 }
530
531 AST_CLASS ast_class() { return AST_OP_CLASS; }
532 int stack_size() { return 1; } // for ast_zero_size; it's a mystery why
533 void emit(Script* script) { cerror(this,"OPs should never be emitted directly."); }
534 void emit_call(AST_OP_CALL *ast,Script* script) { emit_fn(ast,script); }
535 };
536
537 struct AST_GOP : public AST {
538 char *name;
539 int arity;
540 int is_nary;
541 list<AST_OP*> *ops;
542
543 AST_GOP(char *name, int arity, int is_nary, TYPE *type) {
544 AST::name="GOP";
545 this->name=name;
546 this->arity=arity;
547 this->is_nary=is_nary;
548 this->ops = new typeof(*this->ops);
549 this->type=type;
550 }
551
552 int stack_size() { return 1; } // for ast_zero_size; it's a mystery why
553 AST_CLASS ast_class() { return AST_GOP_CLASS; }
554 void emit(Script* script) { cerror(this,"GOP emit is undefined"); }
555 };
556
557 /**** AST_FUN ****/
558 #define MAX_OP_ARITY 2
559 struct AST_OP_CALL : public AST {
560 AST_OP *op;
561 list<AST*> *args;
562 int offsets[MAX_OP_ARITY];
563
564 AST_OP_CALL(AST_OP *op, list<AST*> *args);
565
566 void print();
567 void emit(Script* script) { op->emit_call(this, script); }
568 int stack_size();
569 int env_size();
570 AST_CLASS ast_class() { return AST_OP_CALL_CLASS; }
571
572 };
573
574 struct AST_FUN : public AST{
575 char *name;
576 FUN_TYPE *fun_type;
577 list<VAR*> *vars;
578 Obj *body;
579 AST *ast_body;
580
581 AST_FUN(char *name, list<VAR*> *vars, Obj *body, AST *ast_body);
582 void print() {
583 int i;
584 fprintf(error_log(),"(FUN (");
585 typeof(vars->begin()) it;
586 for (i = 0, it = vars->begin(); it != vars->end(); it++, i++) {
587 if (i != 0)
588 fprintf(error_log()," ");
589 fprintf(error_log(),"%s", (*it)->name);
590 }
591 fprintf(error_log(),") ");
592 if (ast_body == NULL)
593 fprintf(error_log(),"...");
594 else
595 ast_body->print();
596 fprintf(error_log(),")");
597 }
598
599 void emit(Script* script); // turn program element into bytecodes
600 AST_CLASS ast_class() { return AST_FUN_CLASS; }
601 };
602
603 TYPE* blur_type(TYPE* t) {
604 switch (t->kind) {
605 case ONE_NUM_KIND: return &num_type;
606 case ONE_FUN_KIND: return (TYPE*)((((ONE_FUN_TYPE*)t)->value)->fun_type);
607 default: return t;
608 }
609 }
610
611 extern AST_OP *tup_op, *fab_tup_op, *fab_vec_op, *fab_num_vec_op;
612 extern AST_OP *def_op, *def_num_vec_op, *def_vec_op, *def_tup_op;
613 extern AST_OP *def_num_vec_ops[];
614
615 extern AST* null_of(TYPE* t);
616
617 extern AST *new_ast_op_call_offset(AST_OP *op, list<AST*> *args, int offset);
618
619 AST* new_fab_vec (int len, TYPE* elt_type) {
620 AST *ast;
621 if (elt_type->kind == NUM_KIND) {
622 ast = new_ast_op_call_offset(fab_num_vec_op, new list<AST*>(), len);
623 } else {
624 list<AST*> *lst = new typeof(*lst);
625 lst->push_back(null_of(elt_type));
626 ast = new_ast_op_call_offset(fab_vec_op, lst, len);
627 }
628 return ast;
629 }
630
631 AST* null_of(TYPE* t) {
632 int i;
633 switch (t->kind) {
634 case NUM_KIND:
635 case ONE_NUM_KIND:
636 // post("NUM\n");
637 return new AST_LIT(0);
638 case VEC_KIND: {
639 VEC_TYPE *vt = (VEC_TYPE*)t;
640 // post("VEC %d\n", vt->len);
641 return new_fab_vec(vt->len, vt->elt_type); }
642 case TUP_KIND: {
643 TUP_TYPE *tt = (TUP_TYPE*)t;
644 list<AST*> *args = new typeof(*args);
645 // post("TUP %d\n", tt->len);
646 for (i = 0; i < tt->len; i++)
647 args->push_back(null_of(tt->elt_types[i]));
648 return new AST_OP_CALL(fab_tup_op, args);
649 }
650 default:
651 uerror("unable to build null of type %s", t->name());
652 }
653 }
654
655 extern TYPE* tup_type_elt (TYPE*, int);
656 extern int tup_type_len (TYPE*);
657
658 AST* real_null_of(TYPE* t) {
659 int i;
660 switch (t->kind) {
661 case NUM_KIND:
662 case ONE_NUM_KIND:
663 // post("NUM\n");
664 return new AST_LIT(0);
665 case VEC_KIND:
666 case TUP_KIND: {
667 list<AST*> *args = new typeof(*args);
668 // post("VEC/TUP %d\n", tup_type_len(t));
669 for (i = 0; i < tup_type_len(t); i++)
670 args->push_back(real_null_of(tup_type_elt(t, i)));
671 return new AST_OP_CALL(tup_op, args);
672 }
673 default:
674 uerror("unable to build null of type %s", t->name());
675 }
676 }
677
678 int is_same_type (TYPE* t1_, TYPE* t2_) {
679 TYPE* t1 = blur_type(t1_);
680 TYPE* t2 = blur_type(t2_);
681 return t1->subtype(t2) && t2->subtype(t1);
682 }
683
684 AST *ast_fun_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
685 AST_FUN *ast = (AST_FUN*)ast_;
686 if (ast->ast_body == NULL)
687 cerror(ast_, "ILLEGAL REF TO FUN NOT IN CALL POSITION");
688 ast->ast_body = ast_walk(action, ast->ast_body, arg);
689 return ast_;
690 }
691
692 int has_same_fun_bodies (AST *a1, AST *a2) {
693 if (a1->ast_class() == AST_LIT_CLASS && a2->ast_class() == AST_LIT_CLASS) {
694 return (((AST_LIT*)a1)->kind == ((AST_LIT*)a2)->kind &&
695 ((AST_LIT*)a1)->val == ((AST_LIT*)a2)->val);
696 } else
697 return 0;
698 }
699
700 int maybe_lift_fun (AST_FUN *ast, LIFT_DATA *data) {
701 int k, n = data->glos->size();
702 typeof(data->glos->rbegin()) it;
703 // post("LIFTING %s\n", ast->name);
704 for (k = 0, it = data->glos->rbegin();
705 it != data->glos->rend();
706 it++, k++) {
707 AST_FUN *fun = (AST_FUN*)*it;
708 if (fun->ast_class() == AST_FUN_CLASS) {
709 if (fun == ast || has_same_fun_bodies(fun->ast_body, ast->ast_body)) {
710 // post("FOUND OLD AST %d AT %d\n", fun == ast, n-k-1);
711 return n-k-1;
712 }
713 }
714 }
715 data->glos->push_back(ast);
716 return n;
717 }
718
719 list<VAR*> *augment_env (list<VAR*> *vars, list<VAR*> *env) {
720 list<VAR*> *newenv = new list<VAR*>(*env);
721 newenv->insert(newenv->begin(), vars->rbegin(), vars->rend());
722 return newenv;
723 }
724
725 AST *ast_fun_lift_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
726 AST_FUN *ast = (AST_FUN*)ast_;
727 LIFT_DATA *data = (LIFT_DATA*)arg;
728 list<VAR*> *env = data->env;
729 data->env = augment_env(ast->vars, data->env);
730 ast->ast_body = ast_walk(action, ast->ast_body, arg);
731 data->env = env;
732 if (data->is_fun_lift)
733 return new AST_GLO_REF(ast_, maybe_lift_fun(ast, data));
734 else
735 return ast_;
736 }
737
738 void emit_def_fun_op (int n, Script* script) {
739 if(n > 1 && n <= MAX_DEF_FUN_OPS) script->add(DEF_FUN_2_OP+(n-2));
740 else if(n < 256) script->add(DEF_FUN_OP, n);
741 else script->add_op16(DEF_FUN16_OP, n);
742 }
743
744 AST_FUN::AST_FUN(char *name, list<VAR*> *vars, Obj *body, AST *ast_body) {
745 AST::name="FUN"; walkers[0]=&ast_fun_lift_walk; walkers[1]=&ast_fun_walk;
746 this->name = name; this->vars = vars;
747 this->type = new ONE_FUN_TYPE(this);
748 this->fun_type = new FUN_TYPE(vars->size(), 0);
749 this->body = body;
750 this->ast_body = ast_body;
751 }
752
753 void AST_FUN::emit(Script* script) {
754 Script body; ast_body->emit(&body);
755 emit_def_fun_op(body.size()+1,script);
756 script->append(&body);
757 script->add(RET_OP);
758 }
759
760 /**** AST_LET ****/
761 struct AST_LET : public AST {
762 list<VAR*> *vars;
763 list<AST*> *inits;
764 AST *body;
765 list<VAR*> *env;
766
767 AST_LET(list<VAR*> *vars, list<AST*> *inits, AST *body, list<VAR*> *env);
768 void print();
769 void emit(Script* script);
770 int stack_size();
771 int env_size();
772 AST_CLASS ast_class() { return AST_LET_CLASS; }
773 };
774
775 extern AST* parse (Obj *e, list<VAR*> *env);
776
777 AST *ast_let_lift_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
778 AST_LET *ast = (AST_LET*)ast_;
779 LIFT_DATA *data = (LIFT_DATA*)arg;
780 list<AST*> *inits = ast->inits;
781 list<VAR*> *env = data->env;
782 for(typeof(inits->begin()) it = inits->begin();
783 it != inits->end(); it++)
784 *it = ast_walk(action, *it, arg);
785 data->env = augment_env(ast->vars, data->env);
786 ast->body = ast_walk(action, ast->body, arg);
787 data->env = env;
788 return ast_;
789 }
790
791 AST *ast_let_let_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
792 AST_LET *ast = (AST_LET*)ast_;
793 typeof(ast->vars->begin()) vit;
794 typeof(ast->inits->begin()) iit;
795
796 ast->body = ast_walk(action, ast->body, arg);
797 for (vit = ast->vars->begin(), iit = ast->inits->begin();
798 vit != ast->vars->end();) {
799 if (!is_inlining_var(*vit) && !(is_optimizing_lets && (*vit)->n_refs == 0)) {
800 *iit = ast_walk(action, *iit, arg);
801 vit++; iit++;
802 } else {
803 vit = ast->vars->erase(vit);
804 iit = ast->inits->erase(iit);
805 }
806 }
807 if (ast->vars->empty()) {
808 return ast->body;
809 } else
810 return ast_;
811 }
812
813 void AST_LET::print() {
814 fprintf(error_log(),"(LET (");
815 int i;
816 typeof(vars->begin()) vit;
817 typeof(inits->begin()) iit;
818 for(i=0, vit=vars->begin(), iit=inits->begin();
819 vit != vars->end(); i++, vit++, iit++) {
820 if (i != 0)
821 fprintf(error_log(), " ");
822 fprintf(error_log(), "(%s ", (*vit)->name);
823 (*iit)->print();
824 fprintf(error_log(), ")");
825 }
826 fprintf(error_log(),") ");
827 body->print();
828 fprintf(error_log(),")");
829 }
830
831 void emit_let_op (int n, Script* script) {
832 if (n > 0) {
833 if (n <= MAX_LET_OPS) script->add(LET_OP+n);
834 else script->add(LET_OP,n);
835 }
836 }
837
838 void emit_pop_let_op (int n, Script* script) {
839 if (n > 0) {
840 if (n <= MAX_LET_OPS) script->add(POP_LET_OP+n);
841 else script->add(POP_LET_OP,n);
842 }
843 }
844
845 void AST_LET::emit(Script* script) {
846 int n=0;
847 typeof(inits->begin()) iit;
848 for(iit=inits->begin(); iit != inits->end(); iit++) {
849 (*iit)->emit(script);
850 n += 1;
851 }
852 emit_let_op(n, script);
853 body->emit(script);
854 emit_pop_let_op(n, script);
855 }
856
857 inline int int_max (int x, int y) { return x < y ? y : x; }
858
859 void post_space (int depth) {
860 int i;
861 fprintf(error_log(),"[%2d] ", depth);
862 for (i = 0; i < depth; i++)
863 fprintf(error_log()," ");
864 }
865
866 int dep=0;
867 int AST_LET::stack_size() {
868 int size = 0;
869
870 for (typeof(inits->begin()) it = inits->begin();
871 it != inits->end(); it++) {
872 size = int_max(size, (*it)->stack_size() - 1);
873 }
874 size = int_max(size, body->stack_size()) + int_max(1, inits->size());
875
876 return size;
877 }
878
879 int AST_LET::env_size() {
880 int size = 0;
881
882 for (typeof(inits->begin()) it = inits->begin();
883 it != inits->end(); it++) {
884 size = int_max(size, (*it)->env_size());
885 }
886
887 size = int_max(size, body->env_size() + inits->size());
888
889 return size;
890 }
891
892 AST_LET::AST_LET(list<VAR*> *vars, list<AST*> *inits, AST *body, list<VAR*> *env) {
893 name="LET";
894 walkers[0]=&ast_let_lift_walk;
895 walkers[1]=&ast_let_let_walk;
896 this->vars=vars;
897 this->inits=inits;
898 this->body=body;
899 this->env=env;
900 type = body->type;
901 }
902
903 AST *new_ast_let (list<VAR*> *vars, list<AST*> *inits, AST *body, list<VAR*> *env) {
904 return (vars->size() > 0) ? new AST_LET(vars,inits,body,env) : body;
905 }
906
907 /**** AST_OP_CALL ****/
908 // definition moved above for the benefit of AST_FUN
909
910 int add_offset (AST_OP_CALL *ast, int offset) {
911 int i;
912 for (i = 0; i < ast->op->arity; i++)
913 if (ast->offsets[i] == -1)
914 return ast->offsets[i] = offset;
915 cerror((AST*)ast, "UNABLE TO ASSIGN OFFSET %d", offset);
916 }
917
918 AST *new_ast_op_call_offset(AST_OP *op, list<AST*> *args, int offset) {
919 AST_OP_CALL *call = (AST_OP_CALL*)new AST_OP_CALL(op, args);
920 add_offset(call, offset);
921 call->type = op->type_infer((AST*)call);
922 return (AST*)call;
923 }
924
925 AST *ast_op_call_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
926 AST_OP_CALL *ast = (AST_OP_CALL*)ast_;
927
928 for(typeof(ast->args->begin()) it = ast->args->begin();
929 it != ast->args->end(); it++) {
930 *it = ast_walk(action, *it, arg);
931 }
932 return ast_;
933 }
934
935 AST *insert_def_tup (AST *tup_) {
936 AST_OP_CALL *tup = (AST_OP_CALL*)tup_;
937 int len = tup->offsets[0];
938 if (tup->op == fab_num_vec_op) {
939 if (len == 0)
940 uerror("LEN == 0\n");
941 if (len > 0 && len <= MAX_DEF_NUM_VEC_OPS)
942 return new AST_OP_CALL(def_num_vec_ops[len], tup->args);
943 else
944 return new_ast_op_call_offset(def_num_vec_op, tup->args, len);
945 } else if (tup->op == fab_tup_op) {
946 return new AST_OP_CALL(def_tup_op, tup->args);
947 } else if (tup->op == fab_vec_op)
948 return new_ast_op_call_offset(def_vec_op, tup->args, len);
949 else
950 cerror(tup_, "UNABLE TO FIND TUP DEF");
951 }
952
953 void map_lift (AST_OP_CALL *ast, LIFT_DATA *data) {
954 // AST *vec_lit = new_ast_op_call(def_op, PAIR(null_of(ast->type), lisp_nil));
955 AST *vec_lit = insert_def_tup(null_of(ast->type));
956 data->glos->push_back(vec_lit);
957 add_offset(ast, data->glos->size()-1);
958 }
959
960 void channel_lift (AST_OP_CALL *ast, LIFT_DATA *data) {
961 add_offset(ast, data->n_channels);
962 data->n_channels = data->n_channels + 1;
963 }
964
965 void tup_lift (AST_OP_CALL *ast, LIFT_DATA *data) {
966 AST *fab_vec = new_fab_vec(tup_type_len(ast->type), NUMT);
967 data->glos->push_back(insert_def_tup(fab_vec));
968 add_offset(ast, data->glos->size()-1);
969 }
970
971 void init_feedback_lift (AST_OP_CALL *ast, LIFT_DATA *data) {
972 add_offset(ast, data->n_state++);
973 }
974
975 extern AST_CLASS ast_op_call_class;
976
977 void fold_hood_lift (AST_OP_CALL *ast, LIFT_DATA *data) {
978 typeof(ast->args->begin()) it = ast->args->begin();
979 it++; it++;
980 AST* arg = *it;
981 int size = arg->type->size();
982 if (size <= 0)
983 cerror(arg, "UNDERSPECIFIED TYPE SIZE IN EXPORT");
984 data->export_len += size;
985 add_offset(ast, data->n_exports++);
986 }
987
988 // FEEDBACK - (ALL (UNLESS IS-EXEC? (SET INIT (INIT))) (SET IS-EXEC? T) OFF)
989 // SET-FEEDBACK - (SET OFF (EXEC))
990
991 AST_OP_CALL *feedback_init(AST_OP_CALL *ast) {
992 AST *arg = ast->args->front();
993 if (arg->ast_class() == AST_REF_CLASS) {
994 AST_REF* ref = (AST_REF*)arg;
995 return (AST_OP_CALL*)ref->var->ast;
996 } else if (arg->ast_class() == AST_OP_CALL_CLASS) {
997 return (AST_OP_CALL*)arg;
998 } else {
999 cerror((AST*)ast, "UNKNOWN INIT-FEEDBACK FROM FEEDBACK");
1000 }
1001 }
1002
1003 void feedback_lift (AST_OP_CALL *ast, LIFT_DATA *data) {
1004 AST_OP_CALL *init = feedback_init(ast);
1005 add_offset(ast, init->offsets[0]);
1006 // post("LIFTING FEEDBACK %d\n", init->offsets[0]);
1007 }
1008
1009 // feedback_op offset init_bytes
1010 // update_bytes
1011
1012 AST_OP *all_op;
1013 AST_OP *hsv_op;
1014 AST_OP *init_feedback_op;
1015 AST_OP *feedback_op;
1016 AST_OP *nbr_vec_op;
1017 AST_OP *map_op;
1018 AST_OP *channel_op;
1019 AST_OP *vadd_op;
1020 AST_OP *vsub_op;
1021 AST_OP *vmul_op;
1022 AST_OP *fold_hood_op;
1023 AST_OP *vfold_hood_op;
1024 AST_OP *fold_op;
1025 AST_OP *vfold_op;
1026 AST_OP *fold_hood_plus_op;
1027 AST_OP *vfold_hood_plus_op;
1028 AST_OP *apply_op;
1029 AST_OP *nul_tup_op;
1030 AST_OP *tup_op;
1031 AST_OP *if_op;
1032 AST_OP *mux_op, *vmux_op;
1033 AST_OP *fab_tup_op;
1034 AST_OP *fab_vec_op;
1035 AST_OP *fab_num_vec_op;
1036 AST_OP *def_num_vec_op;
1037 AST_OP *def_num_vec_ops[MAX_DEF_NUM_VEC_OPS+1];
1038 AST_OP *def_vec_op;
1039 AST_OP *def_tup_op;
1040 AST_OP *def_op;
1041
1042 AST *ast_op_call_lift_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
1043 AST_OP_CALL *ast = (AST_OP_CALL*)ast_;
1044 AST_OP *op = ast->op;
1045 LIFT_DATA *data = (LIFT_DATA*)arg;
1046 AST *res = ast_op_call_walk(action, ast_, arg);
1047 if (data->is_fun_lift) {
1048 if (op == fold_hood_op || op == vfold_hood_op ||
1049 op == fold_hood_plus_op || op == vfold_hood_plus_op)
1050 fold_hood_lift(ast, data);
1051 } else {
1052 if (op == map_op || op == vadd_op || op == vsub_op || op == vmul_op ||
1053 op == vfold_op || op == vfold_hood_op || op == vfold_hood_plus_op ||
1054 op == nbr_vec_op || op == hsv_op || op == vmux_op)
1055 map_lift(ast, data);
1056 else if (op == tup_op )
1057 tup_lift(ast, data);
1058 else if (op == feedback_op)
1059 feedback_lift(ast, data);
1060 else if (op == init_feedback_op)
1061 init_feedback_lift(ast, data);
1062 else if (op == channel_op)
1063 channel_lift(ast, data);
1064 }
1065 return res;
1066 }
1067
1068 void ast_args_print (list<AST*> *args) {
1069 for (typeof(args->begin()) i = args->begin(); i != args->end(); i++) {
1070 fprintf(error_log()," ");
1071 (*i)->print();
1072 }
1073 }
1074
1075 void AST_OP_CALL::print() {
1076 fprintf(error_log(),"(");
1077 fprintf(error_log(),"%s", op->name);
1078 ast_args_print(args);
1079 fprintf(error_log(),")");
1080 }
1081
1082 void default_ast_op_call_emit(AST_OP_CALL* ast, Script* script) {
1083 for (typeof(ast->args->begin()) it = ast->args->begin();
1084 it != ast->args->end(); it++)
1085 (*it)->emit(script);
1086 script->add(ast->op->code);
1087 if (ast->op->arity > MAX_OP_ARITY)
1088 uerror("ILLEGAL ARITY FOR OP %d > %d", ast->op->arity, MAX_OP_ARITY);
1089 for (int i = 0; i < ast->op->arity; i++)
1090 script->add(ast->offsets[i]);
1091 if (ast->op->is_nary)
1092 script->add(ast->args->size());
1093 }
1094
1095 // <- DONE-OFF ->
1096 // <--- THEN OFF --->
1097 // TST IF_OP T1 T2 ELSE JMP_OP D1 D2 THEN NEXT
1098 // IF_LEN JMP_LEN
1099 void ast_if_emit(AST_OP_CALL* ast, Script* script) {
1100 Script if_script;
1101 Script then_script;
1102 Script jmp_script;
1103
1104 typeof(ast->args->begin()) it = ast->args->begin();
1105 (*it++)->emit(&if_script);
1106 (*it++)->emit(&then_script);
1107 (*it++)->emit(&jmp_script);
1108
1109 uint16_t then_offset = jmp_script.size()+2;
1110 uint16_t done_offset = then_script.size();
1111 if(done_offset > 255) then_offset++;
1112
1113 script->append(&if_script);
1114 if(then_offset > 255)
1115 script->add_op16(IF_16_OP,then_offset);
1116 else
1117 script->add(IF_OP,then_offset);
1118 script->append(&jmp_script);
1119 if(done_offset > 255)
1120 script->add_op16(JMP_16_OP,done_offset);
1121 else
1122 script->add(JMP_OP,done_offset);
1123 script->append(&then_script);
1124 }
1125
1126 int fun_stk_size (AST *rfun) {
1127 AST_FUN* fun = ((ONE_FUN_TYPE*)rfun->type)->value;
1128 FUN_TYPE* type = (FUN_TYPE*)fun->fun_type;
1129 return type->arity + fun->ast_body->stack_size();
1130 }
1131
1132 int AST_OP_CALL::stack_size() {
1133 int size = 0, base_size = 0;
1134
1135 if (op == map_op ||
1136 op == fold_hood_op || op == fold_op ||
1137 op == vfold_hood_op || op == vfold_op ||
1138 op == apply_op) {
1139 base_size = fun_stk_size(args->front());
1140 } else if ( op == feedback_op ) {
1141 base_size = fun_stk_size(feedback_init(this)->args->front());
1142 } else if ( op == fold_hood_plus_op || op == vfold_hood_plus_op) {
1143 typeof(args->begin()) it = args->begin();
1144 base_size = int_max(fun_stk_size(*it++),
1145 fun_stk_size(*it++));
1146 }
1147 for (typeof(args->begin()) it = args->begin();
1148 it != args->end(); it++ ) {
1149 size = int_max(size, (*it)->stack_size() - 1);
1150 }
1151 size = base_size + size + int_max(1, args->size());
1152 return size;
1153 }
1154
1155 int fun_env_size (AST *rfun) {
1156 AST_FUN* fun = ((ONE_FUN_TYPE*)rfun->type)->value;
1157 FUN_TYPE* type = (FUN_TYPE*)fun->fun_type;
1158 return type->arity + fun->ast_body->env_size();
1159 }
1160
1161 int AST_OP_CALL::env_size() {
1162 int size = 0, base_size = 0;
1163 if (op == map_op ||
1164 op == fold_hood_op || op == vfold_hood_op ||
1165 op == fold_op || op == vfold_op || op == apply_op) {
1166 base_size = fun_env_size(args->front());
1167 } else if ( op == feedback_op ) {
1168 base_size = fun_stk_size(feedback_init(this)->args->front());
1169 } else if (op == fold_hood_plus_op || op == vfold_hood_plus_op) {
1170 typeof(args->begin()) it = args->begin();
1171 base_size = int_max(fun_env_size(*it++),
1172 fun_env_size(*it++));
1173 }
1174 for (typeof(args->begin()) it = args->begin();
1175 it != args->end(); it++ ) {
1176 size = int_max(size, (*it)->env_size());
1177 }
1178
1179 size = base_size + size;
1180
1181 return size;
1182 }
1183
1184 AST_OP_CALL::AST_OP_CALL(AST_OP *op, list<AST*> *argv) : args(argv) {
1185 name="OP_CALL";
1186 walkers[0]=&ast_op_call_lift_walk; walkers[1]=&ast_op_call_walk;
1187 this->op=op;
1188 type = op->type_infer(this);
1189 for(int i = 0; i < op->arity; i++) offsets[i] = -1;
1190 }
1191
1192 /**** AST_CALL ****/
1193 struct AST_CALL : public AST {
1194 AST_FUN *fun;
1195 list<AST*> *args;
1196
1197 AST_CALL(AST *fun, list<AST*> *args);
1198
1199 void print() {
1200 fprintf(error_log(),"(");
1201 fun->print();
1202 ast_args_print(args);
1203 fprintf(error_log(),")");
1204 }
1205 void emit(Script* script) { cerror(this,"ILLEGAL CALL IN RUNTIME"); }
1206 int stack_size() { return 1; } // for ast_zero_size; it's a mystery why
1207 AST_CLASS ast_class() { return AST_CALL_CLASS; }
1208 };
1209
1210 AST *ast_call_walk (AST_WALKER_KIND action, AST *ast_, void *arg) {
1211 AST_CALL *ast = (AST_CALL*)ast_;
1212 list<AST*> *new_args = new list<AST*>;
1213 for (typeof(ast->args->begin()) it = ast->args->begin();
1214 it != ast->args->end(); it++) {
1215 new_args->push_back(ast_walk(action, *it, arg));
1216 }
1217 ast->args = new_args;
1218 ast->fun = (AST_FUN*)ast_walk(action, ast->fun, arg);
1219 return ast_;
1220 }
1221
1222 AST_CALL::AST_CALL(AST *fun, list<AST*> *argv) : args(argv) {
1223 name="CALL";
1224 walkers[0]=walkers[1]=&ast_call_walk;
1225 if(!fun->ast_class() == AST_FUN_CLASS) cerror(this,"CALL OF NON-FUNCTION");
1226 this->fun=(AST_FUN*)fun;
1227 type = this->fun->ast_body->type;
1228 }
1229
1230 /****** OPERATION DEFINITION ******/
1231 list<VAR*> *ops;
1232 list<VAR*> *user_ops;
1233
1234 extern VAR* lookup_name (const char *name, list<VAR*> *bindings);
1235
1236 AST_OP *add_op_full
1237 (char *name, char *opname, OPCODE code, int arity, int is_nary,
1238 FUN_TYPE *fun_type, TYPE_INFER type_infer) {
1239 AST_OP *op = (AST_OP*)new AST_OP(name, opname, code, arity, is_nary, (TYPE*)fun_type, type_infer);
1240 VAR *var = lookup_name(name, ops);
1241 if (var == NULL)
1242 ops->push_front(new VAR(name, new ONE_OP_TYPE(op)));
1243 else {
1244 // post("FOUND OLD OP %s\n", name);
1245 switch (var->type->kind) {
1246 case ONE_OP_KIND: {
1247 AST_GOP *gop = (AST_GOP*)new AST_GOP(name, arity, is_nary, (TYPE*)fun_type);
1248 AST_OP *oop = ((ONE_OP_TYPE*)var->type)->op;
1249 TYPE *type = new ONE_GOP_TYPE(gop);
1250 // post("ADDING OP TO NEW GOP\n");
1251 gop->ops = new typeof(*gop->ops);
1252 gop->ops->push_back(op);
1253 gop->ops->push_back(oop);
1254 var->type = type;
1255 break; }
1256 case ONE_GOP_KIND: {
1257 AST_GOP *gop = ((ONE_GOP_TYPE*)var->type)->gop;
1258 // post("ADDING OP TO EXISTING GOP\n");
1259 gop->ops->push_back(op);
1260 break; }
1261 default:
1262 uerror("ADDING OP TO NON OP VAR %s\n", name);
1263 }
1264 }
1265 // post("ADDING %s %d\n", name, code);
1266 return op;
1267 }
1268
1269 extern TYPE* op_type_infer (AST* ast_);
1270
1271 AST_OP *add_op_named
1272 (char *name, char *opname, OPCODE code, int arity, int is_nary,
1273 FUN_TYPE *fun_type) {
1274 return add_op_full
1275 (name, opname, code, arity, is_nary, fun_type, &op_type_infer);
1276 }
1277
1278 AST_OP *add_op_typed
1279 (char *name, OPCODE code, int arity, int is_nary,
1280 FUN_TYPE *fun_type, TYPE_INFER type_infer) {
1281 return add_op_full(name, name, code, arity, is_nary, fun_type, type_infer);
1282 }
1283
1284 AST_OP *add_op_named_typed
1285 (char *name, char *opname, OPCODE code, int arity, int is_nary,
1286 FUN_TYPE *fun_type, TYPE_INFER type_infer) {
1287 return add_op_full(name, opname, code, arity, is_nary, fun_type, type_infer);
1288 }
1289
1290 AST_OP *add_op
1291 (char *name, OPCODE code, int arity, int is_nary, FUN_TYPE *fun_type) {
1292 return add_op_full
1293 (name, name, code, arity, is_nary, fun_type, &op_type_infer);
1294 }
1295
1296 AST_OP *def_op_alias (char *name, AST_OP *op) {
1297 ops->push_front(new VAR(name, new ONE_OP_TYPE(op)));
1298 return op;
1299 }
1300
1301 char *cpy_str (char *s) {
1302 char *r = (char*)MALLOC(strlen(s)+1);
1303 strcpy(r, s);
1304 return r;
1305 }
1306
1307 int tup_type_len (TYPE* type) {
1308 switch (type->kind) {
1309 case TUP_KIND: return ((TUP_TYPE*)type)->len;
1310 case VEC_KIND: return ((VEC_TYPE*)type)->len;
1311 default: uerror("EXPECTED TUP/VEC TYPE %s\n", type->name());
1312 }
1313 }
1314
1315 TYPE* tup_type_elt (TYPE* type, int i) {
1316 switch (type->kind) {
1317 case TUP_KIND: return ((TUP_TYPE*)type)->elt_types[i];
1318 case VEC_KIND: return ((VEC_TYPE*)type)->elt_type;
1319 default: uerror("EXPECTED TUP/VEC TYPE %s\n", type->name());
1320 }
1321 }
1322
1323 TYPE* op_type_infer (AST* ast_) {
1324 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1325 FUN_TYPE *type = (FUN_TYPE*)(ast->op)->type;
1326 return type->result_type;
1327 }
1328
1329 TYPE* tup_type_infer (AST* ast_) {
1330 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1331 // Are all the nodes the same? If so, is VEC; otherwise is TUP
1332 bool is_same = true;
1333 int i = 0;
1334 int len = ast->args->size();
1335 if(len==0)
1336 return new TUP_TYPE(0,NULL);
1337 TYPE* types[len];
1338 for(typeof(ast->args->begin()) it = ast->args->begin();
1339 it != ast->args->end(); it++, i++) {
1340 types[i]=blur_type((*it)->type);
1341 is_same &= is_same_type(types[i],types[0]);
1342 }
1343 if(is_same)
1344 return new VEC_TYPE(len,types[0]);
1345 else
1346 return new TUP_TYPE(len,types);
1347 }
1348
1349 TYPE* vec_type_infer (AST* ast_) {
1350 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1351 TYPE* elt = ast->args->front()->type;
1352 int k = ast->offsets[0];
1353 return new VEC_TYPE(k, elt);
1354 }
1355
1356 TYPE* num_vec_type_infer (AST* ast_) {
1357 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1358 int k = ast->offsets[0];
1359 return new VEC_TYPE(k, &num_type);
1360 }
1361
1362 TYPE* elt_type_infer (AST* ast_) {
1363 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1364 if(ast->args->size()<2)
1365 cerror(ast_,"ELT CANNOT INFER TYPE WHEN NOT ENOUGH ARGUMENTS");
1366 typeof(ast->args->begin()) it = ast->args->begin();
1367 TYPE* elts = (*it++)->type;
1368 TYPE* idx = (*it++)->type;
1369 if (elts->kind == VEC_KIND)
1370 return ((VEC_TYPE*)elts)->elt_type;
1371 else if (idx->kind == ONE_NUM_KIND) {
1372 if (elts->kind == TUP_KIND) {
1373 TYPE *res = ((TUP_TYPE*)elts)->elt_types[(int)((ONE_NUM_TYPE*)idx)->num];
1374 // post("ELT TYPE %s\n", type_name(res));
1375 return res;
1376 } else {
1377 cerror(ast_, "ELT: TYPE ERROR EXPECTED VEC/TUP GOT %s", elts->name());
1378 }
1379 } else {
1380 cerror(ast_, "ELT: UNABLE TO TYPE ELT %s %s", idx->name(), elts->name());
1381 }
1382 }
1383
1384 TYPE* map_type_infer (AST* ast_) {
1385 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1386 ONE_FUN_TYPE* fun = (ONE_FUN_TYPE*)ast->args->front()->type;
1387 return fun->value->ast_body->type;
1388 }
1389
1390 TYPE* fold_type_infer (AST* ast_) {
1391 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1392 ONE_FUN_TYPE* fun = (ONE_FUN_TYPE*)ast->args->front()->type;
1393 return fun->value->ast_body->type;
1394 }
1395
1396 TYPE* fold_hood_type_infer (AST* ast_) {
1397 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1398 ONE_FUN_TYPE* fun = (ONE_FUN_TYPE*)ast->args->front()->type;
1399 return fun->value->ast_body->type;
1400 }
1401
1402 TYPE* fold_hood_plus_type_infer (AST* ast_) {
1403 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1404 typeof(ast->args->begin()) it = ast->args->begin();
1405 it++;
1406 ONE_FUN_TYPE* fun = (ONE_FUN_TYPE*)(*it)->type;
1407 return fun->value->ast_body->type;
1408 }
1409
1410 TYPE* apply_type_infer (AST* ast_) {
1411 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1412 ONE_FUN_TYPE* fun = (ONE_FUN_TYPE*)ast->args->front()->type;
1413 return fun->value->ast_body->type;
1414 }
1415
1416 TYPE* mux_type_infer (AST* ast_) {
1417 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1418 typeof(ast->args->begin()) it = ast->args->begin();
1419 it++; // skip the condition
1420 AST* con = (AST*)(*it++);
1421 return blur_type(con->type);
1422 }
1423
1424 TYPE* vadd_type_infer (AST* ast_) {
1425 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1426 typeof(ast->args->begin()) it = ast->args->begin();
1427 TYPE* t1 = (*it++)->type;
1428 TYPE* t2 = (*it++)->type;
1429 return (tup_type_len(t1) > tup_type_len(t2)) ? t1 : t2;
1430 }
1431
1432 TYPE* vmul_type_infer (AST* ast_) {
1433 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1434 typeof(ast->args->begin()) it = ast->args->begin();
1435 it++;
1436 return (*it)->type;
1437 }
1438
1439 TYPE* probe_type_infer (AST* ast_) {
1440 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1441 AST* val = ast->args->front();
1442 return val->type;
1443 }
1444
1445 TYPE* init_feedback_type_infer (AST* ast_) {
1446 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1447 AST_FUN* fun = (AST_FUN*)ast->args->front();
1448 return fun->ast_body->type;
1449 }
1450
1451 TYPE* all_type_infer (AST* ast_) {
1452 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1453 int len = ast->args->size();
1454 if (len > 0)
1455 return ast->args->back()->type;
1456 else
1457 return &any_type;
1458 }
1459
1460 TYPE* feedback_type_infer (AST* ast_) {
1461 AST_OP_CALL* ast = (AST_OP_CALL*)ast_;
1462 AST* init = ast->args->front();
1463 return init->type;
1464 }
1465
1466 void init_ops () {
1467 int i;
1468 AST_OP *op;
1469 char name[100];
1470 ops = new list<VAR*>();
1471 fold_hood_plus_op =
1472 add_op_typed("FOLD-HOOD-PLUS", FOLD_HOOD_PLUS_OP, 1, 0,
1473 new FUN_TYPE(ANYT,ANYT,ANYT,ANYT,0),
1474 &fold_hood_plus_type_infer);
1475 vfold_hood_plus_op =
1476 add_op_typed("VFOLD-HOOD-PLUS", VFOLD_HOOD_PLUS_OP, 2, 0,
1477 new FUN_TYPE(ANYT,ANYT,ANYT,ANYT,0),
1478 &fold_hood_plus_type_infer);
1479 fold_hood_op =
1480 add_op_typed("FOLD-HOOD", FOLD_HOOD_OP, 1, 0,
1481 new FUN_TYPE(ANYT,ANYT,ANYT,ANYT,0), &fold_hood_type_infer);
1482 vfold_hood_op =
1483 add_op_typed("VFOLD-HOOD", VFOLD_HOOD_OP, 2, 0,
1484 new FUN_TYPE(ANYT,ANYT,ANYT,ANYT,0), &fold_hood_type_infer);
1485 add_op_typed("ELT", ELT_OP, 0, 0,
1486 new FUN_TYPE(ANYT,ANYT,NUMT,0), &elt_type_infer);
1487 def_op_alias("MIX", fold_hood_op);
1488 add_op("DT", DT_OP, 0, 0, new FUN_TYPE(NUMT,0));
1489 op = add_op("MOV", MOV_OP, 0, 0, new FUN_TYPE(VEC3T,VEC3T,0));
1490 add_op("SPEED", SPEED_OP, 0, 0, new FUN_TYPE(NUMT,0));
1491 add_op("BEARING", BEARING_OP, 0, 0, new FUN_TYPE(NUMT,0));
1492 add_op("SET-DT", SET_DT_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1493 add_op_typed("PROBE", PROBE_OP, 0, 0,
1494 new FUN_TYPE(ANYT,ANYT,NUMT,0),&probe_type_infer);
1495 add_op("FLEX", FLEX_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1496
1497
1498 add_op("RND", RND_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1499 add_op_named("INF", "INF", INF_OP, 0, 0, new FUN_TYPE(NUMT,0));
1500
1501 //Mathematical Comparison Operators
1502 add_op_named("<", "LT", LT_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1503 add_op_named("<=", "LTE", LTE_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1504 add_op_named(">", "GT", GT_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1505 add_op_named(">=", "GTE", GTE_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1506 add_op_named("=", "EQ", EQ_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1507
1508 //Mathematical Operators
1509 op = add_op_named("B+", "ADD", ADD_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1510 def_op_alias("+", op);
1511 add_op_named("-", "SUB", SUB_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1512 op = add_op_named("B*", "MUL", MUL_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1513 def_op_alias("*", op);
1514 add_op_named("/", "DIV", DIV_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1515
1516 //Math Functions
1517 add_op("FLOOR", FLOOR_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1518 add_op("CEIL", CEIL_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1519 add_op("ABS", ABS_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1520 add_op("MAX", MAX_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1521 add_op("MIN", MIN_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1522 add_op("MOD", MOD_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1523 add_op("POW", POW_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1524 add_op("SQRT", SQRT_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1525 add_op("LOG", LOG_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1526 add_op("SIN", SIN_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1527 add_op("COS", COS_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1528 add_op("TAN", TAN_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1529 add_op("ASIN", ASIN_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1530 add_op("ACOS", ACOS_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1531 add_op("ATAN2", ATAN2_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,NUMT,0));
1532 add_op("SINH", SINH_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1533 add_op("COSH", COSH_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1534 add_op("TANH", TANH_OP, 0, 0, new FUN_TYPE(NUMT,NUMT,0));
1535
1536 all_op =
1537 add_op_typed("ALL", ALL_OP, 0, 1,
1538 new FUN_TYPE(ANYT,ANYT,1), &all_type_infer);
1539 def_op_alias("PAR", all_op);
1540
1541 //Vector Operations
1542 vadd_op =
1543 add_op_named_typed("B+", "VADD", VADD_OP, 1, 0,
1544 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1545 def_op_alias("VADD", vadd_op);
1546
1547 vsub_op =
1548 add_op_named_typed("-", "VSUB", VSUB_OP, 1, 0,
1549 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1550 def_op_alias("VSUB", vsub_op);
1551
1552 vmul_op =
1553 add_op_named_typed("B*", "VMUL", VMUL_OP, 1, 0,
1554 new FUN_TYPE(VECT,NUMT,VECT,0), &vmul_type_infer);
1555 def_op_alias("VMUL", vmul_op);
1556
1557 add_op_named("LEN", "LEN", LEN_OP, 0, 0,new FUN_TYPE(NUMT,TUPT,0));
1558
1559 //BUG: SLICE NEEDS A TYPE INFERENCE STYLE THAT WORKS.
1560 add_op_named_typed("SLICE", "SLICE", VSLICE_OP, 0, 0,
1561 new FUN_TYPE(VECT,NUMT,NUMT,VECT,0), &elt_type_infer);
1562
1563
1564
1565 //Vector Comparison Operations
1566 add_op_named_typed("<", "VLT", VLT_OP, 0, 0,
1567 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1568 add_op_named_typed(">", "VGT", VGT_OP, 0, 0,
1569 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1570 add_op_named_typed("<=", "VLTE", VLTE_OP, 0, 0,
1571 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1572 add_op_named_typed(">=", "VGTE", VGTE_OP, 0, 0,
1573 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1574 add_op_named_typed("=", "VEQ", VEQ_OP, 0, 0,
1575 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1576 add_op_named_typed("MIN", "VMIN", VMIN_OP, 0, 0,
1577 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1578 add_op_named_typed("MAX", "VMAX", VMAX_OP, 0, 0,
1579 new FUN_TYPE(VECT,VECT,VECT,0), &vadd_type_infer);
1580
1581 //Tuple Operations
1582 nul_tup_op =
1583 add_op_typed("NUL-TUP", NUL_TUP_OP, 0, 0,
1584 new FUN_TYPE(ANYT,0), &tup_type_infer);
1585 tup_op =
1586 add_op_typed("TUP", TUP_OP, 1, 1,
1587 new FUN_TYPE(ANYT,ANYT,1), &tup_type_infer);
1588 map_op =
1589 add_op_typed("MAP", MAP_OP, 1, 0,
1590 new FUN_TYPE(ANYT,ANYT,ANYT,0), &map_type_infer);
1591 apply_op =
1592 add_op_typed("APPLY", APPLY_OP, 0, 0,
1593 new FUN_TYPE(ANYT,ANYT,ANYT,0), &apply_type_infer);
1594 fold_op =
1595 add_op_typed("FOLD", FOLD_OP, 0, 0,
1596 new FUN_TYPE(ANYT,ANYT,ANYT,ANYT,0), &fold_type_infer);
1597 vfold_op =
1598 add_op_typed("VFOLD", VFOLD_OP, 1, 0,
1599 new FUN_TYPE(ANYT,ANYT,ANYT,ANYT,0), &fold_type_infer);
1600 nbr_vec_op =
1601 add_op("NBR-VEC", NBR_VEC_OP, 1, 0, new FUN_TYPE(VEC3T,0));
1602 add_op("VDOT", VDOT_OP, 0, 0, new FUN_TYPE(NUMT,VECT,VECT,0));
1603 mux_op =
1604 add_op_typed("MUX", MUX_OP, 0, 0,
1605 new FUN_TYPE(ANYT,NUMT,ANYT,ANYT,0), &mux_type_infer);
1606 vmux_op =
1607 add_op_typed("VMUX", VMUX_OP, 1, 0,
1608 new FUN_TYPE(ANYT,NUMT,ANYT,ANYT,0), &mux_type_infer);
1609 if_op =
1610 add_op_typed("IF", IF_OP, 1, 0,
1611 new FUN_TYPE(ANYT,NUMT,ANYT,ANYT,0), &mux_type_infer);
1612 def_op_alias("WHERE", if_op);
1613 if_op->emit_fn = &ast_if_emit;
1614 add_op("INFINITESIMAL", INFINITESIMAL_OP, 0, 0, new FUN_TYPE(NUMT,0));
1615 add_op("NBR-RANGE", NBR_RANGE_OP, 0, 0, new FUN_TYPE(NUMT,0));
1616 def_op_alias("NBR-ANGLE", add_op("NBR-BEARING", NBR_BEARING_OP, 0, 0, new FUN_TYPE(NUMT,0)));
1617 op = add_op("HOOD-RADIUS", HOOD_RADIUS_OP, 0, 0, new FUN_TYPE(NUMT,0));
1618 def_op_alias("RADIO-RANGE", op);
1619 add_op("AREA", AREA_OP, 0, 0, new FUN_TYPE(NUMT,0));
1620 add_op("NBR-LAG", NBR_LAG_OP, 0, 0, new FUN_TYPE(NUMT,0));
1621
1622 add_op("MID", MID_OP, 0, 0, new FUN_TYPE(NUMT,0));
1623
1624 user_ops = ops;
1625
1626 // LOW LEVEL
1627
1628 add_op("JMP", JMP_OP, 1, 0, new FUN_TYPE(ANYT,0));
1629 add_op_typed("IF16", IF_16_OP, 2, 0,
1630 new FUN_TYPE(ANYT,NUMT,ANYT,ANYT,0), &mux_type_infer);
1631 add_op("JMP16", JMP_16_OP, 2, 0, new FUN_TYPE(ANYT,0));
1632 add_op("RET", RET_OP, 0, 0, new FUN_TYPE(ANYT,0));
1633 add_op("EXIT", EXIT_OP, 0, 0, new FUN_TYPE(ANYT,0));
1634 add_op("LIT8", LIT8_OP, 1, 0, new FUN_TYPE(NUMT,0));
1635 add_op("LIT-FLO", LIT_FLO_OP, 4, 0, new FUN_TYPE(NUMT,0));
1636 fab_tup_op
1637 = add_op_typed("FAB-TUP", FAB_TUP_OP, 0, 1, new FUN_TYPE(VECT,ANYT,0), &tup_type_infer);
1638 fab_vec_op
1639 = add_op_typed("FAB-VEC", FAB_VEC_OP, 1, 0, new FUN_TYPE(VECT,ANYT,0), &vec_type_infer);
1640 def_tup_op
1641 = add_op("DEF-TUP", DEF_TUP_OP, 0, 1, new FUN_TYPE(VECT,ANYT,0));
1642 def_vec_op
1643 = add_op("DEF-VEC", DEF_VEC_OP, 1, 0, new FUN_TYPE(VECT,ANYT,0));
1644 fab_num_vec_op
1645 = add_op_typed("FAB-NUM-VEC", FAB_NUM_VEC_OP, 1, 0, new FUN_TYPE(VECT,0), &num_vec_type_infer);
1646 def_num_vec_op
1647 = add_op("DEF-NUM-VEC", DEF_NUM_VEC_OP, 1, 0, new FUN_TYPE(VECT,0));
1648 for (i = 1; i <= MAX_DEF_NUM_VEC_OPS; i++) {
1649 sprintf(name, "DEF-NUM-VEC-%d", i);
1650 def_num_vec_ops[i] = add_op(cpy_str(name), (OPCODE)(DEF_NUM_VEC_OP+i), 0, 0, new FUN_TYPE(VECT,0));
1651 }
1652 def_op
1653 = add_op("DEF", DEF_OP, 0, 0, new FUN_TYPE(ANYT,ANYT,0));
1654 for (i = 0; i < MAX_LIT_OPS; i++) {
1655 sprintf(name, "LIT-%d", i);
1656 add_op(cpy_str(name), (OPCODE)(LIT8_OP+i+1), 0, 0, new FUN_TYPE(NUMT,0));
1657 }
1658 add_op("LIT16", LIT16_OP, 2, 0, new FUN_TYPE(NUMT,0));
1659 add_op("REF", REF_OP, 1, 0, new FUN_TYPE(NUMT,0));
1660 for (i = 0; i < MAX_REF_OPS; i++) {
1661 sprintf(name, "REF-%d", i);
1662 add_op(cpy_str(name), (OPCODE)(REF_OP+i+1), 0, 0, new FUN_TYPE(NUMT,0));
1663 }
1664 add_op("DEF-VM", DEF_VM_OP, 8, 0, new FUN_TYPE(NUMT,0));
1665 add_op("GLO-REF16", GLO_REF16_OP, 2, 0, new FUN_TYPE(NUMT,0));
1666 add_op("GLO-REF", GLO_REF_OP, 1, 0, new FUN_TYPE(NUMT,0));
1667 for (i = 0; i < MAX_GLO_REF_OPS; i++) {
1668 sprintf(name, "GLO-REF-%d", i);
1669 add_op(cpy_str(name), (OPCODE)(GLO_REF_OP+i+1), 0, 0, new FUN_TYPE(NUMT,0));
1670 }
1671 add_op("LET", LET_OP, 1, 0, new FUN_TYPE(NUMT,0));
1672 add_op("POP-LET", POP_LET_OP, 1, 0, new FUN_TYPE(NUMT,0));
1673 for (i = 1; i <= MAX_LET_OPS; i++) {
1674 sprintf(name, "LET-%d", i);
1675 add_op(cpy_str(name), (OPCODE)(LET_OP+i), 0, 0, new FUN_TYPE(NUMT,0));
1676 sprintf(name, "POP-LET-%d", i);
1677 add_op(cpy_str(name), (OPCODE)(POP_LET_OP+i), 0, 0, new FUN_TYPE(NUMT,0));
1678 }
1679 for (i = 0; i < MAX_DEF_FUN_OPS; i++) {
1680 sprintf(name, "DEF-FUN-%d", i+2);
1681 add_op(cpy_str(name), (OPCODE)(DEF_FUN_2_OP+i), 0, 0, new FUN_TYPE(NUMT,0));
1682 }
1683 add_op("DEF-FUN", DEF_FUN_OP, 1, 0, new FUN_TYPE(NUMT,0));
1684 add_op("DEF-FUN16", DEF_FUN16_OP, 2, 0, new FUN_TYPE(NUMT,0));
1685 init_feedback_op =
1686 add_op_typed("INIT-FEEDBACK", INIT_FEEDBACK_OP, 1, 0,
1687 new FUN_TYPE(ANYT,ANYT,0), &init_feedback_type_infer);
1688 feedback_op =
1689 add_op_typed("FEEDBACK", FEEDBACK_OP, 1, 0,
1690 new FUN_TYPE(ANYT,ANYT,ANYT,0), &feedback_type_infer);
1691 };
1692
1693 /// PARSING
1694
1695 char* sym_elt (List *e, int offset) {
1696 Obj *n = lst_elt((List*)e, offset);
1697 if (symbolp(n))
1698 return strdup(((Symbol*)n)->getName().c_str());
1699 else
1700 uerror("LOOKING FOR STRING FOUND OTHER TYPE %s", n->typeName());
1701 }
1702
1703 list<VAR*> *globals;
1704
1705 struct ltstr {
1706 bool operator()(const char *s1, const char *s2) {
1707 return strcmp(s1, s2) < 0;
1708 }
1709 };
1710
1711 static map<const char*, int, ltstr> obarray;
1712 static int obval = 0;
1713
1714 int intern_symbol (const char *name) {
1715 typeof(obarray.begin()) it = obarray.find(name);
1716 if (it != obarray.end()) {
1717 return it->second;
1718 } else {
1719 return (obarray[name] = obval++);
1720 }
1721 }
1722
1723 VAR* lookup_name (const char *name, list<VAR*> *bind) {
1724 for (typeof(bind->begin()) it = bind->begin();
1725 it != bind->end(); it++) {
1726 if (strcasecmp((*it)->name, name) == 0) {
1727 (*it)->n_refs++;
1728 return (*it);
1729 }
1730 }
1731 return NULL;
1732 }
1733
1734 VAR* lookup_op (const char *name) {
1735 return lookup_name(name, ops);
1736 }
1737
1738 extern "C" AST_OP* lookup_op_by_code (int code, char **name) {
1739 for (typeof(ops->begin()) it = ops->begin();
1740 it != ops->end(); it++) {
1741 VAR *var = *it;
1742 if (var->type->kind == ONE_GOP_KIND) {
1743 ONE_GOP_TYPE *gop_type = (ONE_GOP_TYPE*)var->type;
1744 list<AST_OP*> *gop_ops = gop_type->gop->ops;
1745 for (typeof(gop_ops->begin()) it2 = gop_ops->begin();
1746 it2 != gop_ops->end(); it2++) {
1747 AST_OP *o = *it2;
1748 if (o->code == code) {
1749 *name = o->opname;
1750 return o;
1751 }
1752 }
1753 } else {
1754 ONE_OP_TYPE *type = (ONE_OP_TYPE*)var->type;
1755 AST_OP *o = type->op;
1756 if (o->code == code) {
1757 *name = o->opname;
1758 return o;
1759 }
1760 }
1761 }
1762 return NULL;
1763 }
1764
1765 void load_def (const char *name) {
1766 List *expr;
1767 // LOOK IT UP IN FILE
1768
1769 string filename = name; filename+=".proto";
1770 expr = read_objects_from_dirs(filename, proto_path);
1771 if (expr == NULL)
1772 return;
1773 else {
1774 Obj *body = PAIR(new Symbol("all"), expr);
1775 parse(body, new list<VAR*>());
1776 }
1777 }
1778
1779 VAR* lookup (const char *name, list<VAR*> *stack) {
1780 VAR *res = lookup_name(name, stack);
1781 if (res != NULL)
1782 return res;
1783 res = lookup_name(name, globals);
1784 if (res != NULL)
1785 return res;
1786 load_def(name);
1787 res = lookup_name(name, globals);
1788 if (res != NULL)
1789 return res;
1790 return lookup_op(name);
1791 }
1792
1793 map<string, AST*> fun_ops;
1794
1795 AST* parse_op_ref (char *op_name, FUN_TYPE *type, list<VAR*> *env) {
1796 int i;
1797 AST *res;
1798 string opname(op_name);
1799 Obj *fun_sym = new Symbol("FUN");
1800 List *args = lisp_nil;
1801 int n = type->arity;
1802
1803 typeof(fun_ops.begin()) it = fun_ops.find(opname);
1804
1805 if(it != fun_ops.end())
1806 return it->second;
1807
1808 for (i = n-1; i >= 0; i--) {
1809 char name[10];
1810 sprintf(name, "a%d", i);
1811 args = PAIR(new Symbol(name), args);
1812 }
1813 res = parse(_list(fun_sym, args, PAIR(new Symbol(op_name), args), NULL), env);
1814
1815 fun_ops[opname] = res;
1816 return res;
1817 }
1818
1819 AST* parse_reference (const char *name, list<VAR*> *env) {
1820 VAR *var = lookup(name, env);
1821 // post("REF %s\n", name);
1822 if (var == NULL)
1823 return NULL;
1824 TYPE *type = var->type;
1825 switch (type->kind) {
1826 case ONE_OP_KIND: {
1827 AST_OP *op = ((ONE_OP_TYPE*)type)->op;
1828 return parse_op_ref(op->name, (FUN_TYPE*)(op->type), env); }
1829 case ONE_GOP_KIND: {
1830 AST_GOP *gop = ((ONE_GOP_TYPE*)type)->gop;
1831 return parse_op_ref(gop->name, (FUN_TYPE*)(gop->type), env); }
1832 case ONE_FUN_KIND:
1833 return (AST*)(((ONE_FUN_TYPE*)type)->value);
1834 default:
1835 return new AST_REF(var, env);
1836 }
1837 }
1838
1839 AST* parse_symbol (const char *name) {
1840 int i;
1841 // post("LOOKING UP %s\n", name);
1842 i = intern_symbol(name);
1843 // post("FOUND %d\n", i);
1844 return new AST_LIT((flo)i);
1845 }
1846
1847 Obj *rewrite_cases (Obj *var, List *cases) {
1848 Obj *if_sym = new Symbol("IF");
1849 Obj *eq_sym = new Symbol("=");
1850 Obj *qt_sym = new Symbol("QUOTE");
1851 if (cases == lisp_nil)
1852 return new Number(0);
1853 else {
1854 List *clause = (List*)lst_head(cases);
1855 Obj *key = PAIR(qt_sym, PAIR(lst_elt(clause, 0), lisp_nil));
1856 Obj *val = lst_elt(clause, 1);
1857 return _list(if_sym,
1858 _list(eq_sym, key, var, NULL),
1859 val,
1860 rewrite_cases(var, lst_tail(cases)),
1861 NULL);
1862 }
1863 }
1864
1865 Obj *cat_sym2 (char *s1, char *s2) {
1866 char str[100]; sprintf(str, "%s%s", s1, s2);
1867 return new Symbol(str);
1868 }
1869
1870 Obj *cat_sym3 (char *s1, char *s2, char *s3) {
1871 char str[100]; sprintf(str, "%s%s%s", s1, s2, s3);
1872 return new Symbol(str);
1873 }
1874
1875 Obj *build_getters (char *name, int off, List *fields) {
1876 Obj *def_sym = new Symbol("DEF");
1877 Obj *elt_sym = new Symbol("ELT");
1878 Obj *var_sym = new Symbol("VAR");
1879 Obj *off_num = new Number(off);
1880 if (fields == lisp_nil)
1881 return lisp_nil;
1882 else {
1883 const std::string &field_name = ((Symbol*)lst_head(fields))->getName();
1884 Symbol *getter = new Symbol(name + ("-" + field_name));
1885 // post("BUILDING GETTER %s %s %d\n", field_name, getter->name, off);
1886 return PAIR(_list(def_sym, getter, _list(var_sym, NULL),
1887 _list(elt_sym, var_sym, off_num, NULL), NULL),
1888 build_getters(name, off + 1, lst_tail(fields)));
1889 }
1890 }
1891
1892 Obj *rewrite_letstar (List *bindings, List *body) {
1893 if (bindings == lisp_nil)
1894 return body->getHead();
1895 else {
1896 return PAIR(new Symbol("let"),
1897 PAIR(PAIR(bindings->getHead(), lisp_nil),
1898 PAIR(rewrite_letstar((List*)(bindings->getTail()), body), lisp_nil)));
1899 }
1900 }
1901
1902 Obj *rewrite_nary (Obj *fun, List *args) {
1903 switch (lst_len(args)) {
1904 case 0: case 1:
1905 uerror("NARY WITH FEWER THAN TWO INPUTS");
1906 case 2:
1907 return _list(fun, lst_elt(args, 0), lst_elt(args, 1), NULL);
1908 default:
1909 return _list(fun, lst_head(args), rewrite_nary(fun, lst_tail(args)), NULL);
1910 }
1911 }
1912
1913 list<VAR*> *params_to_vars (List *params) {
1914 list<VAR*> *vars = new typeof(*vars);
1915 int i, n = lst_len(params);
1916 for (i = 0; i < n; i++) {
1917 char *name = sym_elt(params, i);
1918 vars->push_back(new VAR(name, &any_type));
1919 }
1920 return vars;
1921 }
1922
1923 list<AST*> *parse_args (List* args, list<VAR*> *env) {
1924 int i;
1925 list<AST*> *ast_args = new typeof(*ast_args);
1926 for (i = 0; i < lst_len(args); i++)
1927 ast_args->push_back(parse(lst_elt(args, i), env));
1928 return ast_args;
1929 }
1930
1931 AST *parse_fun_body (list<VAR*> *vars, Obj *body, list<VAR*> *env) {
1932 return parse(body, augment_env(vars, env));
1933 }
1934
1935 void maybe_decr_n_refs (AST *ast) {
1936 if (ast->ast_class() == AST_REF_CLASS) {
1937 AST_REF *ref = (AST_REF*)ast;
1938 ref->var->n_refs -= 1;
1939 }
1940 }
1941
1942 Obj* read_select (int i, Obj *idx, Obj *first, List *args) {
1943 if (lst_len(args) == 0) {
1944 return read_qq("(null $x)", qq_env("$x", first, NULL));
1945 } else {
1946 List *env
1947 = qq_env("$i", new Number(i),
1948 "$o", idx,
1949 "$x", lst_elt(args, 0),
1950 "$r", read_select(i + 1, idx, first, lst_tail(args)),
1951 NULL);
1952 return read_qq("(if (= $o $i) $x $r)", env);
1953 }
1954 }
1955
1956
1957 int n_nbr_refs(Obj *expr) {
1958 if (expr != lisp_nil && listp(expr)) {
1959 Obj *fun = lst_elt((List*)expr, 0);
1960 if (symbolp(fun) && sym_name(fun) == "nbr")
1961 return 1;
1962 else
1963 return n_nbr_refs(fun) + n_nbr_refs(lst_tail((List*)expr));
1964 } else
1965 return 0;
1966 }
1967
1968 Obj* do_rewrite_fold_hood_star(Obj *expr, Obj **nexprs, int *i, int n) {
1969 if (expr != lisp_nil && listp(expr)) {
1970 Obj *fun = lst_elt((List*)expr, 0);
1971 if (symbolp(fun) && strcasecmp(sym_name(fun).c_str(), "nbr") == 0) {
1972 int off = *i;
1973 Obj *nexpr = lst_elt((List*)expr, 1);
1974 *i += 1;
1975 *nexprs = PAIR(nexpr, *nexprs);
1976 if (n == 1)
1977 return read_qq("e", lisp_nil);
1978 else
1979 return read_qq("(elt t $i)", qq_env("$i", new Number(off), NULL));
1980 } else {
1981 Obj *head = do_rewrite_fold_hood_star(fun, nexprs, i, n);
1982 Obj *tail = do_rewrite_fold_hood_star(lst_tail((List*)expr), nexprs, i, n);
1983 return PAIR(head, tail);
1984 }
1985 } else
1986 return expr;
1987 }
1988
1989 Obj* rewrite_fold_hood_star(Obj *expr, Obj **nexprs, int *n) {
1990 int counter = 0;
1991 *n = n_nbr_refs(expr);
1992 Obj *form = do_rewrite_fold_hood_star(expr, nexprs, &counter, *n);
1993 *nexprs = lst_rev((List*)*nexprs);
1994 return form;
1995 }
1996
1997 Obj* hood_folder (char *name, List *args, Obj *merge, Obj *cmp) {
1998 switch (lst_len(args)) {
1999 case 1:
2000 return merge;
2001 case 2:
2002 return read_qq("(fun (a b) (if ($cmp ($elt a) ($elt b)) a b))",
2003 qq_env("$elt", lst_elt(args, 1), "$cmp", cmp, NULL));
2004 default:
2005 clerror(name, /* args */ new list<AST*>(), "MAX-HOOD: WRONG NUM ARGS %d", lst_len(args));
2006 }
2007 }
2008
2009
2010 Obj* rewrite_conds (List *args) {
2011 if (args == lisp_nil)
2012 return read_qq("(if-error)", lisp_nil);
2013 else {
2014 List *arg = (List*)lst_elt(args, 0);
2015 List *qqenv
2016 = qq_env("$pred", lst_elt(arg, 0),
2017 "$body", lst_elt(arg, 1),
2018 "$rest", rewrite_conds(lst_tail(args)),
2019 NULL);
2020 return read_qq("(if $pred $body $rest)", qqenv);
2021 }
2022 }
2023
2024 extern AST *ast_op_call_check (AST_OP* op, list<AST*> *args );
2025
2026 // (cond (pa xa) (pb xb) (pc xc)) -> (if pa xa (if pb xb (if pc xc)))
2027
2028 Obj *body_from(List *forms) {
2029 if (lst_len(forms) == 1)
2030 return lst_elt(forms, 0);
2031 else {
2032 Obj *asym = new Symbol("all");
2033 return PAIR(asym, (Obj*)forms);
2034 }
2035 }
2036
2037 AST* parse_special_form (const char *name, Obj *e, List *args, list<VAR*> *env) {
2038 int i;
2039 if (strcasecmp(name, "let") == 0) {
2040 list<VAR*> *vars = new list<VAR*>();
2041 list<AST*> *inits = new list<AST*>();
2042 Obj *body = body_from(lst_tail(args));
2043 List *bargs = (List*)lst_elt(args, 0);
2044 int n = lst_len(bargs);
2045 list<VAR*> *newenv = new list<VAR*>(*env);
2046 for (i = 0; i < n; i++) {
2047 AST *init_val;
2048 List *arg = (List*)lst_elt(bargs, i);
2049 char *name = sym_elt(arg, 0);
2050 Obj *init = lst_elt(arg, 1);
2051 VAR *var = new VAR(name, &any_type);
2052 vars->push_front(var);
2053 init_val = parse(init, env);
2054 var->ast = init_val;
2055 var->type = init_val->type;
2056 inits->push_front(init_val);
2057 newenv->push_front(var);
2058 }
2059 if (n == 0) {
2060 return parse(body, env);
2061 } else {
2062 return new_ast_let(vars, inits, parse(body, newenv), env);
2063 }
2064 } else if (strcasecmp(name, "let*") == 0) {
2065 Obj *let
2066 = rewrite_letstar((List*)lst_head(args), lst_tail(args));
2067 return parse(let, env);
2068 /*
2069 } else if (strcasecmp(name, "bind") == 0) {
2070 Obj *let
2071 = rewrite_bind((List*)lst_head(args), lst_tail(args));
2072 return parse(let, env);
2073 */
2074 } else if (strcasecmp(name, "fold-hood*") == 0) {
2075 // (fold-hood* folder init expr)
2076 // -> (fold-hood (fun (r t) (folder r (... (elt t i) ...))) init (tup ... ei ...))
2077 // -> (fold-hood (fun (r e) (folder r (... e ...))) init e0)
2078 int n;
2079 Obj *expr = lst_elt(args, 2);
2080 Obj *nexprs = lisp_nil;
2081 Obj *nexpr = rewrite_fold_hood_star(expr, &nexprs, &n);
2082 List *qqenv
2083 = qq_env("$folder", lst_elt(args, 0),
2084 "$nexpr", nexpr,
2085 "$nexprs", nexprs,
2086 "$init", lst_elt(args, 1),
2087 NULL);
2088 char *str;
2089 if (n == 0) // no tup optimization
2090 str = "(fold-hood (fun (r e) ($folder r $nexpr)) $init 0)";
2091 else if (n == 1) // no tup optimization
2092 str = "(fold-hood (fun (r e) ($folder r $nexpr)) $init . $nexprs)";
2093 else
2094 str = "(fold-hood (fun (r t) ($folder r $nexpr)) $init (tup . $nexprs))";
2095 Obj *form = read_qq(str, qqenv);
2096 AST *ast = parse(form, env);
2097 // if ((List*)nexprs == lisp_nil)
2098 // cerror(ast, "FOLD-HOOD*: empty nbr expressions");
2099 return ast;
2100 } else if (strcasecmp(name, "fold-hood-plus*") == 0) {
2101 // (fold-hood-plus* folder expr)
2102 // -> (fold-hood-plus folder (fun (t) (... (elt t i) ...)) (tup ... ei ...))
2103 // -> (fold-hood-plus folder (fun (e) (... e ...)) e0)
2104 int n;
2105 Obj *folder = lst_elt(args, 0);
2106 Obj *expr = lst_elt(args, 1);
2107 Obj *nexprs = lisp_nil;
2108 Obj *nexpr = rewrite_fold_hood_star(expr, &nexprs, &n);
2109 List *qqenv
2110 = qq_env("$folder", folder,
2111 "$nexpr", nexpr,
2112 "$nexprs", nexprs,
2113 NULL);
2114 char *str;
2115 if (n == 0) // no tup optimization
2116 str = "(fold-hood-plus $folder (fun (e) $nexpr) 0)";
2117 else if (n == 1) { // no tup optimization
2118 str = "(fold-hood-plus $folder (fun (e) $nexpr) . $nexprs)";
2119 } else
2120 str = "(fold-hood-plus $folder (fun (t) $nexpr) (tup . $nexprs))";
2121 Obj *form = read_qq(str, qqenv);
2122 // post_form(form); post("YUK\n");
2123 AST *ast = parse(form, env);
2124 return ast;
2125 } else if (strcasecmp(name, "min-hood+") == 0) {
2126 Obj *form = read_qq("(min-hood (if (is-self) (inf) $expr))",
2127 qq_env("$expr", lst_elt(args, 0), NULL));
2128 return parse(form, env);
2129 } else if (strcasecmp(name, "max-hood+") == 0) {
2130 Obj *form = read_qq("(max-hood (if (is-self) (neg (inf)) $expr))",
2131 qq_env("$expr", lst_elt(args, 0), NULL));
2132 return parse(form, env);
2133 } else if (strcasecmp(name, "max-hood") == 0) {
2134 Obj *folder = hood_folder("max-hood", args, read_qq("max", lisp_nil), read_qq(">", lisp_nil));
2135 Obj *form = read_qq("(fold-hood-plus* $folder $expr)",
2136 qq_env("$expr", lst_elt(args, 0), "$folder", folder, NULL));
2137 return parse(form, env);
2138 } else if (strcasecmp(name, "min-hood") == 0) {
2139 Obj *folder = hood_folder("min-hood", args, read_qq("min", lisp_nil), read_qq("<", lisp_nil));
2140 Obj *form = read_qq("(fold-hood-plus* $folder $expr)",
2141 qq_env("$expr", lst_elt(args, 0), "$folder", folder, NULL));
2142 return parse(form, env);
2143 } else if (strcasecmp(name, "all-hood") == 0) {
2144 Obj *folder = hood_folder("all-hood", args, read_qq("and", lisp_nil), read_qq("<", lisp_nil));
2145 Obj *form = read_qq("(fold-hood-plus* $folder $expr)",
2146 qq_env("$expr", lst_elt(args, 0), "$folder", folder, NULL));
2147 return parse(form, env);
2148 } else if (strcasecmp(name, "any-hood") == 0) {
2149 Obj *folder = hood_folder("any-hood", args, read_qq("or", lisp_nil), read_qq(">", lisp_nil));
2150 Obj *form = read_qq("(fold-hood-plus* $folder $expr)",
2151 qq_env("$expr", lst_elt(args, 0), "$folder", folder, NULL));
2152 return parse(form, env);
2153 } else if (strcasecmp(name, "sum-hood") == 0) {
2154 Obj *form = read_qq("(fold-hood-plus* + $expr)",
2155 qq_env("$expr", lst_elt(args, 0), NULL));
2156 return parse(form, env);
2157 } else if (strcasecmp(name, "int-hood") == 0) {
2158 Obj *form = read_qq("(fold-hood-plus* + (* (infinitesimal) $expr))",
2159 qq_env("$expr", lst_elt(args, 0), NULL));
2160 return parse(form, env);
2161 } else if (strcasecmp(name, "rep") == 0) {
2162 List *qenv = qq_env("$n", lst_elt(args, 0),
2163 "$i", lst_elt(args, 1),
2164 "$e", lst_elt(args, 2),
2165 NULL);
2166 Obj *form = read_qq("(letfed (($n $i $e)) $n)", qenv);
2167 return parse(form, env);
2168 } else if (strcasecmp(name, "case") == 0) {
2169 Obj *val = lst_elt(args, 0);
2170 Obj *var = Symbol::gensym("val");
2171 Obj *cases = rewrite_cases(var, lst_tail(args));
2172 Obj *let = _list(new Symbol("let"),
2173 _list(_list(var, val, NULL), NULL),
2174 cases, NULL);
2175 return parse(let, env);
2176 } else if (strcasecmp(name, "cond") == 0) {
2177 Obj *form = rewrite_conds(args);
2178 return parse(form, env);
2179 } else if (strcasecmp(name, "all") == 0) {
2180 if (lst_len(args) == 1)
2181 return parse(lst_elt(args, 0), env);
2182 else {
2183 return ast_op_call_check(all_op, parse_args(args, env));
2184 }
2185 } else if (strcasecmp(name, "null") == 0) {
2186 AST *val = parse(lst_elt(args, 0), env);
2187 // post_form(lst_elt(args, 0));
2188 // post("BEF NULL TYPE %s\n", type_name(val->type));
2189 maybe_decr_n_refs(val);
2190 AST *res = real_null_of(val->type);
2191 // post("AFT NULL TYPE %s\n", type_name(res->type));
2192 return res;
2193 } else if (strcasecmp(name, "*") == 0) {
2194 Obj *call = rewrite_nary(new Symbol("B*"), args);
2195 return parse(call, env);
2196 } else if (strcasecmp(name, "+") == 0) {
2197 Obj *call = rewrite_nary(new Symbol("B+"), args);
2198 return parse(call, env);
2199 } else if (strcasecmp(name, "defstruct") == 0) {
2200 // TODO: ADD SUPPORT FOR INHERITANCE
2201 char *name = sym_elt(args, 0);
2202 Obj *fields = lst_tail(lst_tail(args));
2203 Obj *def_sym = new Symbol("def");
2204 Obj *all_sym = new Symbol("all");
2205 Obj *tup_sym = new Symbol("tup");
2206 Obj *getters = build_getters(name, 0, (List*)fields);
2207 Obj *ds = _list(all_sym,
2208 _list(def_sym,
2209 cat_sym2("new-", name),
2210 fields,
2211 PAIR(tup_sym, fields),
2212 NULL),
2213 PAIR(all_sym, getters),
2214 NULL);
2215 return parse(ds, env);
2216 } else if (strcasecmp(name, "quote") == 0) {
2217 Obj *val = lst_head(args);
2218 if (symbolp(val)) {
2219 return parse_symbol(((Symbol*)val)->getName().c_str());
2220 } else if (numberp(val)) {
2221 return new AST_LIT(((Number*)val)->getValue());
2222 } else
2223 uerror("UNSUPPORTED QUOTE KIND %s", val->lispType());
2224 } else if (strcasecmp(name, "def") == 0) {
2225 Obj *fsym = new Symbol("fun");
2226 char *name = sym_elt(args, 0);
2227 List *params = (List*)lst_elt(args, 1);
2228 Obj *body = body_from(lst_tail(lst_tail(args)));
2229 List *form = _list(fsym, params, body, NULL);
2230 AST_FUN *fun = (AST_FUN*)parse(form, env);
2231 // post("COMPILING DEF %s ", name); env_print(fun->vars); post("\n");
2232 fun->name = name;
2233 globals->push_front(new VAR(name, new ONE_FUN_TYPE(fun)));
2234 // post("ADDED DEF %s\n", name);
2235 return new AST_LIT(0);
2236 } else if (strcasecmp(name, "letfed") == 0) {
2237 // (letfed ((f (fill 0) (add (cam 0) f))) f)
2238 // (let ((f (feedback (fill 0)))) (let ((f (set-feedback f (add (cam 0) f)))) f))
2239 // (letfed ((f (add (cam 0) g)) (g (add f f))) f)
2240 // (let ((f (feedback)) (g (feedback)))
2241 // (let ((f (set-feedback f (add (cam 0) g))) (g (set-feedback g (add f f)))) f))
2242 List *bindings = (List*)lst_elt(args, 0);
2243 Obj *body = body_from(lst_tail(args));
2244 List *inis = lisp_nil;
2245 List *vals = lisp_nil;
2246 List *tbs = lisp_nil;
2247 List *atbs = lisp_nil;
2248 List *cmbs = lisp_nil;
2249 List *bs;
2250 Obj *let_fed;
2251 for (bs = bindings; bs != lisp_nil; bs = lst_tail(bs)) {
2252 List *b = (List*)bs->getHead();
2253 Obj *n = lst_elt(b, 0);
2254 if (lst_len(b) == 2) {
2255 cmbs = PAIR(b, cmbs);
2256 } else if (lst_len(b) == 3) {
2257 Obj *i = read_qq("(fun () $b1)", qq_env("$b1", lst_elt(b, 1), NULL));
2258 Obj *v = lst_elt(b, 2);
2259 List *tn = (List*)n;
2260 if (listp(n) && symbolp(lst_head(tn)) &&
2261 strcasecmp(sym_name(lst_head(tn)).c_str(), "TUP") == 0) {
2262 int i;
2263 List *tns;
2264 Obj *t = Symbol::gensym("t");
2265 for (tns = lst_tail(tn), i = 0; tns != lisp_nil; tns = lst_tail(tns), i++) {
2266 char form[100];
2267 sprintf(form, "($n (elt $t %d))", i);
2268 Obj *tb = read_qq(form, qq_env("$n", lst_head(tns), "$t", t, NULL));
2269 // post_form(tb);
2270 tbs = PAIR(tb, tbs);
2271 atbs = PAIR(tb, atbs);
2272 }
2273 tbs = lst_rev(tbs);
2274 n = t;
2275 }
2276 atbs = lst_rev(atbs);
2277 inis = PAIR(read_qq("($n (init-feedback $i))", qq_env("$n", n, "$i", i, NULL)), inis);
2278 vals = PAIR(read_qq("($n (feedback $n (let $tbs $v)))",
2279 qq_env("$n", n, "$tbs", tbs, "$v", v, NULL)), vals);
2280 } else {
2281 // clerror("LETFED", args, "LETFED: MALFORMED BINDING %d", lst_len(b));
2282 uerror("LETFED: MALFORMED BINDING %d", lst_len(b));
2283 }
2284 }
2285 let_fed = read_qq("(let $inis (let* $cmbs (let $vals (let $atbs $body))))",
2286 qq_env("$inis", inis, "$cmbs", lst_rev(cmbs), "$vals", vals,
2287 "$atbs", atbs, "$body", body, NULL));
2288 return parse(let_fed, env);
2289 } else if (strcasecmp(name, "select") == 0) {
2290 Obj *form
2291 = read_select(0, lst_elt(args, 0), lst_elt(args, 1), lst_tail(args));
2292 // post_form(form);
2293 return parse(form, env);
2294 } else if (strcasecmp(name, "loop") == 0) {
2295 Obj *form = read_qq("(elt (seq . $args) 0)", qq_env("$args", args, NULL));
2296 // post_form(form);
2297 return parse(form, env);
2298 } else if (strcasecmp(name, "seq") == 0) {
2299 List *qqenv
2300 = qq_env("$1st-ss", lst_elt(args, 0),
2301 "$ss", args,
2302 "$len-ss", new Number(lst_len(args)),
2303 NULL);
2304 char *str
2305 = "(letfed ((vei (tup (null $1st-ss) 0) \
2306 (let* ((idx (elt vei 1)) \
2307 (ve (select (mod idx $len-ss) . $ss))) \
2308 (if (elt ve 1) (tup ve idx) \
2309 (tup ve (+ idx 1)))))) \
2310 (tup (elt (elt vei 0) 0) (< (elt vei 1) $len-ss)))";
2311 Obj *form = read_qq(str, qqenv);
2312 // post_form(form);
2313 return parse(form, env);
2314 } else if (strcasecmp(name, "if") == 0) {
2315 list<AST*> *ast_args = parse_args(args, env);
2316 if (lst_len(args) != 3)
2317 clerror("IF", ast_args, "IF: WRONG NUM ARGS %d", lst_len(args));
2318 else {
2319 AST* tst = list_nth(ast_args, 0);
2320 AST* con = list_nth(ast_args, 1);
2321 AST* alt = list_nth(ast_args, 2);
2322
2323 AST* ast = new AST_OP_CALL(if_op, ast_args);
2324 if (!tst->type->subtype(NUMT))
2325 cerror(ast, "IF: BAD TST %s", tst->type->name());
2326 else {
2327 if (!is_same_type(con->type, alt->type)) {
2328 ast->print(); fprintf(error_log(),"\n");
2329 cerror(ast, "IF: REQUIRES SAME TYPE FOR BOTH BRANCHES CON %s ALT %s",
2330 con->type->name(), alt->type->name());
2331 } else
2332 return ast;
2333 }
2334 }
2335 } else if (strcasecmp(name, "mux") == 0) {
2336 list<AST*> *ast_args = parse_args(args, env);
2337 if (lst_len(args) != 3)
2338 clerror("MUX", ast_args, "MUX: WRONG NUM ARGS %d", lst_len(args));
2339 else {
2340 AST* tst = list_nth(ast_args, 0);
2341 AST* con = list_nth(ast_args, 1);
2342 AST* alt = list_nth(ast_args, 2);
2343
2344 int is_vec = con->type->kind == VEC_KIND || con->type->kind == TUP_KIND;
2345 AST* ast = new AST_OP_CALL(is_vec ? vmux_op : mux_op, ast_args);
2346 if (!tst->type->subtype(NUMT))
2347 cerror(ast, "MUX: BAD TST %s", tst->type->name());
2348 else {
2349 if (!is_same_type(con->type, alt->type))
2350 cerror(ast, "MUX: REQUIRE SAME TYPE FOR BOTH BRANCHES CON %s ALT %s",
2351 con->type->name(), alt->type->name());
2352 else
2353 return ast;
2354 }
2355 }
2356 } else if (strcasecmp(name, "map") == 0) {
2357 list<AST*> *ast_args = parse_args(args, env);
2358 if (lst_len(args) != 2)
2359 clerror("MAP", ast_args, "MAP: WRONG NUM ARGS %d", lst_len(args));
2360 else {
2361 AST* rfun = list_nth(ast_args, 0);
2362 AST* tup = list_nth(ast_args, 1);
2363 if (rfun->type->kind != ONE_FUN_KIND)
2364 clerror("MAP", ast_args, "MAP: BAD FUN %s", rfun->type->name());
2365 else {
2366 AST_FUN* fun = ((ONE_FUN_TYPE*)rfun->type)->value;
2367 FUN_TYPE* type = (FUN_TYPE*)fun->fun_type;
2368 if (type->arity != 1)
2369 clerror("MAP", ast_args, "MAP: WRONG NUM ARGS FOR FUN %d", type->arity);
2370 else if (tup->type->kind != VEC_KIND)
2371 clerror("MAP", ast_args, "MAP: REQUIRES HOMOGENOUS TUP ARG %s",
2372 tup->type->name());
2373 else {
2374 TYPE* elt_type
2375 = ((VEC_TYPE*)tup->type)->elt_type;
2376 list<VAR*> *vars = new list<VAR*>();
2377 vars->push_back(new VAR(fun->vars->front()->name, elt_type));
2378 AST* body = parse_fun_body(vars, fun->body, env);
2379 AST* clone_fun
2380 = new AST_FUN("fun", vars, fun->body, body);
2381 maybe_decr_n_refs(rfun);
2382 list<AST*> *args = new list<AST*>();
2383 args->push_back(clone_fun);
2384 args->push_back(tup);
2385 return new AST_OP_CALL(map_op, args);
2386 }
2387 }
2388 }
2389 } else if (strcasecmp(name, "apply") == 0) {
2390 list<AST*> *ast_args = parse_args(args, env);
2391 if (lst_len(args) != 2)
2392 clerror("APPLY", ast_args, "APPLY: WRONG NUM ARGS %d", lst_len(args));
2393 else {
2394 AST* rfun = list_nth(ast_args, 0);
2395 AST* tup = list_nth(ast_args, 1);
2396 TYPE* tup_type = tup->type;
2397 if (tup_type->kind != TUP_KIND && tup_type->kind != VEC_KIND)
2398 clerror("APPLY", ast_args,
2399 "APPLY: REQUIRES TUP/VEC ARG %s", tup_type->name());
2400 else if (rfun->type->kind != ONE_FUN_KIND)
2401 clerror("APPLY", ast_args, "APPLY: BAD FUN %s", rfun->type->name());
2402 else {
2403 AST_FUN* fun = ((ONE_FUN_TYPE*)rfun->type)->value;
2404 FUN_TYPE* type = (FUN_TYPE*)fun->fun_type;
2405 if (type->arity != tup_type_len(tup_type))
2406 clerror("APPLY", ast_args,
2407 "APPLY: WRONG NUM ARGS FOR FUN EXPECTED %d GOT %d",
2408 type->arity, tup_type_len(tup_type));
2409 else {
2410 int i;
2411 AST* body;
2412 AST* clone_fun;
2413 list<VAR*> *vars = new list<VAR*>();
2414 for (i = 0; i < tup_type_len(tup_type); i++)
2415 vars->push_front(new VAR(list_nth(fun->vars, i)->name,
2416 tup_type_elt(tup_type, i)));
2417 body = parse_fun_body(vars, fun->body, env);
2418 clone_fun = new AST_FUN("fun", vars, fun->body, body);
2419 maybe_decr_n_refs(rfun);
2420 list<AST*> *args = new list<AST*>();
2421 args->push_back(clone_fun);
2422 args->push_back(tup);
2423 return new AST_OP_CALL(apply_op, args);
2424 }
2425 }
2426 }
2427 } else if (strcasecmp(name, "fold") == 0) {
2428 list<AST*> *ast_args = parse_args(args, env);
2429 if (lst_len(args) != 3)
2430 clerror("FOLD", ast_args, "FOLD: WRONG NUM ARGS %d", lst_len(args));
2431 else {
2432 AST* rfun = list_nth(ast_args, 0);
2433 AST* init = list_nth(ast_args, 1);
2434 AST* tup = list_nth(ast_args, 2);
2435 if (rfun->type->kind != ONE_FUN_KIND)
2436 clerror("FOLD", ast_args, "FOLD: BAD FUN %s", rfun->type->name());
2437 else {
2438 AST_FUN* fun = ((ONE_FUN_TYPE*)rfun->type)->value;
2439 FUN_TYPE* type = (FUN_TYPE*)fun->fun_type;
2440 if (type->arity != 2)
2441 clerror("FOLD", ast_args, "FOLD: WRONG NUM ARGS FOR FUN %d", type->arity);
2442 else if (tup->type->kind != VEC_KIND)
2443 clerror("FOLD", ast_args, "FOLD: REQUIRES HOMOGENOUS TUP ARG %s",
2444 tup->type->name());
2445 else {
2446 TYPE* elt_type
2447 = ((VEC_TYPE*)tup->type)->elt_type;
2448 if (!is_same_type(elt_type, init->type))
2449 clerror("FOLD", ast_args,
2450 "FOLD: REQUIRES INIT TYPE %s SAME AS TUP ELT_TYPE %s",
2451 init->type->name(), elt_type->name());
2452 else {
2453 list<VAR*> *vars = new list<VAR*>();
2454 vars->push_back(new VAR(list_nth(fun->vars, 0)->name, elt_type));
2455 vars->push_back(new VAR(list_nth(fun->vars, 1)->name, elt_type));
2456 AST* body = parse_fun_body(vars, fun->body, env);
2457 AST* clone_fun = new AST_FUN("fun", vars, fun->body, body);
2458 AST_OP* op
2459 = (elt_type->kind == TUP_KIND || elt_type->kind == VEC_KIND) ?
2460 vfold_op : fold_op;
2461 maybe_decr_n_refs(rfun);
2462 list<AST*> *args = new list<AST*>();
2463 args->push_back(clone_fun);
2464 args->push_back(init);
2465 args->push_back(tup);
2466 return new AST_OP_CALL(op, args);
2467 }
2468 }
2469 }
2470 }
2471 } else if (strcasecmp(name, "tup") == 0) {
2472 if (lst_len(args) == 0)
2473 return new AST_OP_CALL(nul_tup_op, new list<AST*>());
2474 else
2475 return NULL;
2476 } else if (strcasecmp(name, "fold-hood") == 0) {
2477 list<AST*> *ast_args = parse_args(args, env);
2478 if (lst_len(args) != 3)
2479 clerror("FOLD-HOOD", ast_args, "FOLD-HOOD: WRONG NUM ARGS %d", lst_len(args));
2480 else {
2481 AST* rfun = list_nth(ast_args, 0);
2482 AST* init = list_nth(ast_args, 1);
2483 AST* arg = list_nth(ast_args, 2);
2484 if (rfun->type->kind != ONE_FUN_KIND)
2485 clerror("FOLD-HOOD", ast_args,
2486 "FOLD-HOOD: BAD FUN %s", rfun->type->name());
2487 else {
2488 AST_FUN* fun = ((ONE_FUN_TYPE*)rfun->type)->value;
2489 FUN_TYPE* type = (FUN_TYPE*)fun->fun_type;
2490 if (type->arity != 2)
2491 clerror("FOLD-HOOD", ast_args,
2492 "FOLD-HOOD: WRONG NUM ARGS FOR FUN %d", type->arity);
2493 else {
2494 TYPE* elt_type = arg->type;
2495 list<VAR*> *vars = new list<VAR*>();
2496 vars->push_back(new VAR(list_nth(fun->vars, 0)->name, init->type));
2497 vars->push_back(new VAR(list_nth(fun->vars, 1)->name, elt_type));
2498 AST* body = parse_fun_body(vars, fun->body, env);
2499 AST* clone_fun = new AST_FUN("fun", vars, fun->body, body);
2500 AST_OP* op
2501 = (init->type->kind == TUP_KIND || init->type->kind == VEC_KIND) ?
2502 vfold_hood_op : fold_hood_op;
2503 list<AST*> *args = new list<AST*>();
2504 args->push_back(clone_fun);
2505 args->push_back(init);
2506 args->push_back(arg);
2507 AST* ast = new AST_OP_CALL(op, args);
2508 if (!is_same_type(body->type, init->type))
2509 cerror(ast, "FOLD-HOOD: REQUIRES INIT TYPE %s SAME AS FUN RET TYPE %s",
2510 init->type->name(), body->type->name());
2511 maybe_decr_n_refs(rfun);
2512 return ast;
2513 }
2514 }
2515 }
2516 } else if (strcasecmp(name, "fold-hood-plus") == 0) {
2517 list<AST*> *ast_args = parse_args(args, env);
2518 if (lst_len(args) != 3)
2519 clerror("FOLD-HOOD-PLUS", ast_args,
2520 "FOLD-HOOD-PLUS: WRONG NUM ARGS %d", lst_len(args));
2521 else {
2522 AST* fuse = list_nth(ast_args, 0);
2523 AST* mold = list_nth(ast_args, 1);
2524 AST* expr = list_nth(ast_args, 2);
2525 if (fuse->type->kind != ONE_FUN_KIND)
2526 clerror("FOLD-HOOD-PLUS", ast_args,
2527 "FOLD-HOOD+: BAD FUSER %s", fuse->type->name());
2528 if (mold->type->kind != ONE_FUN_KIND)
2529 clerror("FOLD-HOOD-PLUS", ast_args,
2530 "FOLD-HOOD-PLUS: BAD MOLDER %s", mold->type->name());
2531 AST_FUN* ffun = ((ONE_FUN_TYPE*)fuse->type)->value;
2532 FUN_TYPE* ftype = (FUN_TYPE*)ffun->fun_type;
2533 if (ftype->arity != 2)
2534 clerror("FOLD-HOOD-PLUS", ast_args,
2535 "FOLD-HOOD-PLUS: WRONG NUM ARGS FOR FUSER %d", ftype->arity);
2536 AST_FUN* mfun = ((ONE_FUN_TYPE*)mold->type)->value;
2537 FUN_TYPE* mtype = (FUN_TYPE*)mfun->fun_type;
2538 if (mtype->arity != 1)
2539 clerror("FOLD-HOOD-PLUS", ast_args,
2540 "FOLD-HOOD-PLUS: WRONG NUM ARGS FOR MOLDER %d", mtype->arity);
2541 TYPE* elt_type = expr->type;
2542 list<VAR*> *mvars = new list<VAR*>();
2543 mvars->push_back(new VAR(list_nth(mfun->vars, 0)->name, elt_type));
2544 AST* mbody = parse_fun_body(mvars, mfun->body, env);
2545 AST* clone_mfun = new AST_FUN("fun", mvars, mfun->body, mbody);
2546 list<VAR*> *fvars = new typeof(*fvars);
2547 fvars->push_back(new VAR(list_nth(ffun->vars, 0)->name, mbody->type));
2548 fvars->push_back(new VAR(list_nth(ffun->vars, 1)->name, mbody->type));
2549 AST* fbody = parse_fun_body(fvars, ffun->body, env);
2550 AST* clone_ffun = new AST_FUN("fun", fvars, ffun->body, fbody);
2551 AST_OP* op
2552 = (mbody->type->kind == TUP_KIND || mbody->type->kind == VEC_KIND) ?
2553 vfold_hood_plus_op : fold_hood_plus_op;
2554 list<AST*> *args = new list<AST*>();
2555 args->push_back(clone_ffun);
2556 args->push_back(clone_mfun);
2557 args->push_back(expr);
2558 AST* ast = new AST_OP_CALL(op, args);
2559 // if (!is_same_type(body->type, init->type))
2560 // cerror(ast, "FOLD-HOOD-PLUS: REQUIRES INIT TYPE %s SAME AS FUN RET TYPE %s",
2561 // type_name(init->type), type_name(body->type));
2562 maybe_decr_n_refs(fuse);
2563 maybe_decr_n_refs(mold);
2564 return ast;
2565 }
2566 } else if (strcasecmp(name, "fun") == 0) {
2567 List *params = (List*)lst_elt(args, 0);
2568 Obj *body = body_from(lst_tail(args));
2569 list<VAR*> *vars = params_to_vars(params);
2570 AST *abody = vars->size() > 0 ? NULL : parse_fun_body(vars, body, env);
2571 return new AST_FUN("fun", vars, body, abody);
2572 } else
2573 return NULL;
2574 }
2575
2576 int type_check (AST *arg, TYPE *type) {
2577 return arg->type->subtype(type);
2578 // return 1;
2579 }
2580
2581 int ast_op_call_type_check (FUN_TYPE *type, list<AST*> *args) {
2582 int i = 0;
2583 for (typeof(args->begin()) it = args->begin();
2584 it != args->end(); i++, it++) {
2585 AST *arg = *it;
2586 if (i < type->arity && !type_check(arg, type->param_types[i]))
2587 return i;
2588 }
2589 return -1;
2590 }
2591
2592 AST *ast_op_call_check (AST_OP* op, list<AST*> *args ) {
2593 int i;
2594 int nargs = args->size();
2595 AST* ast;
2596 FUN_TYPE *type = (FUN_TYPE*)(op->type);
2597 ast = new AST_OP_CALL(op, args);
2598 if (!(nargs == type->arity ||
2599 (type->is_nary && nargs >= type->arity)))
2600 cerror(ast, "WRONG NUMBER OF ARGS FOR %s GIVEN %d WANTED %d IS_NARY %d",
2601 op->name, nargs, type->arity, type->is_nary);
2602 if ((i = ast_op_call_type_check(type, args)) >= 0)
2603 cerror(ast, "TYPE ERROR FOR %s ON ARG %d GOT %s EXPECTED %s",
2604 op->name, i,
2605 (list_nth(args, i))->type->name(),
2606 type->param_types[i]->name());
2607 // post("OP %s\n", op->name);
2608 return ast;
2609 }
2610
2611 AST *ast_gop_call_check (AST_GOP *gop, list<AST*> *args) {
2612 int nargs = args->size();
2613 FUN_TYPE *gop_type = (FUN_TYPE*)(gop->type);
2614 if (!(nargs == gop_type->arity ||
2615 (gop_type->is_nary && nargs >= gop_type->arity)))
2616 clerror("GOP-CALL", args,
2617 "WRONG NUMBER OF ARGS FOR %s GIVEN %d WANTED %d IS_NARY %d",
2618 gop->name, nargs, gop_type->arity, gop_type->is_nary);
2619 for (typeof(gop->ops->begin()) it = gop->ops->begin();
2620 it != gop->ops->end(); it++) {
2621 AST_OP *op = *it;
2622 if (ast_op_call_type_check((FUN_TYPE*)(op->type), args) < 0) {
2623 AST *ast = new AST_OP_CALL(op, args);
2624 // post("OP %s\n", op->name);
2625 return ast;
2626 }
2627 }
2628 //post_gop(gop);
2629 for (typeof(args->begin()) it = args->begin();
2630 it != args->end(); it++) {
2631 fprintf(error_log()," %s", (*it)->type->name());
2632 }
2633 fprintf(error_log(),": ");
2634 clerror("GOP-CALL", args, "NO APPLICABLE METHODS ERROR FOR %s", gop->name);
2635 }
2636
2637 AST* parse (Obj *e, list<VAR*> *env) {
2638 int i;
2639 // debug("E COMPILE\n");
2640 if (numberp(e)) {
2641 return new AST_LIT(((Number*)e)->getValue());
2642 } else if (symbolp(e)) {
2643 AST *res;
2644 const char *name = ((Symbol*)e)->getName().c_str();
2645 // debug("FOUND SYM %s\n", name);
2646 res = parse_reference(name, env);
2647 if (res != NULL)
2648 return res;
2649 else {
2650 uerror("UNABLE TO FIND %s", name);
2651 }
2652 } else if (listp(e)) {
2653 List *le = (List*)e;
2654 int lstlen = lst_len(le);
2655 int nargs = lstlen - 1;
2656 Obj *fun_obj = lst_head(le);
2657 List *args = lst_tail(le);
2658 AST *ast_fun;
2659 TYPE *type;
2660 // debug("FOUND LST\n");
2661 if (lstlen == 0)
2662 uerror("ILLEGAL EMPTY LIST");
2663
2664 if (symbolp(fun_obj)) {
2665 const char *name = sym_name(fun_obj).c_str();
2666 AST *res = parse_special_form(name, fun_obj, args, env);
2667 if (res != NULL)
2668 return res;
2669 else {
2670 VAR *var = lookup(name, env);
2671 list<AST*> *ast_args = parse_args(args, env);
2672 if (var != NULL) {
2673 type = var->type;
2674 switch (type->kind) {
2675 case ONE_OP_KIND:
2676 return ast_op_call_check(((ONE_OP_TYPE*)type)->op, ast_args);
2677 case ONE_GOP_KIND:
2678 return ast_gop_call_check(((ONE_GOP_TYPE*)type)->gop, ast_args);
2679 }
2680 var->n_refs -= 1;
2681 }
2682 }
2683 }
2684 ast_fun = parse(fun_obj, env);
2685 type = ast_fun->type;
2686 if (type->kind == ONE_FUN_KIND) {
2687 AST_FUN *fun = ((ONE_FUN_TYPE*)type)->value;
2688 FUN_TYPE *type = (FUN_TYPE*)(fun->fun_type);
2689 VAR *var;
2690 AST *body;
2691 list<VAR*> *vars = new typeof(*vars);
2692 list<AST*> *let_vals = new typeof(*let_vals);
2693 list<AST*> *as = parse_args(args, env);
2694
2695 if (!(nargs == type->arity ||
2696 (type->is_nary && nargs >= type->arity)))
2697 clerror("...", /* PAIR(fun, as) */ new list<AST*>(),
2698 "WRONG NUMBER OF ARGS FOR %s GIVEN %d EXPECTED %d IS_NARY %d",
2699 fun->name, nargs, type->arity, type->is_nary);
2700 i = 0;
2701 for (typeof(as->begin()) it = as->begin();
2702 it != as->end(); i++, it++) {
2703 AST* a = *it;
2704 var = new VAR(list_nth(fun->vars, i)->name, &any_type);
2705 var->ast = a;
2706 var->type = a->type;
2707 vars->push_back(var);
2708 let_vals->push_back(a);
2709 }
2710 maybe_decr_n_refs(ast_fun);
2711 body = parse_fun_body(vars, fun->body, env);
2712 return new_ast_let(vars, let_vals, body, env);
2713 } else {
2714 list<AST*> *as = parse_args(args, env);
2715 return new AST_CALL(ast_fun, as);
2716 // uerror("UNKNOWN CALL TYPE %d", type->kind);
2717 }
2718 }
2719 }
2720
2721 Script* compile (Obj *e, int is_dump_ast) {
2722 globals = new list<VAR*>();
2723 // run the initial parse
2724 AST *res = parse(e, new list<VAR*>());
2725 res = ast_optimize_lets(res);
2726 // gather global data through lifting
2727 LIFT_DATA data = {new list<VAR*>(), new list<AST*>(), 0, 0, 0, false};
2728 res = ast_lift(res, &data);
2729 data.is_fun_lift = 1;
2730 res = ast_lift(res, &data);
2731 int n_glos = data.glos->size()+1;
2732 int stk_siz = res->stack_size();
2733 int env_siz = res->env_size();
2734 if (is_dump_ast) {
2735 fprintf(error_log(),"// ");
2736 res->print();
2737 fprintf(error_log(),"\n");
2738 }
2739 // Finally, do the actual emission
2740 Script body; res->emit(&body);
2741 Script* script = new Script(9, DEF_VM_OP, data.export_len, data.n_exports,
2742 n_glos >> 8, n_glos & 255, data.n_state,
2743 stk_siz >> 8, stk_siz & 255, env_siz);
2744 for (typeof(data.glos->begin()) i = data.glos->begin();
2745 i != data.glos->end(); i++)
2746 (*i)->emit(script);
2747 emit_def_fun_op(body.size()+1, script);
2748 script->append(&body);
2749 script->add(RET_OP,EXIT_OP);
2750 return script;
2751 }
2752
2753 char *xlate_opname(char *dst, char *src) {
2754 int i;
2755 for (i = 0; i < strlen(src); i++) {
2756
2757 dst[i] = src[i] == '-' ? '_' : toupper(src[i]);
2758 }
2759 dst[i] = 0;
2760 strcat(dst, "_OP");
2761 return dst;
2762 }
2763
2764 #define MAX_DIRS 100
2765
2766 void init_compiler () {
2767 init_lisp();
2768 init_ops();
2769 }
2770
2771 uint8_t *compile_script (char *str, int *len, int is_dump_ast) {
2772 // post("SCRIPT %s\n", str);
2773 Obj* obj = read_from_str(str);
2774 Script* s = compile(obj, is_dump_ast);
2775 *len = s->size();
2776 uint8_t *dst = (uint8_t*)MALLOC(*len);
2777 for(int i=0;i<*len;i++) dst[i]=s->pop();
2778 return dst;
2779 }
2780
2781 FILE* dump_target=stdout;
2782 void dump_instructions (int is_c, int n, uint8_t *bytes) {
2783 int j;
2784 if (is_c) { fprintf(dump_target,"uint8_t script[] = {"); }
2785 for (j = 0; j < n; j++) {
2786 int i;
2787 char *name, opname[100];
2788 uint8_t code = bytes[j];
2789 AST_OP* op = lookup_op_by_code(code, &name);
2790 if (op == NULL) uerror("NULL OP %d", code);
2791 if (is_c && j != 0) fprintf(dump_target,",");
2792 fprintf(dump_target," %s", is_c ? xlate_opname(opname, name) : name);
2793 for (i = 0; i < op->arity+op->is_nary; i++) {
2794 if (is_c) fprintf(dump_target,",");
2795 j += 1;
2796 fprintf(dump_target," %d", bytes[j]);
2797 }
2798 }
2799 if (is_c) { fprintf(dump_target," };\n"); fprintf(dump_target,"uint16_t script_len = %d;", n); }
2800 fprintf(dump_target,"\n");
2801 }
2802
2803 void dump_code (int n, uint8_t *bytes) {
2804 int j;
2805 for (j = 0; j < n; j++) {
2806 int i;
2807 char *name;
2808 uint8_t code = bytes[j];
2809 AST_OP* op = lookup_op_by_code(code, &name);
2810 if (op == NULL) uerror("NULL OP %d", code);
2811 fprintf(dump_target,"%3d: %s", j, name);
2812 for (i = 0; i < op->arity+op->is_nary; i++) {
2813 j += 1;
2814 fprintf(dump_target," %d", bytes[j]);
2815 }
2816 fprintf(dump_target,"\n");
2817 }
2818 }
2819
2820 /***** PLATFORM-SPECIFIC OP DEFINITIONS *****/
2821 #include <fstream>
2822 #include "sexpr.h"
2823
2824 void downcase(string& str)
2825 { for(int i=0;i<str.size();i++) { str[i]=tolower(str[i]); } }
2826
2827 TYPE* name_to_type (SExpr* ex) {
2828 if(ex->type_of()=="SE_List") {
2829 SE_List* l = (SE_List*)ex;
2830 if(l->len() == 2 && *l->children[0]=="vector" && *l->children[1]==3) {
2831 return VEC3T;
2832 } else {
2833 uerror("Compound type %s is not a (vector 3)",ex->to_str().c_str());
2834 }
2835 } else if(ex->isSymbol()) {
2836 if(*ex=="scalar") return NUMT;
2837 if(*ex=="boolean") return NUMT;
2838 }
2839 uerror("Unhandled or unknown type %s",ex->to_str().c_str());
2840 }
2841
2842 void parse_external_op(SExpr* ex) {
2843 /* parses (defop OP EXTOPCODE FN ARGTYPES*). EXTOPCODE is the extended
2844 * opcode, which is converted to an opcode by adding CORE_CMD_OPS */
2845 if(!ex->isList()) uerror("%s is not a defop",ex->to_str().c_str());
2846 SE_List *l = (SE_List*)ex;
2847
2848 if(!(*l->children[0]=="defop")) uerror("%s is not a defop",ex->to_str().c_str());
2849 if(l->len() < 4) uerror("defop has too few arguments");
2850
2851 if(!l->children[1]->isSymbol()) uerror("defop op not symbol");
2852 /* op symbol is ignored here; it may be used within the platform code */
2853
2854 if(!l->children[2]->isScalar()) uerror("defop extopcode not scalar");
2855 int op = (int)((SE_Scalar*)l->children[1])->value + CORE_CMD_OPS;
2856
2857 if(!l->children[3]->isSymbol()) uerror("defop fn not symbol");
2858 string sfun = ((SE_Symbol*)l->children[3])->name;
2859
2860 /* add_op wants its own copy of this string */
2861 char* fun = strdup(sfun.c_str());
2862
2863 /* make a vector of its types */
2864 vector<TYPE*> types;
2865 for(int i=4;i<l->len();i++) types.push_back(name_to_type(l->children[i]));
2866
2867 /* and add the op to the compiler */
2868 add_op(fun, op, 0, 0, new FUN_TYPE(&types));
2869 }
2870
2871 void read_opfile(string filename) {
2872 ifstream* opfile = new ifstream();
2873 opfile->open(filename.c_str());
2874 if(!opfile->good()) uerror("Could not find opfile %s",filename.c_str());
2875 SExpr* ex = read_sexpr(filename,opfile);
2876 if(ex==NULL) uerror("Could not read opfile %s",filename.c_str());
2877 if(!ex->isList()) uerror("%s is not an opfile",filename.c_str());
2878 SE_List* l = (SE_List*)ex; // is either a defop or an all
2879 if(!l->children[0]->isSymbol()) uerror("%s is not an opfile",filename.c_str());
2880 if(*l->children[0]=="all") {
2881 for(int i=1;i<l->len();i++) parse_external_op(l->children[i]);
2882 } else {
2883 parse_external_op(l);
2884 }
2885 delete opfile;
2886 }
2887
2888
2889 /***** COMPILER WRAPPER CLASS *****/
2890 extern list<string>* read_enum(istream* in, ostream* out=NULL);
2891
2892 Compiler::Compiler(Args* args) {
2893 proto_path = new Path();
2894 if (args->extract_switch("--srcdir"))
2895 srcdir = args->pop_next();
2896
2897 if (args->extract_switch("--basepath"))
2898 proto_path->add_to_path(args->pop_next());
2899 else
2900 proto_path->add_default_path(srcdir);
2901
2902 while(args->extract_switch("-path",false)) // can extract multiple times
2903 proto_path->add_to_path(args->pop_next());
2904
2905 is_show_code = args->extract_switch("-k");
2906 test_mode = args->extract_switch("--test-compiler");
2907 is_dump_code = args->extract_switch("--instructions");
2908 is_dump_ast = args->extract_switch("--print-ast");
2909 init_compiler();
2910 if(args->extract_switch("--platform")) set_platform(args->pop_next());
2911 last_script="";
2912 }
2913
2914 Compiler::~Compiler() {
2915 delete proto_path;
2916 srcdir = "";
2917 }
2918
2919 void Compiler::set_platform(string plat) {
2920 string platdir;
2921
2922 if (srcdir != "") {
2923 // use the platform dir in the source directory
2924 platdir = srcdir + "/src/" + plat;
2925 } else {
2926 // use the install location
2927 platdir = PROTOPLATDIR;
2928 platdir += "/";
2929 platdir += plat;
2930 }
2931
2932 read_opfile((platdir+"/platform_ops.proto").c_str());
2933 }
2934
2935 // When being run standalone, -D controls dumping (it's normally
2936 // consumed by the simulator). Likewise, if -dump-stem is present,
2937 // then dumping goes to a file instead of stdout
2938 void Compiler::init_standalone(Args* args) {
2939 is_dump_code |= args->extract_switch("-D");
2940 bool dump_to_stdout = true;
2941 char *dump_dir = "dumps", *dump_stem = "dump";
2942 if(args->extract_switch("-dump-dir"))
2943 { dump_dir = args->pop_next(); dump_to_stdout=false; }
2944 if(args->extract_switch("-dump-stem"))
2945 { dump_stem = args->pop_next(); dump_to_stdout=false; }
2946 if(dump_to_stdout) {
2947 dump_target=stdout;
2948 } else {
2949 char buf[1000];
2950 // ensure that the directory exists
2951 snprintf(buf, 1000, "mkdir -p %s", dump_dir);
2952 (void)system(buf);
2953 sprintf(buf,"%s/%s.log",dump_dir,dump_stem);
2954
2955 dump_target=fopen(buf,"w");
2956 }
2957 }
2958
2959 uint8_t* Compiler::compile(char *str, int* len) {
2960 last_script=str;
2961 uint8_t* bytes = compile_script(str,len,is_dump_ast);
2962 if(is_dump_code) dump_instructions(1,*len,bytes);
2963 return bytes;
2964 }
2965
2966 void Compiler::visualize() {
2967 if(is_show_code) {
2968 // "compiler should be able to show the code here, but doesn't yet"
2969 }
2970 }
2971
2972 BOOL Compiler::handle_key(KeyEvent* key) {
2973 if(key->normal && !key->ctrl) {
2974 switch(key->key) {
2975 case 'k': is_show_code = !is_show_code; return TRUE;
2976 }
2977 }
2978 return FALSE;
2979 }
Proto, the world's premier language for spatial computing!