diff --git a/meta.leg b/meta.leg new file mode 100644 index 0000000..03d18c5 --- /dev/null +++ b/meta.leg @@ -0,0 +1,2052 @@ +%{ + +/* compile: leg -o parse.c parse.leg + * cc -o parse parse.c + * + * run: echo "3+4" | ./parse + */ + +#include +#include + +#define DO_PROTOS() \ + _DO(Undefined) _DO(Integer) _DO(Float) _DO(String) _DO(Symbol) _DO(Function) _DO(Map) \ + _DO(If) _DO(While) _DO(Do) _DO(For) _DO(ForIn) _DO(Switch) _DO(Call) \ + _DO(Invoke) _DO(Func) _DO(Block) _DO(Declaration) _DO(Assign) \ + _DO(Logor) _DO(Logand) _DO(Bitor) _DO(Bitxor) _DO(Bitand) \ + _DO(Equal) _DO(Noteq) _DO(Less) _DO(Lesseq) _DO(Greater) _DO(Greatereq) \ + _DO(Shleft) _DO(Shright) \ + _DO(Add) _DO(Sub) _DO(Mul) _DO(Div) _DO(Mod) _DO(Not) _DO(Neg) _DO(Com) \ + _DO(PreIncVariable) _DO(PreIncMember) _DO(PreIncIndex) \ + _DO(PostIncVariable) _DO(PostIncMember) _DO(PostIncIndex) \ + _DO(PreDecVariable) _DO(PreDecMember) _DO(PreDecIndex) \ + _DO(PostDecVariable) _DO(PostDecMember) _DO(PostDecIndex) \ + _DO(GetVariable) _DO(GetMember) _DO(SetMember) _DO(GetIndex) _DO(SetIndex) \ + _DO(Return) _DO(Break) _DO(Continue) _DO(Throw) _DO(Try) \ +// _DO(Quasiquote) _DO(Unquote) + +typedef enum { +t_UNDEFINED=0, +#define _DO(NAME) t_##NAME, +DO_PROTOS() +#undef _DO +} proto_t; + +#define SYMBOL_PAYLOAD proto_t prototype; + +#include "object.c" + +#include + +enum jb_t { + j_return = 1, + j_break, + j_continue, + j_throw, +}; + +typedef struct jb_record +{ + sigjmp_buf jb; + oop result; + struct jb_record *next; +} jb_record; + +jb_record *jbs= NULL; + +#define jbRecPush() \ + struct jb_record jbrec; \ + jbrec.next= jbs; \ + jbs= &jbrec + +#define jbRecPop() \ + assert(jbs == &jbrec); \ + jbs= jbrec.next + +// this is the global scope +oop globals= 0; + +#define DO_SYMBOLS() \ + DO_PROTOS() _DO(__proto__) _DO(__name__) _DO(__default__) _DO(__arguments__) \ + _DO(name) _DO(body) _DO(param) _DO(key) _DO(value) _DO(condition) _DO(consequent) _DO(alternate) \ + _DO(lhs) _DO(rhs) _DO(scope) _DO(args) _DO(expression) _DO(labels) _DO(statements) _DO(initialise) \ + _DO(update) _DO(this) _DO(fixed) _DO(operator) _DO(map) _DO(func) \ + _DO(try) _DO(catch) _DO(finally) _DO(exception) \ + _DO(__line__) _DO(__file__) + +#define _DO(NAME) oop NAME##_symbol; +DO_SYMBOLS() +#undef _DO + +#define _DO(NAME) oop NAME##_proto; +DO_PROTOS() +#undef _DO + +int opt_g= 0; +int opt_v= 0; +oop mrAST= &_null; + +void printBacktrace(oop top); +void runtimeError(char *fmt, ...); + +typedef struct input_t +{ + oop name; + FILE *file; + struct input_t *next; + int lineNumber; +} input_t; + +input_t *inputStack= NULL; + +void inputStackPush(char *name) { + FILE *file = stdin; + if (NULL != name) { + file= fopen(name, "rb"); + if (NULL == file) { + perror(name); + exit(1); + } + } else { + name= ""; + } + input_t *input = malloc(sizeof(input_t)); + input->name= makeString(name); + input->lineNumber= 1; + input->file= file; + input->next= inputStack; + inputStack= input; + return; +} + +input_t *inputStackPop(void) { + assert(inputStack); + input_t *first= inputStack; + inputStack= first->next; + return first; +} + +int isFalse(oop obj) +{ + return obj == null || (isInteger(obj) && (0 == getInteger(obj))); +} + +int isTrue(oop obj) +{ + return !isFalse(obj); +} + +oop newObject(oop proto) +{ + oop map = makeMap(); + map_set(map, __proto___symbol, proto); + // set context (file and line) for runtime error msg + map_set(map, __line___symbol, makeInteger(inputStack->lineNumber)); + map_set(map, __file___symbol, inputStack->name); + return map; +} + +void printObjectName(oop object) +{ + assert(is(Map, object)); + oop name = map_get(object, __name___symbol); + if (name != null) { + println(name); + return; + } + + oop proto = map_get(object, __proto___symbol); + if (proto != null) { + printObjectName(proto); + } else { + fprintf(stderr, "\nThis map has no name\n"); + } +} + +// this always creates the key in "object" +oop newVariable(oop object, oop key, oop value) +{ + map_set(object, key, value); + return value; +} + +// this looks in object and everything in the __proto__ chain until it finds the key; +// if the key is not found and it is #__proto__ then the Map prototype is returned +oop getVariable(oop object, oop key) +{ + while (!map_hasKey(object, key)) { + object = map_get(object, __proto___symbol); + if (null == object) { + if (key == __proto___symbol) + return getVariable(globals, Map_symbol); + runtimeError("Undefined: %s", printString(key)); + } + } + return map_get(object, key); +} + +oop getMember(oop object, oop key) +{ + while (!map_hasKey(object, key)) { + object = map_get(object, __proto___symbol); + if (null == object) { + return null; + } + } + return map_get(object, key); +} + +// this follows the __proto__ chain until it finds the key, if it fails it behaves like newMember +oop setVariable(oop object, oop key, oop value) +{ + oop obj= object; + while (!map_hasKey(obj, key)) { + obj= map_get(obj, __proto___symbol); + if (null == obj) { + return map_set(object, key, value); + } + } + return map_set(obj, key, value); +} + +oop getProperty(oop object, oop key) +{ + if (!map_hasKey(object, key)) { + runtimeError("Undefined: .%s", printString(key)); + } + return map_get(object, key); +} + +oop newMap(oop value) +{ + oop map = newObject(Map_proto); + map_set(map, value_symbol, value); + return map; +} + +oop newDeclaration(oop name, oop exp) +{ + oop declaration = newObject(Declaration_proto); + map_set(declaration, lhs_symbol, name); + map_set(declaration, rhs_symbol, exp); + return declaration; +} + +oop newIf(oop cond, oop cons, oop alt) +{ + oop obj = newObject(If_proto); + map_set(obj, condition_symbol, cond); + map_set(obj, consequent_symbol, cons); + map_set(obj, alternate_symbol, alt); + return obj; +} + +oop newWhile(oop cond, oop body) +{ + oop obj = newObject(While_proto); + map_set(obj, condition_symbol, cond); + map_set(obj, body_symbol, body); + return obj; +} + +oop newDo(oop body, oop cond) +{ + oop obj= newObject(Do_proto); + map_set(obj, body_symbol, body); + map_set(obj, condition_symbol, cond); + return obj; +} + +oop newFor(oop init, oop cond, oop step, oop body) +{ + oop obj= newObject(For_proto); + map_set(obj, initialise_symbol, init); + map_set(obj, condition_symbol, cond); + map_set(obj, update_symbol, step); + map_set(obj, body_symbol, body); + return obj; +} + +oop newForIn(oop name, oop expression, oop body) +{ + oop obj= newObject(ForIn_proto); + map_set(obj, name_symbol, name); + map_set(obj, expression_symbol, expression); + map_set(obj, body_symbol, body); + return obj; +} + +oop newSwitch(oop expression, oop labels, oop statements) +{ + oop obj= newObject(Switch_proto); + map_set(obj, expression_symbol, expression); + map_set(obj, labels_symbol, labels); + map_set(obj, statements_symbol, statements); + return obj; +} + +// take char *name or oop already interned? +oop newSymbol(oop name) +{ + oop symbol = newObject(Symbol_proto); + // what is the less confusing, name or value? maybe another word like identifier? + map_set(symbol, value_symbol, name); + return symbol; +} + +oop newInteger(oop value) +{ + oop integer = newObject(Integer_proto); + map_set(integer, value_symbol, value); + return integer; +} + +oop newFloat(oop value) +{ + oop obj = newObject(Float_proto); + map_set(obj, value_symbol, value); + return obj; +} + +int digitValue(int c) +{ + if (c < '0') return -1; + if ('a' <= c && c <= 'z') c -= ('a' - 'A'); // tolower(c) + if ('9' < c && c < 'A') return -1; + if ('Z' < c) return -1; + if (c >= 'A') c -= ('A' - 10); else c -= '0'; + return c; +} + +int isradix(int r, int c) +{ + c= digitValue(c); + return 0 <= c && c < r; +} + +char *unescape(char *s) +{ + char *t= strdup(s); + int in= 0, out= 0, c= 0; + while (0 != (c= t[in++])) { + if ('\\' == c && 0 != (c= t[in])) { + ++in; + switch (c) { + case 'a': c= '\a'; break; + case 'b': c= '\b'; break; + case 'e': c= '\e'; break; + case 'f': c= '\f'; break; + case 'n': c= '\n'; break; + case 'r': c= '\r'; break; + case 't': c= '\t'; break; + case 'v': c= '\v'; break; + case '0'...'7': { + c -= '0'; + if (isradix(8, t[in])) c= c * 8 + t[in++] - '0'; + if (isradix(8, t[in])) c= c * 8 + t[in++] - '0'; + break; + } + case 'x': { + c= 0; + if (isradix(16, t[in])) c= c * 16 + digitValue(t[in++]); + if (isradix(16, t[in])) c= c * 16 + digitValue(t[in++]); + break; + } + case 'u': { + c= 0; + if (isradix(16, t[in])) c= c * 16 + digitValue(t[in++]); + if (isradix(16, t[in])) c= c * 16 + digitValue(t[in++]); + if (isradix(16, t[in])) c= c * 16 + digitValue(t[in++]); + if (isradix(16, t[in])) c= c * 16 + digitValue(t[in++]); + break; + } + } + } + t[out++]= c; + } + t[out]= 0; + return t; +} + +oop newString(oop str) +{ assert(is(String, str)); + oop string = newObject(String_proto); + map_set(string, value_symbol, str); + return string; +} + +oop newPreIncrement(oop rhs) +{ assert(is(Map, rhs)); + oop proto= map_get(rhs, __proto___symbol); assert(null != proto); + oop name= map_get(proto, __name___symbol); assert(null != name); + proto_t type= get(name, Symbol, prototype); + switch (type) { + case t_GetVariable: proto= PreIncVariable_proto; break; + case t_GetMember: proto= PreIncMember_proto; break; + case t_GetIndex: proto= PreIncIndex_proto; break; + default: { + printf("\nNon-lvalue after ++: "); + println(rhs); + exit(1); + } + } + map_set(rhs, __proto___symbol, proto); + return rhs; +} + +oop newPostIncrement(oop rhs) +{ assert(is(Map, rhs)); + oop proto= map_get(rhs, __proto___symbol); assert(null != proto); + oop name= map_get(proto, __name___symbol); assert(null != name); + proto_t type= get(name, Symbol, prototype); + switch (type) { + case t_GetVariable: proto= PostIncVariable_proto; break; + case t_GetMember: proto= PostIncMember_proto; break; + case t_GetIndex: proto= PostIncIndex_proto; break; + default: { + printf("\nNon-lvalue before ++: "); + println(rhs); + exit(1); + } + } + map_set(rhs, __proto___symbol, proto); + return rhs; +} + +oop newPreDecrement(oop rhs) +{ assert(is(Map, rhs)); + oop proto= map_get(rhs, __proto___symbol); assert(null != proto); + oop name= map_get(proto, __name___symbol); assert(null != name); + proto_t type= get(name, Symbol, prototype); + switch (type) { + case t_GetVariable: proto= PreDecVariable_proto; break; + case t_GetMember: proto= PreDecMember_proto; break; + case t_GetIndex: proto= PreDecIndex_proto; break; + default: { + printf("\nNon-lvalue after ++: "); + println(rhs); + exit(1); + } + } + map_set(rhs, __proto___symbol, proto); + return rhs; +} + +oop newPostDecrement(oop rhs) +{ assert(is(Map, rhs)); + oop proto= map_get(rhs, __proto___symbol); assert(null != proto); + oop name= map_get(proto, __name___symbol); assert(null != name); + proto_t type= get(name, Symbol, prototype); + switch (type) { + case t_GetVariable: proto= PostDecVariable_proto; break; + case t_GetMember: proto= PostDecMember_proto; break; + case t_GetIndex: proto= PostDecIndex_proto; break; + default: { + printf("\nNon-lvalue before ++: "); + println(rhs); + exit(1); + } + } + map_set(rhs, __proto___symbol, proto); + return rhs; +} + +oop newUnary(oop proto, oop rhs) +{ + oop obj = newObject(proto); + map_set(obj, rhs_symbol, rhs); + return obj; +} + +oop newBinary(oop proto, oop lhs, oop rhs) +{ + oop obj = newObject(proto); + map_set(obj, lhs_symbol, lhs); + map_set(obj, rhs_symbol, rhs); + return obj; +} + +oop newAssign(oop proto, oop lhs, oop operator, oop rhs) +{ + oop obj = newObject(proto); + map_set(obj, lhs_symbol, lhs); + map_set(obj, operator_symbol, operator); + map_set(obj, rhs_symbol, rhs); + return obj; +} + +oop newSetMap(oop proto, oop map, oop key, oop operator, oop value) +{ + oop obj = newObject(proto); + map_set(obj, map_symbol, map); + map_set(obj, key_symbol, key); + map_set(obj, operator_symbol, operator); + map_set(obj, value_symbol, value); + return obj; +} + +oop newGetMap(oop proto, oop map, oop key) +{ + oop obj = newObject(proto); + map_set(obj, map_symbol, map); + map_set(obj, key_symbol, key); + return obj; +} + +oop newGetVariable(oop name) +{ + oop id= newObject(GetVariable_proto); + map_set(id, key_symbol, name); + return id; +} + +oop newFunc(oop name, oop param, oop body, oop fixed) +{ + oop func = newObject(Func_proto); + map_set(func, name_symbol, name); + map_set(func, param_symbol, param); + map_set(func, body_symbol, body); + map_set(func, fixed_symbol, fixed); + return func; +} + +oop apply(oop scope, oop this, oop func, oop args, oop ast); + +oop getSyntaxId(int n, oop key) +{ + oop val = map_get(globals, key); + if (!is(Function, val)) return null; + oop fix = get(val, Function, fixed); + if (!isInteger(fix)) return null; + if (n != getInteger(fix)) return null; + return val; +} + +oop getSyntax(int n, oop func) +{ + if (map_get(func, __proto___symbol) != GetVariable_proto) return null; + oop key = map_get(func, key_symbol); + return getSyntaxId(n, key); +} + +oop newCall(oop func, oop args) +{ + oop call = newObject(Call_proto); + map_set(call, func_symbol, func); + map_set(call, args_symbol, args); + return call; +} + +oop newInvoke(oop this, oop name, oop args) +{ + oop obj = newObject(Invoke_proto); + map_set(obj, this_symbol, this); + map_set(obj, name_symbol, name); + map_set(obj, args_symbol, args); + return obj; +} + +oop newBlock(oop statements) +{ + oop obj = newObject(Block_proto); + map_set(obj, statements_symbol, statements); + return obj; +} + +oop newReturn(oop exp) +{ + oop obj = newObject(Return_proto); + map_set(obj, value_symbol, exp); + return obj; +} + +oop newBreak(void) +{ + oop obj = newObject(Break_proto); + return obj; +} + +oop newContinue(void) +{ + oop obj = newObject(Continue_proto); + return obj; +} + +oop newTry(oop try, oop exception, oop catch, oop finally) +{ + oop obj = newObject(Try_proto); + map_set(obj, try_symbol, try); + map_set(obj, exception_symbol, exception); + map_set(obj, catch_symbol, catch); + map_set(obj, finally_symbol, finally); + return obj; +} + +#define YY_INPUT(buf, result, max_size) \ +{ \ + int yyc= feof(inputStack->file) ? EOF : getc(inputStack->file); \ + result= (EOF == yyc) ? 0 : (*(buf)= yyc, 1); \ +} + +#define YYSTYPE oop + +YYSTYPE yylval; + +int errorLine= 1; + +void syntaxError(char *text) +{ + fprintf(stderr, "\nSyntax error in %s near line %i:\n%s\n", get(inputStack->name, String, value), errorLine, text); + exit(1); +} + +oop eval(oop scope, oop ast); + +struct _yycontext; + +int yyparsefrom(int (*yystart)(struct _yycontext *yy)); + +%} + +meta_start = - ( META_IMPORT s:META_STRING ";" { yylval = null; inputStackPush(get(s, String, value)) } + | s:meta_stmt { yylval = s } + | !. { yylval = 0 } + | meta_error + ) + +meta_error = { errorLine= inputStack->lineNumber } + eol* < (!eol .)* eol* (!eol .)* > { syntaxError(yytext) } + +meta_stmt = s:meta_block { $$ = s } + | META_SEMICOLON { $$ = null } + | l:META_IDENT p:meta_paramList e:meta_block { $$ = newFunc(l, p, e, null) } + | META_IF META_LPAREN c:meta_exp META_RPAREN t:meta_stmt META_ELSE f:meta_stmt { $$ = newIf(c, t, f ) } + | META_IF META_LPAREN c:meta_exp META_RPAREN t:meta_stmt { $$ = newIf(c, t, null) } + | META_WHILE META_LPAREN c:meta_exp META_RPAREN s:meta_stmt { $$ = newWhile(c, s) } + | META_DO s:meta_stmt META_WHILE META_LPAREN c:meta_exp META_RPAREN { $$ = newDo(s, c) } + | META_FOR META_LPAREN i:meta_ident META_IN e:meta_exp META_RPAREN s:meta_stmt { $$ = newForIn(i, e, s) } + | META_FOR META_LPAREN i:meta_stmt c:meta_stmt u:meta_exp META_RPAREN s:meta_stmt { $$ = newFor(i, c, u, s) } + | s:meta_switch { $$ = s } + | META_RETURN e:meta_exp { $$ = newReturn(e) } + | META_RETURN { $$ = newReturn(null) } + | META_BREAK { $$ = newBreak() } + | META_CONTINUE { $$ = newContinue() } + | META_THROW e:meta_exp { $$ = newUnary(Throw_proto, e) } + | t:meta_try { $$ = t } + | e:meta_exp META_SEMICOLON { $$ = e } + +meta_block = META_LCB m:meta_makeMap + ( s:meta_stmt { map_append(m, s) } + ) * + ( s:meta_exp { map_append(m, s) } + ) ? + META_RCB { $$ = newBlock(m) } + +meta_exp = META_VAR l:meta_ident META_ASSIGN e:meta_exp { $$ = newDeclaration(l, e) } +# | META_SYNTAX l:META_IDENT p:meta_paramList q:META_IDENT e:meta_block { $$ = (map_append(p, q), newFunc(l, p, e, makeInteger(2))) } +# | META_SYNTAX p:meta_paramList q:META_IDENT e:meta_block { $$ = (map_append(p, q), newFunc(null, p, e, makeInteger(2))) } +# | META_SYNTAX l:META_IDENT p:meta_paramList e:meta_block { $$ = newFunc(l, p, e, makeInteger(1)) } +# | META_SYNTAX p:meta_paramList e:meta_block { $$ = newFunc(null, p, e, makeInteger(1)) } + | l:META_IDENT o:meta_assignOp e:meta_exp { $$ = newAssign(Assign_proto, l, o, e) } + | l:meta_postfix META_DOT i:META_IDENT o:meta_assignOp e:meta_exp { $$ = newSetMap(SetMember_proto, l, i, o, e) } + | l:meta_postfix META_LBRAC i:meta_exp META_RBRAC o:meta_assignOp e:meta_exp { $$ = newSetMap(SetIndex_proto, l, i, o, e) } + | l:meta_syntax2 a:meta_argumentList s:meta_block { $$ = (map_append(a, s), apply(globals, globals, l, a, a)) } + | c:meta_cond { $$ = c } + +meta_ident = l:META_IDENT { $$ = l } +# | META_AT n:meta_prefix { $$ = newUnary(Unquote_proto, n) } + +meta_syntax2 = < [a-zA-Z_][a-zA-Z0-9_]* > + &{ null != getSyntaxId(2, intern(yytext)) } - { $$ = getSyntaxId(2, intern(yytext)) } + +meta_try = META_TRY t:meta_stmt i:meta_null c:meta_null f:meta_null + ( META_CATCH META_LPAREN i:META_IDENT META_RPAREN c:meta_stmt ) ? + ( META_FINALLY f:meta_stmt ) ? { $$ = newTry(t, i, c, f) } + +meta_null = { $$ = null } + +meta_assignOp = META_ASSIGN { $$= null } + | META_ASSIGNADD { $$= Add_symbol } + | META_ASSIGNSUB { $$= Sub_symbol } + | META_ASSIGNMUL { $$= Mul_symbol } + | META_ASSIGNDIV { $$= Div_symbol } + | META_ASSIGNMOD { $$= Mod_symbol } + | META_ASSIGNBITOR { $$= Bitor_symbol } + | META_ASSIGNBITXOR { $$= Bitxor_symbol } + | META_ASSIGNBITAND { $$= Bitand_symbol } + | META_ASSIGNSHLEFT { $$= Shleft_symbol } + | META_ASSIGNSHRIGHT { $$= Shright_symbol } + +meta_switch = META_SWITCH META_LPAREN e:meta_exp META_RPAREN + META_LCB statements:meta_makeMap labels:meta_makeMap + ( META_CASE l:meta_exp META_COLON { map_set(labels, eval(globals, l), makeInteger(map_size(statements))) } + | META_DEFAULT META_COLON { map_set(labels, __default___symbol, makeInteger(map_size(statements))) } + | s:meta_stmt { map_append(statements, s) } + )* + META_RCB { $$= newSwitch(e, labels, statements) } + +meta_cond = c:meta_logor META_QUERY t:meta_exp META_COLON f:meta_cond { $$ = newIf(c, t, f) } + | meta_logor + +meta_logor = l:meta_logand + ( META_LOGOR r:meta_logand { l = newBinary(Logor_proto, l, r) } + )* { $$ = l } + +meta_logand = l:meta_bitor + ( META_LOGAND r:meta_bitor { l = newBinary(Logand_proto, l, r) } + )* { $$ = l } + +meta_bitor = l:meta_bitxor + ( META_BITOR r:meta_bitxor { l = newBinary(Bitor_proto, l, r) } + )* { $$ = l } + +meta_bitxor = l:meta_bitand + ( META_BITXOR r:meta_bitand { l = newBinary(Bitxor_proto, l, r) } + )* { $$ = l } + +meta_bitand = l:meta_eq + ( META_BITAND r:meta_eq { l = newBinary(Bitand_proto, l, r) } + )* { $$ = l } + +meta_eq = l:meta_ineq + ( META_EQUAL r:meta_ineq { l = newBinary(Equal_proto, l, r) } + | META_NOTEQ r:meta_ineq { l = newBinary(Noteq_proto, l, r) } + )* { $$ = l } + +meta_ineq = l:meta_shift + ( META_LESS r:meta_shift { l = newBinary(Less_proto, l, r) } + | META_LESSEQ r:meta_shift { l = newBinary(Lesseq_proto, l, r) } + | META_GREATEREQ r:meta_shift { l = newBinary(Greatereq_proto, l, r) } + | META_GREATER r:meta_shift { l = newBinary(Greater_proto, l, r) } + )* { $$ = l } + +meta_shift = l:meta_sum + ( META_SHLEFT r:meta_sum { l = newBinary(Shleft_proto, l, r) } + | META_SHRIGHT r:meta_sum { l = newBinary(Shright_proto, l, r) } + )* { $$ = l } + +meta_sum = l:meta_prod + ( META_PLUS r:meta_prod { l = newBinary(Add_proto, l, r) } + | META_MINUS r:meta_prod { l = newBinary(Sub_proto, l, r) } + )* { $$ = l } + +meta_prod = l:meta_prefix + ( META_MULTI r:meta_prefix { l = newBinary(Mul_proto, l, r) } + | META_DIVIDE r:meta_prefix { l = newBinary(Div_proto, l, r) } + | META_MODULO r:meta_prefix { l = newBinary(Mod_proto, l, r) } + )* { $$ = l } + +meta_prefix = META_PLUS n:meta_prefix { $$= n } + | META_NEGATE n:meta_prefix { $$= newUnary(Neg_proto, n) } + | META_TILDE n:meta_prefix { $$= newUnary(Com_proto, n) } + | META_PLING n:meta_prefix { $$= newUnary(Not_proto, n) } + | META_PLUSPLUS n:meta_prefix { $$= newPreIncrement(n) } + | META_MINUSMINUS n:meta_prefix { $$= newPreDecrement(n) } +# | META_BACKTICK n:meta_prefix { $$ = newUnary(Quasiquote_proto, n) } +# | META_AT n:meta_prefix { $$ = newUnary(Unquote_proto, n) } + | n:meta_postfix { $$= n } + +meta_postfix = i:meta_value ( META_DOT s:META_IDENT a:meta_argumentList { i = newInvoke(i, s, a) } + | META_DOT s:META_IDENT !meta_assignOp { i = newGetMap(GetMember_proto, i, s) } + | META_LBRAC p:meta_exp META_RBRAC !meta_assignOp { i = newGetMap(GetIndex_proto, i, p) } + | a:meta_argumentList { i = (null != getSyntax(1, i)) ? apply(globals, globals, getSyntax(1, i), a, i) : newCall(i, a) } + | META_PLUSPLUS { i = newPostIncrement(i) } + | META_MINUSMINUS { i = newPostDecrement(i) } + ) * { $$ = i } + +meta_paramList = META_LPAREN m:meta_makeMap + ( i:META_IDENT { map_append(m, i) } + ( META_COMMA i:META_IDENT { map_append(m, i) } + ) * + ) ? + META_RPAREN { $$ = m } + +meta_argumentList = META_LPAREN m:meta_makeMap + ( e:meta_exp { map_append(m, e) } + ( META_COMMA e:meta_exp { map_append(m, e) } + ) * + ) ? + META_RPAREN { $$ = m } + +meta_value = n:META_FLOAT { $$ = newFloat(n) } + | n:meta_integer { $$ = newInteger(n) } + | s:meta_string { $$ = newString(s) } + | s:meta_symbol { $$ = s } + | m:meta_map { $$ = newMap(m) } + | META_NULL { $$ = null } + | i:META_IDENT { $$ = newGetVariable(i) } + | p:meta_paramList e:meta_block { $$ = newFunc(null, p, e, null) } + | META_LPAREN ( i:meta_block | i:meta_exp ) META_RPAREN { $$ = i } + +meta_string = s:META_STRING - { $$ = s } + +META_STRING = META_DQUOTE < (!META_DQUOTE meta_char)* > META_DQUOTE { $$ = makeString(unescape(yytext)) } + +meta_char = '\\' . | . + +meta_symbol = META_HASH ( i:META_IDENT { $$ = newSymbol(i) } + | i:meta_string { $$ = newSymbol(intern(get(i, String, value))) } + ) + +meta_map = META_LCB m:meta_makeMap + ( k:meta_key META_COLON v:meta_exp { map_set(m, k, v) } + ( META_COMMA k:meta_key META_COLON v:meta_exp { map_set(m, k, v) } + ) * + ) ? + META_RCB { $$ = m } + | META_LBRAC m:meta_makeMap + ( v:meta_exp { map_append(m, v) } + ( META_COMMA v:meta_exp { map_append(m, v) } + ) * + ) ? + META_RBRAC { $$ = m } + +meta_makeMap = { $$ = makeMap() } + +meta_key = META_IDENT | meta_integer + +- = (blank | comment)* + +blank = space | eol +space = [ \t] +eol = ( "\n""\r"* + | "\r""\n"* + ) { inputStack->lineNumber++ } + +comment = "//" ( ![\n\r] . )* + | "/*" ( !"*/" (eol | .) )* "*/" + +meta_keyword = META_SWITCH | META_CASE | META_DEFAULT | META_DO | META_FOR | META_IN | META_WHILE | META_IF | META_ELSE | META_NULL | META_RETURN | META_BREAK | META_CONTINUE + | META_THROW | META_TRY | META_CATCH | META_FINALLY +# | META_SYNTAX + +META_IDENT = !meta_keyword < [a-zA-Z_][a-zA-Z0-9_]* > - { $$ = intern(yytext) } + +meta_integer = i:META_INTEGER { $$ = i } + | '-' i:meta_integer { $$ = makeInteger(-getInteger(i)) } + +META_INTEGER = '0b' < [01]+ > - { $$ = makeInteger(strtol(yytext, 0, 2)) } + | '0x' < [0-9a-fA-F]+ > - { $$ = makeInteger(strtol(yytext, 0, 16)) } + | '0' < [0-7]+ > - { $$ = makeInteger(strtol(yytext, 0, 8)) } + | < [0-9]+ > - { $$ = makeInteger(strtol(yytext, 0, 10)) } + | META_SQUOTE < (!META_SQUOTE meta_char) > META_SQUOTE - { $$ = makeInteger(unescape(yytext)[0]) } + +META_FLOAT = < [-+]* [0-9]+ '.' [0-9]* ('e'[-+]*[0-9]+)? > - { $$ = makeFloat(strtold(yytext, 0)) } + | < [-+]* [0-9]* '.' [0-9]+ ('e'[-+]*[0-9]+)? > - { $$ = makeFloat(strtold(yytext, 0)) } + | < [-+]* [0-9]+ ('e'[-+]*[0-9]+) > - { $$ = makeFloat(strtold(yytext, 0)) } + +#META_FUN = 'fun' ![a-zA-Z0-9_] - +#META_SYNTAX = 'syntax' ![a-zA-Z0-9_] - +META_VAR = 'var' ![a-zA-Z0-9_] - +META_SWITCH = 'switch' ![a-zA-Z0-9_] - +META_CASE = 'case' ![a-zA-Z0-9_] - +META_DEFAULT = 'default' ![a-zA-Z0-9_] - +META_DO = 'do' ![a-zA-Z0-9_] - +META_FOR = 'for' ![a-zA-Z0-9_] - +META_IN = 'in' ![a-zA-Z0-9_] - +META_WHILE = 'while' ![a-zA-Z0-9_] - +META_IF = 'if' ![a-zA-Z0-9_] - +META_ELSE = 'else' ![a-zA-Z0-9_] - +META_NULL = 'null' ![a-zA-Z0-9_] - +META_RETURN = 'return' ![a-zA-Z0-9_] - +META_BREAK = 'break' ![a-zA-Z0-9_] - +META_CONTINUE = 'continue' ![a-zA-Z0-9_] - +META_THROW = 'throw' ![a-zA-Z0-9_] - +META_TRY = 'try' ![a-zA-Z0-9_] - +META_CATCH = 'catch' ![a-zA-Z0-9_] - +META_FINALLY = 'finally' ![a-zA-Z0-9_] - +META_IMPORT = 'import' ![a-zA-Z0-9_] - +META_HASH = '#' - +META_LOGOR = '||' - +META_LOGAND = '&&' - +META_BITOR = '|' ![|=] - +META_BITXOR = '^' ![=] - +META_BITAND = '&' ![&=] - +META_EQUAL = '==' - +META_NOTEQ = '!=' - +META_LESS = '<' ![<=] - +META_LESSEQ = '<=' - +META_GREATEREQ = '>=' - +META_GREATER = '>' ![>=] - +META_SHLEFT = '<<' ![=] - +META_SHRIGHT = '>>' ![=] - +META_PLUS = '+' ![+=] - +META_MINUS = '-' ![-=] - +META_NEGATE = '-' ![-=0-9.] - +META_PLUSPLUS = '++' - +META_MINUSMINUS = '--' - +META_TILDE = '~' - +META_PLING = '!' ![=] - +META_MULTI = '*' ![=] - +META_DIVIDE = '/' ![/=] - +META_MODULO = '%' ![=] - +META_ASSIGN = '=' ![=] - +META_ASSIGNADD = '+=' - +META_ASSIGNSUB = '-=' - +META_ASSIGNMUL = '*=' - +META_ASSIGNDIV = '/=' - +META_ASSIGNMOD = '%=' - +META_ASSIGNBITOR = '|=' - +META_ASSIGNBITXOR = '^=' - +META_ASSIGNBITAND = '&=' - +META_ASSIGNSHLEFT = '<<=' - +META_ASSIGNSHRIGHT = '>>=' - +META_QUERY = '?' - +META_COLON = ':' - +META_SEMICOLON = ';' - +META_COMMA = ',' - +META_DOT = '.' - +#META_BACKTICK = '`' - +#META_AT = '@' - +META_LCB = '{' - +META_RCB = '}' - +META_LBRAC = '[' - +META_RBRAC = ']' - +META_LPAREN = '(' - +META_RPAREN = ')' - +META_DQUOTE = '"' +META_SQUOTE = "'" + +%% +; + + +oop map_zip(oop map, oop keys, oop values) +{ + assert(is(Map, map)); + assert(is(Map, keys)); + assert(is(Map, values)); + size_t sk= map_size(keys), sv= map_size(values); + if (sk < sv) sk= sv; + for (size_t i= 0; i < sk; ++i) { + oop key = i < sk && map_hasIntegerKey(keys, i) ? get(keys, Map, elements)[i].value : makeInteger(i); + oop value = i < sv && map_hasIntegerKey(values, i) ? get(values, Map, elements)[i].value : null; + map_set(map, key, value); + } + return map; +} + +oop clone(oop obj) +{ + switch(getType(obj)) { + case Undefined: + case Integer: + case Float: + case Function: + case Symbol: + return obj; + case String: + return makeString(get(obj, String, value)); + case Map: { + struct Pair *elements= malloc(sizeof(struct Pair) * get(obj, Map, capacity)); + memcpy(elements, get(obj, Map, elements), sizeof(struct Pair) * get(obj, Map, capacity)); + oop map= malloc(sizeof(*obj)); + memcpy(map, obj, sizeof(*obj)); + set(map, Map, elements, elements); + return map; + } + } + return obj; +} + +struct Call +{ + oop ast, function; +}; + +DECLARE_BUFFER(struct Call, CallArray); + +CallArray backtrace= BUFFER_INITIALISER; + +struct Call CallArray_pop(CallArray *oa) +{ assert(oa->position > 0); + return oa->contents[--oa->position]; +} + +void trace(oop ast, oop func) +{ + CallArray_append(&backtrace, (struct Call){ ast, func }); +} + +void untrace(oop ast) +{ + struct Call top= CallArray_pop(&backtrace); assert(top.ast == ast); +} + +void printLocation(oop ast) +{ + fflush(stdout); + if (!is(Map, ast)) return; + char *fileName = get (map_get(ast, __file___symbol), String, value); + int lineNumber = getInteger(map_get(ast, __line___symbol) ); + fprintf(stderr, "%s:%i", fileName, lineNumber); +} + +void printlnLocation(oop ast) +{ + fflush(stdout); + if (!is(Map, ast)) return; + printLocation(ast); + fprintf(stderr, "\n"); +} + +void printBacktrace(oop top) +{ + fflush(stdout); + printLocation(top); + while (CallArray_position(&backtrace) > 0) { + struct Call call= CallArray_pop(&backtrace); + if (is(Map, call.ast) && Call_proto == map_get(call.ast, __proto___symbol)) { + oop name= get(call.function, Function, name); + if (null != name) { + printf(" in "); + if (get(call.function, Function, primitive)) printf("primitive "); + else printf("function "); + println(get(call.function, Function, name)); + } + } + else { + printf("\n"); + } + printLocation(call.ast); + } + printf("\n"); +} + +void runtimeError(char *fmt, ...) +{ + fflush(stdout); + va_list ap; + va_start(ap, fmt); + fprintf(stderr, "\n"); + vfprintf(stderr, fmt, ap); + fprintf(stderr, "\n"); + va_end(ap); + printBacktrace(mrAST); + exit(1); +} + +#define TYPESIG(L, R) L*NTYPES+R +#define CASE(L, R) case TYPESIG(L, R) + +oop addOperation(oop lhs, oop rhs) +{ + switch (TYPESIG(getType(lhs), getType(rhs))) { + CASE(Integer, Integer): return makeInteger(getInteger(lhs) + getInteger(rhs)); + CASE(Integer, Float ): return makeFloat(getInteger(lhs) + get(rhs, Float, _value)); + CASE(Float , Integer): return makeFloat(get(lhs, Float, _value) + getInteger(rhs)); + CASE(Float , Float ): return makeFloat(get(lhs, Float, _value) + get(rhs, Float, _value)); + CASE(String , String ): return string_concat(lhs, rhs); + } + runtimeError("addition between two incompatible types"); + return NULL; // to prevent: control may reach end of non-void function +} + +oop subOperation(oop lhs, oop rhs) +{ + switch (TYPESIG(getType(lhs), getType(rhs))) { + CASE(Integer, Integer): return makeInteger(getInteger(lhs) - getInteger(rhs)); + CASE(Integer, Float ): return makeFloat(getInteger(lhs) - get(rhs, Float, _value)); + CASE(Float , Integer): return makeFloat(get(lhs, Float, _value) - getInteger(rhs)); + CASE(Float , Float ): return makeFloat(get(lhs, Float, _value) - get(rhs, Float, _value)); + } + runtimeError("substraction between two incompatible types"); + return NULL; // to prevent: control may reach end of non-void function +} + +oop mulOperation(oop lhs, oop rhs) +{ + switch (TYPESIG(getType(lhs), getType(rhs))) { + CASE(Integer, Integer): return makeInteger(getInteger(lhs) * getInteger(rhs)); + CASE(Integer, Float ): return makeFloat(getInteger(lhs) * get(rhs, Float, _value)); + CASE(Float , Integer): return makeFloat(get(lhs, Float, _value) * getInteger(rhs)); + CASE(Float , Float ): return makeFloat(get(lhs, Float, _value) * get(rhs, Float, _value)); + CASE(String , Integer): return string_mul(lhs, rhs); + CASE(Integer, String ): return string_mul(rhs, lhs); + } + runtimeError("multiplication between two incompatible types"); + return NULL; // to prevent: control may reach end of non-void function +} + +oop divOperation(oop lhs, oop rhs) +{ + switch (TYPESIG(getType(lhs), getType(rhs))) { + CASE(Integer, Integer): return makeInteger(getInteger(lhs) / getInteger(rhs)); + CASE(Integer, Float ): return makeFloat(getInteger(lhs) / get(rhs, Float, _value)); + CASE(Float , Integer): return makeFloat(get(lhs, Float, _value) / getInteger(rhs)); + CASE(Float , Float ): return makeFloat(get(lhs, Float, _value) / get(rhs, Float, _value)); + } + runtimeError("division between two incompatible types"); + return NULL; // to prevent: control may reach end of non-void function +} + +oop modOperation(oop lhs, oop rhs) +{ + switch (TYPESIG(getType(lhs), getType(rhs))) { + CASE(Integer, Integer): return makeInteger(getInteger(lhs) % getInteger(rhs)); + CASE(Float , Float ): return makeFloat(fmodl(get(lhs, Float, _value), get(rhs, Float, _value))); + } + runtimeError("modulo between two incompatible types"); + return NULL; // to prevent: control may reach end of non-void function +} + +#undef TYPESIG +#undef CASE + +#if 0 + +oop expandUnquotes(oop scope, oop obj) +{ + obj = clone(obj); + if (!is(Map, obj)) { + return obj; + } + if (map_get(obj, __proto___symbol) == Unquote_proto) { + return eval(scope, map_get(obj, rhs_symbol)); + } + for (size_t i= 0; i < map_size(obj); ++i) { + struct Pair *pair= &get(obj, Map, elements)[i]; + if (__proto___symbol != pair->key) { + pair->value= expandUnquotes(scope, pair->value); + } + } + return obj; +} + +#endif + +oop applyOperator(oop op, oop lhs, oop rhs) +{ + if (null != op) { assert(is(Symbol, op)); + switch (get(op, Symbol, prototype)) { + case t_Add: return addOperation(lhs, rhs); + case t_Sub: return subOperation(lhs, rhs); + case t_Mul: return mulOperation(lhs, rhs); + case t_Div: return divOperation(lhs, rhs); + case t_Mod: return modOperation(lhs, rhs); + case t_Bitor: return makeInteger(getInteger(lhs) | getInteger(rhs)); + case t_Bitxor: return makeInteger(getInteger(lhs) ^ getInteger(rhs)); + case t_Bitand: return makeInteger(getInteger(lhs) & getInteger(rhs)); + case t_Shleft: return makeInteger(getInteger(lhs) << getInteger(rhs)); + case t_Shright: return makeInteger(getInteger(lhs) >> getInteger(rhs)); + default: { + fprintf(stderr, "\nIllegal operator %i\n", get(op, Symbol, prototype)); + exit(1); + } + } + } + return rhs; +} + +oop freeScopes= 0; // pool of free scopes + +oop fixScope(oop scope) // prevent this scope and its parents from being recycled +{ assert(is(Map, scope)); + oop tmp= scope; + while (is(Map, tmp) && (0 == (tmp->Map.flags & MAP_ENCLOSED))) { + tmp->Map.flags |= MAP_ENCLOSED; + tmp= map_get(tmp, __proto___symbol); + } + return scope; +} + +oop newScope(oop parent) +{ + if (0 == freeScopes) freeScopes= makeMap(); + oop scope= freeScopes; assert(is(Map, scope)); + freeScopes= freeScopes->Map.pool; + scope->Map.size= 0; + map_set(scope, __proto___symbol, parent); + return scope; +} + +void delScope(oop scope) +{ assert(is(Map, scope)); + if (scope->Map.flags & MAP_ENCLOSED) { + printf("IGNORE %p\n", scope); + return; + } + scope->Map.pool= freeScopes; + freeScopes= scope; +} + +oop evalArgs(oop scope, oop args); + +oop apply(oop scope, oop this, oop func, oop args, oop ast) +{ + assert(is(Function, func)); + + if (NULL != get(func, Function, primitive)) { + return get(func, Function, primitive)(scope, args); + } + + oop param = get(func, Function, param); + oop localScope = newScope(get(func, Function, parentScope)); + map_zip(localScope, param, args); + map_set(localScope, this_symbol, this); + map_set(localScope, __arguments___symbol, args); + jbRecPush(); + trace(ast, func); + int jbt = sigsetjmp(jbs->jb, 0); + switch (jbt) { + case j_return: { + untrace(ast); + delScope(localScope); + oop result = jbs->result; + jbRecPop(); + return result; + } + case j_break: { + delScope(localScope); + runtimeError("break outside of a loop or switch"); + } + case j_continue: { + delScope(localScope); + runtimeError("continue outside of a loop"); + } + case j_throw: { + untrace(ast); + delScope(localScope); + oop res= jbs->result; + jbRecPop(); + jbs->result= res; + siglongjmp(jbs->jb, j_throw); + } + } + oop result= eval(localScope, get(func, Function, body)); + untrace(ast); + delScope(localScope); + jbRecPop(); + return result; +} + +oop eval(oop scope, oop ast) +{ + if (opt_v > 3) { + printf("EVAL: "); + println(ast); + } + + switch(getType(ast)) { + case Undefined: + case Integer: + case Float: + case String: + case Function: + return ast; + case Symbol: + return getVariable(scope, ast); + case Map: + break; + } + + assert(is(Map, ast)); + + mrAST= ast; + + oop proto = map_get(ast, __proto___symbol); + if (proto == null) { + return ast; + } + // proto_number is the enum version of the proto symbol + proto_t proto_number = get(map_get(proto, __name___symbol), Symbol, prototype); + switch (proto_number) { + case t_UNDEFINED: { + assert(0); + return 0; + } + case t_Map: { + oop map= clone(map_get(ast, value_symbol)); + for (size_t i= 0; i < map_size(map); ++i) { + struct Pair *pair= &get(map, Map, elements)[i]; + pair->value= eval(scope, pair->value); + } + return map; + } +#if 0 + case t_Quasiquote: { + oop obj = map_get(ast, rhs_symbol); + return expandUnquotes(scope, obj); + } + case t_Unquote: { + runtimeError("@ outside of `"); + } +#endif + case t_Declaration: { + oop lhs = map_get(ast, lhs_symbol); + oop rhs = eval(scope, map_get(ast, rhs_symbol)); + return newVariable(scope, lhs, rhs); + } + case t_If: { + oop condition = map_get(ast, condition_symbol ); + oop consequent = map_get(ast, consequent_symbol); + oop alternate = map_get(ast, alternate_symbol ); + return eval(scope, isTrue(eval(scope, condition)) ? consequent : alternate); + } + case t_While: { + oop condition = map_get(ast, condition_symbol ); + oop body = map_get(ast, body_symbol); + oop result = null; + + jbRecPush(); + int jbt = sigsetjmp(jbs->jb, 0); + switch (jbt) { + case j_return: + case j_throw: { + oop result = jbs->result; + jbRecPop(); + assert(jbs); + jbs->result = result; + siglongjmp(jbs->jb, jbt); + assert(0); + } + case j_break: { + jbRecPop(); + return null; + } + case j_continue: { + break; + } + } + + while (isTrue(eval(scope, condition))) result= eval(scope, body); + jbRecPop(); + return result; + } + case t_Do: { + oop body = map_get(ast, body_symbol); + oop condition = map_get(ast, condition_symbol ); + oop result = null; + + jbRecPush(); + int jbt = sigsetjmp(jbs->jb, 0); + switch (jbt) { + case j_return: + case j_throw: { + oop result = jbs->result; + jbRecPop(); + assert(jbs); + jbs->result = result; + siglongjmp(jbs->jb, jbt); + assert(0); + } + case j_break: { + jbRecPop(); + return null; + } + case j_continue: { + goto restart_do; + } + } + + do { + result= eval(scope, body); + restart_do:; + } while (isTrue(eval(scope, condition))); + jbRecPop(); + return result; + } + case t_For: { + oop initialise = map_get(ast, initialise_symbol ); + oop condition = map_get(ast, condition_symbol ); + oop update = map_get(ast, update_symbol ); + oop body = map_get(ast, body_symbol); + oop result = null; + oop localScope = newScope(scope); + + jbRecPush(); + int jbt = sigsetjmp(jbs->jb, 0); + switch (jbt) { + case j_return: + case j_throw: { + delScope(localScope); + oop result = jbs->result; + jbRecPop(); + assert(jbs); + jbs->result = result; + siglongjmp(jbs->jb, jbt); + assert(0); + } + case j_break: { + delScope(localScope); + jbRecPop(); + return result; + } + case j_continue: { + goto restart_for; + } + } + + for (eval(localScope, initialise); isTrue(eval(localScope, condition)); eval(localScope, update)) { + result= eval(localScope, body); + restart_for:; + } + delScope(localScope); + jbRecPop(); + return result; + } + case t_ForIn: { + oop expr = eval(scope, map_get(ast, expression_symbol)); if (!is(Map, expr)) return null; + oop name = map_get(ast, name_symbol ) ; + oop body = map_get(ast, body_symbol ) ; + oop result = null; + oop localScope = newScope(scope); + jbRecPush(); + int jbt = sigsetjmp(jbs->jb, 0); + switch (jbt) { + case j_return: + case j_throw: { + delScope(localScope); + oop result = jbs->result; + jbRecPop(); + assert(jbs); + jbs->result = result; + siglongjmp(jbs->jb, jbt); + assert(0); + } + case j_break: { + delScope(localScope); + jbRecPop(); + return result; + } + case j_continue: { + goto restart_forin; + } + } + for (size_t i= 0; i < map_size(expr); ++i) { + map_set(localScope, name, get(expr, Map, elements)[i].key); + result= eval(localScope, body); + restart_forin:; + } + delScope(localScope); + jbRecPop(); + return result; + } + case t_Switch: { + oop expression = map_get(ast, expression_symbol ); + oop labels = map_get(ast, labels_symbol ); + oop statements = map_get(ast, statements_symbol ); + oop result = eval(scope, expression); + oop label = map_get(labels, result); + if (null == label) label= map_get(labels, __default___symbol); + if (null == label) return result; + assert(isInteger(label)); + int limit= map_size(statements); + + jbRecPush(); + int jbt = sigsetjmp(jbs->jb, 0); + switch (jbt) { + case j_return: + case j_throw: { + oop result = jbs->result; + jbRecPop(); + assert(jbs); + jbs->result = result; + siglongjmp(jbs->jb, jbt); + assert(0); + } + case j_break: { + jbRecPop(); + return null; + } + case j_continue: { + jbRecPop(); + assert(jbs); + siglongjmp(jbs->jb, j_continue); + assert(0); + } + } + + for (int i= getInteger(label); i < limit; ++i) { + assert(map_hasIntegerKey(statements, i)); + result= eval(scope, get(statements, Map, elements)[i].value); + } + jbRecPop(); + return result; + } + case t_Assign: { + oop lhs = map_get(ast, lhs_symbol); + oop op = map_get(ast, operator_symbol); + oop rhs = eval(scope, map_get(ast, rhs_symbol)); + if (null != op) rhs= applyOperator(op, getVariable(scope, lhs), rhs); + setVariable(scope, lhs, rhs); + if (is(Function, rhs) && null == get(rhs, Function, name)) { + set(rhs, Function, name, lhs); + } + return rhs; + } + case t_Func: { + oop name = map_get(ast, name_symbol); + oop param = map_get(ast, param_symbol); + oop body = map_get(ast, body_symbol); + oop fixed = map_get(ast, fixed_symbol); + oop func = makeFunction(NULL, name, param, body, fixScope(scope), fixed); + if (opt_v > 4) { + printf("funcscope: "); + println(scope); + printf("globalScope: "); + println(scope); + } + if (name != null) newVariable(scope, name, func); + return func; + } + case t_Call: { + oop func = eval(scope, map_get(ast, func_symbol)); + if (!is(Function, func)) { + printf("\ncannot call %s\n", printString(func)); + printBacktrace(ast); + exit(1); + } + oop args = map_get(ast, args_symbol); + if (isFalse(get(func, Function, fixed))) { + args = evalArgs(scope, args); + } + return apply(scope, globals, func, args, ast); + } + case t_Invoke: { + oop this = eval(scope, map_get(ast, this_symbol)); + oop func = map_get(ast, name_symbol); assert(is(Symbol, func)); + func = getVariable(this, func); + if (!is(Function, func)) { + printf("\ncannot invoke %s\n", printString(func)); + printBacktrace(ast); + exit(1); + } + oop args = map_get(ast, args_symbol); + if (isFalse(get(func, Function, fixed))) { + args = evalArgs(scope, args); + } + return apply(scope, this, func, args, ast); + } + + case t_Return: { + assert(jbs); + jbs->result = eval(scope, map_get(ast, value_symbol)); + siglongjmp(jbs->jb, j_return); + } + case t_Break: { + assert(jbs); + siglongjmp(jbs->jb, j_break); + } + case t_Continue: { + assert(jbs); + siglongjmp(jbs->jb, j_continue); + } + case t_Throw: { + assert(jbs); + jbs->result = eval(scope, map_get(ast, rhs_symbol)); + siglongjmp(jbs->jb, j_throw); + } + case t_Try: { + oop try = map_get(ast, try_symbol); + oop exception = map_get(ast, exception_symbol); + oop catch = map_get(ast, catch_symbol); + oop finally = map_get(ast, finally_symbol); + + jbRecPush(); + int jbt = sigsetjmp(jbs->jb, 0); + if (0 == jbt) { + oop res = eval(scope, try); + jbRecPop(); + eval(scope, finally); + return res; + } + oop res= jbs->result; + jbRecPop(); + // something happend in the try block + if (j_throw == jbt) { + assert(jbs); + jbs->result= res; + + if (null == catch) { + return eval(scope, finally); + } + oop localScope= newScope(scope); + setVariable(localScope, exception, res); + + jbRecPush(); + jbt= sigsetjmp(jbs->jb, 0); + if (0 == jbt) { + eval(localScope, catch); + delScope(localScope); + jbRecPop(); + return eval(scope, finally); + } + delScope(localScope); + // something happend in the catch block + res= jbs->result; + jbRecPop(); + } + eval(scope, finally); + assert(jbs); + jbs->result= res; + siglongjmp(jbs->jb, jbt); + } + case t_Block: { + oop statements = map_get(ast, statements_symbol); + int i = 0; + oop index; + oop statement, res; + oop localScope = newScope(scope); + while ((index = makeInteger(i)), map_hasKey(statements, index)) { + statement = map_get(statements, index); + res = eval(localScope, statement); + i++; + } + delScope(localScope); + return res; + } + case t_GetVariable: { + return getVariable(scope, map_get(ast, key_symbol)); + } + case t_GetMember: { + oop map = eval(scope, map_get(ast, map_symbol)); + oop key = map_get(ast, key_symbol); + return getMember(map, key); + } + case t_SetMember: { + oop map = eval(scope, map_get(ast, map_symbol)); + oop key = map_get(ast, key_symbol); + oop op = map_get(ast, operator_symbol); + oop value = eval(scope, map_get(ast, value_symbol)); + if (null != op) value= applyOperator(op, getProperty(map, key), value); + if (is(Function, value) && null == get(value, Function, name)) { + set(value, Function, name, key); + } + return map_set(map, key, value); + } + case t_GetIndex: { + oop map = eval(scope, map_get(ast, map_symbol)); + oop key = eval(scope, map_get(ast, key_symbol)); + switch (getType(map)) { + case String: + if (getInteger(key) >= get(map, String, size)) { + runtimeError("GetIndex out of range on String"); + } + return makeInteger(unescape(get(map, String, value))[getInteger(key)]); + case Map: + return getVariable(map, key); + default: + runtimeError("GetIndex on non Map or String"); + } + } + case t_SetIndex: { + oop map = eval(scope, map_get(ast, map_symbol)); + oop key = eval(scope, map_get(ast, key_symbol)); + oop op = map_get(ast, operator_symbol); + oop value = eval(scope, map_get(ast, value_symbol)); + switch (getType(map)) { + case String: + if (getInteger(key) >= get(map, String, size)) { + runtimeError("SetIndex out of range on String"); + } + get(map, String, value)[getInteger(key)] = getInteger(value); + return value; + case Map: + if (null != op) value= applyOperator(op, map_get(map, key), value); + return map_set(map, key, value); + default: + runtimeError("SetIndex on non Map or String"); + } + + } + case t_Symbol: + case t_Integer: + case t_Float: + case t_String: { + return map_get(ast, value_symbol); + } + case t_Logor: { + oop lhs = map_get(ast, lhs_symbol); + oop rhs = map_get(ast, rhs_symbol); + if (isTrue(eval(scope, lhs))) return makeInteger(1); + if (isTrue(eval(scope, rhs))) return makeInteger(1); + return makeInteger(0); + } + case t_Logand: { + oop lhs = map_get(ast, lhs_symbol); + oop rhs = map_get(ast, rhs_symbol); + if (isFalse(eval(scope, lhs))) return makeInteger(0); + if (isFalse(eval(scope, rhs))) return makeInteger(0); + return makeInteger(1); + } +# define RELATION(NAME, OPERATOR) \ + case t_##NAME: { \ + oop lhs = eval(scope, map_get(ast, lhs_symbol)); \ + oop rhs = eval(scope, map_get(ast, rhs_symbol)); \ + return makeInteger(oopcmp(lhs, rhs) OPERATOR 0); \ + } +# define BINARY(NAME, OPERATOR) \ + case t_##NAME: { \ + oop lhs = eval(scope, map_get(ast, lhs_symbol)); \ + oop rhs = eval(scope, map_get(ast, rhs_symbol)); \ + return makeInteger(getInteger(lhs) OPERATOR getInteger(rhs)); \ + } +# define BINARYOP(NAME, FUNCPREFIX) \ + case t_##NAME: { \ + oop lhs = eval(scope, map_get(ast, lhs_symbol)); \ + oop rhs = eval(scope, map_get(ast, rhs_symbol)); \ + return FUNCPREFIX##Operation(lhs, rhs); \ + } + BINARY(Bitor, | ); + BINARY(Bitxor, ^ ); + BINARY(Bitand, & ); + RELATION(Equal, ==); + RELATION(Noteq, !=); + RELATION(Less, < ); + RELATION(Lesseq, <=); + RELATION(Greatereq, >=); + RELATION(Greater, > ); + BINARY(Shleft, <<); + BINARY(Shright, >>); + BINARYOP(Add, add); + BINARYOP(Mul, mul); + BINARYOP(Sub, sub); + BINARYOP(Div, div); + BINARYOP(Mod, mod); +# undef BINARYOP +# undef BINARY +# undef RELATION + case t_Not: { + oop rhs = eval(scope, map_get(ast, rhs_symbol)); + return makeInteger(isFalse(rhs)); + } +# define UNARY(NAME, OPERATOR) \ + case t_##NAME: { \ + oop rhs = eval(scope, map_get(ast, rhs_symbol)); \ + return makeInteger(OPERATOR getInteger(rhs)); \ + } + UNARY(Neg, -); + UNARY(Com, ~); +# undef UNARY + case t_PreIncVariable: { + oop key= map_get(ast, key_symbol); + oop val= getVariable(scope, key); + val= makeInteger(getInteger(val) + 1); + return setVariable(scope, key, val); + } + case t_PreDecVariable: { + oop key= map_get(ast, key_symbol); + oop val= getVariable(scope, key); + val= makeInteger(getInteger(val) - 1); + return setVariable(scope, key, val); + } + case t_PreIncMember: { + oop map= eval(scope, map_get(ast, map_symbol)); + oop key= map_get(ast, key_symbol); + oop val= map_get(map, key); + val= makeInteger(getInteger(val) + 1); + return map_set(map, key, val); + } + case t_PreDecMember: { + oop map= eval(scope, map_get(ast, map_symbol)); + oop key= map_get(ast, key_symbol); + oop val= map_get(map, key); + val= makeInteger(getInteger(val) - 1); + return map_set(map, key, val); + } + case t_PreIncIndex: { + oop map= eval(scope, map_get(ast, map_symbol)); + oop key= eval(scope, map_get(ast, key_symbol)); + oop val= map_get(map, key); + val= makeInteger(getInteger(val) + 1); + return map_set(map, key, val); + } + case t_PreDecIndex: { + oop map= eval(scope, map_get(ast, map_symbol)); + oop key= eval(scope, map_get(ast, key_symbol)); + oop val= map_get(map, key); + val= makeInteger(getInteger(val) - 1); + return map_set(map, key, val); + } + case t_PostIncVariable: { + oop key= map_get(ast, key_symbol); + oop val= getVariable(scope, key); + oop inc= makeInteger(getInteger(val) + 1); + setVariable(scope, key, inc); + return val; + } + case t_PostDecVariable: { + oop key= map_get(ast, key_symbol); + oop val= getVariable(scope, key); + oop inc= makeInteger(getInteger(val) - 1); + setVariable(scope, key, inc); + return val; + } + case t_PostIncMember: { + oop map= eval(scope, map_get(ast, map_symbol)); + oop key= map_get(ast, key_symbol); + oop val= map_get(map, key); + oop inc= makeInteger(getInteger(val) + 1); + map_set(map, key, inc); + return val; + } + case t_PostDecMember: { + oop map= eval(scope, map_get(ast, map_symbol)); + oop key= map_get(ast, key_symbol); + oop val= map_get(map, key); + oop inc= makeInteger(getInteger(val) - 1); + map_set(map, key, inc); + return val; + } + case t_PostIncIndex: { + oop map= eval(scope, map_get(ast, map_symbol)); + oop key= eval(scope, map_get(ast, key_symbol)); + oop val= map_get(map, key); + oop inc= makeInteger(getInteger(val) + 1); + map_set(map, key, inc); + return val; + } + case t_PostDecIndex: { + oop map= eval(scope, map_get(ast, map_symbol)); + oop key= eval(scope, map_get(ast, key_symbol)); + oop val= map_get(map, key); + oop inc= makeInteger(getInteger(val) - 1); + map_set(map, key, inc); + return val; + } + } + printf("EVAL "); + println(ast); + assert(0); + return null; +} + +oop prim_exit(oop scope, oop params) +{ + int status= 0; + if (map_hasIntegerKey(params, 0)) { + oop arg= get(params, Map, elements)[0].value; + if (isInteger(arg)) status= getInteger(arg); + } + exit(status); +} + +oop prim_keys(oop scope, oop params) +{ + if (map_hasIntegerKey(params, 0)) { + oop arg= get(params, Map, elements)[0].value; + if (is(Map, arg)) return map_keys(arg); + } + return null; +} + +oop prim_values(oop scope, oop params) +{ + if (map_hasIntegerKey(params, 0)) { + oop arg= get(params, Map, elements)[0].value; + if (is(Map, arg)) return map_values(arg); + } + return null; +} + +oop prim_length(oop scope, oop params) +{ + if (map_hasIntegerKey(params, 0)) { + oop arg= get(params, Map, elements)[0].value; + switch (getType(arg)) { + case String: return makeInteger(string_size(arg)); + case Symbol: return makeInteger(strlen(get(arg, Symbol, name))); + case Map: return makeInteger(map_size(arg)); + default: break; + } + } + return null; +} + +oop prim_apply(oop scope, oop params) { + oop func= null; if (map_hasIntegerKey(params, 0)) func= get(params, Map, elements)[0].value; + oop args= null; if (map_hasIntegerKey(params, 1)) args= get(params, Map, elements)[1].value; + return apply(scope, globals, func, args, mrAST); +} + +oop prim_invoke(oop scope, oop params) +{ + oop this= null; if (map_hasIntegerKey(params, 0)) this= get(params, Map, elements)[0].value; + oop func= null; if (map_hasIntegerKey(params, 1)) func= get(params, Map, elements)[1].value; + oop args= null; if (map_hasIntegerKey(params, 2)) args= get(params, Map, elements)[2].value; + return apply(scope, this, func, args, mrAST); +} + +oop prim_clone(oop scope, oop params) +{ + if (map_hasIntegerKey(params, 0)) return clone(get(params, Map, elements)[0].value); + return null; +} + +oop prim_print(oop scope, oop params) +{ + assert(is(Map, params)); + for (int i= 0; map_hasIntegerKey(params, i); ++i) { + print(get(params, Map, elements)[i].value); + } + return params; +} + +oop evalArgs(oop scope, oop args) +{ + int i = 0; + oop params = makeMap(); + oop index; + while ((index = makeInteger(i)), map_hasKey(args, index)) { + map_set(params, index, eval(scope, map_get(args, index))); + i++; + } + return params; +} + +oop AST= NULL; + +void readEvalPrint(oop scope, char *fileName) +{ + inputStackPush(fileName); + input_t *top= inputStack; + jbRecPush(); + jb_record *jtop= jbs; + int jbt= sigsetjmp(jbs->jb, 0); + + if (0 == jbt) { + while (yyparse()) { + if (opt_v > 1) printf("%s:%i: ", get(inputStack->name, String, value), inputStack->lineNumber); + if (!yylval) { + fclose(inputStack->file); + if (top == inputStack) break; + inputStackPop(); + assert(inputStack); + continue; + } // EOF + if (opt_v > 1) println(yylval); + oop res = eval(scope, yylval); + if (opt_v > 0) println(res); + assert(jbs == jtop); + } + assert(inputStack); + inputStackPop(); + jbRecPop(); + return; + } + + assert(jbs == jtop); + oop res = jbs->result; + jbRecPop(); + switch (jbt) { + case j_return: runtimeError("return outside of a function"); + case j_break: runtimeError("break outside of a loop or switch"); + case j_continue: runtimeError("continue outside of a loop"); + case j_throw: runtimeError("unhandled exception: %s", printString(res)); + } +} + +oop prim_import(oop scope, oop params) +{ + if (map_hasIntegerKey(params, 0)) { + char *file= get(get(params, Map, elements)[0].value, String, value); + if (yyctx->__pos < yyctx->__limit) { + yyctx->__limit--; + ungetc(yyctx->__buf[yyctx->__limit], inputStack->file); + } + readEvalPrint(scope, file); + } + return null; +} + +oop prim_String(oop scope, oop params) +{ + if (!map_hasIntegerKey(params, 0)) return null; + return makeString(printString(get(params, Map, elements)[0].value)); +} + +oop prim_scope(oop scope, oop params) +{ + return fixScope(scope); +} + +#include + +oop prim_microseconds(oop scope, oop params) +{ + struct rusage ru; + getrusage(RUSAGE_SELF, &ru); + return makeInteger(ru.ru_utime.tv_sec * 1000*1000 + ru.ru_utime.tv_usec); +} + +int main(int argc, char **argv) +{ +# if (USE_GC) + GC_INIT(); +# endif + + symbol_table= makeMap(); + globals= makeMap(); + + map_set(globals, intern("exit" ), makeFunction(prim_exit, intern("exit" ), null, null, globals, null)); + map_set(globals, intern("keys" ), makeFunction(prim_keys, intern("keys" ), null, null, globals, null)); + map_set(globals, intern("values" ), makeFunction(prim_values, intern("values" ), null, null, globals, null)); + map_set(globals, intern("length" ), makeFunction(prim_length, intern("length" ), null, null, globals, null)); + map_set(globals, intern("print" ), makeFunction(prim_print, intern("print" ), null, null, globals, null)); + map_set(globals, intern("invoke" ), makeFunction(prim_invoke, intern("invoke" ), null, null, globals, null)); + map_set(globals, intern("apply" ), makeFunction(prim_apply, intern("apply" ), null, null, globals, null)); + map_set(globals, intern("clone" ), makeFunction(prim_clone, intern("clone" ), null, null, globals, null)); + map_set(globals, intern("import" ), makeFunction(prim_import, intern("import" ), null, null, globals, null)); + map_set(globals, intern("microseconds"), makeFunction(prim_microseconds, intern("microseconds"), null, null, globals, null)); + map_set(globals, intern("String" ), makeFunction(prim_String , intern("String" ), null, null, globals, null)); + + map_set(globals, intern("scope"), makeFunction(prim_scope, intern("scope"), null, null, globals, null)); + + #define _DO(NAME) NAME##_symbol=intern(#NAME); + DO_SYMBOLS() + #undef _DO + + #define _DO(NAME) set(NAME##_symbol, Symbol, prototype, t_##NAME); + DO_PROTOS() + #undef _DO + + #define _DO(NAME) NAME##_proto=makeMap(); map_set(NAME##_proto, __name___symbol, NAME##_symbol); + DO_PROTOS() + #undef _DO + + #define _DO(NAME) map_set(globals, NAME##_symbol, NAME##_proto); + DO_PROTOS() + #undef _DO + + AST = makeMap(); + map_set(globals, intern("AST"), AST); + #define _DO(NAME) map_set(AST, NAME##_symbol, NAME##_proto); + DO_PROTOS() + #undef _DO + + fixScope(globals); + + int repled = 0; + while (argc-- > 1) { + ++argv; + if (!strcmp(*argv, "-g")) ++opt_g; + else if (!strcmp(*argv, "-v")) ++opt_v; + else if (!strcmp(*argv, "-")) { + readEvalPrint(globals, NULL); + repled= 1; + } + else { + readEvalPrint(globals, *argv); + repled= 1; + } + } + if (!repled) { + readEvalPrint(globals, NULL); + } + + if (opt_g) { + if (nalloc < 1024) printf("[GC: %lli bytes allocated]\n", nalloc ); + else if (nalloc < 1024*1024) printf("[GC: %lli kB allocated]\n", nalloc / 1024 ); + else if (nalloc < 1024*1024*1024) printf("[GC: %.2f MB allocated]\n", (double)nalloc / ( 1024*1024)); + else printf("[GC: %.2f GB allocated]\n", (double)nalloc / (1024*1024*1024)); + } + + return 0; + + (void)yyAccept; +} + +// Local Variables: +// indent-tabs-mode: nil +// End: