diff --git a/demofiles/memory-leak.c b/demofiles/memory-leak.c index a7fb1ec..fc7d634 100644 --- a/demofiles/memory-leak.c +++ b/demofiles/memory-leak.c @@ -8,6 +8,7 @@ int main() { for (int i = 0; i < 10; ++i) { int *ptr = malloc(sizeof(*ptr)); assert(ptr != 0); + printf("%p\n", ptr); *ptr = i; } return 0; diff --git a/demofiles/multiple-free.c b/demofiles/multiple-free.c index 1d38172..e72a524 100644 --- a/demofiles/multiple-free.c +++ b/demofiles/multiple-free.c @@ -6,8 +6,8 @@ int main() { int *ptr = malloc(sizeof(*ptr)); - assert(ptr); - free(ptr); - free(ptr); + assert(ptr != 0); + free(ptr); printf("%p\n", ptr); + free(ptr); printf("%p\n", ptr); return 0; } diff --git a/demofiles/null-pointer.c b/demofiles/null-pointer.c index eb9518b..a9d961b 100644 --- a/demofiles/null-pointer.c +++ b/demofiles/null-pointer.c @@ -3,7 +3,7 @@ #include int main() { - char *ptr = NULL; - printf("%s\n", ptr); - return 0; + char *ptr = (void *)0; // NULL + printf("%s\n", ptr); + return 0; } diff --git a/include/stdlib.h b/include/stdlib.h index abbca30..c327175 100644 --- a/include/stdlib.h +++ b/include/stdlib.h @@ -1 +1,2 @@ extern void *malloc(long size); +extern void free(void *pointer); diff --git a/main.leg b/main.leg index a26b53a..0185333 100644 --- a/main.leg +++ b/main.leg @@ -1,6 +1,6 @@ # main.leg -- C parser + interpreter # -# Last edited: 2025-01-27 11:18:13 by piumarta on zora +# Last edited: 2025-01-28 04:46:58 by piumarta on zora %{ ; @@ -56,14 +56,14 @@ typedef union Object Object, *oop; #define YYSTYPE oop -#define _do_types(_) \ - _(Undefined) _(Input) _(Integer) _(Float) _(Symbol) _(Pair) _(String) _(Array) \ - _(Memory) _(Reference) _(Closure) _(Call) _(Block) \ - _(Address) _(Dereference) _(Sizeof) _(Unary) _(Binary) _(Assign) _(Cast) \ - _(While) _(For) _(If) _(Return) _(Continue) _(Break) \ - _(Tvoid) _(Tchar) _(Tshort) _(Tint) _(Tlong) _(Tfloat) _(Tdouble) \ - _(Tpointer) _(Tarray) _(Tstruct) _(Tfunction) _(Tetc) \ - _(Scope) _(TypeName) _(Variable) _(Constant) _(Function) _(Primitive) \ +#define _do_types(_) \ + _(Undefined) _(Input) _(Integer) _(Float) _(Pointer) _(Symbol) _(Pair) _(String) _(Array) \ + _(Memory) _(Reference) _(Closure) _(Call) _(Block) \ + _(Addressof) _(Dereference) _(Sizeof) _(Unary) _(Binary) _(Assign) _(Cast) \ + _(While) _(For) _(If) _(Return) _(Continue) _(Break) \ + _(Tvoid) _(Tchar) _(Tshort) _(Tint) _(Tlong) _(Tfloat) _(Tdouble) \ + _(Tpointer) _(Tarray) _(Tstruct) _(Tfunction) _(Tetc) \ + _(Scope) _(TypeName) _(Variable) _(Constant) _(Function) _(Primitive) \ _(VarDecls) _(TypeDecls) #define _do_unaries(_) \ @@ -99,6 +99,13 @@ char *binaryName(int op) { #undef _ +#define _do_primitives(_) \ + _(printf) _(assert) _(malloc) _(free) + +#define _(X) oop s_##X = 0; +_do_primitives(_) +#undef _ + typedef oop (* prim_t)(int nargs, oop *arguments, oop environment); typedef oop (*cvt_t)(oop input); @@ -107,6 +114,7 @@ struct Undefined { type_t _type; }; struct Input { type_t _type; char *name; FILE *file; oop next; }; struct Integer { type_t _type; long value; }; struct Float { type_t _type; double value; }; +struct Pointer { type_t _type; oop type, base; int offset; }; struct Symbol { type_t _type; char *name; oop value; }; struct Pair { type_t _type; oop head, tail; }; struct String { type_t _type; int size; char *elements; }; @@ -116,7 +124,7 @@ struct Reference { type_t _type; oop target; }; struct Closure { type_t _type; oop function, environment; }; struct Call { type_t _type; oop function, arguments; }; struct Block { type_t _type; oop statements; }; -struct Address { type_t _type; oop rhs; }; +struct Addressof { type_t _type; oop rhs; }; struct Dereference { type_t _type; oop rhs; }; struct Sizeof { type_t _type; oop rhs, size; }; struct Unary { type_t _type; unary_t operator; oop rhs; }; @@ -235,6 +243,15 @@ oop newInteger(long value) # endif } +oop newPointer(oop type, oop base, int offset) +{ + oop obj = new(Pointer); + obj->Pointer.type = type; + obj->Pointer.base = base; + obj->Pointer.offset = offset; + return obj; +} + oop newFloat(double value) { # if TAGFLOAT @@ -587,7 +604,7 @@ CTOR1(Reference, target); CTOR2(Closure, function, environment); CTOR2(Call, function, arguments); CTOR1(Block, statements); -CTOR1(Address, rhs); +CTOR1(Addressof, rhs); CTOR1(Dereference, rhs); oop newSizeof(oop operand) @@ -666,7 +683,9 @@ oop t_int = 0; oop t_long = 0; oop t_float = 0; oop t_double = 0; -oop t_string = 0; +oop t_pvoid = 0; +oop t_pchar = 0; +oop t_ppchar = 0; oop newTpointer(oop target) { @@ -986,6 +1005,25 @@ oop toStringOn(oop obj, oop str) case Integer: String_format(str, "%d", _integerValue(obj)); break; + case Pointer: { + oop base = get(obj, Pointer,base); + switch (getType(base)) { + case Integer: + String_format(str, "<%p", (void *)(intptr_t)_integerValue(base)); + break; + case Variable: + String_format(str, "<&%s", symbolName(get(base, Variable,name))); + break; + case Memory: + String_format(str, "<%p[%d]", get(base, Memory,base), get(base, Memory,size)); + break; + default: + fatal("cannot convert pointer base %s to string", toString(base)); + break; + } + String_format(str, "%+d>", get(obj, Pointer,offset)); + break; + } case Symbol: String_format(str, "%s", get(obj, Symbol,name)); break; @@ -1205,6 +1243,11 @@ void printiln(oop obj, int indent) case Input: printf("<%s>\n", get(obj, Input,name)); break; case Integer: printf("%ld\n", integerValue(obj)); break; case Float: printf("%f\n", floatValue(obj)); break; + case Pointer: { + printf("POINTER %s [%d]\n", toString(get(obj, Pointer,type)), get(obj, Pointer,offset)); + printiln(get(obj, Pointer,base), indent+1); + break; + } case Symbol: printf("%s\n", symbolName (obj)); break; case Pair: { printf("PAIR\n"); @@ -1267,9 +1310,9 @@ void printiln(oop obj, int indent) printiln(get(obj, Block,statements), indent+1); break; } - case Address: { - printf("ADDRESS\n"); - printiln(get(obj, Address,rhs), indent+1); + case Addressof: { + printf("ADDRESSOF\n"); + printiln(get(obj, Addressof,rhs), indent+1); break; } case Dereference: { @@ -1678,7 +1721,7 @@ unary = MINUS r:unary { $$ = newUnary(NEG, r) } | PLING r:unary { $$ = newUnary(NOT, r) } | TILDE r:unary { $$ = newUnary(COM, r) } | STAR r:unary { $$ = newDereference(r) } - | AND r:unary { $$ = newAddress(r) } + | AND r:unary { $$ = newAddressof(r) } | PPLUS r:unary { $$ = newUnary(PREINC, r) } | MMINUS r:unary { $$ = newUnary(PREDEC, r) } | SIZEOF @@ -1978,6 +2021,7 @@ oop declarePrimitive(oop name, oop type, oop parameters, prim_t function) oop cvt_(oop obj) { return obj; } oop cvtI(oop obj) { return newInteger((int)_integerValue(obj)); } +oop cvtP(oop obj) { return newPointer(t_pvoid, obj, 0); } cvt_t converter(int tfrom, int tto) { @@ -2008,1369 +2052,1486 @@ oop incr(oop val, int amount) return nil; } -oop eval(oop exp, oop env) +int isType(oop obj) +{ + type_t type = getType(obj); + return Tvoid <= type && type <= Tfunction; +} + +int typeSize(oop type) +{ + switch (getType(type)) { + case Tvoid: return 1; + case Tchar: return 1; + case Tshort: return 2; + case Tint: return 4; + case Tlong: return 8; + case Tfloat: return 4; + case Tdouble: return 8; + case Tpointer: return 8; // fixme: make this a parameter + case Tstruct: assert(!"unimplemented"); + case Tarray: assert(!"unimplemented"); + case Tfunction: assert(!"unimplemented"); + default: assert(!"this cannot happen"); + } + return 0; +} + +int toBoolean(oop arg) +{ + switch (getType(arg)) { + case Integer: return _integerValue(arg); + case Float: return integerValue(arg); + case Reference: return 1; + default: fatal("cannot convert %s to boolean", getTypeName(arg)); + } + return 0; +} + +oop prim_printf(int argc, oop *argv, oop env) // array +{ + oop result = nil; + if (argc < 1) fatal("printf: no format string"); + oop format = argv[0]; + if (!is(String, format)) fatal("printf: format is not a string"); + char *fmt = get(format, String,elements); + int size = get(format, String,size); + int n = 0; + int argn = 1; + for (int i = 0; i < size;) { + int c = fmt[i++]; + if (c == '%' && fmt[i]) { + c = fmt[i++]; + if (c == '%') goto echo; + if (argn >= argc) fatal("too few arguments for printf format string"); + oop arg = argv[argn++]; + switch (c) { + case 'd': { + if (!is(Integer, arg)) + fatal("%%d conversion argument is %s", getTypeName(arg)); + n += printf("%ld", _integerValue(arg)); + continue; + } + case 'p': { + switch (getType(arg)) { + case Pointer: { + oop base = get(arg, Pointer,base); + switch (getType(base)) { + case Integer: + n += printf("<%p", (void *)(intptr_t)_integerValue(base)); + break; + case Variable: + n += printf("<&%s", symbolName(get(base, Variable,name))); + break; + case Memory: + n += printf("<%p[%zd]", get(base, Memory,base), get(base, Memory,size)); + break; + default: + fatal("%%p conversion base is %s", getTypeName(base)); + break; + } + printf("%+d>", get(arg, Pointer,offset)); + continue; + } + default: + break; + } + fatal("%%p conversion argument is %s", getTypeName(arg)); + continue; + } + case 's': { + switch (getType(arg)) { + case String: { + n += printf("%.*s", get(arg, String,size), get(arg, String,elements)); + continue; + } + case Pointer: { + oop type = get(arg, Pointer,type); + if (t_pchar != type) + fatal("%%s conversion of non-string pointer: %s %s", + toString(type), toString(arg)); + oop base = get(arg, Pointer,base); + switch (getType(base)) { + case Integer: { + if (!_integerValue(base)) + fatal("%%s conversion of null pointer"); + fatal("%%s conversion of arbitrary pointer: %s", toString(arg)); + } + case Variable: fatal("%%s conversion of variable: %s", toString(arg)); + case Memory: fatal("%%s conversion of memory: %s", toString(arg)); + default: assert(!"this cannot happen"); + } + break; + } + default: + break; + } + fatal("%%s conversion argument is: %s", toString(arg)); + continue; + } + default: + fatal("illegal printf conversion: %%%c", c); + } + } + echo: + putchar(c); + ++n; + } + if (argn != argc) fatal("too many arguments for printf format string"); + return newInteger(n); +} + +oop prim_assert(int argc, oop *argv, oop env) // array +{ + if (argc != 1) fatal("assert: wrong number of arguments"); + int value = toBoolean(argv[0]); + if (!value) fatal("assertion failed\n"); + return nil; +} + +oop prim_malloc(int argc, oop *argv, oop env) // array +{ + if (argc != 1) fatal("malloc: wrong number of arguments"); + oop arg = argv[0]; + if (is(Integer,arg)) { + size_t size = _integerValue(arg); + if (size >= 0) { + if (size > 10*1024*1024) + fatal("cowardly refusing to allocate memory of size %zd", size); + void *mem = malloc(_integerValue(arg)); + if (!mem) fatal("malloc(%zd) failed", size); + return newPointer(t_pvoid, newMemory(mem, size), 0); + } + } + fatal("malloc: invalid argument: %s", toString(arg)); + return 0; +} + +oop prim_free(int argc, oop *argv, oop env) // array +{ + if (argc != 1) fatal("free: wrong number of arguments"); + oop arg = argv[0]; + if (!is(Pointer,arg)) fatal("free: argument is not a pointer"); + oop base = get(arg, Pointer,base); + switch (getType(base)) { + case Integer: fatal("attempt to free arbitrary pointer %s", toString(arg)); + case Variable: fatal("attempt to free pointer to variable %s", toString(arg)); + case Memory: free(get(base, Memory,base)); break; + default: assert(!"this cannot happen"); + } + return nil; +} + +oop typeCheck(oop exp, oop fntype) { - if (opt_v > 2) { printf("EVAL "); println(exp); } switch (getType(exp)) { - case Undefined: assert(!"this cannot happen"); - case Input: assert(!"this cannot happen"); - case Integer: return exp; - case Float: return exp; + case Integer: return t_int; + case Float: return t_float; + case Pointer: break; + case String: return t_pchar; case Symbol: { oop value = Scope_lookup(exp); - if (!value) fatal("'%s' is undefined\n", get(exp, Symbol,name)); - if (isNil(value)) fatal("'%s' is uninitialised\n", get(exp, Symbol,name)); + if (!value) fatal("undefined variable '%s'", symbolName(exp)); + if (nil == value) fatal("uninitialised variable '%s'", symbolName(exp)); switch (getType(value)) { - case Variable: return get(value, Variable,value); - case Function: return value; - case Primitive: return value; - default: fatal("cannot eval: %s", toString(value)); - } - break; - } - case Pair: assert(!"this cannot happen"); - case String: return exp; - case Array: assert(!"this cannot happen"); - case Memory: assert(!"this cannot happen"); - case Primitive: return exp; - case Reference: return exp; - case Closure: return exp; - case Call: { - oop fun = eval(get(exp, Call,function), env); - oop args = get(exp, Call,arguments); - return apply(fun, args, nil); - } - case Block: { - Object *stmts = get(exp, Block,statements); - int size = get(stmts, Array,size); - oop *elts = get(stmts, Array,elements); - Object *result = nil; - Scope_begin(); - switch (nlrPush()) { // longjmp occurred - case NLR_INIT: break; - case NLR_RETURN: Scope_end(); return nlrPop(); - case NLR_CONTINUE: Scope_end(); nlrReturn(NLR_CONTINUE, nlrPop()); - case NLR_BREAK: Scope_end(); nlrReturn(NLR_BREAK, nlrPop()); - } - for (int i = 0; i < size; ++i) { - result = eval(elts[i], env); - } - Scope_end(); - nlrPop(); - return result; - } - case Address: { - oop rhs = get(exp, Address,rhs); - switch (getType(rhs)) { - case Symbol: { - rhs = Scope_lookup(rhs); - if (!rhs) assert(!"this cannot happen"); - return newReference(rhs); - } + case Primitive: return get(value, Primitive,type); + case Function: return get(value, Function,type); + case Variable: return get(value, Variable,type); default: - break; + fatal("cannot typecheck value of type %s", getTypeName(value)); } - fatal("cannot take address of: %s", toString(rhs)); - break; + return nil; + } + case Addressof: { + return newTpointer(typeCheck(get(exp, Addressof,rhs), fntype)); } case Dereference: { - oop rhs = get(exp, Dereference,rhs); - rhs = eval(rhs, nil); - switch (getType(rhs)) { - case Reference: rhs = get(rhs, Reference,target); break; - default: - printf("cannot dereference\n"); - println(rhs); - exit(1); - } - switch (getType(rhs)) { - case Variable: return get(rhs, Variable,value); - default: - printf("cannot complete dereference\n"); - println(rhs); - exit(1); + oop rhs = typeCheck(get(exp, Dereference,rhs), fntype); + if (!is(Tpointer, rhs)) { + fatal("cannot dereference '%s'", toString(rhs)); } - break; + return get(rhs, Tpointer,target); + } + case Cast: { + oop lhs = makeBaseType(get(exp, Cast,type)); + oop rhs = get(exp, Cast,rhs); + set(exp, Cast,type, lhs); + type_t lht = getType(lhs); + if (Tpointer == lht && is(Integer,rhs) && !_integerValue(rhs)) { + set(exp, Cast,converter, cvtP); + return lhs; + } + rhs = typeCheck(get(exp, Cast,rhs), fntype); + cvt_t cvt = converter(getType(rhs), lht); + if (!cvt) fatal("cannot convert '%s' to '%s'", toString(rhs), toString(lhs)); + set(exp, Cast,converter, cvt); + return lhs; } case Sizeof: { - return get(exp, Sizeof,size); + oop rhs = get(exp, Sizeof,rhs); + if (!isType(rhs)) rhs = typeCheck(rhs, fntype); assert(isType(rhs)); + set(exp, Sizeof,size, newInteger(typeSize(rhs))); + return t_long; } case Unary: { - unary_t op = get(exp, Unary,operator); - oop rhs = get(exp, Unary,rhs); - switch (op) { - case PREINC: - case PREDEC: - case POSTINC: - case POSTDEC: { - if (is(Symbol, rhs)) { - rhs = Scope_lookup(rhs); - switch (getType(rhs)) { - case Variable: { - oop val = get(rhs, Variable,value); - oop result = nil; - switch (op) { - case PREINC: val = incr(val, 1); result = val; break; - case PREDEC: val = incr(val, -1); result = val; break; - case POSTINC: result = val; val = incr(val, 1); break; - case POSTDEC: result = val; val = incr(val, -1); break; - default: assert("!this cannot happen"); - } - set(rhs, Variable,value, val); - return result; - } - default: break; - } - } - fatal("illegal increment operation: %s", toString(exp)); - } - case NEG: - case NOT: - case COM: { - rhs = eval(rhs, env); - switch (op) { - case NEG: return ( is(Float, rhs) - ? newFloat (-floatValue (rhs)) - : newInteger(-integerValue(rhs)) ); - case NOT: return isFalse(rhs) ? true : false; - case COM: return newInteger(~integerValue(rhs)); - default: break; - } - } + oop rhs = typeCheck(get(exp, Unary,rhs), fntype); + switch (get(exp, Unary,operator)) { + case NEG: assert(!"unimplemented"); + case NOT: assert(!"unimplemented"); + case COM: assert(!"unimplemented"); + case PREINC: return rhs; + case PREDEC: return rhs; + case POSTINC: assert(!"unimplemented"); + case POSTDEC: assert(!"unimplemented"); } - assert("!this cannot happen"); - break; + return nil; } case Binary: { - oop lhs = get(exp, Binary,lhs); - oop rhs = get(exp, Binary,rhs); + oop lhs = typeCheck(get(exp, Binary,lhs), fntype); + oop rhs = typeCheck(get(exp, Binary,rhs), fntype); switch (get(exp, Binary,operator)) { - case LAND: return isFalse(eval(lhs, env)) ? false : eval(rhs, env); - case LOR: return isTrue (eval(lhs, env)) ? true : eval(rhs, env); - default: { - lhs = eval(lhs, env); - rhs = eval(rhs, env); - if (Float == getType(lhs) || Float == getType(rhs)) { // floating point result - switch (get(exp, Binary,operator)) { - case INDEX: assert(!"unimplemented"); - case MUL: return FBINOP(lhs, * , rhs); - case DIV: return FBINOP(lhs, / , rhs); - case MOD: return newFloat(fmod(floatValue(lhs), floatValue(rhs))); - case ADD: return FBINOP(lhs, + , rhs); - case SUB: return FBINOP(lhs, - , rhs); - case SHL: return IBINOP(lhs, <<, rhs); - case SHR: return IBINOP(lhs, >>, rhs); - case LT: return FRELOP(lhs, < , rhs); - case LE: return FRELOP(lhs, <=, rhs); - case GE: return FRELOP(lhs, >=, rhs); - case GT: return FRELOP(lhs, > , rhs); - case EQ: return FRELOP(lhs, == , rhs); - case NE: return FRELOP(lhs, !=, rhs); - case BAND: return IBINOP(lhs, & , rhs); - case BXOR: return IBINOP(lhs, ^ , rhs); - case BOR: return IBINOP(lhs, | , rhs); - case LAND: - case LOR: - break; - } - } - else { // integer result - switch (get(exp, Binary,operator)) { - case INDEX: assert("!unimplemented"); - case MUL: return IBINOP(lhs, * , rhs); - case DIV: return IBINOP(lhs, / , rhs); - case MOD: return IBINOP(lhs, % , rhs); - case ADD: return IBINOP(lhs, + , rhs); - case SUB: return IBINOP(lhs, - , rhs); - case SHL: return IBINOP(lhs, <<, rhs); - case SHR: return IBINOP(lhs, >>, rhs); - case LT: return IRELOP(lhs, < , rhs); - case LE: return IRELOP(lhs, <=, rhs); - case GE: return IRELOP(lhs, >=, rhs); - case GT: return IRELOP(lhs, > , rhs); - case EQ: { - if (is(Reference,lhs) && is(Integer,rhs) && _integerValue(rhs) == 0) return false; - if (is(Reference,rhs) && is(Integer,lhs) && _integerValue(lhs) == 0) return false; - return IRELOP(lhs, == , rhs); - } - case NE: { - if (is(Reference,lhs) && is(Integer,rhs) && _integerValue(rhs) == 0) return true; - if (is(Reference,rhs) && is(Integer,lhs) && _integerValue(lhs) == 0) return true; - if (is(Memory, lhs) && is(Integer,rhs) && _integerValue(rhs) == 0) - return (intptr_t)get(lhs, Memory,base) != _integerValue(rhs) ? true : false; - if (is(Memory, rhs) && is(Integer,lhs) && _integerValue(lhs) == 0) - return (intptr_t)get(rhs, Memory,base) != _integerValue(lhs) ? true : false; - return IRELOP(lhs, !=, rhs); - } - case BAND: return IBINOP(lhs, & , rhs); - case BXOR: return IBINOP(lhs, ^ , rhs); - case BOR: return IBINOP(lhs, | , rhs); - case LAND: - case LOR: - break; - } + case INDEX: assert(!"unimplemented"); break; + case MUL: assert(!"unimplemented"); break; + case DIV: assert(!"unimplemented"); break; + case MOD: assert(!"unimplemented"); break; + case ADD: { + if (lhs == rhs) { + if (t_int == lhs) return lhs; } + fatal("cannot add '%s' and '%s'", toString(lhs), toString(rhs)); + break; } + case SUB: assert(!"unimplemented"); break; + case SHL: assert(!"unimplemented"); break; + case SHR: assert(!"unimplemented"); break; + case LT: return t_int; + case LE: assert(!"unimplemented"); break; + case GE: assert(!"unimplemented"); break; + case GT: return t_int; + case EQ: return t_int; + case NE: return t_int; + case BAND: assert(!"unimplemented"); break; + case BXOR: assert(!"unimplemented"); break; + case BOR: assert(!"unimplemented"); break; + case LAND: assert(!"unimplemented"); break; + case LOR: assert(!"unimplemented"); break; } - assert(!"this cannot happen"); - break; + return nil; } case Assign: { - oop dst = get(exp, Assign,lhs); - oop lhs = dst; - oop rhs = eval(get(exp, Assign,rhs), nil); - switch (getType(lhs)) { - case Symbol: { - lhs = Scope_lookup(lhs); - if (Variable != getType(lhs)) break; - return set(lhs, Variable,value, rhs); - } - case Dereference: { - lhs = eval(get(lhs, Dereference,rhs), nil); - switch (getType(lhs)) { - case Reference: { - lhs = get(lhs, Reference,target); - switch (getType(lhs)) { - case Variable: return set(lhs, Variable,value, rhs); - default: break; - } - } - default: break; - } - break; - } - default: - break; - } - if (dst == lhs) - fatal("cannot assign to: %s", toString(lhs)); - else - fatal("invalid rvalue '%s' assigning to: %s", - toString(lhs), toString(dst)); - break; + oop lhs = typeCheck(get(exp, Assign,lhs), fntype); + oop rhs = typeCheck(get(exp, Assign,rhs), fntype); + if (lhs != rhs) + fatal("incompatible types assigning '%s' to '%s'", toString(rhs), toString(lhs)); + return lhs; } - case Cast: { - cvt_t cvt = get(exp, Cast,converter); assert(cvt); - oop rhs = eval(get(exp, Cast,rhs), nil); - return cvt(rhs); + case If: { + if (t_int != typeCheck(get(exp, If,condition), fntype)) fatal("if condition is not 'int'"); + typeCheck(get(exp, If,consequent), fntype); + if (nil != get(exp, If,alternate)) + typeCheck(get(exp, If,alternate), fntype); + return nil; } case While: { - oop cond = get(exp, While,condition); - oop expr = get(exp, While,expression); - oop result = nil; - switch (nlrPush()) { - case NLR_INIT: break; - case NLR_RETURN: nlrReturn(NLR_RETURN, nlrPop()); // propagate upwards - case NLR_CONTINUE: break; - case NLR_BREAK: return nlrPop(); - } - while (isTrue(eval(cond, env))) { - result = eval(expr, env); - } - nlrPop(); - return result; + oop cond = get(exp, While,condition); + oop body = get(exp, While,expression); + cond = typeCheck(cond, fntype); + if (t_int != cond) fatal("while condition is not 'int'"); + typeCheck(body, fntype); + return nil; } case For: { oop init = get(exp, For,initialiser); oop cond = get(exp, For,condition); oop step = get(exp, For,update); oop body = get(exp, For,body); - eval(init, nil); - while (integerValue(eval(cond, nil))) { - eval(body, nil); - eval(step, nil); - } - return nil; - } - case If: { - oop cond = get(exp, If,condition); - oop conseq = get(exp, If,consequent); - oop altern = get(exp, If,alternate); - if (isTrue(eval(cond, env))) eval(conseq, env); - else if (!isNil(altern)) eval(altern, env); + typeCheck(init, fntype); + cond = typeCheck(cond, fntype); + if (t_int != cond) fatal("for condition is not 'int'"); + typeCheck(step, fntype); + typeCheck(body, fntype); return nil; } - case Return: { - nlrReturn(NLR_RETURN, eval(get(exp, Return,value), env)); - break; - } - case Continue: { - nlrReturn(NLR_CONTINUE, nil); - break; - } - case Break: { - nlrReturn(NLR_BREAK, nil); - break; - } - case Tvoid: assert(!"unimplemented"); break; - case Tchar: assert(!"unimplemented"); break; - case Tshort: assert(!"unimplemented"); break; - case Tint: assert(!"unimplemented"); break; - case Tlong: assert(!"unimplemented"); break; - case Tfloat: assert(!"unimplemented"); break; - case Tdouble: assert(!"unimplemented"); break; - case Tpointer: assert(!"unimplemented"); break; - case Tarray: assert(!"unimplemented"); break; - case Tstruct: assert(!"unimplemented"); break; - case Tfunction: assert(!"unimplemented"); break; - case Tetc: assert(!"unimplemented"); break; - case VarDecls: { - oop vars = get(exp, VarDecls,variables); - Array_do(vars, var) { - oop name = get(var, Variable,name); - oop type = get(var, Variable,type); - oop init = get(var, Variable,value); - oop valu = nil; - if (is(Tfunction, type)) continue; // function declaration - // do this now so that init can refer to the new variable - oop var = declareVariable(name, type, valu); - if (!isNil(init)) valu = eval(init, nil); - set (var, Variable,value, valu); + case Primitive: { + oop type = get(exp, Primitive,type ); + oop name = get(exp, Primitive,name ); + oop parameters = get(exp, Primitive,parameters); + oop ptypes = newArray(); + oop result = makeType(type, name); + name = makeName(name); + set(exp, Primitive,name, name); + set(exp, Primitive,type, result); + if (Array_size(parameters) && t_etc == Array_last(parameters)) { + Array_popLast(parameters); + set(exp, Primitive,variadic, 1); + } + Array_do(parameters, var) { + oop ptype = makeBaseType(get(var, Variable,type)); + if (t_void == ptype && (do_index || do_size > 1)) + fatal("illegal void parameter"); + oop pname = get(var, Variable,name); + ptype = makeType(ptype, pname); + pname = makeName(pname); + set(var, Variable,name, pname); + set(var, Variable,type, ptype); + Array_append(ptypes, ptype); + } + if (1 == Array_size(ptypes) && Array_last(ptypes) == t_void) { + Array_popLast(ptypes); + Array_popLast(parameters); } + assert(isNil(fntype)); + if (get(exp, Primitive,variadic)) Array_append(ptypes, t_etc); + fntype = newTfunction(result, ptypes); + set(exp, Primitive,type, fntype); +# define _(X) if (s_##X == name) set(exp, Primitive,function, prim_##X); + _do_primitives(_); +# undef _ + if (!get(exp, Primitive,function)) + fatal("external symbol '%s' is undefined", toString(name)); + declare(name, exp); return nil; } - case TypeDecls: { - oop types = get(exp, TypeDecls,typenames); - Array_do(types, type) { - oop name = get(type, TypeName,name); - oop type = get(type, TypeName,type); - declareType(name, type); + case Function: { + oop type = makeBaseType(get(exp, Function,type)); + oop name = get(exp, Function,name ); + oop parameters = get(exp, Function,parameters); + oop body = get(exp, Function,body ); + oop ptypes = newArray(); + oop result = makeType(type, name); + name = makeName(name); + set(exp, Function,name, name); + set(exp, Function,type, result); + if (Array_size(parameters) && t_etc == Array_last(parameters)) { + Array_popLast(parameters); + set(exp, Function,variadic, 1); + } + Array_do(parameters, var) { + oop ptype = makeBaseType(get(var, Variable,type)); + if (t_void == ptype && (do_index || do_size > 1)) + fatal("illegal void parameter"); + oop pname = get(var, Variable,name); + ptype = makeType(ptype, pname); + pname = makeName(pname); + set(var, Variable,name, pname); + set(var, Variable,type, ptype); + Array_append(ptypes, ptype); + } + if (1 == Array_size(ptypes) && Array_last(ptypes) == t_void) { + Array_popLast(ptypes); + Array_popLast(parameters); } + assert(isNil(fntype)); + if (get(exp, Function,variadic)) Array_append(ptypes, t_etc); + fntype = newTfunction(result, ptypes); + set(exp, Function,type, fntype); + declare(name, exp); // add function to global scope so recursive calls will work + Scope_begin(); // parameters + Array_do(parameters, param) declare(get(param, Variable,name), param); + typeCheck(body, fntype); // block + Scope_end(); return nil; } - case Scope: break; - case TypeName: break; - case Variable: break; - case Constant: break; - case Function: break; - } - assert(!"this cannot happen"); - return 0; -} - -// pre-evaluate a top-level declaration, definition, or constant expression - -oop preval(oop exp) -{ - if (opt_v > 2) { printf("PREVAL "); println(exp); } - switch (getType(exp)) { - case Undefined: break; - case Input: break; - case Integer: return exp; - case Float: return exp; - case Symbol: break; - case Pair: break; - case String: break; - case Array: break; - case Memory: break; - case Primitive: return exp; - case Reference: break; - case Closure: break; - case Call: break; - case Block: break; - case Address: break; - case Dereference: break; - case Sizeof: return get(exp, Sizeof,size); - case Unary: break; - case Binary: break; - case Assign: break; - case Cast: break; - case While: break; - case For: break; - case If: break; - case Return: break; - case Continue: break; - case Break: break; - case Tvoid: break; - case Tchar: break; - case Tshort: break; - case Tint: break; - case Tlong: break; - case Tfloat: break; - case Tdouble: break; - case Tpointer: break; - case Tarray: break; - case Tstruct: break; - case Tfunction: break; - case Tetc: break; + case Block: { + Scope_begin(); + oop statements = get(exp, Block,statements); + Array_do(statements, statement) typeCheck(statement, fntype); + Scope_end(); + return nil; + } + case Call: { + oop function = get(exp, Call,function ); + oop arguments = get(exp, Call,arguments); + oop tfunc = typeCheck(function, fntype); + if (!is(Tfunction, tfunc)) fatal("cannot call %s", getTypeName(tfunc)); + oop params = get(tfunc, Tfunction,parameters); + int argc = get(arguments, Array,size); + oop *argv = get(arguments, Array,elements); + int parc = get(params, Array,size); + oop *parv = get(params, Array,elements); + int vararg = parc && (t_etc == parv[parc - 1]); + if ((!vararg && (argc != parc)) || (vararg && (argc < parc - 1))) + fatal("wrong number (%d) of arguments, expected %d", argc, parc); + int argn = 0; + while (argn < argc) { + oop part = parv[argn]; + if (part == t_etc) break; + oop arg = argv[argn++]; + oop argt = typeCheck(arg, fntype); + if (argt != part) { + if (is(Tpointer, argt) && t_pvoid == part) continue; + if (is(Tpointer, part) && t_pvoid == argt) continue; + fatal("cannot pass argument of type '%s' to parameter of type '%s': %s ", + toString(argt), toString(part), toString(exp)); + } + } + while (argn < argc) typeCheck(argv[argn++], fntype); + return get(tfunc, Tfunction,result); + } + case Return: { + assert(nil != fntype); + oop result = get(fntype, Tfunction,result); + oop value = get(exp, Return,value); + oop vtype = isNil(value) ? t_void : typeCheck(value, fntype); + if (vtype != result) + fatal("incompatible return of %s from function returning %s", + toString(vtype), toString(result)); + return result; + } case VarDecls: { - oop vars = get(exp, VarDecls,variables); - Array_do(vars, var) { - assert(Scope_lookup(get(var, Variable,name))); - oop init = get(var, Variable,value); - if (!isNil(init)) set(var, Variable,value, preval(init)); + oop base = makeBaseType(get(exp, VarDecls,type)); + oop decls = get(exp, VarDecls,variables); + oop vars = newArray(); + Array_do(decls, decl) { + oop init = nil; + if (is(Assign, decl)) { + init = get(decl, Assign,rhs); + decl = get(decl, Assign,lhs); + } + oop varname = makeName(decl); + oop vartype = makeType(base, decl); + if (is(Tfunction, vartype)) { + oop ptypes = get(vartype, Tfunction,parameters); + if (1 == Array_size(ptypes) && t_void == Array_last(ptypes)) { + Array_popLast(ptypes); + // make unique + vartype = newTfunction(get(vartype, Tfunction,result), ptypes); + } + } + oop old = Scope_local(varname); + if (old) { // declared + oop oldtype = nil; + switch (getType(old)) { + case Variable: { + oldtype = get(old, Variable,type); + if (oldtype == vartype) { // identical declarations + oop oldval = get(old, Variable,value); + if (isNil(fntype)) // global declarations + if (isNil(init) || isNil(oldval)) // at most one initialiser + continue; // redeclaration is permitted + fatal("multiple definiton of variable '%s'", toString(varname)); + } + break; + } + case Function: oldtype = get(old, Function,type); break; + case Primitive: oldtype = get(old, Primitive,type); break; + default: + fatal("cannot find type of declaration: %s", toString(old)); + } + if (vartype == oldtype) continue; + fatal("identifier '%s' redefined as different type: %s -> %s", + toString(varname), + declareString(oldtype, varname), + declareString(vartype, varname)); + } + // do this now so that initialiser can refer to the new variable + oop var = declareVariable(varname, vartype, init); + Array_append(vars, var); + if (!isNil(init)) { + oop initype = typeCheck(init, fntype); + cvt_t cvt = converter(getType(initype), getType(vartype)); + if (!cvt) { + fatal("initialising '%s': cannot convert '%s' to '%s'", + toString(varname), toString(vartype), toString(initype)); + } + } } + set(exp, VarDecls,variables, vars); return nil; } case TypeDecls: { - oop types = get(exp, TypeDecls,typenames); - Array_do(types, type) { - assert(Scope_lookup(get(type, TypeName,name))); + oop base = makeBaseType(get(exp, TypeDecls,type)); + oop decls = get(exp, TypeDecls,typenames); + oop typenames = newArray(); + Array_do(decls, decl) { + oop name = makeName(decl); + oop type = makeType(base, decl); + if (is(Tfunction, type)) { + oop ptypes = get(type, Tfunction,parameters); + if (1 == Array_size(ptypes) && t_void == Array_last(ptypes)) { + Array_popLast(ptypes); + type = newTfunction(get(type, Tfunction,result), ptypes); + } + } + oop old = Scope_local(name); + if (old) { // declared + if (getType(old) != TypeName) + fatal("'%s' redeclared as different kind of symbol", toString(name)); + oop oldtype = get(old, TypeName,type); + if (oldtype != type) + fatal("incompatible declarations of type '%s': %s -> %s", + toString(name), toString(oldtype), toString(type)); + } + else { + oop typename = declareType(name, type); + Array_append(typenames, typename); + } } + set(exp, TypeDecls,typenames, typenames); return nil; } - case Scope: break; - case TypeName: break; - case Variable: break; - case Constant: break; - case Function: { - assert(Scope_lookup(get(exp, Function,name))); - return exp; - } + default: + break; } - println(exp); - assert(!"this cannot happen"); + fatal("cannot typeCheck: %s", toString(exp)); return 0; } -// primitive functions - -#define _do_primitives(_) \ - _(printf) _(assert) _(malloc) - -#define _(X) oop s_##X = 0; -_do_primitives(_) -#undef _ - -oop prim_printf(int argc, oop *argv, oop env) // array +oop assign(oop lhs, oop rhs) { - oop result = nil; - if (argc < 1) fatal("printf: no format string"); - oop format = argv[0]; - if (!is(String, format)) fatal("printf: format is not a string"); - char *fmt = get(format, String,elements); - int size = get(format, String,size); - int n = 0; - int argn = 1; - for (int i = 0; i < size;) { - int c = fmt[i++]; - if (c == '%' && fmt[i]) { - c = fmt[i++]; - if (c == '%') goto echo; - if (argn >= argc) fatal("too few arguments for printf format string"); - oop arg = argv[argn++]; - switch (c) { - case 'd': { - if (!is(Integer, arg)) - fatal("%%d conversion argument is %s", getTypeName(arg)); - n += printf("%ld", _integerValue(arg)); - continue; - } - case 'p': { - switch (getType(arg)) { - case Integer: - n += printf("%p", (void *)(intptr_t)_integerValue(arg)); - continue; - case Reference: - n += printf("%p", get(arg, Reference,target)); - continue; - default: - break; + //printf("ASSIGN "); println(lhs); + //printf(" = "); println(rhs); + oop dst = lhs; + if (is(Symbol, lhs)) lhs = Scope_lookup(lhs); + switch (getType(lhs)) { + case Variable: { + oop ltype = get(lhs, Variable,type); + if (is(Tpointer, ltype)) { + switch (getType(rhs)) { + case Integer: { + rhs = newPointer(ltype, rhs, 0); + break; + } + case Pointer: { + if (get(rhs, Pointer,type) != ltype) + rhs = newPointer(ltype, get(rhs, Pointer,base), get(rhs, Pointer,offset)); + break; + } + default: { + fatal("cannot assign '%s' = '%s'", getTypeName(lhs), getTypeName(rhs)); } - fatal("%%p conversion argument is %s", getTypeName(arg)); - continue; } - case 's': { - if (!is(String, arg)) - fatal("%%d conversion argument is %s", getTypeName(arg)); - n += printf("%.*s", get(arg, String,size), get(arg, String,elements)); - continue; + } + return set(lhs, Variable,value, rhs); + } + case Dereference: { // *<&var> = rhs + lhs = eval(get(dst, Dereference,rhs), nil); + switch (getType(lhs)) { + case Pointer: { // &x + oop base = get(lhs, Pointer,base); + int offset = get(lhs, Pointer,offset); + oop type = get(get(lhs, Pointer,type), Tpointer,target); + int scale = typeSize(type); + switch (getType(base)) { + case Integer: { // (void *)(intptr_t)N + fatal("attempt to store into arbitrary memory location"); + } + case Variable: { // &var + if (offset) fatal("pointer modified"); + return set(base, Variable,value, rhs); + } + case Memory: { + int size = get(base, Memory,size); + if (offset < 0 || offset * scale > size - scale) + fatal("assigning to out-of-bounds pointer"); + void *addr = get(base, Memory,base) + offset * scale; + switch (getType(type)) { + case Tchar: return newInteger(*(char *)addr = _integerValue(rhs)); + case Tshort: return newInteger(*(short *)addr = _integerValue(rhs)); + case Tint: return newInteger(*(int *)addr = _integerValue(rhs)); + case Tlong: return newInteger(*(long *)addr = _integerValue(rhs)); + case Tfloat: return newFloat (*(float *)addr = _floatValue(rhs)); + case Tdouble: return newFloat (*(double *)addr = _floatValue(rhs)); + default: break; + } + fatal("cannot store '%s' through pointer", getTypeName(type)); + } + default: break; + } } - default: - fatal("illegal printf conversion: %%%c", c); + default: break; } } - echo: - putchar(c); - ++n; - } - if (argn != argc) fatal("too many arguments for printf format string"); - return newInteger(n); -} - -int toBoolean(oop arg) -{ - switch (getType(arg)) { - case Integer: return _integerValue(arg); - case Float: return integerValue(arg); - case Reference: return 1; - default: fatal("cannot convert %s to boolean", getTypeName(arg)); + default: break; } + if (dst == lhs) + fatal("cannot assign to: %s", toString(lhs)); + else + fatal("invalid rvalue '%s' assigning to: %s", + toString(lhs), toString(dst)); + abort(); return 0; } -oop prim_assert(int argc, oop *argv, oop env) // array -{ - if (argc != 1) fatal("assert: wrong number of arguments"); - int value = toBoolean(argv[0]); - if (!value) fatal("assertion failed\n"); - return nil; -} - -oop prim_malloc(int argc, oop *argv, oop env) // array +int equal(oop a, oop b) { - if (argc != 1) fatal("malloc: wrong number of arguments"); - oop arg = argv[0]; - if (is(Integer,arg)) { - size_t size = _integerValue(arg); - if (size >= 0) { - if (size > 10*1024*1024) - fatal("cowardly refusing to allocate memory of size %zd", size); - void *mem = malloc(_integerValue(arg)); - if (!mem) fatal("malloc(%zd) failed", size); - return newMemory(mem, size); + if (a == b) return 1; + type_t ta = getType(a), tb = getType(b); + if (ta == tb) { + switch (getType(a)) { + case Integer: return _integerValue(a) == _integerValue(b); + case Float: return _floatValue(a) == _floatValue(b); + case Pointer: return get(a, Pointer,base) == get(b, Pointer,base); + default: break; } + fatal("cannot compare %ss", getTypeName(a)); } - fatal("malloc: invalid argument: %s", toString(arg)); - return 0; -} - -enum opcode_t { iHALT = 0, iPUSH, iPOP, - iNOT, iCOM, iNEG, iDEREF, iINDEX, - iMUL, iDIV, iMOD, iADD, iSUB, iSHL, iSHR, - iLT, iLE, iGE, iGT, iEQ, iNE, - iAND, iXOR, iOR, - iGETGVAR, iSETGVAR, - iCLOSE, - iCALL, iRETURN, - iJMP, iJMPF, -}; - -oop stackError(char *reason) -{ - printf("stack %s\n", reason); - exit(1); - return nil; -} - -void disassemble(oop program) -{ - oop *code = get(program, Array,elements); - int size = get(program, Array,size); - int pc = 0; - while (pc < size) { - printf("%04d", pc); - int opcode = _integerValue(code[pc++]); - printf(" %02d\t", opcode); - switch (opcode) { - case iHALT: printf("HALT\n"); break; - case iPUSH: printf("PUSH\t"); println(code[pc++]); break; - case iPOP: printf("POP\n"); break; - case iNOT: printf("NOT\n"); break; - case iCOM: printf("COM\n"); break; - case iNEG: printf("NEG\n"); break; - case iDEREF: printf("DEREF\n"); break; - case iINDEX: printf("INDEX\n"); break; - case iMUL: printf("MUL\n"); break; - case iDIV: printf("DIV\n"); break; - case iMOD: printf("MOD\n"); break; - case iADD: printf("ADD\n"); break; - case iSUB: printf("SUB\n"); break; - case iSHL: printf("SHL\n"); break; - case iSHR: printf("SHR\n"); break; - case iLT: printf("LT\n"); break; - case iLE: printf("LE\n"); break; - case iGE: printf("GE\n"); break; - case iGT: printf("GT\n"); break; - case iEQ: printf("EQ\n"); break; - case iNE: printf("NE\n"); break; - case iAND: printf("AND\n"); break; - case iXOR: printf("XOR\n"); break; - case iOR: printf("OR\n"); break; - case iGETGVAR: printf("GETGVAR\t"); println(code[pc++]); break; - case iSETGVAR: printf("SETGVAR\t"); println(code[pc++]); break; - case iCLOSE: printf("CLOSE\t"); println(code[pc++]); break; - case iCALL: printf("CALL\t"); println(code[pc++]); break; - case iRETURN: printf("RETURN\n"); break; - case iJMP: printf("JMP\t"); println(code[pc++]); break; - case iJMPF: printf("JMPF\t"); println(code[pc++]); break; + else { + if (is(Pointer, a) && is(Integer, b)) { + oop base = get(a, Pointer,base); + if (is(Integer, base)) { + oop type = get(a, Pointer,type); + int offset = get(a, Pointer,offset); + int scale = typeSize(get(type, Tpointer,target)); + return _integerValue(base) + offset * scale == _integerValue(b); + } + return 0; } } + fatal("cannot compare %s with %s", getTypeName(a), getTypeName(b)); + return 0; } - -oop execute(oop program) +oop eval(oop exp, oop env) { - oop *code = get(program, Array,elements); - int pc = 0; - - oop stack[32]; - int sp = 32; // clear the stack - - oop env = nil; - - struct Frame { - Object *env; - oop *code; - int pc; - } frames[32]; - int fp = 32; - -# define push(O) (sp > 0 ? stack[--sp] = (O) : stackError("overflow")) -# define pop() (sp < 32 ? stack[sp++] : stackError("underflow")) -# define top (stack[sp]) - - for (;;) { - oop insn = code[pc++]; - switch ((enum opcode_t)_integerValue(insn)) { - case iHALT: { - if (sp < 31) fatal("%d items on stack at end of execution", 32-sp); - if (sp < 32) return stack[sp]; - fatal("stack empty at end of execution"); - return nil; - } - case iPUSH: { - oop operand = code[pc++]; - push(operand); - continue; - } - case iPOP: { - pop(); - continue; + if (opt_v > 2) { printf("EVAL "); println(exp); } + switch (getType(exp)) { + case Undefined: assert(!"this cannot happen"); + case Input: assert(!"this cannot happen"); + case Integer: return exp; + case Float: return exp; + case Pointer: return exp; + case Symbol: { + oop value = Scope_lookup(exp); + if (!value) fatal("'%s' is undefined\n", get(exp, Symbol,name)); + if (isNil(value)) fatal("'%s' is uninitialised\n", get(exp, Symbol,name)); + switch (getType(value)) { + case Variable: return get(value, Variable,value); + case Function: return value; + case Primitive: return value; + default: fatal("cannot eval: %s", toString(value)); } - case iNOT: { - top = (isFalse(top) ? true : false); - continue; + break; + } + case Pair: assert(!"this cannot happen"); + case String: return exp; + case Array: assert(!"this cannot happen"); + case Memory: assert(!"this cannot happen"); + case Primitive: return exp; + case Reference: return exp; + case Closure: return exp; + case Call: { + oop fun = eval(get(exp, Call,function), env); + oop args = get(exp, Call,arguments); + return apply(fun, args, nil); + } + case Block: { + Object *stmts = get(exp, Block,statements); + int size = get(stmts, Array,size); + oop *elts = get(stmts, Array,elements); + Object *result = nil; + Scope_begin(); + switch (nlrPush()) { // longjmp occurred + case NLR_INIT: break; + case NLR_RETURN: Scope_end(); return nlrPop(); + case NLR_CONTINUE: Scope_end(); nlrReturn(NLR_CONTINUE, nlrPop()); + case NLR_BREAK: Scope_end(); nlrReturn(NLR_BREAK, nlrPop()); } - case iCOM: { - top = newInteger(~integerValue(top)); - continue; + for (int i = 0; i < size; ++i) { + result = eval(elts[i], env); } - case iNEG: { - top = is(Float, top) ? newFloat(-floatValue(top)) : newInteger(-integerValue(top)); - continue; + Scope_end(); + nlrPop(); + return result; + } + case Addressof: { + oop rhs = get(exp, Addressof,rhs); + switch (getType(rhs)) { + case Symbol: { + rhs = Scope_lookup(rhs); + if (!rhs) assert(!"this cannot happen"); + switch (getType(rhs)) { + case Variable: + return newPointer(newTpointer(get(rhs, Variable,type)), rhs, 0); + default: + break; + } + break; + } + default: + break; } - case iDEREF: { - assert(!"unimplemented"); - continue; + fatal("cannot take address of: %s", toString(rhs)); + break; + } + case Dereference: { + oop rhs = get(exp, Dereference,rhs); + rhs = eval(rhs, nil); + switch (getType(rhs)) { + case Pointer: { + oop base = get(rhs, Pointer,base); + switch (getType(base)) { + case Variable: return get(base, Variable,value); + default: break; + } + break; + } + default: break; } - case iINDEX: { - assert(!"unimplemented"); - continue; - } -# define BINOP(OP) { \ - oop rhs = pop(), lhs = pop(); \ - if (is(Float, lhs) || is(Float, rhs)) push(FBINOP(lhs, OP, rhs)); \ - else push(IBINOP(lhs, OP, rhs)); \ - continue; \ - } - case iMUL: BINOP(*); - case iDIV: BINOP(/); - case iMOD: { - oop rhs = pop(), lhs = pop(); - if (is(Float, lhs) || is(Float, rhs)) - push(newFloat(fmod(floatValue(lhs), floatValue(rhs)))); - else - push(IBINOP(lhs, %, rhs)); - continue; - } - case iADD: BINOP(+); - case iSUB: BINOP(-); -# undef BINOP -# define BINOP(OP) { \ - oop rhs = pop(), lhs = pop(); \ - push(IBINOP(lhs, OP, rhs)); \ - continue; \ - } - case iSHL: BINOP(<<); - case iSHR: BINOP(>>); - case iAND: BINOP(&); - case iXOR: BINOP(^); - case iOR: BINOP(|); -# undef BINOP -# define BINOP(OP) { \ - oop rhs = pop(), lhs = pop(); \ - if (is(Float, lhs) || is(Float, rhs)) \ - push(floatValue(lhs) OP floatValue(rhs) ? true : false); \ - else \ - push(integerValue(lhs) OP integerValue(rhs) ? true : false); \ - continue; \ - } - case iLT: BINOP(< ); - case iLE: BINOP(<=); - case iGE: BINOP(>=); - case iGT: BINOP(> ); - case iEQ: BINOP(==); - case iNE: BINOP(!=); -# undef BINOP - case iGETGVAR: { - oop operand = code[pc++]; - oop keyval = assoc(env, operand); - if (nil != keyval) { - push(get(keyval, Pair,tail)); - continue; + printf("cannot dereference\n"); + println(rhs); + exit(1); + break; + } + case Sizeof: { + return get(exp, Sizeof,size); + } + case Unary: { + unary_t op = get(exp, Unary,operator); + oop rhs = get(exp, Unary,rhs); + switch (op) { + case PREINC: + case PREDEC: + case POSTINC: + case POSTDEC: { + if (is(Symbol, rhs)) { + rhs = Scope_lookup(rhs); + switch (getType(rhs)) { + case Variable: { + oop val = get(rhs, Variable,value); + oop result = nil; + switch (op) { + case PREINC: val = incr(val, 1); result = val; break; + case PREDEC: val = incr(val, -1); result = val; break; + case POSTINC: result = val; val = incr(val, 1); break; + case POSTDEC: result = val; val = incr(val, -1); break; + default: assert("!this cannot happen"); + } + set(rhs, Variable,value, val); + return result; + } + default: break; + } + } + fatal("illegal increment operation: %s", toString(exp)); } - push(get(operand, Symbol,value)); - continue; - } - case iSETGVAR: { - oop operand = code[pc++]; - oop keyval = assoc(env, operand); - if (nil != keyval) { - set(keyval, Pair,tail, top); - continue; + case NEG: + case NOT: + case COM: { + rhs = eval(rhs, env); + switch (op) { + case NEG: return ( is(Float, rhs) + ? newFloat (-floatValue (rhs)) + : newInteger(-integerValue(rhs)) ); + case NOT: return isFalse(rhs) ? true : false; + case COM: return newInteger(~integerValue(rhs)); + default: break; + } } - set(operand, Symbol,value, top); - continue; - } - case iCLOSE: { - oop func = code[pc++]; - push(newClosure(func, env)); - continue; } - case iCALL: { - int argc = _integerValue(code[pc++]); - oop func = pop(); - switch (getType(func)) { - case Primitive: { - oop result = get(func, Primitive,function)(argc, stack + sp, nil); - sp += argc; // pop all arguments - push(result); - continue; // next instruction + assert("!this cannot happen"); + break; + } + case Binary: { + oop lhs = get(exp, Binary,lhs); + oop rhs = get(exp, Binary,rhs); + switch (get(exp, Binary,operator)) { + case LAND: return isFalse(eval(lhs, env)) ? false : eval(rhs, env); + case LOR: return isTrue (eval(lhs, env)) ? true : eval(rhs, env); + default: { + lhs = eval(lhs, env); + rhs = eval(rhs, env); + if (Float == getType(lhs) || Float == getType(rhs)) { // floating point result + switch (get(exp, Binary,operator)) { + case INDEX: assert(!"unimplemented"); + case MUL: return FBINOP(lhs, * , rhs); + case DIV: return FBINOP(lhs, / , rhs); + case MOD: return newFloat(fmod(floatValue(lhs), floatValue(rhs))); + case ADD: return FBINOP(lhs, + , rhs); + case SUB: return FBINOP(lhs, - , rhs); + case SHL: return IBINOP(lhs, <<, rhs); + case SHR: return IBINOP(lhs, >>, rhs); + case LT: return FRELOP(lhs, < , rhs); + case LE: return FRELOP(lhs, <=, rhs); + case GE: return FRELOP(lhs, >=, rhs); + case GT: return FRELOP(lhs, > , rhs); + case EQ: return FRELOP(lhs, == , rhs); + case NE: return FRELOP(lhs, !=, rhs); + case BAND: return IBINOP(lhs, & , rhs); + case BXOR: return IBINOP(lhs, ^ , rhs); + case BOR: return IBINOP(lhs, | , rhs); + case LAND: + case LOR: + break; + } } - case Closure: { - Object *function = get(func, Closure,function); - Object *environment = get(func, Closure,environment); - Object *parameters = get(function, Function,parameters); - int parc = get(parameters, Array,size); - oop *parv = get(parameters, Array,elements); - int parn = 0; - while (parn < parc && argc > 0) { - environment = newPair(newPair(parv[parn++], pop()), environment); - --argc; + else { // integer result + switch (get(exp, Binary,operator)) { + case INDEX: assert("!unimplemented"); + case MUL: return IBINOP(lhs, * , rhs); + case DIV: return IBINOP(lhs, / , rhs); + case MOD: return IBINOP(lhs, % , rhs); + case ADD: return IBINOP(lhs, + , rhs); + case SUB: return IBINOP(lhs, - , rhs); + case SHL: return IBINOP(lhs, <<, rhs); + case SHR: return IBINOP(lhs, >>, rhs); + case LT: return IRELOP(lhs, < , rhs); + case LE: return IRELOP(lhs, <=, rhs); + case GE: return IRELOP(lhs, >=, rhs); + case GT: return IRELOP(lhs, > , rhs); + case EQ: return equal(lhs, rhs) ? true : false; + case NE: return equal(lhs, rhs) ? false : true; + case BAND: return IBINOP(lhs, & , rhs); + case BXOR: return IBINOP(lhs, ^ , rhs); + case BOR: return IBINOP(lhs, | , rhs); + case LAND: + case LOR: + break; } - while (parn < parc) - environment = newPair(newPair(parv[parn++], nil), environment); - sp += argc; - if (fp < 1) fatal("too many function calls"); - --fp; - frames[fp].env = env; env = environment; - frames[fp].code = code; code = get(function, Function,code); - frames[fp].pc = pc; pc = 0; - assert(code != 0); - continue; } - default: - fatal("cannot call value of type %d", getType(func)); } - continue; } - case iRETURN: { - assert(fp < 32); - env = frames[fp].env; - code = frames[fp].code; - pc = frames[fp].pc; - ++fp; - continue; + assert(!"this cannot happen"); + break; + } + case Assign: { + return assign(get(exp, Assign,lhs), eval(get(exp, Assign,rhs), nil)); + } + case Cast: { + cvt_t cvt = get(exp, Cast,converter); assert(cvt); + oop rhs = eval(get(exp, Cast,rhs), nil); + return cvt(rhs); + } + case While: { + oop cond = get(exp, While,condition); + oop expr = get(exp, While,expression); + oop result = nil; + switch (nlrPush()) { + case NLR_INIT: break; + case NLR_RETURN: nlrReturn(NLR_RETURN, nlrPop()); // propagate upwards + case NLR_CONTINUE: break; + case NLR_BREAK: return nlrPop(); } - case iJMP: { - int dest = _integerValue(code[pc++]); - pc = dest; - continue; + while (isTrue(eval(cond, env))) { + result = eval(expr, env); } - case iJMPF: { - int dest = _integerValue(code[pc++]); - oop cond = pop(); - if (nil == cond) pc = dest; - continue; + nlrPop(); + return result; + } + case For: { + oop init = get(exp, For,initialiser); + oop cond = get(exp, For,condition); + oop step = get(exp, For,update); + oop body = get(exp, For,body); + eval(init, nil); + while (integerValue(eval(cond, nil))) { + eval(body, nil); + eval(step, nil); } - } - } - assert(!"this cannot happen"); - return 0; -} - -#define EMITo(O) Array_append(program, (O)) -#define EMITi(I) EMITo(newInteger(I)) - -#define EMIToo(O, P) (( EMITo(O), EMITo(P) )) -#define EMITio(I, P) EMIToo(newInteger(I), P) -#define EMITii(I, J) EMIToo(newInteger(I), newInteger(J)) - -oop compileFunction(oop exp); - -void compileOn(oop exp, oop program, oop cs, oop bs) -{ - switch (getType(exp)) { - case Undefined: EMITio(iPUSH, exp); return; - case Input: EMITio(iPUSH, exp); return; - case Integer: EMITio(iPUSH, exp); return; - case Float: EMITio(iPUSH, exp); return; - case Symbol: EMITio(iGETGVAR, exp); return; - case Pair: EMITio(iPUSH, exp); return; - case String: EMITio(iPUSH, exp); return; - case Array: assert(!"unimplemented"); - case Memory: assert(!"unimplemented"); - case Primitive: EMITio(iPUSH, exp); return; - case Reference: assert(!"unimplemented"); - case Closure: EMITio(iPUSH, exp); return; - case Call: { - Object *args = get(exp, Call,arguments); - int argc = get(args, Array,size); - oop *argv = get(args, Array,elements); - for (int n = argc; n--;) compileOn(argv[n], program, cs, bs); - compileOn(get(exp, Call,function), program, cs, bs); // GETVAR print - EMITii(iCALL, argc); - return; - } - case Block: { - oop statements = get(exp, Block,statements); - int size = get(statements, Array,size); - if (0 == size) { - EMITio(iPUSH, nil); - return; - } - oop *exps = get(statements, Array,elements); - for (int i = 0; i < size - 1; ++i) { - compileOn(exps[i], program, cs, bs); - EMITi(iPOP); - } - compileOn(exps[size - 1], program, cs, bs); - return; - } - case Address: assert(0); - case Dereference: assert(0); - case Sizeof: assert(0); - case Unary: { - compileOn(get(exp, Unary,rhs), program, cs, bs); - switch (get(exp, Unary,operator)) { - case NEG: EMITi(iNEG); return; - case NOT: EMITi(iNOT); return; - case COM: EMITi(iCOM); return; - case PREINC: assert(!"unimplemented"); - case PREDEC: assert(!"unimplemented"); - case POSTINC: assert(!"unimplemented"); - case POSTDEC: assert(!"unimplemented"); - } - break; - } - case Binary: { // MUL{op, lhs, rhs} - switch (get(exp, Binary,operator)) { - case LAND: assert(!"unimplemented"); - case LOR: assert(!"unimplemented"); - default: break; - } - compileOn(get(exp, Binary,lhs), program, cs, bs); - compileOn(get(exp, Binary,rhs), program, cs, bs); - switch (get(exp, Binary,operator)) { - case INDEX: assert(!"unimplemented"); - case MUL: EMITi(iMUL); return; - case DIV: EMITi(iDIV); return; - case MOD: EMITi(iMOD); return; - case ADD: EMITi(iADD); return; - case SUB: EMITi(iSUB); return; - case SHL: EMITi(iSHL); return; - case SHR: EMITi(iSHR); return; - case LT: EMITi(iLT); return; - case LE: EMITi(iLE); return; - case GE: EMITi(iGE); return; - case GT: EMITi(iGT); return; - case EQ: EMITi(iEQ); return; - case NE: EMITi(iNE); return; - case BAND: EMITi(iAND); return; - case BXOR: EMITi(iXOR); return; - case BOR: EMITi(iOR); return; - case LAND: - case LOR: - assert(!"unimplemented"); - } - } - - case Assign: { - oop symbol = get(exp, Assign,lhs); - oop expr = get(exp, Assign,rhs); - compileOn(expr, program, cs, bs); - EMITio(iSETGVAR, symbol); - return; - } - - case Cast: { - assert(!"unimplemented"); - return; - } - -# define LABEL(NAME) int NAME = get(program, Array,size) -# define PATCH(J, L) Array_set(program, J+1, newInteger(L)) - - case While: { - oop continues = newArray(); - oop breaks = newArray(); - oop cond = get(exp, While,condition); - oop body = get(exp, While,expression); - EMITio(iPUSH, nil); - LABEL(L1); - compileOn(cond, program, cs, bs); // break/continue apply to enclosing loop - LABEL(J1); - EMITio(iJMPF, nil); - EMITi(iPOP); - compileOn(body, program, continues, breaks); - EMITii(iJMP, L1); - LABEL(L2); - PATCH(J1, L2); - for (int i = get(continues, Array,size); i--;) - PATCH(_integerValue(get(continues, Array,elements)[i]), L1); - for (int i = get(breaks, Array,size); i--;) - PATCH(_integerValue(get(breaks, Array,elements)[i]), L2); - return; - } - case For: { - assert(!"unimplemented"); - return; + return nil; } case If: { oop cond = get(exp, If,condition); oop conseq = get(exp, If,consequent); oop altern = get(exp, If,alternate); - compileOn(cond, program, cs, bs); - LABEL(J1); - EMITio(iJMPF, nil); // L1 - compileOn(conseq, program, cs, bs); - LABEL(J2); - EMITio(iJMP, nil); // L2 - LABEL(L1); - compileOn(altern, program, cs, bs); - LABEL(L2); - PATCH(J1, L1); - PATCH(J2, L2); - return; + if (isTrue(eval(cond, env))) eval(conseq, env); + else if (!isNil(altern)) eval(altern, env); + return nil; + } + case Return: { + nlrReturn(NLR_RETURN, eval(get(exp, Return,value), env)); + break; } - case Return: assert(!"unimplemented"); case Continue: { - if (nil == cs) fatal("continue outside loop"); - EMITio(iPUSH, nil); - LABEL(L1); - EMITio(iJMP, nil); - Array_append(cs, newInteger(L1)); - return; + nlrReturn(NLR_CONTINUE, nil); + break; } case Break: { - if (nil == bs) fatal("continue outside loop"); - EMITio(iPUSH, nil); - LABEL(L1); - EMITio(iJMP, nil); - Array_append(bs, newInteger(L1)); - return; + nlrReturn(NLR_BREAK, nil); + break; } - case Tvoid: assert(!"unimplemented"); return; - case Tchar: assert(!"unimplemented"); return; - case Tshort: assert(!"unimplemented"); return; - case Tint: assert(!"unimplemented"); return; - case Tlong: assert(!"unimplemented"); return; - case Tfloat: assert(!"unimplemented"); return; - case Tdouble: assert(!"unimplemented"); return; - case Tpointer: assert(!"unimplemented"); return; - case Tarray: assert(!"unimplemented"); return; - case Tstruct: assert(!"unimplemented"); return; - case Tfunction: assert(!"unimplemented"); return; - case Tetc: assert(!"unimplemented"); return; - case VarDecls: assert(!"unimplemented"); return; - case TypeDecls: assert(!"unimplemented"); return; - case Scope: assert(!"this cannot happen"); return; - case TypeName: assert(!"unimplemented"); return; - case Variable: assert(!"unimplemented"); return; - case Constant: assert(!"unimplemented"); return; - case Function: { - assert(0 == get(exp, Function,code)); - oop prog2 = compileFunction(get(exp, Function,body)); - set(exp, Function,code, get(prog2, Array,elements)); - EMITio(iCLOSE, exp); - return; + case Tvoid: assert(!"unimplemented"); break; + case Tchar: assert(!"unimplemented"); break; + case Tshort: assert(!"unimplemented"); break; + case Tint: assert(!"unimplemented"); break; + case Tlong: assert(!"unimplemented"); break; + case Tfloat: assert(!"unimplemented"); break; + case Tdouble: assert(!"unimplemented"); break; + case Tpointer: assert(!"unimplemented"); break; + case Tarray: assert(!"unimplemented"); break; + case Tstruct: assert(!"unimplemented"); break; + case Tfunction: assert(!"unimplemented"); break; + case Tetc: assert(!"unimplemented"); break; + case VarDecls: { + oop vars = get(exp, VarDecls,variables); + Array_do(vars, var) { + oop name = get(var, Variable,name); + oop type = get(var, Variable,type); + oop init = get(var, Variable,value); + if (is(Tfunction, type)) continue; // function declaration + // do this now so that init can refer to the new variable + oop var = declareVariable(name, type, nil); + if (!isNil(init)) assign(var, eval(init, nil)); + } + return nil; + } + case TypeDecls: { + oop types = get(exp, TypeDecls,typenames); + Array_do(types, type) { + oop name = get(type, TypeName,name); + oop type = get(type, TypeName,type); + declareType(name, type); + } + return nil; } + case Scope: break; + case TypeName: break; + case Variable: break; + case Constant: break; + case Function: break; } + assert(!"this cannot happen"); + return 0; } -oop compileFunction(oop exp) -{ - oop program = newArray(); - compileOn(exp, program, nil, nil); - EMITi(iRETURN); - if (opt_v > 2) disassemble(program); - return program; -} - -oop compile(oop exp) // 6*7 -{ - oop program = newArray(); - compileOn(exp, program, nil, nil); - EMITi(iHALT); - if (opt_v > 2) disassemble(program); - return program; -} +// pre-evaluate a top-level declaration, definition, or constant expression -int isType(oop obj) +oop preval(oop exp) { - type_t type = getType(obj); - return Tvoid <= type && type <= Tfunction; + if (opt_v > 2) { printf("PREVAL "); println(exp); } + switch (getType(exp)) { + case Undefined: break; + case Input: break; + case Integer: return exp; + case Float: return exp; + case Pointer: return exp; + case Symbol: break; + case Pair: break; + case String: break; + case Array: break; + case Memory: break; + case Primitive: return exp; + case Reference: break; + case Closure: break; + case Call: break; + case Block: break; + case Addressof: break; + case Dereference: break; + case Sizeof: return get(exp, Sizeof,size); + case Unary: break; + case Binary: break; + case Assign: break; + case Cast: break; + case While: break; + case For: break; + case If: break; + case Return: break; + case Continue: break; + case Break: break; + case Tvoid: break; + case Tchar: break; + case Tshort: break; + case Tint: break; + case Tlong: break; + case Tfloat: break; + case Tdouble: break; + case Tpointer: break; + case Tarray: break; + case Tstruct: break; + case Tfunction: break; + case Tetc: break; + case VarDecls: { + oop vars = get(exp, VarDecls,variables); + Array_do(vars, var) { + assert(Scope_lookup(get(var, Variable,name))); + oop init = get(var, Variable,value); + if (!isNil(init)) assign(var, preval(init)); + } + return nil; + } + case TypeDecls: { + oop types = get(exp, TypeDecls,typenames); + Array_do(types, type) { + assert(Scope_lookup(get(type, TypeName,name))); + } + return nil; + } + case Scope: break; + case TypeName: break; + case Variable: break; + case Constant: break; + case Function: { + assert(Scope_lookup(get(exp, Function,name))); + return exp; + } + } + println(exp); + assert(!"this cannot happen"); + return 0; } -int typeSize(oop type) +enum opcode_t { iHALT = 0, iPUSH, iPOP, + iNOT, iCOM, iNEG, iDEREF, iINDEX, + iMUL, iDIV, iMOD, iADD, iSUB, iSHL, iSHR, + iLT, iLE, iGE, iGT, iEQ, iNE, + iAND, iXOR, iOR, + iGETGVAR, iSETGVAR, + iCLOSE, + iCALL, iRETURN, + iJMP, iJMPF, +}; + +oop stackError(char *reason) { - switch (getType(type)) { - case Tvoid: return 1; - case Tchar: return 1; - case Tshort: return 2; - case Tint: return 4; - case Tlong: return 8; - case Tfloat: return 4; - case Tdouble: return 8; - case Tpointer: return 8; // fixme: make this a parameter - case Tstruct: assert(!"unimplemented"); - case Tarray: assert(!"unimplemented"); - case Tfunction: assert(!"unimplemented"); - default: assert(!"this cannot happen"); + printf("stack %s\n", reason); + exit(1); + return nil; +} + +void disassemble(oop program) +{ + oop *code = get(program, Array,elements); + int size = get(program, Array,size); + int pc = 0; + while (pc < size) { + printf("%04d", pc); + int opcode = _integerValue(code[pc++]); + printf(" %02d\t", opcode); + switch (opcode) { + case iHALT: printf("HALT\n"); break; + case iPUSH: printf("PUSH\t"); println(code[pc++]); break; + case iPOP: printf("POP\n"); break; + case iNOT: printf("NOT\n"); break; + case iCOM: printf("COM\n"); break; + case iNEG: printf("NEG\n"); break; + case iDEREF: printf("DEREF\n"); break; + case iINDEX: printf("INDEX\n"); break; + case iMUL: printf("MUL\n"); break; + case iDIV: printf("DIV\n"); break; + case iMOD: printf("MOD\n"); break; + case iADD: printf("ADD\n"); break; + case iSUB: printf("SUB\n"); break; + case iSHL: printf("SHL\n"); break; + case iSHR: printf("SHR\n"); break; + case iLT: printf("LT\n"); break; + case iLE: printf("LE\n"); break; + case iGE: printf("GE\n"); break; + case iGT: printf("GT\n"); break; + case iEQ: printf("EQ\n"); break; + case iNE: printf("NE\n"); break; + case iAND: printf("AND\n"); break; + case iXOR: printf("XOR\n"); break; + case iOR: printf("OR\n"); break; + case iGETGVAR: printf("GETGVAR\t"); println(code[pc++]); break; + case iSETGVAR: printf("SETGVAR\t"); println(code[pc++]); break; + case iCLOSE: printf("CLOSE\t"); println(code[pc++]); break; + case iCALL: printf("CALL\t"); println(code[pc++]); break; + case iRETURN: printf("RETURN\n"); break; + case iJMP: printf("JMP\t"); println(code[pc++]); break; + case iJMPF: printf("JMPF\t"); println(code[pc++]); break; + } + } +} + + +oop execute(oop program) +{ + oop *code = get(program, Array,elements); + int pc = 0; + + oop stack[32]; + int sp = 32; // clear the stack + + oop env = nil; + + struct Frame { + Object *env; + oop *code; + int pc; + } frames[32]; + int fp = 32; + +# define push(O) (sp > 0 ? stack[--sp] = (O) : stackError("overflow")) +# define pop() (sp < 32 ? stack[sp++] : stackError("underflow")) +# define top (stack[sp]) + + for (;;) { + oop insn = code[pc++]; + switch ((enum opcode_t)_integerValue(insn)) { + case iHALT: { + if (sp < 31) fatal("%d items on stack at end of execution", 32-sp); + if (sp < 32) return stack[sp]; + fatal("stack empty at end of execution"); + return nil; + } + case iPUSH: { + oop operand = code[pc++]; + push(operand); + continue; + } + case iPOP: { + pop(); + continue; + } + case iNOT: { + top = (isFalse(top) ? true : false); + continue; + } + case iCOM: { + top = newInteger(~integerValue(top)); + continue; + } + case iNEG: { + top = is(Float, top) ? newFloat(-floatValue(top)) : newInteger(-integerValue(top)); + continue; + } + case iDEREF: { + assert(!"unimplemented"); + continue; + } + case iINDEX: { + assert(!"unimplemented"); + continue; + } +# define BINOP(OP) { \ + oop rhs = pop(), lhs = pop(); \ + if (is(Float, lhs) || is(Float, rhs)) push(FBINOP(lhs, OP, rhs)); \ + else push(IBINOP(lhs, OP, rhs)); \ + continue; \ + } + case iMUL: BINOP(*); + case iDIV: BINOP(/); + case iMOD: { + oop rhs = pop(), lhs = pop(); + if (is(Float, lhs) || is(Float, rhs)) + push(newFloat(fmod(floatValue(lhs), floatValue(rhs)))); + else + push(IBINOP(lhs, %, rhs)); + continue; + } + case iADD: BINOP(+); + case iSUB: BINOP(-); +# undef BINOP +# define BINOP(OP) { \ + oop rhs = pop(), lhs = pop(); \ + push(IBINOP(lhs, OP, rhs)); \ + continue; \ + } + case iSHL: BINOP(<<); + case iSHR: BINOP(>>); + case iAND: BINOP(&); + case iXOR: BINOP(^); + case iOR: BINOP(|); +# undef BINOP +# define BINOP(OP) { \ + oop rhs = pop(), lhs = pop(); \ + if (is(Float, lhs) || is(Float, rhs)) \ + push(floatValue(lhs) OP floatValue(rhs) ? true : false); \ + else \ + push(integerValue(lhs) OP integerValue(rhs) ? true : false); \ + continue; \ + } + case iLT: BINOP(< ); + case iLE: BINOP(<=); + case iGE: BINOP(>=); + case iGT: BINOP(> ); + case iEQ: BINOP(==); + case iNE: BINOP(!=); +# undef BINOP + case iGETGVAR: { + oop operand = code[pc++]; + oop keyval = assoc(env, operand); + if (nil != keyval) { + push(get(keyval, Pair,tail)); + continue; + } + push(get(operand, Symbol,value)); + continue; + } + case iSETGVAR: { + oop operand = code[pc++]; + oop keyval = assoc(env, operand); + if (nil != keyval) { + set(keyval, Pair,tail, top); + continue; + } + set(operand, Symbol,value, top); + continue; + } + case iCLOSE: { + oop func = code[pc++]; + push(newClosure(func, env)); + continue; + } + case iCALL: { + int argc = _integerValue(code[pc++]); + oop func = pop(); + switch (getType(func)) { + case Primitive: { + oop result = get(func, Primitive,function)(argc, stack + sp, nil); + sp += argc; // pop all arguments + push(result); + continue; // next instruction + } + case Closure: { + Object *function = get(func, Closure,function); + Object *environment = get(func, Closure,environment); + Object *parameters = get(function, Function,parameters); + int parc = get(parameters, Array,size); + oop *parv = get(parameters, Array,elements); + int parn = 0; + while (parn < parc && argc > 0) { + environment = newPair(newPair(parv[parn++], pop()), environment); + --argc; + } + while (parn < parc) + environment = newPair(newPair(parv[parn++], nil), environment); + sp += argc; + if (fp < 1) fatal("too many function calls"); + --fp; + frames[fp].env = env; env = environment; + frames[fp].code = code; code = get(function, Function,code); + frames[fp].pc = pc; pc = 0; + assert(code != 0); + continue; + } + default: + fatal("cannot call value of type %d", getType(func)); + } + continue; + } + case iRETURN: { + assert(fp < 32); + env = frames[fp].env; + code = frames[fp].code; + pc = frames[fp].pc; + ++fp; + continue; + } + case iJMP: { + int dest = _integerValue(code[pc++]); + pc = dest; + continue; + } + case iJMPF: { + int dest = _integerValue(code[pc++]); + oop cond = pop(); + if (nil == cond) pc = dest; + continue; + } + } } + assert(!"this cannot happen"); return 0; } -oop typeCheck(oop exp, oop fntype) +#define EMITo(O) Array_append(program, (O)) +#define EMITi(I) EMITo(newInteger(I)) + +#define EMIToo(O, P) (( EMITo(O), EMITo(P) )) +#define EMITio(I, P) EMIToo(newInteger(I), P) +#define EMITii(I, J) EMIToo(newInteger(I), newInteger(J)) + +oop compileFunction(oop exp); + +void compileOn(oop exp, oop program, oop cs, oop bs) { - printf("TYPECHECK "); println(exp); switch (getType(exp)) { - case Integer: return t_int; - case Float: return t_float; - case String: return t_string; - case Symbol: { - oop value = Scope_lookup(exp); - if (!value) fatal("undefined variable '%s'", symbolName(exp)); - if (nil == value) fatal("uninitialised variable '%s'", symbolName(exp)); - switch (getType(value)) { - case Primitive: return get(value, Primitive,type); - case Function: return get(value, Function,type); - case Variable: return get(value, Variable,type); - default: - fatal("cannot typecheck value of type %s", getTypeName(value)); - } - return nil; - } - case Address: { - return newTpointer(typeCheck(get(exp, Address,rhs), fntype)); + case Undefined: EMITio(iPUSH, exp); return; + case Input: EMITio(iPUSH, exp); return; + case Integer: EMITio(iPUSH, exp); return; + case Float: EMITio(iPUSH, exp); return; + case Pointer: assert(!"unimplemented"); + case Symbol: EMITio(iGETGVAR, exp); return; + case Pair: EMITio(iPUSH, exp); return; + case String: EMITio(iPUSH, exp); return; + case Array: assert(!"unimplemented"); + case Memory: assert(!"unimplemented"); + case Primitive: EMITio(iPUSH, exp); return; + case Reference: assert(!"unimplemented"); + case Closure: EMITio(iPUSH, exp); return; + case Call: { + Object *args = get(exp, Call,arguments); + int argc = get(args, Array,size); + oop *argv = get(args, Array,elements); + for (int n = argc; n--;) compileOn(argv[n], program, cs, bs); + compileOn(get(exp, Call,function), program, cs, bs); // GETVAR print + EMITii(iCALL, argc); + return; } - case Dereference: { - oop rhs = typeCheck(get(exp, Dereference,rhs), fntype); - if (!is(Tpointer, rhs)) { - fatal("cannot dereference '%s'", toString(rhs)); + case Block: { + oop statements = get(exp, Block,statements); + int size = get(statements, Array,size); + if (0 == size) { + EMITio(iPUSH, nil); + return; } - return get(rhs, Tpointer,target); - } - case Cast: { - oop lhs = makeBaseType(get(exp, Cast,type)); - set(exp, Cast,type, lhs); - oop rhs = typeCheck(get(exp, Cast,rhs), fntype); - type_t lht = getType(lhs), rht = getType(rhs); - cvt_t cvt = converter(rht, lht); - if (!cvt) - fatal("cannot convert '%s' to '%s'", toString(rhs), toString(lhs)); - set(exp, Cast,converter, cvt); - return lhs; - } - case Sizeof: { - oop rhs = get(exp, Sizeof,rhs); - if (!isType(rhs)) rhs = typeCheck(rhs, fntype); assert(isType(rhs)); - set(exp, Sizeof,size, newInteger(typeSize(rhs))); - return t_long; + oop *exps = get(statements, Array,elements); + for (int i = 0; i < size - 1; ++i) { + compileOn(exps[i], program, cs, bs); + EMITi(iPOP); + } + compileOn(exps[size - 1], program, cs, bs); + return; } + case Addressof: assert(0); + case Dereference: assert(0); + case Sizeof: assert(0); case Unary: { - oop rhs = typeCheck(get(exp, Unary,rhs), fntype); + compileOn(get(exp, Unary,rhs), program, cs, bs); switch (get(exp, Unary,operator)) { - case NEG: assert(!"unimplemented"); - case NOT: assert(!"unimplemented"); - case COM: assert(!"unimplemented"); - case PREINC: return rhs; - case PREDEC: return rhs; + case NEG: EMITi(iNEG); return; + case NOT: EMITi(iNOT); return; + case COM: EMITi(iCOM); return; + case PREINC: assert(!"unimplemented"); + case PREDEC: assert(!"unimplemented"); case POSTINC: assert(!"unimplemented"); case POSTDEC: assert(!"unimplemented"); } - return nil; + break; } - case Binary: { - oop lhs = typeCheck(get(exp, Binary,lhs), fntype); - oop rhs = typeCheck(get(exp, Binary,rhs), fntype); + case Binary: { // MUL{op, lhs, rhs} switch (get(exp, Binary,operator)) { - case INDEX: assert(!"unimplemented"); break; - case MUL: assert(!"unimplemented"); break; - case DIV: assert(!"unimplemented"); break; - case MOD: assert(!"unimplemented"); break; - case ADD: { - if (lhs == rhs) { - if (t_int == lhs) return lhs; - } - fatal("cannot add '%s' and '%s'", toString(lhs), toString(rhs)); - break; - } - case SUB: assert(!"unimplemented"); break; - case SHL: assert(!"unimplemented"); break; - case SHR: assert(!"unimplemented"); break; - case LT: return t_int; - case LE: assert(!"unimplemented"); break; - case GE: assert(!"unimplemented"); break; - case GT: return t_int; - case EQ: return t_int; - case NE: return t_int; - case BAND: assert(!"unimplemented"); break; - case BXOR: assert(!"unimplemented"); break; - case BOR: assert(!"unimplemented"); break; - case LAND: assert(!"unimplemented"); break; - case LOR: assert(!"unimplemented"); break; - } - return nil; - } - case Assign: { - oop lhs = typeCheck(get(exp, Assign,lhs), fntype); - oop rhs = typeCheck(get(exp, Assign,rhs), fntype); - if (lhs != rhs) - fatal("incompatible types assigning '%s' to '%s'", toString(rhs), toString(lhs)); - return lhs; - } - case If: { - if (t_int != typeCheck(get(exp, If,condition), fntype)) fatal("if condition is not 'int'"); - typeCheck(get(exp, If,consequent), fntype); - if (nil != get(exp, If,alternate)) - typeCheck(get(exp, If,alternate), fntype); - return nil; - } - case While: { - oop cond = get(exp, While,condition); - oop body = get(exp, While,expression); - cond = typeCheck(cond, fntype); - if (t_int != cond) fatal("while condition is not 'int'"); - typeCheck(body, fntype); - return nil; - } - case For: { - oop init = get(exp, For,initialiser); - oop cond = get(exp, For,condition); - oop step = get(exp, For,update); - oop body = get(exp, For,body); - typeCheck(init, fntype); - cond = typeCheck(cond, fntype); - if (t_int != cond) fatal("for condition is not 'int'"); - typeCheck(step, fntype); - typeCheck(body, fntype); - return nil; - } - case Primitive: { - oop type = get(exp, Primitive,type ); - oop name = get(exp, Primitive,name ); - oop parameters = get(exp, Primitive,parameters); - oop ptypes = newArray(); - oop result = makeType(type, name); - name = makeName(name); - set(exp, Primitive,name, name); - set(exp, Primitive,type, result); - if (Array_size(parameters) && t_etc == Array_last(parameters)) { - Array_popLast(parameters); - set(exp, Primitive,variadic, 1); - } - Array_do(parameters, var) { - oop ptype = makeBaseType(get(var, Variable,type)); - if (t_void == ptype && (do_index || do_size > 1)) - fatal("illegal void parameter"); - oop pname = get(var, Variable,name); - ptype = makeType(ptype, pname); - pname = makeName(pname); - set(var, Variable,name, pname); - set(var, Variable,type, ptype); - Array_append(ptypes, ptype); - } - if (1 == Array_size(ptypes) && Array_last(ptypes) == t_void) { - Array_popLast(ptypes); - Array_popLast(parameters); - } - assert(isNil(fntype)); - if (get(exp, Primitive,variadic)) Array_append(ptypes, t_etc); - fntype = newTfunction(result, ptypes); - set(exp, Primitive,type, fntype); -# define _(X) if (s_##X == name) set(exp, Primitive,function, prim_##X); - _do_primitives(_); -# undef _ - if (!get(exp, Primitive,function)) - fatal("external symbol '%s' is undefined", toString(name)); - declare(name, exp); - return nil; - } - case Function: { - oop type = makeBaseType(get(exp, Function,type)); - oop name = get(exp, Function,name ); - oop parameters = get(exp, Function,parameters); - oop body = get(exp, Function,body ); - oop ptypes = newArray(); - oop result = makeType(type, name); - name = makeName(name); - set(exp, Function,name, name); - set(exp, Function,type, result); - if (Array_size(parameters) && t_etc == Array_last(parameters)) { - Array_popLast(parameters); - set(exp, Function,variadic, 1); - } - Array_do(parameters, var) { - oop ptype = makeBaseType(get(var, Variable,type)); - if (t_void == ptype && (do_index || do_size > 1)) - fatal("illegal void parameter"); - oop pname = get(var, Variable,name); - ptype = makeType(ptype, pname); - pname = makeName(pname); - set(var, Variable,name, pname); - set(var, Variable,type, ptype); - Array_append(ptypes, ptype); + case LAND: assert(!"unimplemented"); + case LOR: assert(!"unimplemented"); + default: break; } - if (1 == Array_size(ptypes) && Array_last(ptypes) == t_void) { - Array_popLast(ptypes); - Array_popLast(parameters); + compileOn(get(exp, Binary,lhs), program, cs, bs); + compileOn(get(exp, Binary,rhs), program, cs, bs); + switch (get(exp, Binary,operator)) { + case INDEX: assert(!"unimplemented"); + case MUL: EMITi(iMUL); return; + case DIV: EMITi(iDIV); return; + case MOD: EMITi(iMOD); return; + case ADD: EMITi(iADD); return; + case SUB: EMITi(iSUB); return; + case SHL: EMITi(iSHL); return; + case SHR: EMITi(iSHR); return; + case LT: EMITi(iLT); return; + case LE: EMITi(iLE); return; + case GE: EMITi(iGE); return; + case GT: EMITi(iGT); return; + case EQ: EMITi(iEQ); return; + case NE: EMITi(iNE); return; + case BAND: EMITi(iAND); return; + case BXOR: EMITi(iXOR); return; + case BOR: EMITi(iOR); return; + case LAND: + case LOR: + assert(!"unimplemented"); } - assert(isNil(fntype)); - if (get(exp, Function,variadic)) Array_append(ptypes, t_etc); - fntype = newTfunction(result, ptypes); - set(exp, Function,type, fntype); - declare(name, exp); // add function to global scope so recursive calls will work - Scope_begin(); // parameters - Array_do(parameters, param) declare(get(param, Variable,name), param); - typeCheck(body, fntype); // block - Scope_end(); - return nil; } - case Block: { - Scope_begin(); - oop statements = get(exp, Block,statements); - Array_do(statements, statement) typeCheck(statement, fntype); - Scope_end(); - return nil; + + case Assign: { + oop symbol = get(exp, Assign,lhs); + oop expr = get(exp, Assign,rhs); + compileOn(expr, program, cs, bs); + EMITio(iSETGVAR, symbol); + return; } - case Call: { - oop function = get(exp, Call,function ); - oop arguments = get(exp, Call,arguments); - oop tfunc = typeCheck(function, fntype); - if (!is(Tfunction, tfunc)) fatal("cannot call %s", getTypeName(tfunc)); - oop params = get(tfunc, Tfunction,parameters); - int argc = get(arguments, Array,size); - oop *argv = get(arguments, Array,elements); - int parc = get(params, Array,size); - oop *parv = get(params, Array,elements); - int vararg = parc && (t_etc == parv[parc - 1]); - printf("argc %d parc %d\n", argc, parc); - if ((!vararg && (argc != parc)) || (vararg && (argc < parc - 1))) - fatal("wrong number (%d) of arguments, expected %d", argc, parc); - int argn = 0; - while (argn < argc) { - oop part = parv[argn]; - if (part == t_etc) break; - oop arg = argv[argn++]; - oop argt = typeCheck(arg, fntype); - if (argt != part) - fatal("cannot pass argument of type '%s' to parameter of type '%s': %s ", - toString(argt), toString(part), toString(exp)); - } - while (argn < argc) typeCheck(argv[argn++], fntype); - return get(tfunc, Tfunction,result); + + case Cast: { + assert(!"unimplemented"); + return; } - case Return: { - assert(nil != fntype); - oop result = get(fntype, Tfunction,result); - oop value = get(exp, Return,value); - oop vtype = isNil(value) ? t_void : typeCheck(value, fntype); - if (vtype != result) - fatal("incompatible return of %s from function returning %s", - toString(vtype), toString(result)); - return result; + +# define LABEL(NAME) int NAME = get(program, Array,size) +# define PATCH(J, L) Array_set(program, J+1, newInteger(L)) + + case While: { + oop continues = newArray(); + oop breaks = newArray(); + oop cond = get(exp, While,condition); + oop body = get(exp, While,expression); + EMITio(iPUSH, nil); + LABEL(L1); + compileOn(cond, program, cs, bs); // break/continue apply to enclosing loop + LABEL(J1); + EMITio(iJMPF, nil); + EMITi(iPOP); + compileOn(body, program, continues, breaks); + EMITii(iJMP, L1); + LABEL(L2); + PATCH(J1, L2); + for (int i = get(continues, Array,size); i--;) + PATCH(_integerValue(get(continues, Array,elements)[i]), L1); + for (int i = get(breaks, Array,size); i--;) + PATCH(_integerValue(get(breaks, Array,elements)[i]), L2); + return; } - case VarDecls: { - oop base = makeBaseType(get(exp, VarDecls,type)); - oop decls = get(exp, VarDecls,variables); - oop vars = newArray(); - Array_do(decls, decl) { - oop init = nil; - if (is(Assign, decl)) { - init = get(decl, Assign,rhs); - decl = get(decl, Assign,lhs); - } - oop varname = makeName(decl); - oop vartype = makeType(base, decl); - if (is(Tfunction, vartype)) { - oop ptypes = get(vartype, Tfunction,parameters); - if (1 == Array_size(ptypes) && t_void == Array_last(ptypes)) { - Array_popLast(ptypes); - // make unique - vartype = newTfunction(get(vartype, Tfunction,result), ptypes); - } - } - oop old = Scope_local(varname); - if (old) { // declared - oop oldtype = nil; - switch (getType(old)) { - case Variable: { - oldtype = get(old, Variable,type); - if (oldtype == vartype) { // identical declarations - oop oldval = get(old, Variable,value); - if (isNil(fntype)) // global declarations - if (isNil(init) || isNil(oldval)) // at most one initialiser - continue; // redeclaration is permitted - fatal("multiple definiton of variable '%s'", toString(varname)); - } - break; - } - case Function: oldtype = get(old, Function,type); break; - case Primitive: oldtype = get(old, Primitive,type); break; - default: - fatal("cannot find type of declaration: %s", toString(old)); - } - if (vartype == oldtype) continue; - fatal("identifier '%s' redefined as different type: %s -> %s", - toString(varname), - declareString(oldtype, varname), - declareString(vartype, varname)); - } - // do this now so that initialiser can refer to the new variable - oop var = declareVariable(varname, vartype, init); - Array_append(vars, var); - if (!isNil(init)) { - oop initype = typeCheck(init, fntype); - cvt_t cvt = converter(getType(initype), getType(vartype)); - if (!cvt) { - fatal("initialising '%s': cannot convert '%s' to '%s'", - toString(varname), toString(vartype), toString(initype)); - } - } - } - set(exp, VarDecls,variables, vars); - return nil; + case For: { + assert(!"unimplemented"); + return; } - case TypeDecls: { - oop base = makeBaseType(get(exp, TypeDecls,type)); - oop decls = get(exp, TypeDecls,typenames); - oop typenames = newArray(); - Array_do(decls, decl) { - oop name = makeName(decl); - oop type = makeType(base, decl); - if (is(Tfunction, type)) { - oop ptypes = get(type, Tfunction,parameters); - if (1 == Array_size(ptypes) && t_void == Array_last(ptypes)) { - Array_popLast(ptypes); - type = newTfunction(get(type, Tfunction,result), ptypes); - } - } - oop old = Scope_local(name); - if (old) { // declared - if (getType(old) != TypeName) - fatal("'%s' redeclared as different kind of symbol", toString(name)); - oop oldtype = get(old, TypeName,type); - if (oldtype != type) - fatal("incompatible declarations of type '%s': %s -> %s", - toString(name), toString(oldtype), toString(type)); - } - else { - oop typename = declareType(name, type); - Array_append(typenames, typename); - } - } - set(exp, TypeDecls,typenames, typenames); - return nil; + case If: { + oop cond = get(exp, If,condition); + oop conseq = get(exp, If,consequent); + oop altern = get(exp, If,alternate); + compileOn(cond, program, cs, bs); + LABEL(J1); + EMITio(iJMPF, nil); // L1 + compileOn(conseq, program, cs, bs); + LABEL(J2); + EMITio(iJMP, nil); // L2 + LABEL(L1); + compileOn(altern, program, cs, bs); + LABEL(L2); + PATCH(J1, L1); + PATCH(J2, L2); + return; + } + case Return: assert(!"unimplemented"); + case Continue: { + if (nil == cs) fatal("continue outside loop"); + EMITio(iPUSH, nil); + LABEL(L1); + EMITio(iJMP, nil); + Array_append(cs, newInteger(L1)); + return; + } + case Break: { + if (nil == bs) fatal("continue outside loop"); + EMITio(iPUSH, nil); + LABEL(L1); + EMITio(iJMP, nil); + Array_append(bs, newInteger(L1)); + return; + } + case Tvoid: assert(!"unimplemented"); return; + case Tchar: assert(!"unimplemented"); return; + case Tshort: assert(!"unimplemented"); return; + case Tint: assert(!"unimplemented"); return; + case Tlong: assert(!"unimplemented"); return; + case Tfloat: assert(!"unimplemented"); return; + case Tdouble: assert(!"unimplemented"); return; + case Tpointer: assert(!"unimplemented"); return; + case Tarray: assert(!"unimplemented"); return; + case Tstruct: assert(!"unimplemented"); return; + case Tfunction: assert(!"unimplemented"); return; + case Tetc: assert(!"unimplemented"); return; + case VarDecls: assert(!"unimplemented"); return; + case TypeDecls: assert(!"unimplemented"); return; + case Scope: assert(!"this cannot happen"); return; + case TypeName: assert(!"unimplemented"); return; + case Variable: assert(!"unimplemented"); return; + case Constant: assert(!"unimplemented"); return; + case Function: { + assert(0 == get(exp, Function,code)); + oop prog2 = compileFunction(get(exp, Function,body)); + set(exp, Function,code, get(prog2, Array,elements)); + EMITio(iCLOSE, exp); + return; } - default: - break; } - fatal("cannot typeCheck: %s", toString(exp)); - return 0; } +oop compileFunction(oop exp) +{ + oop program = newArray(); + compileOn(exp, program, nil, nil); + EMITi(iRETURN); + if (opt_v > 2) disassemble(program); + return program; +} + +oop compile(oop exp) // 6*7 +{ + oop program = newArray(); + compileOn(exp, program, nil, nil); + EMITi(iHALT); + if (opt_v > 2) disassemble(program); + return program; +} void replFile(char *name, FILE *file) { input = pushInput(name, file); @@ -3432,7 +3593,9 @@ int main(int argc, char **argv) t_long = newTlong(); t_float = newTfloat(); t_double = newTdouble(); - t_string = newTpointer(t_char); + t_pvoid = newTpointer(t_void); + t_pchar = newTpointer(t_char); + t_ppchar = newTpointer(t_pchar); t_etc = newTetc(); scopes = newArray(); @@ -3441,7 +3604,7 @@ int main(int argc, char **argv) #if 0 declarePrimitive(intern("printf"), - newTfunction(t_int, newArray2(t_string, t_etc)), + newTfunction(t_int, newArray2(t_pchar, t_etc)), prim_printf); #endif @@ -3481,15 +3644,14 @@ int main(int argc, char **argv) if (!entry || isNil(entry)) fatal("main is not defined"); if (!is(Function, entry)) fatal("main is not a function"); oop params = get(get(entry, Function,type), Tfunction, parameters); - oop t_sptr = newTpointer(newTpointer(t_char)); switch (Array_size(params)) { default: fatal("main has too many parameters"); case 3: - if (Array_get(params, 2) != t_sptr) + if (Array_get(params, 2) != t_ppchar) fatal("third parameter of main should be 'char **'"); case 2: - if (Array_get(params, 1) != t_sptr) + if (Array_get(params, 1) != t_ppchar) fatal("second parameter of main should be 'char **'"); case 1: if (Array_get(params, 0) != t_int)