diff --git a/object.c b/object.c index 243ae27..622d52f 100644 --- a/object.c +++ b/object.c @@ -91,10 +91,11 @@ typedef oop (*primitive_t)(oop params); struct Function { type_t type; primitive_t primitive; - char *name; + oop name; oop body; oop param; oop parentScope; + oop fixed; }; // usefull for map's elements @@ -159,7 +160,7 @@ oop _checkType(oop ptr, type_t type, char *file, int line) return ptr; } -// added parens around e/makexpansion to protect assignment +// added parens around expansion to protect assignment #define get(PTR, TYPE, FIELD) (_checkType(PTR, TYPE, __FILE__, __LINE__)->TYPE.FIELD) #define set(PTR, TYPE, FIELD, VALUE) (_checkType(PTR, TYPE, __FILE__, __LINE__)->TYPE.FIELD = VALUE) @@ -219,15 +220,16 @@ oop makeSymbol(char *name) return newSymb; } -oop makeFunction(primitive_t primitive, char * name, oop param, oop body, oop parentScope) +oop makeFunction(primitive_t primitive, oop name, oop param, oop body, oop parentScope, oop fixed) { oop newFunc = memcheck(malloc(sizeof(union object))); newFunc->type = Function; newFunc->Function.primitive = primitive; - newFunc->Function.name = memcheck(strdup(name)); + newFunc->Function.name = name; newFunc->Function.param = param; newFunc->Function.body = body; newFunc->Function.parentScope = parentScope; + newFunc->Function.fixed = fixed; return newFunc; } @@ -467,10 +469,11 @@ void print(oop ast) return; case Function: if (get(ast, Function, primitive) == NULL) { - printf("Function:%s", get(ast, Function, name)); + printf("Function:"); } else { - printf("Primitive:%s@%p", get(ast, Function, name), get(ast, Function, primitive)); + printf("Primitive:"); } + print(get(ast, Function, name)); return; case Map: map_print(ast, 0); diff --git a/parse.leg b/parse.leg index 9a53131..37f251f 100644 --- a/parse.leg +++ b/parse.leg @@ -24,7 +24,7 @@ _DO(setIndexAdd) _DO(setIndexSub) _DO(setIndexMul) _DO(setIndexDiv) _DO(setIndexMod) \ _DO(setIndexBitor) _DO(setIndexBitxor) _DO(setIndexBitand) _DO(setIndexShleft) _DO(setIndexShright) \ _DO(return) _DO(break) _DO(continue) \ - _DO(literal) + _DO(quasiquote) _DO(unquote) typedef enum { t_UNDEFINED=0, @@ -85,7 +85,7 @@ oop globals= 0; 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(update) _DO(this) _DO(fixed) #define _DO(NAME) oop NAME##_symbol; DO_SYMBOLS() @@ -97,6 +97,16 @@ DO_PROTOS() int opt_v = 0; +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(); @@ -121,6 +131,38 @@ void printObjectName(oop object) } } +// 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 +oop getVariable(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 == object) { + return map_set(object, key, value); + } + } + return map_set(obj, key, value); +} + oop newMap(oop value) { oop map = newObject(map_proto); @@ -378,17 +420,27 @@ oop newGetVariable(oop name) return id; } -oop newFunc(oop name, oop param, oop body) +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 func, oop args); + oop newCall(oop func, oop args) { + if (map_get(func, __proto___symbol) == getVariable_proto) { + oop key = map_get(func, key_symbol); + oop val = getVariable(globals, key); + if (is(Function, val) && isTrue(get(val, Function, fixed))) { + return apply(val, args); + } + } oop call = newObject(call_proto); map_set(call, func_symbol, func); map_set(call, args_symbol, args); @@ -430,45 +482,6 @@ oop newContinue(void) return obj; } -oop newLiteral(oop exp) -{ - oop obj = newObject(literal_proto); - map_set(obj, value_symbol, exp); - return obj; -} - -// 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 -oop getVariable(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 == object) { - return map_set(object, key, value); - } - } - return map_set(obj, key, value); -} - oop fold(oop ast); #define YYSTYPE oop @@ -497,8 +510,10 @@ stmt = e:exp SEMICOLON* { $$ = e } exp = VAR l:IDENT ASSIGN e:exp { $$ = newDeclaration(l, e) } | VAR l:IDENT { $$ = newDeclaration(l, null) } - | FUN l:IDENT p:paramList e:stmt { $$ = newFunc(l, p, e) } - | FUN p:paramList e:stmt { $$ = newFunc(null, p, e) } + | FUN l:IDENT p:paramList e:stmt { $$ = newFunc(l, p, e, null) } + | FUN p:paramList e:stmt { $$ = newFunc(null, p, e, null) } + | SYNTAX l:IDENT p:paramList e:stmt { $$ = newFunc(l, p, e, makeInteger(1)) } + | SYNTAX p:paramList e:stmt { $$ = newFunc(null, p, e, makeInteger(1)) } | IF LPAREN c:exp RPAREN t:stmt ELSE f:stmt { $$ = newIf(c, t, f ) } | IF LPAREN c:exp RPAREN t:stmt { $$ = newIf(c, t, null) } | WHILE LPAREN c:exp RPAREN s:stmt { $$ = newWhile(c, s) } @@ -509,7 +524,7 @@ exp = VAR l:IDENT ASSIGN e:exp { $$ = newDeclarati | RETURN { $$ = newReturn(null) } | BREAK { $$ = newBreak() } | CONTINUE { $$ = newContinue() } - | l:IDENT + | l:IDENT ( ASSIGN e:exp { $$ = newBinary(assign_proto, l, e) } | ASSIGNADD e:exp { $$ = newBinary(assignAdd_proto, l, e) } | ASSIGNSUB e:exp { $$ = newBinary(assignSub_proto, l, e) } @@ -522,7 +537,7 @@ exp = VAR l:IDENT ASSIGN e:exp { $$ = newDeclarati | ASSIGNSHLEFT e:exp { $$ = newBinary(assignShleft_proto , l, e) } | ASSIGNSHRIGHT e:exp { $$ = newBinary(assignShright_proto, l, e) } ) - | l:postfix DOT i:IDENT + | l:postfix DOT i:IDENT ( ASSIGN e:exp { $$ = newSetMap(setMember_proto, l, i, e) } | ASSIGNADD e:exp { $$ = newSetMap(setMemberAdd_proto, l, i, e) } | ASSIGNSUB e:exp { $$ = newSetMap(setMemberSub_proto, l, i, e) } @@ -535,7 +550,7 @@ exp = VAR l:IDENT ASSIGN e:exp { $$ = newDeclarati | ASSIGNSHLEFT e:exp { $$ = newSetMap(setMemberShleft_proto, l, i, e) } | ASSIGNSHRIGHT e:exp { $$ = newSetMap(setMemberShright_proto, l, i, e) } ) - | l:postfix LBRAC i:exp RBRAC + | l:postfix LBRAC i:exp RBRAC ( ASSIGN e:exp { $$ = newSetMap(setIndex_proto, l, i, e) } | ASSIGNADD e:exp { $$ = newSetMap(setIndexAdd_proto, l, i, e) } | ASSIGNSUB e:exp { $$ = newSetMap(setIndexSub_proto, l, i, e) } @@ -620,6 +635,8 @@ prefix = PLUS n:prefix { $$= n } | PLING n:prefix { $$= newUnary(not_proto, n) } | PLUSPLUS n:prefix { $$= newPreIncrement(n) } | MINUSMINUS n:prefix { $$= newPreDecrement(n) } + | BACKTICK n:prefix { $$ = newUnary(quasiquote_proto, n) } + | AT n:prefix { $$ = newUnary(unquote_proto, n) } | n:postfix { $$= n } postfix = i:value ( DOT s:IDENT a:argumentList { i = newInvoke(i, s, a) } @@ -630,7 +647,7 @@ postfix = i:value ( DOT s:IDENT a:argumentList { i = newInvoke( | MINUSMINUS { i = newPostDecrement(i) } ) * { $$ = i } -assignOp = ASSIGN +assignOp = ASSIGN | ASSIGNADD | ASSIGNSUB | ASSIGNMUL @@ -640,7 +657,7 @@ assignOp = ASSIGN | ASSIGNBITXOR | ASSIGNBITAND | ASSIGNSHLEFT - | ASSIGNSHRIGHT + | ASSIGNSHRIGHT paramList = LPAREN m:makeMap ( i:IDENT { map_append(m, i) } @@ -663,8 +680,6 @@ value = n:NUMBER { $$ = n } | NULL { $$ = null } | i:IDENT { $$ = newGetVariable(i) } | LPAREN i:exp RPAREN { $$ = i } - | BACKTICK e:exp { $$ = newLiteral(e) } - | AT e:exp { $$ = eval(globals, e) } STRING = SQUOTE < (!SQUOTE char)* > SQUOTE { $$ = makeString(unescape(yytext)) } | DQUOTE < (!DQUOTE char)* > DQUOTE { $$ = makeString(unescape(yytext)) } @@ -693,7 +708,7 @@ eol = "\n""\r"* | "\r""\n"* comment = "//" ( ![\n\r] . )* | "/*" ( !"*/" . )* "*/" -keyword = FUN | VAR | SWITCH | CASE | DEFAULT | DO | FOR | WHILE | IF | ELSE | NULL | RETURN | BREAK | CONTINUE +keyword = FUN | SYNTAX | VAR | SWITCH | CASE | DEFAULT | DO | FOR | WHILE | IF | ELSE | NULL | RETURN | BREAK | CONTINUE IDENT = !keyword < [a-zA-Z_][a-zA-Z0-9_]* > - { $$ = intern(yytext) } @@ -703,6 +718,7 @@ NUMBER = '0b' < [01]+ > - { $$ = newInteger(strtol( | < [0-9]+ > - { $$ = newInteger(strtol(yytext, 0, 10)) } FUN = 'fun' ![a-zA-Z0-9_] - +SYNTAX = 'syntax' ![a-zA-Z0-9_] - VAR = 'var' ![a-zA-Z0-9_] - SWITCH = 'switch' ![a-zA-Z0-9_] - CASE = 'case' ![a-zA-Z0-9_] - @@ -769,16 +785,6 @@ SQUOTE = "'" - %% ; -int isFalse(oop obj) -{ - return obj == null || (isInteger(obj) && (0 == getInteger(obj))); -} - -int isTrue(oop obj) -{ - return !isFalse(obj); -} - oop map_zip(oop keys, oop values) { assert(is(Map, keys)); @@ -814,6 +820,22 @@ oop clone(oop obj) return obj; } +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]; + pair->value= expandUnquotes(scope, pair->value); + } + return obj; +} + oop fold(oop ast) { if (is(Map, ast)) { @@ -925,9 +947,13 @@ oop eval(oop scope, oop ast) } return map; } - case t_literal: { - oop obj = map_get(ast, value_symbol); - return obj; + case t_quasiquote: { + oop obj = map_get(ast, rhs_symbol); + return expandUnquotes(scope, obj); + } + case t_unquote: { + fprintf(stderr, "\n@ outside of `\n"); + exit(1); } case t_declaration: { oop lhs = map_get(ast, lhs_symbol); @@ -1078,13 +1104,18 @@ oop eval(oop scope, oop ast) case t_assign: { oop lhs = map_get(ast, lhs_symbol); oop rhs = eval(scope, map_get(ast, rhs_symbol)); - return setVariable(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 func = makeFunction(NULL, get(name, Symbol, name), param, body, scope); + oop fixed = map_get(ast, fixed_symbol); + oop func = makeFunction(NULL, name, param, body, scope, fixed); if (opt_v) { printf("funcscope: "); println(scope); @@ -1102,7 +1133,10 @@ oop eval(oop scope, oop ast) exit(1); } - oop args = evalArgs(scope, map_get(ast, args_symbol)); + oop args = map_get(ast, args_symbol); + if (isFalse(get(func, Function, fixed))) { + args = evalArgs(scope, args); + } if (get(func, Function, primitive) == NULL) { oop param = get(func, Function, param); oop localScope = map_zip(param, args); @@ -1227,6 +1261,9 @@ oop eval(oop scope, oop ast) oop map = eval(scope, map_get(ast, map_symbol)); oop key = map_get(ast, key_symbol); oop value = eval(scope, map_get(ast, value_symbol)); + if (is(Function, value) && null == get(value, Function, name)) { + set(value, Function, name, key); + } return map_set(map, key, value); } # define SETMEMBEROP(OPERATION, OPERATOR) \ @@ -1514,6 +1551,48 @@ oop prim_invoke(oop params) return result; } +oop apply(oop func, oop args) +{ + if (!is(Function, func)) { + printf("cannot apply "); + println(func); + exit(1); + } + if (NULL != get(func, Function, primitive)) { + return get(func, Function, primitive)(args); + } + oop param = get(func, Function, param); + oop localScope = map_zip(param, args); + map_set(localScope, __arguments___symbol, args); + map_set(localScope, __proto___symbol, get(func, Function, parentScope)); + jbRecPush(); + int jbt = sigsetjmp(jbs->jb, 0); + switch (jbt) { + case j_return: { + oop result = jbs->result; + jbRecPop(); + return result; + } + case j_break: { + fprintf(stderr, "\nbreak outside of a loop\n"); + exit(1); + } + case j_continue: { + fprintf(stderr, "\ncontinue outside of a loop\n"); + exit(1); + } + } + oop result= eval(localScope, get(func, Function, body)); + jbRecPop(); + return result; +} + +oop prim_apply(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(func, args); +} + oop prim_clone(oop params) { if (map_hasIntegerKey(params, 0)) return clone(get(params, Map, elements)[0].value); @@ -1558,12 +1637,14 @@ int main(int argc, char **argv) symbol_table = makeMap(); globals = makeMap(); - map_set(globals, intern("exit") , makeFunction(prim_exit, "exit", null, null, globals)); - map_set(globals, intern("keys") , makeFunction(prim_keys, "keys", null, null, globals)); - map_set(globals, intern("length"), makeFunction(prim_length, "length", null, null, globals)); - map_set(globals, intern("print") , makeFunction(prim_print, "print", null, null, globals)); - map_set(globals, intern("invoke"), makeFunction(prim_invoke, "invoke", null, null, globals)); - map_set(globals, intern("clone") , makeFunction(prim_clone, "clone", null, null, globals)); + 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("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)); + #define _DO(NAME) NAME##_symbol=intern(#NAME); DO_SYMBOLS()