type check variable declarations

main.leg

@@ -1,6 +1,6 @@
 # main.leg -- C parser + interpreter
 #
-# Last edited: 2025-01-20 17:35:37 by piumarta on zora
+# Last edited: 2025-01-21 11:58:53 by piumarta on zora
 
 %{
 ;
@@ -54,12 +54,12 @@ typedef union Object Object, *oop;
 
 #define YYSTYPE oop
 
-#define _do_types(_)										\
-    _(Undefined) _(Input) _(Integer) _(Float) _(Symbol) _(Pair) _(String) _(Array)		\
-    _(Closure) _(Call)										\
-    _(Block) _(Unary) _(Binary) _(Cast) _(While) _(For) _(If) _(Return) _(Continue) _(Break)	\
-    _(Tbase) _(Tpointer) _(Tarray) _(Tstruct) _(Tfunction)					\
-    _(Scope) _(TypeName) _(Variable) _(Constant) _(Function) _(Primitive)			\
+#define _do_types(_)									\
+    _(Undefined) _(Input) _(Integer) _(Float) _(Symbol) _(Pair) _(String) _(Array)	\
+    _(Closure) _(Call) _(Block) _(Unary) _(Binary) _(Assign) _(Cast) 			\
+    _(While) _(For) _(If) _(Return) _(Continue) _(Break)				\
+    _(Tbase) _(Tpointer) _(Tarray) _(Tstruct) _(Tfunction)				\
+    _(Scope) _(TypeName) _(Variable) _(Constant) _(Function) _(Primitive)		\
     _(VarDecls)
 
 
@@ -76,7 +76,6 @@ typedef enum {
     MUL, DIV, MOD, ADD, SUB, SHL, SHR,
     LT, LE, GE, GT, EQ, NE,
     BAND, BXOR, BOR, LAND, LOR,
-    ASSIGN,
 } binary_t;
 
 typedef oop (* prim_t)(int nargs, oop *arguments, oop environment);
@@ -94,6 +93,7 @@ struct Call   	 { type_t _type;  oop function, arguments; };
 struct Block   	 { type_t _type;  oop statements; };
 struct Unary   	 { type_t _type;  unary_t  operator;  oop      rhs; };
 struct Binary  	 { type_t _type;  binary_t operator;  oop lhs, rhs; };
+struct Assign  	 { type_t _type;  oop lhs, rhs; };
 struct Cast   	 { type_t _type;  oop type, declarator, rhs; };
 struct While   	 { type_t _type;  oop condition, expression; };
 struct For   	 { type_t _type;  oop initialiser, condition, update, body; };
@@ -132,6 +132,7 @@ union Object
     struct Block      Block;
     struct Unary      Unary;
     struct Binary     Binary;
+    struct Assign     Assign;
     struct Cast       Cast;
     struct For        For;
     struct While      While;
@@ -411,10 +412,11 @@ char *String_appendAll(oop string, char *chars, int len)
     return chars;
 }
 
-#define Array_do(ARR, VAR)						\
-    for (int do_size = get(ARR, Array,size), do_index = 0;		\
-	 do_index < do_size && (VAR = (ARR)->Array.elements[do_index]);	\
-	 ++do_index)
+#define Array_do(ARR, VAR)							\
+    for (oop do_array = (ARR), VAR = nil;  do_array;  do_array = 0)		\
+	for (int do_size = get(do_array, Array,size), do_index = 0;		\
+	     do_index < do_size && (VAR = do_array->Array.elements[do_index]);	\
+	     ++do_index)
 
 oop newArray(void)
 {
@@ -555,6 +557,7 @@ oop newBinary(binary_t operator, oop lhs, oop rhs)
     return obj;
 }
 
+CTOR2(Assign, lhs, rhs);
 CTOR3(Cast,   type, declarator, rhs);
 CTOR2(While,  condition, expression);
 CTOR4(For,    initialiser, condition, update, body);
@@ -581,16 +584,28 @@ oop t_string = 0;
 
 oop newTpointer(oop target)
 {
+    static oop pointers = 0;
+    if (!pointers) pointers = newArray();
+    Array_do(pointers, t)
+	if (target == get(t, Tpointer,target))
+	    return t; // uniqe types allow comparison by identity
     oop obj = new(Tpointer);
     obj->Tpointer.target = target;
+    Array_append(pointers, obj);
     return obj;
 }
 
 oop newTarray(oop target, oop size)
 {
+    static oop arrays = 0;
+    if (!arrays) arrays = newArray();
+    Array_do(arrays, t)
+	if (target == get(t, Tarray,target) && size == get(t, Tarray,size))
+	    return t; // uniqe types allow comparison by identity
     oop obj = new(Tarray);
     obj->Tarray.target = target;
     obj->Tarray.size   = size;
+    Array_append(arrays, obj);
     return obj;
 }
 
