X-Git-Url: https://ocean-lang.org/code/?a=blobdiff_plain;f=csrc%2Foceani.mdc;h=07caefafca523bf1014752bf1cc228f0f7689a72;hb=6f3c6db8d0e5c5bf244f9a101e72e5e498b5fb6d;hp=68e5b603038a94b4ab27bbd739f671e12bf104de;hpb=9b6476d3862c262532453a916c54467a350714f9;p=ocean

diff --git a/csrc/oceani.mdc b/csrc/oceani.mdc
index 68e5b60..07caefa 100644
--- a/csrc/oceani.mdc
+++ b/csrc/oceani.mdc
@@ -580,6 +580,17 @@ which are often passed around by value.
 		return rv;
 	}
 
+###### forward decls
+
+	static void free_value(struct value v);
+	static int type_compat(struct type *require, struct type *have, int rules);
+	static void type_print(struct type *type, FILE *f);
+	static struct value val_init(struct type *type);
+	static struct value dup_value(struct value v);
+	static int value_cmp(struct value left, struct value right);
+	static void print_value(struct value v);
+	static struct value parse_value(struct type *type, char *arg);
+
 ###### free context types
 
 	while (context.typelist) {
@@ -1305,6 +1316,8 @@ subclasses, and to access these we need to be able to `cast` the
 
 	static int __fput_loc(struct exec *loc, FILE *f)
 	{
+		if (!loc)
+			return 0;
 		if (loc->line >= 0) {
 			fprintf(f, "%d:%d: ", loc->line, loc->column);
 			return 1;
@@ -1732,6 +1745,7 @@ link to find the primary instance.
 		}
 	} }$
 
+	$*exec
 	Variable -> IDENTIFIER ${ {
 		struct variable *v = var_ref(config2context(config), $1.txt);
 		$0 = new_pos(var, $1);
@@ -1744,8 +1758,9 @@ link to find the primary instance.
 				v->where_set = $0;
 			}
 		}
-		$0->var = v;
+		cast(var, $0)->var = v;
 	} }$
+	## variable grammar
 
 	$*type
 	Type -> IDENTIFIER ${
@@ -1757,6 +1772,7 @@ link to find the primary instance.
 			$0 = Tnone;
 		}
 	}$
+	## type grammar
 
 ###### print exec cases
 	case Xvar:
@@ -1845,30 +1861,111 @@ link to find the primary instance.
 ###### free exec cases
 	case Xvar: free_var(cast(var, e)); break;
 
+### Expressions: Conditional
+
+Our first user of the `binode` will be conditional expressions, which
+is a bit odd as they actually have three components.  That will be
+handled by having 2 binodes for each expression.  The conditional
+expression is the lowest precedence operatior, so it gets to define
+what an "Expression" is.  The next level up is "BoolExpr", which
+comes next.
+
+Conditional expressions are of the form "value `if` condition `else`
+other_value".  There is no associativite with this operator: the
+values and conditions can only be other conditional expressions if
+they are enclosed in parentheses.  Allowing nesting without
+parentheses would be too confusing.
+
+###### Binode types
+	CondExpr,
+
+###### Grammar
+
+	$*exec
+	Expression -> BoolExpr if BoolExpr else BoolExpr ${ {
+			struct binode *b1 = new(binode);
+			struct binode *b2 = new(binode);
+			b1->op = CondExpr;
+			b1->left = $<3;
+			b1->right = b2;
+			b2->op = CondExpr;
+			b2->left = $<1;
+			b2->right = $<5;
+			$0 = b1;
+		} }$
+		| BoolExpr ${ $0 = $<1; }$
+
+###### print binode cases
+
+	case CondExpr:
+		b2 = cast(binode, b->right);
+		print_exec(b2->left, -1, 0);
+		printf(" if ");
+		print_exec(b->left, -1, 0);
+		printf(" else ");
+		print_exec(b2->right, -1, 0);
+		break;
+
+###### propagate binode cases
+
+	case CondExpr: {
+		/* cond must be Tbool, others must match */
+		struct binode *b2 = cast(binode, b->right);
+		struct type *t2;
+
+		propagate_types(b->left, c, ok, Tbool, 0);
+		t = propagate_types(b2->left, c, ok, type, Rnolabel);
+		t2 = propagate_types(b2->right, c, ok, type ?: t, Rnolabel);
+		return t ?: t2;
+	}
+
+###### interp binode cases
+
+	case CondExpr: {
+		struct binode *b2 = cast(binode, b->right);
+		left = interp_exec(b->left);
+		if (left.bool)
+			rv = interp_exec(b2->left);
+		else
+			rv = interp_exec(b2->right);
+		}
+		break;
+
 ### Expressions: Boolean
 
