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.
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. */
24 using namespace std
; // allow c-strings, etc; note: shadows 'pair'
26 int is_optimizing_lets
= 1;
31 struct TYPE
; struct AST_FUN
; struct AST_OP
; struct AST_GOP
;
34 /****** VARIABLES ******/
41 VAR(char* name
, TYPE
*type
) {
42 this->name
=name
; this->type
=type
; n_refs
=0; ast
=NULL
;
46 /****** SCRIPT ******/
47 // This is the output target
50 list
<uint8_t> contents
;
54 va_list v
; va_start(v
,n
);
55 for(int i
=0;i
<n
;i
++) { contents
.push_back(va_arg(v
,int)); }
60 int size() { return contents
.size(); }
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)); }
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
; }
78 /****** PROTO TYPES ******/
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
,
84 char* type_kind_name
[NUM_TYPE_KINDS
]={"NUL","ANY","NUM","VEC","TUP","FUN","ONE_NUM","ONE_FUN","ONE_OP","ONE_GOP"};
89 TYPE(TYPE_KIND kind
) { this->kind
= kind
; }
90 virtual const char* name() { return type_kind_name
[kind
]; }
92 if(kind
==NUL_KIND
|| kind
==ANY_KIND
)
93 uerror("ILLEGAL SIZE OF ABSTRACT TYPE %d", kind
);
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");
107 TYPE
num_type(NUM_KIND
), nul_type(NUL_KIND
), any_type(ANY_KIND
);
108 TYPE
vec_type(VEC_KIND
), fun_type(FUN_KIND
);
110 struct ONE_FUN_TYPE
: public TYPE
{
112 ONE_FUN_TYPE(AST_FUN
*fun
) : TYPE(ONE_FUN_KIND
) { value
=fun
; }
114 struct ONE_OP_TYPE
: public TYPE
{
116 ONE_OP_TYPE(AST_OP
*op
) : TYPE(ONE_OP_KIND
) { this->op
=op
; }
118 struct ONE_GOP_TYPE
: public TYPE
{
120 ONE_GOP_TYPE(AST_GOP
*gop
) : TYPE(ONE_GOP_KIND
) { this->gop
=gop
; }
122 struct ONE_NUM_TYPE
: public TYPE
{
124 ONE_NUM_TYPE(flo num
) : TYPE(ONE_NUM_KIND
) { this->num
=num
; }
126 virtual const char* name() {
127 namestr
=""; namestr
=namestr
+"(ONE_NUM "+flo2str(num
)+")";
128 return namestr
.c_str();
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
);
136 TYPE
* blur_type(TYPE
* t
);
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
;
143 TUP_TYPE(int len
, TYPE
** types
) : TYPE(TUP_KIND
) {
145 elt_types
= new TYPE
*[len
];
146 for(int i
=0;i
<len
;i
++) { elt_types
[i
]=types
[i
]; }
149 virtual const char* name() {
151 for(int i
=0;i
<len
;i
++) { namestr
=namestr
+" "+elt_types
[i
]->name(); }
152 if(len
==-1) namestr
+=" *";
154 return namestr
.c_str();
158 int sum
=TYPE::size();
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();
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;
177 return TYPE::subtype(parent
);
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
; }
188 virtual const char* name() {
189 namestr
=""; namestr
=namestr
+"(VEC "+elt_type
->name()+" "+int2str(len
)+")";
190 return namestr
.c_str();
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]));
200 return TYPE::subtype(parent
);
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
);
209 struct FUN_TYPE
: public TYPE
{
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
; }
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
];
226 for(int i
=0;i
<arity
;i
++) param_types
[i
] = (*types
)[i
+1];
228 FUN_TYPE(TYPE
* result_type
, ...) : TYPE(FUN_KIND
) {
232 va_start(ap
, result_type
);
234 types
[i
] = va_arg(ap
, TYPE
*);
235 if (types
[i
] == (TYPE
*)0) {
237 } else if (types
[i
] == (TYPE
*)1) {
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
];
248 virtual ~FUN_TYPE() { delete param_types
; }
250 virtual const char* name() {
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();
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;
266 } else { return TYPE::subtype(parent
);
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)
281 /****** AST ZONE ******/
288 typedef AST
* (*AST_WALKER
)(AST_WALKER_KIND walker
, AST
* val
, void* arg
);
290 AST
*default_walk (AST_WALKER_KIND action
, AST
*ast
, void *arg
) { return ast
; }
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
299 T
& list_nth(list
<T
> *lst
, int n
) {
300 typeof(lst
->begin()) it
= lst
->begin();
305 // ASTs are program elements ("abstract syntax tree")
306 // They need to be renamed at some point, because AST isn't quite right
310 AST_WALKER walkers
[N_WALKERS
];
313 walkers
[0]=walkers
[1]=&default_walk
;
314 type
= &nul_type
; // is this still needed?
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
; }
325 AST
*ast_walk (AST_WALKER_KIND action
, AST
*ast
, void *arg
) {
326 return ast
->walkers
[action
](action
, ast
, arg
);
339 AST
*ast_lift (AST
*ast
, LIFT_DATA
*data
) {
340 return ast_walk(LIFT_WALK
, ast
, data
);
343 AST
*ast_optimize_lets (AST
*ast
) {
344 return ast_walk(LET_WALK
, ast
, NULL
);
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
); }
352 void cerror (AST
* ast
, char* message
, ...) {
354 ast
->print(); fprintf(error_log(),"\n");
355 va_start(ap
, message
);
356 vfprintf(error_log(),message
, ap
); fprintf(error_log(),"\n");
358 exit(test_mode
? 0 : 1);
362 void clerror (char* name
, list
<AST
*> *args
, char* message
, ...) {
364 fprintf(error_log(),"(%s", name
);
365 for (typeof(args
->begin()) it
= args
->begin();
366 it
!= args
->end(); it
++) {
367 fprintf(error_log()," ");
370 fprintf(error_log(),")\n");
371 va_start(ap
, message
);
372 vfprintf(error_log(), message
, ap
);
373 fprintf(error_log(),"\n");
375 exit(test_mode
? 0 : 1);
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
;
384 struct AST_LIT
: public AST
{
389 val
= num
; name
="LIT";
390 type
= new ONE_NUM_TYPE(num
);
392 kind
= (n
== num
&& (n
>= 0 && n
< 128)) ? LIT_INT8
: LIT_FLO
;
395 void print() { fprintf(error_log(),"%.1f", val
); }
396 AST_CLASS
ast_class() { return AST_LIT_CLASS
; }
398 void emit(Script
* script
) {
399 // post("EMIT LIT %d %f\n", ast->kind, num);
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
);
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]);
411 // *bytes = PAIR(new_num(num), PAIR(new_num(DEF_TUP_OP), *bytes));
414 // *bytes = PAIR(new_num(DEF_VEC_OP), *bytes);
417 cerror(this, "UNKNOWN LIT KIND %d", kind
);
423 struct AST_REF
: public AST
{
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
; }
434 AST
*ast_ref_lift_walk (AST_WALKER_KIND action
, AST
*ast_
, void *arg
) {
436 AST_REF
*ast
= (AST_REF
*)ast_
;
437 LIFT_DATA
*data
= (LIFT_DATA
*)arg
;
438 ast
->env
= data
->env
;
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
));
448 AST
*ast_ref_let_walk (AST_WALKER_KIND action
, AST
*ast_
, void *arg
) {
449 AST_REF
*ast
= (AST_REF
*)ast_
;
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
);
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");
466 int lookup_index (VAR
*var
, list
<VAR
*> *env
) {
468 typeof(env
->begin()) it
;
469 for (j
= 0, it
= env
->begin(); it
!= env
->end(); it
++, j
++) {
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
);
483 /**** AST_GLO_REF ****/
484 struct AST_GLO_REF
: public AST
{
486 int offset
; // Note: offset is always positive
488 AST_GLO_REF(AST
*dat
, int offset
) {
489 this->dat
=dat
; this->offset
=offset
;
490 type
= dat
->type
; name
="REF";
494 fprintf(error_log(),"REF("); dat
->print();
495 fprintf(error_log()," %d)", offset
);
497 void emit(Script
* script
);
498 AST_CLASS
ast_class() { return AST_GLO_REF_CLASS
; }
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
);
507 /**** AST_OP, AST_GOP ****/
508 typedef TYPE
* (*TYPE_INFER
)(AST
* ast
);
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
);
514 struct AST_OP
: public AST
{
520 TYPE_INFER type_infer
;
521 AST_EMIT emit_fn
; // this is a leftover of some sort...
523 AST_OP(char *name
, char *opname
, OPCODE code
, int arity
, int is_nary
, TYPE
*type
, TYPE_INFER type_infer
) {
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
;
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
); }
537 struct AST_GOP
: public AST
{
543 AST_GOP(char *name
, int arity
, int is_nary
, TYPE
*type
) {
547 this->is_nary
=is_nary
;
548 this->ops
= new typeof(*this->ops
);
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"); }
558 #define MAX_OP_ARITY 2
559 struct AST_OP_CALL
: public AST
{
562 int offsets
[MAX_OP_ARITY
];
564 AST_OP_CALL(AST_OP
*op
, list
<AST
*> *args
);
567 void emit(Script
* script
) { op
->emit_call(this, script
); }
570 AST_CLASS
ast_class() { return AST_OP_CALL_CLASS
; }
574 struct AST_FUN
: public AST
{
581 AST_FUN(char *name
, list
<VAR
*> *vars
, Obj
*body
, AST
*ast_body
);
584 fprintf(error_log(),"(FUN (");
585 typeof(vars
->begin()) it
;
586 for (i
= 0, it
= vars
->begin(); it
!= vars
->end(); it
++, i
++) {
588 fprintf(error_log()," ");
589 fprintf(error_log(),"%s", (*it
)->name
);
591 fprintf(error_log(),") ");
592 if (ast_body
== NULL
)
593 fprintf(error_log(),"...");
596 fprintf(error_log(),")");
599 void emit(Script
* script
); // turn program element into bytecodes
600 AST_CLASS
ast_class() { return AST_FUN_CLASS
; }
603 TYPE
* blur_type(TYPE
* t
) {
605 case ONE_NUM_KIND
: return &num_type
;
606 case ONE_FUN_KIND
: return (TYPE
*)((((ONE_FUN_TYPE
*)t
)->value
)->fun_type
);
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
[];
615 extern AST
* null_of(TYPE
* t
);
617 extern AST
*new_ast_op_call_offset(AST_OP
*op
, list
<AST
*> *args
, int offset
);
619 AST
* new_fab_vec (int len
, TYPE
* elt_type
) {
621 if (elt_type
->kind
== NUM_KIND
) {
622 ast
= new_ast_op_call_offset(fab_num_vec_op
, new list
<AST
*>(), len
);
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
);
631 AST
* null_of(TYPE
* t
) {
637 return new AST_LIT(0);
639 VEC_TYPE
*vt
= (VEC_TYPE
*)t
;
640 // post("VEC %d\n", vt->len);
641 return new_fab_vec(vt
->len
, vt
->elt_type
); }
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
);
651 uerror("unable to build null of type %s", t
->name());
655 extern TYPE
* tup_type_elt (TYPE
*, int);
656 extern int tup_type_len (TYPE
*);
658 AST
* real_null_of(TYPE
* t
) {
664 return new AST_LIT(0);
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
);
674 uerror("unable to build null of type %s", t
->name());
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
);
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
);
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
);
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();
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);
715 data
->glos
->push_back(ast
);
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());
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
);
732 if (data
->is_fun_lift
)
733 return new AST_GLO_REF(ast_
, maybe_lift_fun(ast
, data
));
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
);
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);
750 this->ast_body
= ast_body
;
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
);
761 struct AST_LET
: public AST
{
767 AST_LET(list
<VAR
*> *vars
, list
<AST
*> *inits
, AST
*body
, list
<VAR
*> *env
);
769 void emit(Script
* script
);
772 AST_CLASS
ast_class() { return AST_LET_CLASS
; }
775 extern AST
* parse (Obj
*e
, list
<VAR
*> *env
);
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
);
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
;
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
);
803 vit
= ast
->vars
->erase(vit
);
804 iit
= ast
->inits
->erase(iit
);
807 if (ast
->vars
->empty()) {
813 void AST_LET::print() {
814 fprintf(error_log(),"(LET (");
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
++) {
821 fprintf(error_log(), " ");
822 fprintf(error_log(), "(%s ", (*vit
)->name
);
824 fprintf(error_log(), ")");
826 fprintf(error_log(),") ");
828 fprintf(error_log(),")");
831 void emit_let_op (int n
, Script
* script
) {
833 if (n
<= MAX_LET_OPS
) script
->add(LET_OP
+n
);
834 else script
->add(LET_OP
,n
);
838 void emit_pop_let_op (int n
, Script
* script
) {
840 if (n
<= MAX_LET_OPS
) script
->add(POP_LET_OP
+n
);
841 else script
->add(POP_LET_OP
,n
);
845 void AST_LET::emit(Script
* script
) {
847 typeof(inits
->begin()) iit
;
848 for(iit
=inits
->begin(); iit
!= inits
->end(); iit
++) {
849 (*iit
)->emit(script
);
852 emit_let_op(n
, script
);
854 emit_pop_let_op(n
, script
);
857 inline int int_max (int x
, int y
) { return x
< y
? y
: x
; }
859 void post_space (int depth
) {
861 fprintf(error_log(),"[%2d] ", depth
);
862 for (i
= 0; i
< depth
; i
++)
863 fprintf(error_log()," ");
867 int AST_LET::stack_size() {
870 for (typeof(inits
->begin()) it
= inits
->begin();
871 it
!= inits
->end(); it
++) {
872 size
= int_max(size
, (*it
)->stack_size() - 1);
874 size
= int_max(size
, body
->stack_size()) + int_max(1, inits
->size());
879 int AST_LET::env_size() {
882 for (typeof(inits
->begin()) it
= inits
->begin();
883 it
!= inits
->end(); it
++) {
884 size
= int_max(size
, (*it
)->env_size());
887 size
= int_max(size
, body
->env_size() + inits
->size());
892 AST_LET::AST_LET(list
<VAR
*> *vars
, list
<AST
*> *inits
, AST
*body
, list
<VAR
*> *env
) {
894 walkers
[0]=&ast_let_lift_walk
;
895 walkers
[1]=&ast_let_let_walk
;
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
;
907 /**** AST_OP_CALL ****/
908 // definition moved above for the benefit of AST_FUN
910 int add_offset (AST_OP_CALL
*ast
, int offset
) {
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
);
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
);
925 AST
*ast_op_call_walk (AST_WALKER_KIND action
, AST
*ast_
, void *arg
) {
926 AST_OP_CALL
*ast
= (AST_OP_CALL
*)ast_
;
928 for(typeof(ast
->args
->begin()) it
= ast
->args
->begin();
929 it
!= ast
->args
->end(); it
++) {
930 *it
= ast_walk(action
, *it
, arg
);
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
) {
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
);
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
);
950 cerror(tup_
, "UNABLE TO FIND TUP DEF");
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);
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;
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);
971 void init_feedback_lift (AST_OP_CALL
*ast
, LIFT_DATA
*data
) {
972 add_offset(ast
, data
->n_state
++);
975 extern AST_CLASS ast_op_call_class
;
977 void fold_hood_lift (AST_OP_CALL
*ast
, LIFT_DATA
*data
) {
978 typeof(ast
->args
->begin()) it
= ast
->args
->begin();
981 int size
= arg
->type
->size();
983 cerror(arg
, "UNDERSPECIFIED TYPE SIZE IN EXPORT");
984 data
->export_len
+= size
;
985 add_offset(ast
, data
->n_exports
++);
988 // FEEDBACK - (ALL (UNLESS IS-EXEC? (SET INIT (INIT))) (SET IS-EXEC? T) OFF)
989 // SET-FEEDBACK - (SET OFF (EXEC))
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
;
999 cerror((AST
*)ast
, "UNKNOWN INIT-FEEDBACK FROM FEEDBACK");
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]);
1009 // feedback_op offset init_bytes
1014 AST_OP
*init_feedback_op
;
1015 AST_OP
*feedback_op
;
1022 AST_OP
*fold_hood_op
;
1023 AST_OP
*vfold_hood_op
;
1026 AST_OP
*fold_hood_plus_op
;
1027 AST_OP
*vfold_hood_plus_op
;
1032 AST_OP
*mux_op
, *vmux_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];
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
);
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
);
1068 void ast_args_print (list
<AST
*> *args
) {
1069 for (typeof(args
->begin()) i
= args
->begin(); i
!= args
->end(); i
++) {
1070 fprintf(error_log()," ");
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(),")");
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());
1096 // <--- THEN OFF --->
1097 // TST IF_OP T1 T2 ELSE JMP_OP D1 D2 THEN NEXT
1099 void ast_if_emit(AST_OP_CALL
* ast
, Script
* script
) {
1104 typeof(ast
->args
->begin()) it
= ast
->args
->begin();
1105 (*it
++)->emit(&if_script
);
1106 (*it
++)->emit(&then_script
);
1107 (*it
++)->emit(&jmp_script
);
1109 uint16_t then_offset
= jmp_script
.size()+2;
1110 uint16_t done_offset
= then_script
.size();
1111 if(done_offset
> 255) then_offset
++;
1113 script
->append(&if_script
);
1114 if(then_offset
> 255)
1115 script
->add_op16(IF_16_OP
,then_offset
);
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
);
1122 script
->add(JMP_OP
,done_offset
);
1123 script
->append(&then_script
);
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();
1132 int AST_OP_CALL::stack_size() {
1133 int size
= 0, base_size
= 0;
1136 op
== fold_hood_op
|| op
== fold_op
||
1137 op
== vfold_hood_op
|| op
== vfold_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
++));
1147 for (typeof(args
->begin()) it
= args
->begin();
1148 it
!= args
->end(); it
++ ) {
1149 size
= int_max(size
, (*it
)->stack_size() - 1);
1151 size
= base_size
+ size
+ int_max(1, args
->size());
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();
1161 int AST_OP_CALL::env_size() {
1162 int size
= 0, base_size
= 0;
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
++));
1174 for (typeof(args
->begin()) it
= args
->begin();
1175 it
!= args
->end(); it
++ ) {
1176 size
= int_max(size
, (*it
)->env_size());
1179 size
= base_size
+ size
;
1184 AST_OP_CALL::AST_OP_CALL(AST_OP
*op
, list
<AST
*> *argv
) : args(argv
) {
1186 walkers
[0]=&ast_op_call_lift_walk
; walkers
[1]=&ast_op_call_walk
;
1188 type
= op
->type_infer(this);
1189 for(int i
= 0; i
< op
->arity
; i
++) offsets
[i
] = -1;
1192 /**** AST_CALL ****/
1193 struct AST_CALL
: public AST
{
1197 AST_CALL(AST
*fun
, list
<AST
*> *args
);
1200 fprintf(error_log(),"(");
1202 ast_args_print(args
);
1203 fprintf(error_log(),")");
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
; }
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
));
1217 ast
->args
= new_args
;
1218 ast
->fun
= (AST_FUN
*)ast_walk(action
, ast
->fun
, arg
);
1222 AST_CALL::AST_CALL(AST
*fun
, list
<AST
*> *argv
) : args(argv
) {
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
;
1230 /****** OPERATION DEFINITION ******/
1232 list
<VAR
*> *user_ops
;
1234 extern VAR
* lookup_name (const char *name
, list
<VAR
*> *bindings
);
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
);
1242 ops
->push_front(new VAR(name
, new ONE_OP_TYPE(op
)));
1244 // post("FOUND OLD OP %s\n", name);
1245 switch (var
->type
->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
);
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
);
1262 uerror("ADDING OP TO NON OP VAR %s\n", name
);
1265 // post("ADDING %s %d\n", name, code);
1269 extern TYPE
* op_type_infer (AST
* ast_
);
1271 AST_OP
*add_op_named
1272 (char *name
, char *opname
, OPCODE code
, int arity
, int is_nary
,
1273 FUN_TYPE
*fun_type
) {
1275 (name
, opname
, code
, arity
, is_nary
, fun_type
, &op_type_infer
);
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
);
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
);
1291 (char *name
, OPCODE code
, int arity
, int is_nary
, FUN_TYPE
*fun_type
) {
1293 (name
, name
, code
, arity
, is_nary
, fun_type
, &op_type_infer
);
1296 AST_OP
*def_op_alias (char *name
, AST_OP
*op
) {
1297 ops
->push_front(new VAR(name
, new ONE_OP_TYPE(op
)));
1301 char *cpy_str (char *s
) {
1302 char *r
= (char*)MALLOC(strlen(s
)+1);
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());
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());
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
;
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;
1334 int len
= ast
->args
->size();
1336 return new TUP_TYPE(0,NULL
);
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]);
1344 return new VEC_TYPE(len
,types
[0]);
1346 return new TUP_TYPE(len
,types
);
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
);
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
);
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));
1377 cerror(ast_
, "ELT: TYPE ERROR EXPECTED VEC/TUP GOT %s", elts
->name());
1380 cerror(ast_
, "ELT: UNABLE TO TYPE ELT %s %s", idx
->name(), elts
->name());
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
;
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
;
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
;
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();
1406 ONE_FUN_TYPE
* fun
= (ONE_FUN_TYPE
*)(*it
)->type
;
1407 return fun
->value
->ast_body
->type
;
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
;
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
);
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
;
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();
1439 TYPE
* probe_type_infer (AST
* ast_
) {
1440 AST_OP_CALL
* ast
= (AST_OP_CALL
*)ast_
;
1441 AST
* val
= ast
->args
->front();
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
;
1451 TYPE
* all_type_infer (AST
* ast_
) {
1452 AST_OP_CALL
* ast
= (AST_OP_CALL
*)ast_
;
1453 int len
= ast
->args
->size();
1455 return ast
->args
->back()->type
;
1460 TYPE
* feedback_type_infer (AST
* ast_
) {
1461 AST_OP_CALL
* ast
= (AST_OP_CALL
*)ast_
;
1462 AST
* init
= ast
->args
->front();
1470 ops
= new list
<VAR
*>();
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
);
1480 add_op_typed("FOLD-HOOD", FOLD_HOOD_OP
, 1, 0,
1481 new FUN_TYPE(ANYT
,ANYT
,ANYT
,ANYT
,0), &fold_hood_type_infer
);
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));
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));
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));
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));
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));
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
);
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
);
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
);
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
);
1557 add_op_named("LEN", "LEN", LEN_OP
, 0, 0,new FUN_TYPE(NUMT
,TUPT
,0));
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
);
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
);
1583 add_op_typed("NUL-TUP", NUL_TUP_OP
, 0, 0,
1584 new FUN_TYPE(ANYT
,0), &tup_type_infer
);
1586 add_op_typed("TUP", TUP_OP
, 1, 1,
1587 new FUN_TYPE(ANYT
,ANYT
,1), &tup_type_infer
);
1589 add_op_typed("MAP", MAP_OP
, 1, 0,
1590 new FUN_TYPE(ANYT
,ANYT
,ANYT
,0), &map_type_infer
);
1592 add_op_typed("APPLY", APPLY_OP
, 0, 0,
1593 new FUN_TYPE(ANYT
,ANYT
,ANYT
,0), &apply_type_infer
);
1595 add_op_typed("FOLD", FOLD_OP
, 0, 0,
1596 new FUN_TYPE(ANYT
,ANYT
,ANYT
,ANYT
,0), &fold_type_infer
);
1598 add_op_typed("VFOLD", VFOLD_OP
, 1, 0,
1599 new FUN_TYPE(ANYT
,ANYT
,ANYT
,ANYT
,0), &fold_type_infer
);
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));
1604 add_op_typed("MUX", MUX_OP
, 0, 0,
1605 new FUN_TYPE(ANYT
,NUMT
,ANYT
,ANYT
,0), &mux_type_infer
);
1607 add_op_typed("VMUX", VMUX_OP
, 1, 0,
1608 new FUN_TYPE(ANYT
,NUMT
,ANYT
,ANYT
,0), &mux_type_infer
);
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));
1622 add_op("MID", MID_OP
, 0, 0, new FUN_TYPE(NUMT
,0));
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));
1637 = add_op_typed("FAB-TUP", FAB_TUP_OP
, 0, 1, new FUN_TYPE(VECT
,ANYT
,0), &tup_type_infer
);
1639 = add_op_typed("FAB-VEC", FAB_VEC_OP
, 1, 0, new FUN_TYPE(VECT
,ANYT
,0), &vec_type_infer
);
1641 = add_op("DEF-TUP", DEF_TUP_OP
, 0, 1, new FUN_TYPE(VECT
,ANYT
,0));
1643 = add_op("DEF-VEC", DEF_VEC_OP
, 1, 0, new FUN_TYPE(VECT
,ANYT
,0));
1645 = add_op_typed("FAB-NUM-VEC", FAB_NUM_VEC_OP
, 1, 0, new FUN_TYPE(VECT
,0), &num_vec_type_infer
);
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));
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));
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));
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));
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));
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));
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));
1686 add_op_typed("INIT-FEEDBACK", INIT_FEEDBACK_OP
, 1, 0,
1687 new FUN_TYPE(ANYT
,ANYT
,0), &init_feedback_type_infer
);
1689 add_op_typed("FEEDBACK", FEEDBACK_OP
, 1, 0,
1690 new FUN_TYPE(ANYT
,ANYT
,ANYT
,0), &feedback_type_infer
);
1695 char* sym_elt (List
*e
, int offset
) {
1696 Obj
*n
= lst_elt((List
*)e
, offset
);
1698 return strdup(((Symbol
*)n
)->getName().c_str());
1700 uerror("LOOKING FOR STRING FOUND OTHER TYPE %s", n
->typeName());
1703 list
<VAR
*> *globals
;
1706 bool operator()(const char *s1
, const char *s2
) {
1707 return strcmp(s1
, s2
) < 0;
1711 static map
<const char*, int, ltstr
> obarray
;
1712 static int obval
= 0;
1714 int intern_symbol (const char *name
) {
1715 typeof(obarray
.begin()) it
= obarray
.find(name
);
1716 if (it
!= obarray
.end()) {
1719 return (obarray
[name
] = obval
++);
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) {
1734 VAR
* lookup_op (const char *name
) {
1735 return lookup_name(name
, ops
);
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
++) {
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
++) {
1748 if (o
->code
== code
) {
1754 ONE_OP_TYPE
*type
= (ONE_OP_TYPE
*)var
->type
;
1755 AST_OP
*o
= type
->op
;
1756 if (o
->code
== code
) {
1765 void load_def (const char *name
) {
1767 // LOOK IT UP IN FILE
1769 string filename
= name
; filename
+=".proto";
1770 expr
= read_objects_from_dirs(filename
, proto_path
);
1774 Obj
*body
= PAIR(new Symbol("all"), expr
);
1775 parse(body
, new list
<VAR
*>());
1779 VAR
* lookup (const char *name
, list
<VAR
*> *stack
) {
1780 VAR
*res
= lookup_name(name
, stack
);
1783 res
= lookup_name(name
, globals
);
1787 res
= lookup_name(name
, globals
);
1790 return lookup_op(name
);
1793 map
<string
, AST
*> fun_ops
;
1795 AST
* parse_op_ref (char *op_name
, FUN_TYPE
*type
, list
<VAR
*> *env
) {
1798 string
opname(op_name
);
1799 Obj
*fun_sym
= new Symbol("FUN");
1800 List
*args
= lisp_nil
;
1801 int n
= type
->arity
;
1803 typeof(fun_ops
.begin()) it
= fun_ops
.find(opname
);
1805 if(it
!= fun_ops
.end())
1808 for (i
= n
-1; i
>= 0; i
--) {
1810 sprintf(name
, "a%d", i
);
1811 args
= PAIR(new Symbol(name
), args
);
1813 res
= parse(_list(fun_sym
, args
, PAIR(new Symbol(op_name
), args
), NULL
), env
);
1815 fun_ops
[opname
] = res
;
1819 AST
* parse_reference (const char *name
, list
<VAR
*> *env
) {
1820 VAR
*var
= lookup(name
, env
);
1821 // post("REF %s\n", name);
1824 TYPE
*type
= var
->type
;
1825 switch (type
->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
); }
1833 return (AST
*)(((ONE_FUN_TYPE
*)type
)->value
);
1835 return new AST_REF(var
, env
);
1839 AST
* parse_symbol (const char *name
) {
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
);
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);
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
),
1860 rewrite_cases(var
, lst_tail(cases
)),
1865 Obj
*cat_sym2 (char *s1
, char *s2
) {
1866 char str
[100]; sprintf(str
, "%s%s", s1
, s2
);
1867 return new Symbol(str
);
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
);
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
)
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
)));
1892 Obj
*rewrite_letstar (List
*bindings
, List
*body
) {
1893 if (bindings
== lisp_nil
)
1894 return body
->getHead();
1896 return PAIR(new Symbol("let"),
1897 PAIR(PAIR(bindings
->getHead(), lisp_nil
),
1898 PAIR(rewrite_letstar((List
*)(bindings
->getTail()), body
), lisp_nil
)));
1902 Obj
*rewrite_nary (Obj
*fun
, List
*args
) {
1903 switch (lst_len(args
)) {
1905 uerror("NARY WITH FEWER THAN TWO INPUTS");
1907 return _list(fun
, lst_elt(args
, 0), lst_elt(args
, 1), NULL
);
1909 return _list(fun
, lst_head(args
), rewrite_nary(fun
, lst_tail(args
)), NULL
);
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
));
1923 list
<AST
*> *parse_args (List
* args
, list
<VAR
*> *env
) {
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
));
1931 AST
*parse_fun_body (list
<VAR
*> *vars
, Obj
*body
, list
<VAR
*> *env
) {
1932 return parse(body
, augment_env(vars
, env
));
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;
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
));
1947 = qq_env("$i", new Number(i
),
1949 "$x", lst_elt(args
, 0),
1950 "$r", read_select(i
+ 1, idx
, first
, lst_tail(args
)),
1952 return read_qq("(if (= $o $i) $x $r)", env
);
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")
1963 return n_nbr_refs(fun
) + n_nbr_refs(lst_tail((List
*)expr
));
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) {
1973 Obj
*nexpr
= lst_elt((List
*)expr
, 1);
1975 *nexprs
= PAIR(nexpr
, *nexprs
);
1977 return read_qq("e", lisp_nil
);
1979 return read_qq("(elt t $i)", qq_env("$i", new Number(off
), NULL
));
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
);
1989 Obj
* rewrite_fold_hood_star(Obj
*expr
, Obj
**nexprs
, int *n
) {
1991 *n
= n_nbr_refs(expr
);
1992 Obj
*form
= do_rewrite_fold_hood_star(expr
, nexprs
, &counter
, *n
);
1993 *nexprs
= lst_rev((List
*)*nexprs
);
1997 Obj
* hood_folder (char *name
, List
*args
, Obj
*merge
, Obj
*cmp
) {
1998 switch (lst_len(args
)) {
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
));
2005 clerror(name
, /* args */ new list
<AST
*>(), "MAX-HOOD: WRONG NUM ARGS %d", lst_len(args
));
2010 Obj
* rewrite_conds (List
*args
) {
2011 if (args
== lisp_nil
)
2012 return read_qq("(if-error)", lisp_nil
);
2014 List
*arg
= (List
*)lst_elt(args
, 0);
2016 = qq_env("$pred", lst_elt(arg
, 0),
2017 "$body", lst_elt(arg
, 1),
2018 "$rest", rewrite_conds(lst_tail(args
)),
2020 return read_qq("(if $pred $body $rest)", qqenv
);
2024 extern AST
*ast_op_call_check (AST_OP
* op
, list
<AST
*> *args
);
2026 // (cond (pa xa) (pb xb) (pc xc)) -> (if pa xa (if pb xb (if pc xc)))
2028 Obj
*body_from(List
*forms
) {
2029 if (lst_len(forms
) == 1)
2030 return lst_elt(forms
, 0);
2032 Obj
*asym
= new Symbol("all");
2033 return PAIR(asym
, (Obj
*)forms
);
2037 AST
* parse_special_form (const char *name
, Obj
*e
, List
*args
, list
<VAR
*> *env
) {
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
++) {
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
);
2060 return parse(body
, env
);
2062 return new_ast_let(vars
, inits
, parse(body
, newenv
), env
);
2064 } else if (strcasecmp(name
, "let*") == 0) {
2066 = rewrite_letstar((List
*)lst_head(args
), lst_tail(args
));
2067 return parse(let
, env
);
2069 } else if (strcasecmp(name, "bind") == 0) {
2071 = rewrite_bind((List*)lst_head(args), lst_tail(args));
2072 return parse(let, env);
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)
2079 Obj
*expr
= lst_elt(args
, 2);
2080 Obj
*nexprs
= lisp_nil
;
2081 Obj
*nexpr
= rewrite_fold_hood_star(expr
, &nexprs
, &n
);
2083 = qq_env("$folder", lst_elt(args
, 0),
2086 "$init", lst_elt(args
, 1),
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)";
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");
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)
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
);
2110 = qq_env("$folder", folder
,
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)";
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
);
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),
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
),
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
);
2183 return ast_op_call_check(all_op
, parse_args(args
, env
));
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));
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
,
2209 cat_sym2("new-", name
),
2211 PAIR(tup_sym
, fields
),
2213 PAIR(all_sym
, getters
),
2215 return parse(ds
, env
);
2216 } else if (strcasecmp(name
, "quote") == 0) {
2217 Obj
*val
= lst_head(args
);
2219 return parse_symbol(((Symbol
*)val
)->getName().c_str());
2220 } else if (numberp(val
)) {
2221 return new AST_LIT(((Number
*)val
)->getValue());
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");
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
;
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) {
2264 Obj
*t
= Symbol::gensym("t");
2265 for (tns
= lst_tail(tn
), i
= 0; tns
!= lisp_nil
; tns
= lst_tail(tns
), i
++) {
2267 sprintf(form
, "($n (elt $t %d))", i
);
2268 Obj
*tb
= read_qq(form
, qq_env("$n", lst_head(tns
), "$t", t
, NULL
));
2270 tbs
= PAIR(tb
, tbs
);
2271 atbs
= PAIR(tb
, atbs
);
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
);
2281 // clerror("LETFED", args, "LETFED: MALFORMED BINDING %d", lst_len(b));
2282 uerror("LETFED: MALFORMED BINDING %d", lst_len(b
));
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) {
2291 = read_select(0, lst_elt(args
, 0), lst_elt(args
, 1), lst_tail(args
));
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
));
2297 return parse(form
, env
);
2298 } else if (strcasecmp(name
, "seq") == 0) {
2300 = qq_env("$1st-ss", lst_elt(args
, 0),
2302 "$len-ss", new Number(lst_len(args
)),
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
);
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
));
2319 AST
* tst
= list_nth(ast_args
, 0);
2320 AST
* con
= list_nth(ast_args
, 1);
2321 AST
* alt
= list_nth(ast_args
, 2);
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());
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());
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
));
2340 AST
* tst
= list_nth(ast_args
, 0);
2341 AST
* con
= list_nth(ast_args
, 1);
2342 AST
* alt
= list_nth(ast_args
, 2);
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());
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());
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
));
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());
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",
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
);
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
);
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
));
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());
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
));
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
);
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
));
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());
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",
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());
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
);
2459 = (elt_type
->kind
== TUP_KIND
|| elt_type
->kind
== VEC_KIND
) ?
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
);
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
*>());
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
));
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());
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
);
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
);
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
);
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
));
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
);
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
);
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
);
2576 int type_check (AST
*arg
, TYPE
*type
) {
2577 return arg
->type
->subtype(type
);
2581 int ast_op_call_type_check (FUN_TYPE
*type
, list
<AST
*> *args
) {
2583 for (typeof(args
->begin()) it
= args
->begin();
2584 it
!= args
->end(); i
++, it
++) {
2586 if (i
< type
->arity
&& !type_check(arg
, type
->param_types
[i
]))
2592 AST
*ast_op_call_check (AST_OP
* op
, list
<AST
*> *args
) {
2594 int nargs
= args
->size();
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",
2605 (list_nth(args
, i
))->type
->name(),
2606 type
->param_types
[i
]->name());
2607 // post("OP %s\n", op->name);
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
++) {
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);
2629 for (typeof(args
->begin()) it
= args
->begin();
2630 it
!= args
->end(); it
++) {
2631 fprintf(error_log()," %s", (*it
)->type
->name());
2633 fprintf(error_log(),": ");
2634 clerror("GOP-CALL", args
, "NO APPLICABLE METHODS ERROR FOR %s", gop
->name
);
2637 AST
* parse (Obj
*e
, list
<VAR
*> *env
) {
2639 // debug("E COMPILE\n");
2641 return new AST_LIT(((Number
*)e
)->getValue());
2642 } else if (symbolp(e
)) {
2644 const char *name
= ((Symbol
*)e
)->getName().c_str();
2645 // debug("FOUND SYM %s\n", name);
2646 res
= parse_reference(name
, env
);
2650 uerror("UNABLE TO FIND %s", name
);
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
);
2660 // debug("FOUND LST\n");
2662 uerror("ILLEGAL EMPTY LIST");
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
);
2670 VAR
*var
= lookup(name
, env
);
2671 list
<AST
*> *ast_args
= parse_args(args
, env
);
2674 switch (type
->kind
) {
2676 return ast_op_call_check(((ONE_OP_TYPE
*)type
)->op
, ast_args
);
2678 return ast_gop_call_check(((ONE_GOP_TYPE
*)type
)->gop
, ast_args
);
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
);
2691 list
<VAR
*> *vars
= new typeof(*vars
);
2692 list
<AST
*> *let_vals
= new typeof(*let_vals
);
2693 list
<AST
*> *as
= parse_args(args
, env
);
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
);
2701 for (typeof(as
->begin()) it
= as
->begin();
2702 it
!= as
->end(); i
++, it
++) {
2704 var
= new VAR(list_nth(fun
->vars
, i
)->name
, &any_type
);
2706 var
->type
= a
->type
;
2707 vars
->push_back(var
);
2708 let_vals
->push_back(a
);
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
);
2714 list
<AST
*> *as
= parse_args(args
, env
);
2715 return new AST_CALL(ast_fun
, as
);
2716 // uerror("UNKNOWN CALL TYPE %d", type->kind);
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();
2735 fprintf(error_log(),"// ");
2737 fprintf(error_log(),"\n");
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
++)
2747 emit_def_fun_op(body
.size()+1, script
);
2748 script
->append(&body
);
2749 script
->add(RET_OP
,EXIT_OP
);
2753 char *xlate_opname(char *dst
, char *src
) {
2755 for (i
= 0; i
< strlen(src
); i
++) {
2757 dst
[i
] = src
[i
] == '-' ? '_' : toupper(src
[i
]);
2764 #define MAX_DIRS 100
2766 void init_compiler () {
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
);
2776 uint8_t *dst
= (uint8_t*)MALLOC(*len
);
2777 for(int i
=0;i
<*len
;i
++) dst
[i
]=s
->pop();
2781 FILE* dump_target
=stdout
;
2782 void dump_instructions (int is_c
, int n
, uint8_t *bytes
) {
2784 if (is_c
) { fprintf(dump_target
,"uint8_t script[] = {"); }
2785 for (j
= 0; j
< n
; j
++) {
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
,",");
2796 fprintf(dump_target
," %d", bytes
[j
]);
2799 if (is_c
) { fprintf(dump_target
," };\n"); fprintf(dump_target
,"uint16_t script_len = %d;", n
); }
2800 fprintf(dump_target
,"\n");
2803 void dump_code (int n
, uint8_t *bytes
) {
2805 for (j
= 0; j
< n
; j
++) {
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
++) {
2814 fprintf(dump_target
," %d", bytes
[j
]);
2816 fprintf(dump_target
,"\n");
2820 /***** PLATFORM-SPECIFIC OP DEFINITIONS *****/
2824 void downcase(string
& str
)
2825 { for(int i
=0;i
<str
.size();i
++) { str
[i
]=tolower(str
[i
]); } }
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) {
2833 uerror("Compound type %s is not a (vector 3)",ex
->to_str().c_str());
2835 } else if(ex
->isSymbol()) {
2836 if(*ex
=="scalar") return NUMT
;
2837 if(*ex
=="boolean") return NUMT
;
2839 uerror("Unhandled or unknown type %s",ex
->to_str().c_str());
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
;
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");
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 */
2854 if(!l
->children
[2]->isScalar()) uerror("defop extopcode not scalar");
2855 int op
= (int)((SE_Scalar
*)l
->children
[1])->value
+ CORE_CMD_OPS
;
2857 if(!l
->children
[3]->isSymbol()) uerror("defop fn not symbol");
2858 string sfun
= ((SE_Symbol
*)l
->children
[3])->name
;
2860 /* add_op wants its own copy of this string */
2861 char* fun
= strdup(sfun
.c_str());
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
]));
2867 /* and add the op to the compiler */
2868 add_op(fun
, op
, 0, 0, new FUN_TYPE(&types
));
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
]);
2883 parse_external_op(l
);
2889 /***** COMPILER WRAPPER CLASS *****/
2890 extern list
<string
>* read_enum(istream
* in
, ostream
* out
=NULL
);
2892 Compiler::Compiler(Args
* args
) {
2893 proto_path
= new Path();
2894 if (args
->extract_switch("--srcdir"))
2895 srcdir
= args
->pop_next();
2897 if (args
->extract_switch("--basepath"))
2898 proto_path
->add_to_path(args
->pop_next());
2900 proto_path
->add_default_path(srcdir
);
2902 while(args
->extract_switch("-path",false)) // can extract multiple times
2903 proto_path
->add_to_path(args
->pop_next());
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");
2910 if(args
->extract_switch("--platform")) set_platform(args
->pop_next());
2914 Compiler::~Compiler() {
2919 void Compiler::set_platform(string plat
) {
2923 // use the platform dir in the source directory
2924 platdir
= srcdir
+ "/src/" + plat
;
2926 // use the install location
2927 platdir
= PROTOPLATDIR
;
2932 read_opfile((platdir
+"/platform_ops.proto").c_str());
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
) {
2950 // ensure that the directory exists
2951 snprintf(buf
, 1000, "mkdir -p %s", dump_dir
);
2953 sprintf(buf
,"%s/%s.log",dump_dir
,dump_stem
);
2955 dump_target
=fopen(buf
,"w");
2959 uint8_t* Compiler::compile(char *str
, int* len
) {
2961 uint8_t* bytes
= compile_script(str
,len
,is_dump_ast
);
2962 if(is_dump_code
) dump_instructions(1,*len
,bytes
);
2966 void Compiler::visualize() {
2968 // "compiler should be able to show the code here, but doesn't yet"
2972 BOOL
Compiler::handle_key(KeyEvent
* key
) {
2973 if(key
->normal
&& !key
->ctrl
) {
2975 case 'k': is_show_code
= !is_show_code
; return TRUE
;