@@ -624,7 +639,7 @@ int Scope_find(oop scope, oop name)
     oop  names = get(scope, Scope,names);
     int  size  = get(names, Array,size);
     oop *elts  = get(names, Array,elements);
-    for (int i = size;  i--;)
+    for (int i = size;  i--;) // fixme: binary search
 	if (name == elts[i])
 	    return i;
     return -1;
@@ -701,11 +716,17 @@ oop makeTypes(oop declarations)
 oop makeType(oop base, oop type)
 {
     switch (getType(type)) {
+	case Undefined:	return base;
 	case Symbol:	return base;
+	case Assign:	return makeType(base, get(type, Assign,lhs));
 	case Tpointer:	return newTpointer(makeType(base, get(type, Tpointer,target)));
+	case Tarray:	return newTarray(makeType(base, get(type, Tarray,target)),
+					 get(type, Tarray,size));
+	case Tfunction:	return newTfunction(base, get(type, Tfunction,parameters));
 	default:	break;
     }
     printf("cannot make type from delcaration: ");
+    println(base);
     println(type);
     exit(1);
     return 0;
@@ -717,7 +738,10 @@ oop makeName(oop decl)
     switch (getType(decl)) {
 	case Undefined:
 	case Symbol:	return decl;
+	case Assign:	return makeName(get(decl, Assign,lhs));
 	case Tpointer:	return makeName(get(decl, Tpointer,target));
+	case Tarray:	return makeName(get(decl, Tarray,target));
+	case Tfunction:	return makeName(get(decl, Tfunction,result));
 	default:	break;
     }
     printf("cannot make name from delcaration: ");
@@ -726,25 +750,25 @@ oop makeName(oop decl)
     return 0;
 }
 
+void VarDecls_append(oop vds, oop decl)
+{
+    oop val  = is(Assign, decl) ? get(decl, Assign,rhs) : nil;
+    oop type = makeType(get(vds, VarDecls,type), decl);
+    oop name = makeName(decl);
+    Array_append(get(vds, VarDecls,declarations), decl);
+    Array_append(get(vds, VarDecls,variables), newVariable(name, type, val));
+}
+
 oop newVarDecls(oop type, oop decl)
 {
     oop obj = new(VarDecls);
     obj->VarDecls.type         = type;
     obj->VarDecls.declarations = newArray();
     obj->VarDecls.variables    = newArray();
-    Array_append(obj->VarDecls.declarations, decl);
-    Array_append(obj->VarDecls.variables, newVariable(makeName(decl), makeType(type, decl), nil));
+    VarDecls_append(obj, decl);
     return obj;
 }
 
-void VarDecls_append(oop vds, oop decl)
-{
-    Array_append(get(vds, VarDecls,declarations), decl);
-    oop type = makeType(get(vds, VarDecls,type), decl);
-    oop name = makeName(decl);
-    Array_append(get(vds, VarDecls,variables), newVariable(name, type, nil));
-}
-
 #undef CTOR4
 #undef CTOR3
 #undef CTOR2
@@ -775,6 +799,13 @@ void declareStringOn(oop type, oop name, oop str)
 	    String_append(str, '*');
 	    declareStringOn(get(type, Tpointer,target), name, str);
 	    break;
+	case Tarray: {
+	    declareStringOn(get(type, Tarray,target), name, str);
+	    String_append(str, '[');
+	    toStringOn(get(type, Tarray,size), str);
+	    String_append(str, ']');
+	    break;
+	}
 	default:
 	    fatal("cannot convert to declaration: %s", getTypeName(type));
     }
@@ -784,6 +815,9 @@ oop toStringOn(oop obj, oop str)
 {
     int n = 0;
     switch (getType(obj)) {
+	case Undefined:
+	    String_appendAll(str, "<NIL>", 5);
+	    break;
 	case Symbol:
 	    String_appendAll(str, get(obj, Symbol,name), strlen(get(obj, Symbol,name)));
 	    break;
@@ -805,7 +839,6 @@ oop toStringOn(oop obj, oop str)
 	    oop params = get(obj, Tfunction,parameters);
 	    toStringOn(result, str);
 	    String_append(str, '(');
-	    oop param = nil;
 	    Array_do(params, param) {
 		if (do_index) String_appendAll(str, ", ", 2);
 		toStringOn(param, str);
@@ -817,8 +850,10 @@ oop toStringOn(oop obj, oop str)
 	    oop type = get(obj, Variable,type);
 	    oop name = get(obj, Variable,name);
 	    toStringOn(baseType(type), str);
-	    String_append(str, ' ');
-	    declareStringOn(type, name, str);
+	    if (t_void != type) {
+		String_append(str, ' ');
+		declareStringOn(type, name, str);
+	    }
 	    break;
 	}
 	case Function: {
@@ -827,7 +862,6 @@ oop toStringOn(oop obj, oop str)
 	    toStringOn(get(obj, Function,name), str);
 	    String_append(str, '(');
 	    oop params = get(obj, Function,parameters);
-	    oop param  = nil;
 	    Array_do(params, param) {
 		if (do_index) String_appendAll(str, ", ", 2);
 		toStringOn(param, str);
@@ -839,7 +873,6 @@ oop toStringOn(oop obj, oop str)
 	    oop vars = get(obj, VarDecls,variables);
 	    oop base  = get(obj, VarDecls,type);
 	    oop decls = get(obj, VarDecls,declarations);
-	    oop decl  = nil;
 	    Array_do(decls, decl) {
 		if (do_index) String_appendAll(str, ", ", 2);
 		toStringOn(decl, str);
@@ -957,12 +990,17 @@ void printiln(oop obj, int indent)
 		case BOR: 	printf("BOR\n"); 	break;
 		case LAND: 	printf("LAND\n"); 	break;
 		case LOR: 	printf("LOR\n"); 	break;
-		case ASSIGN: 	printf("ASSIGN\n"); 	break;
 	    }
 	    printiln(get(obj, Binary,lhs), indent+1);
 	    printiln(get(obj, Binary,rhs), indent+1);
 	    break;
 	}
+	case Assign: {
+	    printf("ASSIGN\n");
+	    printiln(get(obj, Assign,lhs), indent+1);
+	    printiln(get(obj, Assign,rhs), indent+1);
+	    break;
+	}
 	case Cast: {
 	    printf("CAST\n");
 	    printiln(get(obj, Cast,type      ), indent+1);
@@ -1169,11 +1207,16 @@ tname	= INT				{ $$ = t_int  }
 struct	= STRUCT ( i:id m:members	{ $$ = newTstruct(  i,   m) }
 	  	 | i:id			{ $$ = newTstruct(nil,   m) }
 	  	 |      m:members	{ $$ = newTstruct(  i, nil) }
+		 | e:error		{ expected(e, "structure/union definition") }
 	  	 )
 
-members = LBRACE vardecl* RBRACE
+members = LBRACE vardecl* ( RBRACE
+	  	 	  | e:error	{ expected(e, "struct/union member specification") }
+			  )
 
-inidecl	= d:decltor ( ASSIGN e:initor	{ $$ = newBinary(ASSIGN, d, e) }
+inidecl	= d:decltor ( ASSIGN ( e:initor	{ $$ = newAssign(d, e) }
+	  	      	     | e:error	{ expected(e, "variable initialiser") }
+			     )
 	  	    |			{ $$ = d }
 		    )
 
@@ -1189,7 +1232,9 @@ ddector	= ( LPAREN d:decltor RPAREN
 params	= LPAREN a:mkArray
 	  ( p:pdecl			{ Array_append(a, p) }
 	    ( COMMA p:pdecl		{ Array_append(a, p) }
-	    )* )? RPAREN		{ $$ = a }
+	    )* )? ( RPAREN		{ $$ = a }
+	       	  | e:error		{ expected(e, "parameter declaration") }
+		  )
 
 pdecl	= t:tname d:decltor		{ $$ = newVarDecls(t, d) }
 
@@ -1208,7 +1253,9 @@ funid	= STAR   d:funid		{ $$ = newUnary(DEREF, d) }
 
 block	= LBRACE b:mkArray
 	  ( s:stmt			{ Array_append(b, s) }
-	  )* RBRACE			{ $$ = newBlock(b) }
+	  )* ( RBRACE			{ $$ = newBlock(b) }
+	     | e:error			{ expected(e, "statement") }
+	     )
 
 stmt	= WHILE c:cond s:stmt	 	{ $$ = newWhile(c, e) }
 	| FOR LPAREN
@@ -1232,7 +1279,7 @@ expropt	= expr | { $$ = nil }
 
 expr	= assign
 
-assign	= l:unary ASSIGN x:expr		{ $$ = newBinary(ASSIGN, l, x) }
+assign	= l:unary ASSIGN x:expr		{ $$ = newAssign(l, x) }
 	| logor
 
 logor	= l:logand  ( BARBAR r:logand	{ l  = newBinary(LOR, l, r) }
@@ -1454,7 +1501,7 @@ oop apply(oop function, oop arguments, oop env)
 	    fatal("type %s is not callable", getTypeName(function));
 	}
 	case Primitive: {
-	    oop argv = newArray(), arg = nil;
+	    oop argv = newArray();
 	    Array_do(arguments, arg) Array_append(argv, eval(arg, nil));
 	    return get(function, Primitive,function)
 		( get(argv, Array,size),
@@ -1534,7 +1581,6 @@ int VarDecls_finalise(oop vds)
 	assert(nil == vars);
 	oop base  = get(vds, VarDecls,type        );
 	oop decls = get(vds, VarDecls,declarations);
-	oop decl  = nil;
 	vars = newArray();
 	Array_do(decls, decl) {
 	    oop name = makeName(decl);
@@ -1575,9 +1621,11 @@ oop eval(oop exp, oop env)
 	    int      size   = get(stmts, Array,size);
 	    oop *elts   = get(stmts, Array,elements);
 	    Object  *result = nil;
+	    Scope_begin();
 	    for (int i = 0;  i < size;  ++i) {
 		result = eval(elts[i], env);
 	    }
+	    Scope_end();
 	    return result;
 	}
 	case Unary: {
@@ -1603,10 +1651,6 @@ oop eval(oop exp, oop env)
 	    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);
-		case ASSIGN: {
-		    assert(!"unimplemented");
-		    return nil;
-		}
 		default: {
 		    lhs = eval(lhs, env);
 		    rhs = eval(rhs, env);
@@ -1631,7 +1675,6 @@ oop eval(oop exp, oop env)
 			    case BOR: 	return IBINOP(lhs, | , rhs);
 			    case LAND:
 			    case LOR:
-			    case ASSIGN:
 				break;
 			}
 		    }
@@ -1656,7 +1699,6 @@ oop eval(oop exp, oop env)
 			    case BOR: 	return IBINOP(lhs, | , rhs);
 			    case LAND:
 			    case LOR:
-			    case ASSIGN:
 				break;
 			}
 		    }
@@ -1665,6 +1707,10 @@ oop eval(oop exp, oop env)
 	    assert(!"this cannot happen");
 	    break;
 	}
+	case Assign: {
+	    assert(!"unimplemented");
+	    break;
+	}
 	case Cast: {
 	    assert(!"unimplemented");
 	    break;
@@ -1712,7 +1758,20 @@ oop eval(oop exp, oop env)
 	case Tarray:	assert(!"unimplemented");	    break;
 	case Tstruct:	assert(!"unimplemented");	    break;
 	case Tfunction:	assert(!"unimplemented");	    break;
-	case VarDecls:	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
+		if (!isNil(init)) valu = eval(init, nil);
+		defineVariable(name, type, valu);
+	    }
+	    return nil;
+	    break;
+	}
 	case Scope:	break;
 	case TypeName:	break;
 	case Variable:	break;