-Our first user of the `binode` will be expressions, and particularly
-Boolean expressions.  As I haven't implemented precedence in the
-parser generator yet, we need different names for each precedence
-level used by expressions.  The outer most or lowest level precedence
-are Boolean `or` `and`, and `not` which form an `Expression` out of `BTerm`s
-and `BFact`s.
+The next class of expressions to use the `binode` will be Boolean
+expressions.  As I haven't implemented precedence in the parser
+generator yet, we need different names for each precedence level used
+by expressions.  The outer most or lowest level precedence are
+conditional expressions are Boolean operators which form an `BoolExpr`
+out of `BTerm`s and `BFact`s.  As well as `or` `and`, and `not` we
+have `and then` and `or else` which only evaluate the second operand
+if the result would make a difference.
 
 ###### Binode types
 	And,
+	AndThen,
 	Or,
+	OrElse,
 	Not,
 
 ###### Grammar
 
 	$*exec
-	Expression -> Expression or BTerm ${ {
+	BoolExpr -> BoolExpr or BTerm ${ {
 			struct binode *b = new(binode);
 			b->op = Or;
 			b->left = $<1;
 			b->right = $<3;
 			$0 = b;
 		} }$
+		| BoolExpr or else BTerm ${ {
+			struct binode *b = new(binode);
+			b->op = OrElse;
+			b->left = $<1;
+			b->right = $<4;
+			$0 = b;
+		} }$
 		| BTerm ${ $0 = $<1; }$
 
 	BTerm -> BTerm and BFact ${ {
@@ -1878,6 +1975,13 @@ and `BFact`s.
 			b->right = $<3;
 			$0 = b;
 		} }$
+		| BTerm and then BFact ${ {
+			struct binode *b = new(binode);
+			b->op = AndThen;
+			b->left = $<1;
+			b->right = $<4;
+			$0 = b;
+		} }$
 		| BFact ${ $0 = $<1; }$
 
 	BFact -> not BFact ${ {
@@ -1894,11 +1998,21 @@ and `BFact`s.
 		printf(" and ");
 		print_exec(b->right, -1, 0);
 		break;
+	case AndThen:
+		print_exec(b->left, -1, 0);
+		printf(" and then ");
+		print_exec(b->right, -1, 0);
+		break;
 	case Or:
 		print_exec(b->left, -1, 0);
 		printf(" or ");
 		print_exec(b->right, -1, 0);
 		break;
+	case OrElse:
+		print_exec(b->left, -1, 0);
+		printf(" or else ");
+		print_exec(b->right, -1, 0);
+		break;
 	case Not:
 		printf("not ");
 		print_exec(b->right, -1, 0);
@@ -1906,7 +2020,9 @@ and `BFact`s.
 
 ###### propagate binode cases
 	case And:
+	case AndThen:
 	case Or:
+	case OrElse:
 	case Not:
 		/* both must be Tbool, result is Tbool */
 		propagate_types(b->left, c, ok, Tbool, 0);
@@ -1924,11 +2040,21 @@ and `BFact`s.
 		right = interp_exec(b->right);
 		rv.bool = rv.bool && right.bool;
 		break;
+	case AndThen:
+		rv = interp_exec(b->left);
+		if (rv.bool)
+			rv = interp_exec(b->right);
+		break;
 	case Or:
 		rv = interp_exec(b->left);
 		right = interp_exec(b->right);
 		rv.bool = rv.bool || right.bool;
 		break;
+	case OrElse:
+		rv = interp_exec(b->left);
+		if (!rv.bool)
+			rv = interp_exec(b->right);
+		break;
 	case Not:
 		rv = interp_exec(b->right);
 		rv.bool = !rv.bool;
@@ -3187,6 +3313,217 @@ defined.
 		break;
 	}
 
+## Complex types
+
+Now that we have the shape of the interpreter in place we can add some
+complex types and connected them in to the data structures and the
+different phases of parse, analyse, print, interpret.
+
+For now, just arrays.
+
+### Arrays
+
+Arrays can be declared by giving a size and a type, as `[size]type' so
+`freq:[26]number` declares `freq` to be an array of 26 numbers.  The
+size can be an arbitrary expression which is evaluated when the name
+comes into scope.
+
+Arrays cannot be assigned.  When pointers are introduced we will also
+introduce array slices which can refer to part or all of an array -
+the assignment syntax will create a slice.  For now, an array can only
+ever be referenced by the name it is declared with.  It is likely that
+a "`copy`" primitive will eventually be define which can be used to
+make a copy of an array with controllable depth.
+
+###### type union fields
+
+	struct {
+		int size;
+		struct variable *vsize;
+		struct type *member;
+	} array;
+
+###### value union fields
+	struct {
+		struct value *elmnts;
+	} array;
+
+###### value functions
+
+	static struct value array_prepare(struct type *type)
+	{
+		struct value ret;
+
+		ret.type = type;
+		ret.array.elmnts = NULL;
+		return ret;
+	}
+
+	static struct value array_init(struct type *type)
+	{
+		struct value ret;
+		int i;
+
+		ret.type = type;
+		if (type->array.vsize) {
+			mpz_t q;
+			mpz_init(q);
+			mpz_tdiv_q(q, mpq_numref(type->array.vsize->val.num),
+			           mpq_denref(type->array.vsize->val.num));
+			type->array.size = mpz_get_si(q);
+			mpz_clear(q);
+		}
+		ret.array.elmnts = calloc(type->array.size,
+		                          sizeof(ret.array.elmnts[0]));
+		for (i = 0; ret.array.elmnts && i < type->array.size; i++)
+			ret.array.elmnts[i] = val_init(type->array.member);
+		return ret;
+	}
+
+	static void array_free(struct value val)
+	{
+		int i;
+
+		if (val.array.elmnts)
+			for (i = 0; i < val.type->array.size; i++)
+				free_value(val.array.elmnts[i]);
+		free(val.array.elmnts);
+	}
+
+	static int array_compat(struct type *require, struct type *have)
+	{
+		if (have->compat != require->compat)
+			return 0;
+		/* Both are arrays, so we can look at details */
+		if (!type_compat(require->array.member, have->array.member, 0))
+			return 0;
+		if (require->array.vsize == NULL && have->array.vsize == NULL)
+			return require->array.size == have->array.size;
+
+		return require->array.vsize == have->array.vsize;
+	}
+
+	static void array_print_type(struct type *type, FILE *f)
+	{
+		fputs("[", f);
+		if (type->array.vsize) {
+			struct binding *b = type->array.vsize->name;
+			fprintf(f, "%.*s]", b->name.len, b->name.txt);
+		} else
+			fprintf(f, "%d]", type->array.size);
+		type_print(type->array.member, f);
+	}
+
+	static struct type array_prototype = {
+		.prepare = array_prepare,
+		.init = array_init,
+		.print_type = array_print_type,
+		.compat = array_compat,
+		.free = array_free,
+	};
+
+###### type grammar
+
+	| [ NUMBER ] Type ${
+		$0 = calloc(1, sizeof(struct type));
+		*($0) = array_prototype;
+		$0->array.member = $<4;
+		$0->array.vsize = NULL;
+		{
+		char tail[3];
+		mpq_t num;
+		if (number_parse(num, tail, $2.txt) == 0)
+			tok_err(config2context(config), "error: unrecognised number", &$2);
+		else if (tail[0])
+			tok_err(config2context(config), "error: unsupported number suffix", &$2);
+		else {
+			$0->array.size = mpz_get_ui(mpq_numref(num));
+			if (mpz_cmp_ui(mpq_denref(num), 1) != 0) {
+				tok_err(config2context(config), "error: array size must be an integer",
+				        &$2);
+			} else if (mpz_cmp_ui(mpq_numref(num), 1UL << 30) >= 0)
+				tok_err(config2context(config), "error: array size is too large",
+				        &$2);
+		}
+		}
+	}$
+
+	| [ IDENTIFIER ] Type ${ {
+		struct variable *v = var_ref(config2context(config), $2.txt);
+
+		if (!v)
+			tok_err(config2context(config), "error: name undeclared", &$2);
+		else if (!v->constant)
+			tok_err(config2context(config), "error: array size must be a constant", &$2);
+
+		$0 = calloc(1, sizeof(struct type));
+		*($0) = array_prototype;
+		$0->array.member = $<4;
+		$0->array.size = 0;
+		$0->array.vsize = v;
+	} }$
+
+###### Binode types
+	Index,
+
+###### variable grammar
+
+	| Variable [ Expression ] ${ {
+		struct binode *b = new(binode);
+		b->op = Index;
+		b->left = $<1;
+		b->right = $<3;
+		$0 = b;
+	} }$
+
+###### print binode cases
+	case Index:
+		print_exec(b->left, -1, 0);
+		printf("[");
+		print_exec(b->right, -1, 0);
+		printf("]");
+		break;
+
+###### propagate binode cases
+	case Index:
+		/* left must be an array, right must be a number,
+		 * result is the member type of the array
+		 */
+		propagate_types(b->right, c, ok, Tnum, 0);
+		t = propagate_types(b->left, c, ok, NULL, rules & Rnoconstant);
+		if (!t || t->compat != array_compat) {
+			type_err(c, "error: %1 cannot be indexed", prog, t, 0, NULL);
+			*ok = 0;
+			return NULL;
+		} else {
+			if (!type_compat(type, t->array.member, rules)) {
+				type_err(c, "error: have %1 but need %2", prog,
+				         t->array.member, rules, type);
+				*ok = 0;
+			}
+			return t->array.member;
+		}
+		break;
+
+###### interp binode cases
+	case Index: {
+		mpz_t q;
+		long i;
+
+		lleft = linterp_exec(b->left);
+		right = interp_exec(b->right);
+		mpz_init(q);
+		mpz_tdiv_q(q, mpq_numref(right.num), mpq_denref(right.num));
+		i = mpz_get_si(q);
+		mpz_clear(q);
+
+		if (i >= 0 && i < lleft->type->array.size)
+			lrv = &lleft->array.elmnts[i];
+		else
+			rv = val_init(lleft->type->array.member);
+		break;
+	}
+
 ### Finally the whole program.
 
 Somewhat reminiscent of Pascal a (current) Ocean program starts with
@@ -3360,7 +3697,7 @@ Fibonacci, and performs a binary search for a number.
 		a : number
 		a = A;
 		b:number = B
-		if a > 0 and b > 0:
+		if a > 0 and then b > 0:
 			while a != b:
 				if a < b:
 					b = b - a
@@ -3404,3 +3741,24 @@ Fibonacci, and performs a binary search for a number.
 			print "Yay, I found", target
 		case GiveUp:
 			print "Closest I found was", mid
+
+		size::=55
+		list:[size]number
+		list[0] = 1234
+		for i:=1; then i = i + 1; while i < size:
+			n := list[i-1] * list[i-1]
+			list[i] = (n / 100) % 10000
+
+		print "Before sort:"
+		for i:=0; then i = i + 1; while i < size:
+			print "list[",i,"]=",list[i]
+
+		for i := 1; then i=i+1; while i < size:
+			for j:=i-1; then j=j-1; while j >= 0:
+				if list[j] > list[j+1]:
+					t:= list[j]
+					list[j] = list[j+1]
+					list[j+1] = t
+		print "After sort:"
+		for i:=0; then i = i + 1; while i < size:
+			print "list[",i,"]=",list[i]