@@ -2080,13 +2139,6 @@ void compileOn(oop exp, oop program, oop cs, oop bs)
 	    switch (get(exp, Binary,operator)) {
 		case LAND:	assert(!"unimplemented");
 		case LOR:	assert(!"unimplemented");
-		case ASSIGN: {
-		    oop symbol = get(exp, Binary,lhs);
-		    oop expr   = get(exp, Binary,rhs);
-		    compileOn(expr, program, cs, bs);
-		    EMITio(iSETGVAR, symbol);
-		    return;
-		}
 		default:	break;
 	    }
 	    compileOn(get(exp, Binary,lhs), program, cs, bs);
@@ -2111,10 +2163,18 @@ void compileOn(oop exp, oop program, oop cs, oop bs)
 		case BOR:	EMITi(iOR);	return;
 		case LAND:
 		case LOR:
-		case ASSIGN:	assert(!"this cannot happen");
+		    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;
@@ -2220,7 +2280,7 @@ oop compile(oop exp) // 6*7
     return program;
 }
 
-oop typeCheck(oop exp)
+oop typeCheck(oop exp, oop fntype)
 {
     // printf("TYPE CHECK ");  println(exp);
     switch (getType(exp)) {
@@ -2236,7 +2296,7 @@ oop typeCheck(oop exp)
 		case Function:	return get(value, Function,type);
 		case Variable:	return get(value, Variable,type);
 		default:
-		    fatal("cannot typecheck value %s", getTypeName(value));
+		    fatal("cannot typecheck value of type %s", getTypeName(value));
 	    }
 	    return nil;
 	}
@@ -2248,34 +2308,42 @@ oop typeCheck(oop exp)
 	    oop name       = get(exp, Function,name      );
 	    oop parameters = get(exp, Function,parameters);
 	    oop body       = get(exp, Function,body      );
-	    oop vdecls     = nil;
 	    oop ptypes     = newArray();
 	    Array_do(parameters, vdecls) {
 		oop vars = get(vdecls, VarDecls,variables);	assert(1 == Array_size(vars));
 		oop var  = Array_get(vars, 0);
 		Array_set(parameters, do_index, var);
-		Array_append(ptypes, get(var, Variable,type));
+		oop type = get(var, Variable,type);
+		if (t_void == type)
+		    if (do_index || do_size > 1)
+			fatal("illegal void parameter");
+		Array_append(ptypes, type);
 	    }
-	    set(exp, Function,type, newTfunction(result, ptypes));
+	    if (1 == Array_size(ptypes) && Array_last(ptypes) == t_void) {
+		Array_popLast(ptypes);
+		Array_popLast(parameters);
+	    }
+	    assert(isNil(fntype));
+	    fntype = newTfunction(result, ptypes);
+	    set(exp, Function,type, fntype);
 	    define(name, exp);	// add function to global scope so recursive calls will work
 	    Scope_begin();	// parameters
-	    oop param = nil;
 	    Array_do(parameters, param)	define(get(param, Variable,name), param);
-	    typeCheck(body); // block
+	    typeCheck(body, fntype); // block
 	    Scope_end();
 	    return nil;
 	}
 	case Block: {
 	    Scope_begin();
-	    oop statements = get(exp, Block,statements), statement = nil;
-	    Array_do(statements, statement) typeCheck(statement);
+	    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);
+	    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);
@@ -2286,17 +2354,63 @@ oop typeCheck(oop exp)
 	    for (int i = 0;  i < argc;  ++i) {
 		oop part = parv[i];
 		oop arg  = argv[i];
-		oop argt = typeCheck(arg);
+		oop argt = typeCheck(arg, fntype);
 		if (argt != part)
 		    fatal("cannot pass argument of type '%s' to parameter of type '%s' ",
 			  toString(argt), toString(part));
 	    }
-	    return get(tfunc,Tfunction, result);
+	    return get(tfunc, Tfunction,result);
 	}
 	case Return: {
-	    oop value = get(exp, Return,value);
-	    if (isNil(value)) return t_void;
-	    return typeCheck(value);
+	    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) {
+		oop varname = get(var, Variable,name);
+		oop vartype = get(var, Variable,type);
+		oop varval  = get(var, Variable,value);
+		oop old     = Scope_lookup(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(varval) || 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:
+			    printf("cannot find type of declaration: ");
+			    println(old);
+			    exit(1);
+		    }
+		    if (vartype == oldtype) continue;
+		    fatal("identifier '%s' redefined as different type", toString(varname));
+		}
+		if (!isNil(varval)) {
+		    oop initype = typeCheck(varval, fntype);
+		    if (initype != vartype)
+			fatal("initialising %s (%s) with incompatible expression (%s)",
+			      toString(varname), toString(vartype), toString(initype));
+		}
+		define(varname, var);
+	    }
+	    return nil;
 	}
 	default:
 	    break;
@@ -2327,7 +2441,7 @@ void replFile(char *name, FILE *file)
 			case NLR_CONTINUE: fatal("continue outside loop");
 			case NLR_BREAK:    fatal("break outside loop");
 		    }
-		    typeCheck(yysval);
+		    typeCheck(yysval, nil);
 		    result = eval(yysval, nil);
 		    nlrPop();
 		}