X-Git-Url: https://ocean-lang.org/code/?p=ocean;a=blobdiff_plain;f=csrc%2Foceani.mdc;h=dca205570c9af2c1ae704e0a58c04f01bdd96782;hp=34c17b234efaefda84540c2560a045b1b6a5309a;hb=63e4b945b7fcf3c2ccbf7fee64bc08ae9f0aecf0;hpb=89b05f4755bfc7c6ba81305f4f4cada1141b991e diff --git a/csrc/oceani.mdc b/csrc/oceani.mdc index 34c17b2..dca2055 100644 --- a/csrc/oceani.mdc +++ b/csrc/oceani.mdc @@ -110,6 +110,7 @@ structures can be used. ## macros struct parse_context; ## ast + ## ast late struct parse_context { struct token_config config; char *file_name; @@ -242,10 +243,11 @@ structures can be used. parse_oceani(ss->code, &context.config, dotrace ? stderr : NULL); + resolve_consts(&context); prepare_types(&context); if (!context.parse_error && !analyse_funcs(&context)) { fprintf(stderr, "oceani: type error in program - not running.\n"); - context.parse_error = 1; + context.parse_error += 1; } if (doprint) { @@ -266,6 +268,7 @@ structures can be used. while (context.scope_depth > 0) scope_pop(&context); ## free global vars + ## free const decls ## free context types ## free context storage exit(context.parse_error ? 1 : 0); @@ -365,6 +368,7 @@ context so indicate that parsing failed. static void type_err(struct parse_context *c, char *fmt, struct exec *loc, struct type *t1, int rules, struct type *t2); + static void tok_err(struct parse_context *c, char *fmt, struct token *t); ###### core functions @@ -393,14 +397,14 @@ context so indicate that parsing failed. } } fputs("\n", stderr); - c->parse_error = 1; + c->parse_error += 1; } static void tok_err(struct parse_context *c, char *fmt, struct token *t) { fprintf(stderr, "%s:%d:%d: %s: %.*s\n", c->file_name, t->line, t->col, fmt, t->txt.len, t->txt.txt); - c->parse_error = 1; + c->parse_error += 1; } ## Entities: declared and predeclared. @@ -475,12 +479,12 @@ from the `exec_types` enum. if (loc->type == Xbinode) return __fput_loc(cast(binode,loc)->left, f) || __fput_loc(cast(binode,loc)->right, f); // NOTEST - return 0; + return 0; // NOTEST } static void fput_loc(struct exec *loc, FILE *f) { if (!__fput_loc(loc, f)) - fprintf(f, "??:??: "); + fprintf(f, "??:??: "); // NOTEST } Each different type of `exec` node needs a number of functions defined, @@ -581,28 +585,27 @@ program and looking for errors. So `propagate_types` is passed an expected type (being a `struct type` pointer together with some `val_rules` flags) that the `exec` is -expected to return, and returns the type that it does return, either -of which can be `NULL` signifying "unknown". An `ok` flag is passed -by reference. It is set to `0` when an error is found, and `2` when -any change is made. If it remains unchanged at `1`, then no more -propagation is needed. +expected to return, and returns the type that it does return, either of +which can be `NULL` signifying "unknown". A `prop_err` flag set is +passed by reference. It has `Efail` set when an error is found, and +`Eretry` when the type for some element is set via propagation. If +any expression cannot be evaluated a compile time, `Eruntime` is set. +If the expression can be copied, `Emaycopy` is set. -###### ast +If it remains unchanged at `0`, then no more propagation is needed. - enum val_rules {Rnolabel = 1<<0, Rboolok = 1<<1, Rnoconstant = 1<<2}; +###### ast -###### format cases - case 'r': - if (rules & Rnolabel) - fputs(" (labels not permitted)", stderr); - break; + enum val_rules {Rboolok = 1<<1, Rnoconstant = 1<<2}; + enum prop_err {Efail = 1<<0, Eretry = 1<<1, Eruntime = 1<<2, + Emaycopy = 1<<3}; ###### forward decls - static struct type *propagate_types(struct exec *prog, struct parse_context *c, int *ok, + static struct type *propagate_types(struct exec *prog, struct parse_context *c, enum prop_err *perr, struct type *type, int rules); ###### core functions - static struct type *__propagate_types(struct exec *prog, struct parse_context *c, int *ok, + static struct type *__propagate_types(struct exec *prog, struct parse_context *c, enum prop_err *perr, struct type *type, int rules) { struct type *t; @@ -624,13 +627,14 @@ propagation is needed. return Tnone; } - static struct type *propagate_types(struct exec *prog, struct parse_context *c, int *ok, + static struct type *propagate_types(struct exec *prog, struct parse_context *c, enum prop_err *perr, struct type *type, int rules) { - struct type *ret = __propagate_types(prog, c, ok, type, rules); + int pre_err = c->parse_error; + struct type *ret = __propagate_types(prog, c, perr, type, rules); - if (c->parse_error) - *ok = 0; + if (c->parse_error > pre_err) + *perr |= Efail; return ret; } @@ -780,13 +784,15 @@ which might be reported in error messages. }; }; +###### ast late struct type { struct text name; struct type *next; + struct token first_use; int size, align; int anon; void (*init)(struct type *type, struct value *val); - void (*prepare_type)(struct parse_context *c, struct type *type, int parse_time); + int (*prepare_type)(struct parse_context *c, struct type *type, int parse_time); void (*print)(struct type *type, struct value *val, FILE *f); void (*print_type)(struct type *type, FILE *f); int (*cmp_order)(struct type *t1, struct type *t2, @@ -794,6 +800,7 @@ which might be reported in error messages. int (*cmp_eq)(struct type *t1, struct type *t2, struct value *v1, struct value *v2); void (*dup)(struct type *type, struct value *vold, struct value *vnew); + int (*test)(struct type *type, struct value *val); void (*free)(struct type *type, struct value *val); void (*free_type)(struct type *t); long long (*to_int)(struct value *v); @@ -830,7 +837,10 @@ which might be reported in error messages. struct type *n; n = calloc(1, sizeof(*n)); - *n = *proto; + if (proto) + *n = *proto; + else + n->size = -1; n->name = s; n->anon = anon; n->next = c->typelist; @@ -853,10 +863,32 @@ which might be reported in error messages. va_start(ap, name); vasprintf(&t.txt, name, ap); va_end(ap); - t.len = strlen(name); + t.len = strlen(t.txt); return _add_type(c, t, proto, 1); } + static struct type *find_anon_type(struct parse_context *c, + struct type *proto, char *name, ...) + { + struct type *t = c->typelist; + struct text nm; + va_list ap; + + va_start(ap, name); + vasprintf(&nm.txt, name, ap); + va_end(ap); + nm.len = strlen(name); + + while (t && (!t->anon || + text_cmp(t->name, nm) != 0)) + t = t->next; + if (t) { + free(nm.txt); + return t; + } + return _add_type(c, nm, proto, 1); + } + static void free_type(struct type *t) { /* The type is always a reference to something in the @@ -880,8 +912,10 @@ which might be reported in error messages. fprintf(f, "%.*s", type->name.len, type->name.txt); else if (type->print_type) type->print_type(type, f); + else if (type->name.len && type->anon) + fprintf(f, "\"%.*s\"", type->name.len, type->name.txt); else - fputs("*invalid*type*", f); + fputs("*invalid*type*", f); // NOTEST } static void val_init(struct type *type, struct value *val) @@ -902,8 +936,8 @@ which might be reported in error messages. { if (tl && tl->cmp_order) return tl->cmp_order(tl, tr, left, right); - if (tl && tl->cmp_eq) // NOTEST - return tl->cmp_eq(tl, tr, left, right); // NOTEST + if (tl && tl->cmp_eq) + return tl->cmp_eq(tl, tr, left, right); return -1; // NOTEST } @@ -918,10 +952,35 @@ which might be reported in error messages. static void prepare_types(struct parse_context *c) { struct type *t; - - for (t = c->typelist; t; t = t->next) - if (t->prepare_type) - t->prepare_type(c, t, 1); + int retry = 1; + enum { none, some, cannot } progress = none; + + while (retry) { + retry = 0; + + for (t = c->typelist; t; t = t->next) { + if (t->size < 0) + tok_err(c, "error: type used but not declared", + &t->first_use); + if (t->size == 0 && t->prepare_type) { + if (t->prepare_type(c, t, 1)) + progress = some; + else if (progress == cannot) + tok_err(c, "error: type has recursive definition", + &t->first_use); + else + retry = 1; + } + } + switch (progress) { + case cannot: + retry = 0; break; + case none: + progress = cannot; break; + case some: + progress = none; break; + } + } } ###### forward decls @@ -960,12 +1019,10 @@ symbol for those. $*type Type -> IDENTIFIER ${ - $0 = find_type(c, $1.txt); + $0 = find_type(c, $ID.txt); if (!$0) { - tok_err(c, - "error: undefined type", &$1); - - $0 = Tnone; + $0 = add_type(c, $ID.txt, NULL); + $0->first_use = $ID; } }$ ## type grammar @@ -1002,8 +1059,6 @@ A separate function encoding these cases will simplify some code later. { if ((rules & Rboolok) && have == Tbool) return 1; // NOTEST - if ((rules & Rnolabel) && have == Tlabel) - return 0; // NOTEST if (!require || !have) return 1; @@ -1029,7 +1084,7 @@ A separate function encoding these cases will simplify some code later. struct text str; mpq_t num; unsigned char bool; - void *label; + int label; ###### ast functions static void _free_value(struct type *type, struct value *v) @@ -1062,8 +1117,8 @@ A separate function encoding these cases will simplify some code later. val->bool = 0; break; case Vlabel: - val->label = NULL; - break; + val->label = 0; // NOTEST + break; // NOTEST } } @@ -1074,8 +1129,8 @@ A separate function encoding these cases will simplify some code later. case Vnone: // NOTEST break; // NOTEST case Vlabel: - vnew->label = vold->label; - break; + vnew->label = vold->label; // NOTEST + break; // NOTEST case Vbool: vnew->bool = vold->bool; break; @@ -1113,7 +1168,7 @@ A separate function encoding these cases will simplify some code later. case Vnone: // NOTEST fprintf(f, "*no-value*"); break; // NOTEST case Vlabel: // NOTEST - fprintf(f, "*label-%p*", v->label); break; // NOTEST + fprintf(f, "*label-%d*", v->label); break; // NOTEST case Vstr: fprintf(f, "%.*s", v->str.len, v->str.txt); break; case Vbool: @@ -1123,7 +1178,7 @@ A separate function encoding these cases will simplify some code later. mpf_t fl; mpf_init2(fl, 20); mpf_set_q(fl, v->num); - gmp_fprintf(f, "%Fg", fl); + gmp_fprintf(f, "%.10Fg", fl); mpf_clear(fl); break; } @@ -1132,6 +1187,11 @@ A separate function encoding these cases will simplify some code later. static void _free_value(struct type *type, struct value *v); + static int bool_test(struct type *type, struct value *v) + { + return v->bool; + } + static struct type base_prototype = { .init = _val_init, .print = _print_value, @@ -1162,6 +1222,7 @@ A separate function encoding these cases will simplify some code later. ###### context initialization Tbool = add_base_type(&context, "Boolean", Vbool, sizeof(char)); + Tbool->test = bool_test; Tstr = add_base_type(&context, "string", Vstr, sizeof(struct text)); Tnum = add_base_type(&context, "number", Vnum, sizeof(mpq_t)); Tnone = add_base_type(&context, "none", Vnone, 0); @@ -1192,10 +1253,11 @@ executable. return v; } -###### Grammar - +###### declare terminals $TERM True False +###### Grammar + $*val Value -> True ${ $0 = new_val(Tbool, $1); @@ -1237,6 +1299,7 @@ executable. struct val *v = cast(val, e); if (v->vtype == Tstr) printf("\""); + // FIXME how to ensure numbers have same precision. print_value(v->vtype, &v->val, stdout); if (v->vtype == Tstr) printf("\""); @@ -1248,7 +1311,7 @@ executable. { struct val *val = cast(val, prog); if (!type_compat(type, val->vtype, rules)) - type_err(c, "error: expected %1%r found %2", + type_err(c, "error: expected %1 found %2", prog, type, rules, val->vtype); return val->vtype; } @@ -1291,6 +1354,98 @@ executable. return rv; } +#### Labels + +Labels are a temporary concept until I implement enums. There are an +anonymous enum which is declared by usage. Thet are only allowed in +`use` statements and corresponding `case` entries. They appear as a +period followed by an identifier. All identifiers that are "used" must +have a "case". + +For now, we have a global list of labels, and don't check that all "use" +match "case". + +###### exec type + Xlabel, + +###### ast + struct label { + struct exec; + struct text name; + int value; + }; +###### free exec cases + case Xlabel: + free(e); + break; +###### print exec cases + case Xlabel: { + struct label *l = cast(label, e); + printf(".%.*s", l->name.len, l->name.txt); + break; + } + +###### ast + struct labels { + struct labels *next; + struct text name; + int value; + }; +###### parse context + struct labels *labels; + int next_label; +###### ast functions + static int label_lookup(struct parse_context *c, struct text name) + { + struct labels *l, **lp = &c->labels; + while (*lp && text_cmp((*lp)->name, name) < 0) + lp = &(*lp)->next; + if (*lp && text_cmp((*lp)->name, name) == 0) + return (*lp)->value; + l = calloc(1, sizeof(*l)); + l->next = *lp; + l->name = name; + if (c->next_label == 0) + c->next_label = 2; + l->value = c->next_label; + c->next_label += 1; + *lp = l; + return l->value; + } + +###### free context storage + while (context.labels) { + struct labels *l = context.labels; + context.labels = l->next; + free(l); + } + +###### declare terminals + $TERM . +###### term grammar + | . IDENTIFIER ${ { + struct label *l = new_pos(label, $ID); + l->name = $ID.txt; + $0 = l; + } }$ +###### propagate exec cases + case Xlabel: { + struct label *l = cast(label, prog); + l->value = label_lookup(c, l->name); + if (!type_compat(type, Tlabel, rules)) + type_err(c, "error: expected %1 found %2", + prog, type, rules, Tlabel); + return Tlabel; + } +###### interp exec cases + case Xlabel : { + struct label *l = cast(label, e); + rv.label = l->value; + rvtype = Tlabel; + break; + } + + ### Variables Variables are scoped named values. We store the names in a linked list @@ -1588,10 +1743,10 @@ need to be freed. For this we need to be able to find it, so assume that while (v) { struct variable *next = v->previous; - if (v->global) { + if (v->global && v->frame_pos >= 0) { free_value(v->type, var_value(&context, v)); - if (v->depth == 0) - // This is a global constant + if (v->depth == 0 && v->type->free == function_free) + // This is a function constant free_exec(v->where_decl); } free(v); @@ -1768,9 +1923,6 @@ all pending-scope variables become conditionally scoped. v->previous->scope == PendingScope) /* all previous branches used name */ v->scope = PendingScope; - else if (v->type == Tlabel) - /* Labels remain pending even when not used */ - v->scope = PendingScope; // UNTESTED else v->scope = OutScope; if (ct == CloseElse) { @@ -1801,8 +1953,6 @@ all pending-scope variables become conditionally scoped. v->scope = InScope; /* fallthrough */ case CloseSequential: - if (v->type == Tlabel) - v->scope = PendingScope; switch (v->scope) { case InScope: v->scope = OutScope; @@ -1816,10 +1966,7 @@ all pending-scope variables become conditionally scoped. for (v2 = v; v2 && v2->scope == PendingScope; v2 = v2->previous) - if (v2->type == Tlabel) - v2->scope = CondScope; - else - v2->scope = OutScope; + v2->scope = OutScope; break; case CondScope: case OutScope: break; @@ -1868,7 +2015,7 @@ tell if it was set or not later. { if (!v->global) { if (!c->local || !v->type) - return NULL; + return NULL; // UNTESTED if (v->frame_pos + v->type->size > c->local_size) { printf("INVALID frame_pos\n"); // NOTEST exit(2); // NOTEST @@ -1906,7 +2053,7 @@ tell if it was set or not later. if (init) memcpy(ret, init, t->size); else - val_init(t, ret); + val_init(t, ret); // NOTEST return ret; } @@ -2069,7 +2216,11 @@ correctly. struct variable *v = var_ref(c, $1.txt); $0 = new_pos(var, $1); if (v == NULL) { - /* This might be a label - allocate a var just in case */ + /* This might be a global const or a label + * Allocate a var with impossible type Tnone, + * which will be adjusted when we find out what it is, + * or will trigger an error. + */ v = var_decl(c, $1.txt); if (v) { v->type = Tnone; @@ -2101,7 +2252,7 @@ correctly. } else fputs("???", stderr); // NOTEST } else - fputs("NOTVAR", stderr); + fputs("NOTVAR", stderr); // NOTEST break; ###### propagate exec cases @@ -2126,19 +2277,19 @@ correctly. type_err(c, "error: variable used but not declared: %v", prog, NULL, 0, NULL); if (v->type == NULL) { - if (type && *ok != 0) { + if (type && !(*perr & Efail)) { v->type = type; v->where_set = prog; - *ok = 2; + *perr |= Eretry; } - return type; - } - if (!type_compat(type, v->type, rules)) { - type_err(c, "error: expected %1%r but variable '%v' is %2", prog, + } else if (!type_compat(type, v->type, rules)) { + type_err(c, "error: expected %1 but variable '%v' is %2", prog, type, rules, v->type); type_err(c, "info: this is where '%v' was set to %1", v->where_set, v->type, rules, NULL); } + if (!v->global || v->frame_pos < 0) + *perr |= Eruntime; if (!type) return v->type; return type; @@ -2240,31 +2391,37 @@ with a const size by whether they are prepared at parse time or not. ###### value functions - static void array_prepare_type(struct parse_context *c, struct type *type, + static int array_prepare_type(struct parse_context *c, struct type *type, int parse_time) { struct value *vsize; mpz_t q; if (type->array.static_size) - return; + return 1; // UNTESTED if (type->array.unspec && parse_time) - return; + return 1; // UNTESTED + if (parse_time && type->array.vsize && !type->array.vsize->global) + return 1; // UNTESTED if (type->array.vsize) { vsize = var_value(c, type->array.vsize); if (!vsize) - return; + return 1; // UNTESTED mpz_init(q); mpz_tdiv_q(q, mpq_numref(vsize->num), mpq_denref(vsize->num)); type->array.size = mpz_get_si(q); mpz_clear(q); } + if (!parse_time) + return 1; + if (type->array.member->size <= 0) + return 0; // UNTESTED - if (parse_time && type->array.member->size) { - type->array.static_size = 1; - type->size = type->array.size * type->array.member->size; - type->align = type->array.member->align; - } + type->array.static_size = 1; + type->size = type->array.size * type->array.member->size; + type->align = type->array.member->align; + + return 1; } static void array_init(struct type *type, struct value *val) @@ -2442,8 +2599,8 @@ with a const size by whether they are prepared at parse time or not. /* 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); + propagate_types(b->right, c, perr, Tnum, 0); + t = propagate_types(b->left, c, perr, NULL, rules & Rnoconstant); if (!t || t->compat != array_compat) { type_err(c, "error: %1 cannot be indexed", prog, t, 0, NULL); return NULL; @@ -2542,6 +2699,8 @@ function will be needed. ###### type functions void (*print_type_decl)(struct type *type, FILE *f); + struct type *(*fieldref)(struct type *t, struct parse_context *c, + struct fieldref *f, struct value **vp); ###### value functions @@ -2593,29 +2752,32 @@ function will be needed. free_fieldlist(t->structure.field_list); } - static void structure_prepare_type(struct parse_context *c, - struct type *t, int parse_time) + static int structure_prepare_type(struct parse_context *c, + struct type *t, int parse_time) { int cnt = 0; struct fieldlist *f; if (!parse_time || t->structure.fields) - return; + return 1; for (f = t->structure.field_list; f; f=f->prev) { - int ok; + enum prop_err perr; cnt += 1; + if (f->f.type->size <= 0) + return 0; if (f->f.type->prepare_type) - f->f.type->prepare_type(c, f->f.type, 1); + f->f.type->prepare_type(c, f->f.type, parse_time); + if (f->init == NULL) continue; do { - ok = 1; - propagate_types(f->init, c, &ok, f->f.type, 0); - } while (ok == 2); - if (!ok) - c->parse_error = 1; // NOTEST + perr = 0; + propagate_types(f->init, c, &perr, f->f.type, 0); + } while (perr & Eretry); + if (perr & Efail) + c->parse_error += 1; // NOTEST } t->structure.nfields = cnt; @@ -2640,6 +2802,35 @@ function will be needed. f = f->prev; } + return 1; + } + + static int find_struct_index(struct type *type, struct text field) + { + int i; + for (i = 0; i < type->structure.nfields; i++) + if (text_cmp(type->structure.fields[i].name, field) == 0) + return i; + return IndexInvalid; + } + + static struct type *structure_fieldref(struct type *t, struct parse_context *c, + struct fieldref *f, struct value **vp) + { + if (f->index == IndexUnknown) { + f->index = find_struct_index(t, f->name); + if (f->index < 0) + type_err(c, "error: cannot find requested field in %1", + f->left, t, 0, NULL); + } + if (f->index < 0) + return NULL; + if (vp) { + struct value *v = *vp; + v = (void*)v->ptr + t->structure.fields[f->index].offset; + *vp = v; + } + return t->structure.fields[f->index].type; } static struct type structure_prototype = { @@ -2648,6 +2839,7 @@ function will be needed. .free_type = structure_free_type, .print_type_decl = structure_print_type, .prepare_type = structure_prepare_type, + .fieldref = structure_fieldref, }; ###### exec type @@ -2660,6 +2852,7 @@ function will be needed. int index; struct text name; }; + enum { IndexUnknown = -1, IndexInvalid = -2 }; ###### free exec cases case Xfieldref: @@ -2668,7 +2861,7 @@ function will be needed. break; ###### declare terminals - $TERM struct . + $TERM struct ###### term grammar @@ -2676,7 +2869,7 @@ function will be needed. struct fieldref *fr = new_pos(fieldref, $2); fr->left = $<1; fr->name = $3.txt; - fr->index = -2; + fr->index = IndexUnknown; $0 = fr; } }$ @@ -2690,41 +2883,22 @@ function will be needed. break; } -###### ast functions - static int find_struct_index(struct type *type, struct text field) - { - int i; - for (i = 0; i < type->structure.nfields; i++) - if (text_cmp(type->structure.fields[i].name, field) == 0) - return i; - return -1; - } - ###### propagate exec cases case Xfieldref: { struct fieldref *f = cast(fieldref, prog); - struct type *st = propagate_types(f->left, c, ok, NULL, 0); + struct type *st = propagate_types(f->left, c, perr, NULL, 0); - if (!st) - type_err(c, "error: unknown type for field access", f->left, // UNTESTED - NULL, 0, NULL); - else if (st->init != structure_init) - type_err(c, "error: field reference attempted on %1, not a struct", + if (!st || !st->fieldref) + type_err(c, "error: field reference on %1 is not supported", f->left, st, 0, NULL); - else if (f->index == -2) { - f->index = find_struct_index(st, f->name); - if (f->index < 0) - type_err(c, "error: cannot find requested field in %1", - f->left, st, 0, NULL); - } - if (f->index >= 0) { - struct type *ft = st->structure.fields[f->index].type; - if (!type_compat(type, ft, rules)) + else { + t = st->fieldref(st, c, f, NULL); + if (t && !type_compat(type, t, rules)) type_err(c, "error: have %1 but need %2", prog, - ft, rules, type); - return ft; + t, rules, type); + return t; } break; } @@ -2735,16 +2909,30 @@ function will be needed. struct fieldref *f = cast(fieldref, e); struct type *ltype; struct value *lleft = linterp_exec(c, f->left, <ype); - lrv = (void*)lleft->ptr + ltype->structure.fields[f->index].offset; - rvtype = ltype->structure.fields[f->index].type; + lrv = lleft; + rvtype = ltype->fieldref(ltype, c, f, &lrv); break; } ###### top level grammar DeclareStruct -> struct IDENTIFIER FieldBlock Newlines ${ { - struct type *t = - add_type(c, $2.txt, &structure_prototype); + struct type *t; + t = find_type(c, $ID.txt); + if (!t) + t = add_type(c, $ID.txt, &structure_prototype); + else if (t->size >= 0) { + tok_err(c, "error: type already declared", &$ID); + tok_err(c, "info: this is location of declartion", &t->first_use); + /* Create a new one - duplicate */ + t = add_type(c, $ID.txt, &structure_prototype); + } else { + struct type tmp = *t; + *t = structure_prototype; + t->name = tmp.name; + t->next = tmp.next; + } t->structure.field_list = $first_use = $ID; } }$ $*fieldlist @@ -2832,6 +3020,336 @@ function will be needed. } } +#### References + +References, or pointers, are values that refer to another value. They +can only refer to a `struct`, though as a struct can embed anything they +can effectively refer to anything. + +References are potentially dangerous as they might refer to some +variable which no longer exists - either because a stack frame +containing it has been discarded or because the value was allocated on +the heap and has now been free. Ocean does not yet provide any +protection against these problems. It will in due course. + +With references comes the opportunity and the need to explicitly +allocate values on the "heap" and to free them. We currently provide +fairly basic support for this. + +Reference make use of the `@` symbol in various ways. A type that starts +with `@` is a reference to whatever follows. A reference value +followed by an `@` acts as the referred value, though the `@` is often +not needed. Finally, an expression that starts with `@` is a special +reference related expression. Some examples might help. + +##### Example: Reference examples + + struct foo + a: number + b: string + ref: @foo + bar: foo + bar.number = 23; bar.string = "hello" + baz: foo + ref = bar + baz = @ref + baz.a = ref.a * 2 + + ref = @new() + ref@ = baz + @free = ref + ref = @nil + +Obviously this is very contrived. `ref` is a reference to a `foo` which +is initially set to refer to the value stored in `bar` - no extra syntax +is needed to "Take the address of" `bar` - the fact that `ref` is a +reference means that only the address make sense. + +When `ref.a` is accessed, that is whatever value is stored in `bar.a`. +The same syntax is used for accessing fields both in structs and in +references to structs. It would be correct to use `ref@.a`, but not +necessary. + +`@new()` creates an object of whatever type is needed for the program +to by type-correct. In future iterations of Ocean, arguments a +constructor will access arguments, so the the syntax now looks like a +function call. `@free` can be assigned any reference that was returned +by `@new()`, and it will be freed. `@nil` is a value of whatever +reference type is appropriate, and is stable and never the address of +anything in the heap or on the stack. A reference can be assigned +`@nil` or compared against that value. + +###### declare terminals + $TERM @ + +###### type union fields + + struct { + struct type *referent; + } reference; + +###### value union fields + struct value *ref; + +###### value functions + + static void reference_print_type(struct type *t, FILE *f) + { + fprintf(f, "@"); + type_print(t->reference.referent, f); + } + + static int reference_cmp(struct type *tl, struct type *tr, + struct value *left, struct value *right) + { + return left->ref == right->ref ? 0 : 1; + } + + static void reference_dup(struct type *t, + struct value *vold, struct value *vnew) + { + vnew->ref = vold->ref; + } + + static void reference_free(struct type *t, struct value *v) + { + /* Nothing to do here */ + } + + static int reference_compat(struct type *require, struct type *have) + { + if (have->compat != require->compat) + return 0; + if (have->reference.referent != require->reference.referent) + return 0; + return 1; + } + + static int reference_test(struct type *type, struct value *val) + { + return val->ref != NULL; + } + + static struct type *reference_fieldref(struct type *t, struct parse_context *c, + struct fieldref *f, struct value **vp) + { + struct type *rt = t->reference.referent; + + if (rt->fieldref) { + if (vp) + *vp = (*vp)->ref; + return rt->fieldref(rt, c, f, vp); + } + type_err(c, "error: field reference on %1 is not supported", + f->left, rt, 0, NULL); + return Tnone; + } + + + static struct type reference_prototype = { + .print_type = reference_print_type, + .cmp_eq = reference_cmp, + .dup = reference_dup, + .test = reference_test, + .free = reference_free, + .compat = reference_compat, + .fieldref = reference_fieldref, + .size = sizeof(void*), + .align = sizeof(void*), + }; + +###### type grammar + + | @ IDENTIFIER ${ { + struct type *t = find_type(c, $ID.txt); + if (!t) { + t = add_type(c, $ID.txt, NULL); + t->first_use = $ID; + } + $0 = find_anon_type(c, &reference_prototype, "@%.*s", + $ID.txt.len, $ID.txt.txt); + $0->reference.referent = t; + } }$ + +###### core functions + static int text_is(struct text t, char *s) + { + return (strlen(s) == t.len && + strncmp(s, t.txt, t.len) == 0); + } + +###### exec type + Xref, + +###### ast + struct ref { + struct exec; + enum ref_func { RefNew, RefFree, RefNil } action; + struct type *reftype; + struct exec *right; + }; + +###### SimpleStatement Grammar + + | @ IDENTIFIER = Expression ${ { + struct ref *r = new_pos(ref, $ID); + // Must be "free" + if (!text_is($ID.txt, "free")) + tok_err(c, "error: only \"@free\" makes sense here", + &$ID); + + $0 = r; + r->action = RefFree; + r->right = $action = RefNew; + } + }$ + | @ IDENTIFIER ${ + // Only 'nil' valid here + if (!text_is($ID.txt, "nil")) { + tok_err(c, "error: Only reference value is \"@nil\"", + &$ID); + } else { + struct ref *r = new_pos(ref,$ID); + $0 = r; + r->action = RefNil; + } + }$ + +###### print exec cases + case Xref: { + struct ref *r = cast(ref, e); + switch (r->action) { + case RefNew: + printf("@new()"); break; + case RefNil: + printf("@nil"); break; + case RefFree: + do_indent(indent, "@free = "); + print_exec(r->right, indent, bracket); + break; + } + break; + } + +###### propagate exec cases + case Xref: { + struct ref *r = cast(ref, prog); + switch (r->action) { + case RefNew: + if (type && type->free != reference_free) { + type_err(c, "error: @new() can only be used with references, not %1", + prog, type, 0, NULL); + return NULL; + } + if (type && !r->reftype) { + r->reftype = type; + *perr |= Eretry; + } + return type; + case RefNil: + if (type && type->free != reference_free) + type_err(c, "error: @nil can only be used with reference, not %1", + prog, type, 0, NULL); + if (type && !r->reftype) { + r->reftype = type; + *perr |= Eretry; + } + return type; + case RefFree: + t = propagate_types(r->right, c, perr, NULL, 0); + if (t && t->free != reference_free) + type_err(c, "error: @free can only be assigned a reference, not %1", + prog, t, 0, NULL); + r->reftype = Tnone; + return Tnone; + } + break; // NOTEST + } + + +###### interp exec cases + case Xref: { + struct ref *r = cast(ref, e); + switch (r->action) { + case RefNew: + if (r->reftype) + rv.ref = calloc(1, r->reftype->reference.referent->size); + rvtype = r->reftype; + break; + case RefNil: + rv.ref = NULL; + rvtype = r->reftype; + break; + case RefFree: + rv = interp_exec(c, r->right, &rvtype); + free_value(rvtype->reference.referent, rv.ref); + free(rv.ref); + rvtype = Tnone; + break; + } + break; + } + +###### free exec cases + case Xref: { + struct ref *r = cast(ref, e); + free_exec(r->right); + free(r); + break; + } + +###### Expressions: dereference + +###### Binode types + Deref, + +###### term grammar + + | Term @ ${ { + struct binode *b = new(binode); + b->op = Deref; + b->left = $left, -1, bracket); + printf("@"); + break; + +###### propagate binode cases + case Deref: + /* left must be a reference, and we return what it refers to */ + /* FIXME how can I pass the expected type down? */ + t = propagate_types(b->left, c, perr, NULL, 0); + if (!t || t->free != reference_free) + type_err(c, "error: Cannot dereference %1", b, t, 0, NULL); + else + return t->reference.referent; + break; + +###### interp binode cases + case Deref: { + left = interp_exec(c, b->left, <ype); + lrv = left.ref; + rvtype = ltype->reference.referent; + break; + } + + #### Functions A function is a chunk of code which can be passed parameters and can @@ -2911,7 +3429,7 @@ further detailed when Expression Lists are introduced. struct exec *function; ###### type functions - void (*check_args)(struct parse_context *c, int *ok, + void (*check_args)(struct parse_context *c, enum prop_err *perr, struct type *require, struct exec *args); ###### value functions @@ -2928,7 +3446,7 @@ further detailed when Expression Lists are introduced. return 0; } - static void function_check_args(struct parse_context *c, int *ok, + static void function_check_args(struct parse_context *c, enum prop_err *perr, struct type *require, struct exec *args) { /* This should be 'compat', but we don't have a 'tuple' type to @@ -2944,8 +3462,8 @@ further detailed when Expression Lists are introduced. args, NULL, 0, NULL); break; } - *ok = 1; - propagate_types(arg->left, c, ok, pv->var->type, 0); + *perr = 0; + propagate_types(arg->left, c, perr, pv->var->type, 0); param = cast(binode, param->right); arg = cast(binode, arg->right); } @@ -3024,6 +3542,7 @@ further detailed when Expression Lists are introduced. e->var = v; if (v) { v->where_decl = e; + v->where_set = e; $0 = v; } else { v = var_ref(c, $1.txt); @@ -3052,7 +3571,7 @@ further detailed when Expression Lists are introduced. | Varlist ; ${ $0 = $<1; }$ Varlist -> Varlist ; ArgDecl ${ - $0 = new(binode); + $0 = new_pos(binode, $2); $0->op = List; $0->left = $right = $ IDENTIFIER : FormalType ${ { - struct variable *v = var_decl(c, $1.txt); - $0 = new(var); + struct variable *v = var_decl(c, $ID.txt); + $0 = new_pos(var, $ID); $0->var = v; + v->where_decl = $0; + v->where_set = $0; v->type = $var->type->check_args(c, ok, v->var->type, args); + *perr |= Eruntime; + v->var->type->check_args(c, perr, v->var->type, args); + if (v->var->type->function.inline_result) + *perr |= Emaycopy; return v->var->type->function.return_type; } @@ -3257,9 +3781,9 @@ there. 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); + propagate_types(b->left, c, perr, Tbool, 0); + t = propagate_types(b2->left, c, perr, type, 0); + t2 = propagate_types(b2->right, c, perr, type ?: t, 0); return t ?: t2; } @@ -3426,8 +3950,8 @@ evaluate the second expression if not necessary. case OrElse: case Not: /* both must be Tbool, result is Tbool */ - propagate_types(b->left, c, ok, Tbool, 0); - propagate_types(b->right, c, ok, Tbool, 0); + propagate_types(b->left, c, perr, Tbool, 0); + propagate_types(b->right, c, perr, Tbool, 0); if (type && type != Tbool) type_err(c, "error: %1 operation found where %2 expected", prog, Tbool, 0, type); @@ -3541,13 +4065,13 @@ expression operator, and the `CMPop` non-terminal will match one of them. case Eql: case NEql: /* Both must match but not be labels, result is Tbool */ - t = propagate_types(b->left, c, ok, NULL, Rnolabel); + t = propagate_types(b->left, c, perr, NULL, 0); if (t) - propagate_types(b->right, c, ok, t, 0); + propagate_types(b->right, c, perr, t, 0); else { - t = propagate_types(b->right, c, ok, NULL, Rnolabel); // UNTESTED + t = propagate_types(b->right, c, perr, NULL, 0); // UNTESTED if (t) // UNTESTED - t = propagate_types(b->left, c, ok, t, 0); // UNTESTED + t = propagate_types(b->left, c, perr, t, 0); // UNTESTED } if (!type_compat(type, Tbool, 0)) type_err(c, "error: Comparison returns %1 but %2 expected", prog, @@ -3582,10 +4106,17 @@ expression operator, and the `CMPop` non-terminal will match one of them. ### Expressions: Arithmetic etc. The remaining expressions with the highest precedence are arithmetic, -string concatenation, and string conversion. String concatenation +string concatenation, string conversion, and testing. String concatenation (`++`) has the same precedence as multiplication and division, but lower than the uniary. +Testing comes in two forms. A single question mark (`?`) is a uniary +operator which converts come types into Boolean. The general meaning is +"is this a value value" and there will be more uses as the language +develops. A double questionmark (`??`) is a binary operator (Choose), +with same precedence as multiplication, which returns the LHS if it +tests successfully, else returns the RHS. + String conversion is a temporary feature until I get a better type system. `$` is a prefix operator which expects a string and returns a number. @@ -3601,15 +4132,15 @@ parentheses around an expression converts it into a Term, ###### Binode types Plus, Minus, Times, Divide, Rem, - Concat, - Absolute, Negate, + Concat, Choose, + Absolute, Negate, Test, StringConv, Bracket, ###### declare terminals $LEFT + - Eop - $LEFT * / % ++ Top - $LEFT Uop $ + $LEFT * / % ++ ?? Top + $LEFT Uop $ ? $TERM ( ) ###### expression grammar @@ -3654,11 +4185,13 @@ parentheses around an expression converts it into a Term, Uop -> + ${ $0.op = Absolute; }$ | - ${ $0.op = Negate; }$ | $ ${ $0.op = StringConv; }$ + | ? ${ $0.op = Test; }$ Top -> * ${ $0.op = Times; }$ | / ${ $0.op = Divide; }$ | % ${ $0.op = Rem; }$ | ++ ${ $0.op = Concat; }$ + | ?? ${ $0.op = Choose; }$ ###### print binode cases case Plus: @@ -3667,6 +4200,7 @@ parentheses around an expression converts it into a Term, case Divide: case Concat: case Rem: + case Choose: if (bracket) printf("("); print_exec(b->left, indent, bracket); switch(b->op) { @@ -3676,6 +4210,7 @@ parentheses around an expression converts it into a Term, case Divide: fputs(" / ", stdout); break; case Rem: fputs(" % ", stdout); break; case Concat: fputs(" ++ ", stdout); break; + case Choose: fputs(" ?? ", stdout); break; default: abort(); // NOTEST } // NOTEST print_exec(b->right, indent, bracket); @@ -3684,11 +4219,13 @@ parentheses around an expression converts it into a Term, case Absolute: case Negate: case StringConv: + case Test: if (bracket) printf("("); switch (b->op) { case Absolute: fputs("+", stdout); break; case Negate: fputs("-", stdout); break; case StringConv: fputs("$", stdout); break; + case Test: fputs("?", stdout); break; default: abort(); // NOTEST } // NOTEST print_exec(b->right, indent, bracket); @@ -3711,8 +4248,8 @@ parentheses around an expression converts it into a Term, case Negate: /* as propagate_types ignores a NULL, * unary ops fit here too */ - propagate_types(b->left, c, ok, Tnum, 0); - propagate_types(b->right, c, ok, Tnum, 0); + propagate_types(b->left, c, perr, Tnum, 0); + propagate_types(b->right, c, perr, Tnum, 0); if (!type_compat(type, Tnum, 0)) type_err(c, "error: Arithmetic returns %1 but %2 expected", prog, Tnum, rules, type); @@ -3720,8 +4257,8 @@ parentheses around an expression converts it into a Term, case Concat: /* both must be Tstr, result is Tstr */ - propagate_types(b->left, c, ok, Tstr, 0); - propagate_types(b->right, c, ok, Tstr, 0); + propagate_types(b->left, c, perr, Tstr, 0); + propagate_types(b->right, c, perr, Tstr, 0); if (!type_compat(type, Tstr, 0)) type_err(c, "error: Concat returns %1 but %2 expected", prog, Tstr, rules, type); @@ -3729,15 +4266,34 @@ parentheses around an expression converts it into a Term, case StringConv: /* op must be string, result is number */ - propagate_types(b->left, c, ok, Tstr, 0); + propagate_types(b->left, c, perr, Tstr, 0); if (!type_compat(type, Tnum, 0)) type_err(c, // UNTESTED "error: Can only convert string to number, not %1", prog, type, 0, NULL); return Tnum; + case Test: + /* LHS must support ->test, result is Tbool */ + t = propagate_types(b->right, c, perr, NULL, 0); + if (!t || !t->test) + type_err(c, "error: '?' requires a testable value, not %1", + prog, t, 0, NULL); + return Tbool; + + case Choose: + /* LHS and RHS must match and are returned. Must support + * ->test + */ + t = propagate_types(b->left, c, perr, type, rules); + t = propagate_types(b->right, c, perr, t, rules); + if (t && t->test == NULL) + type_err(c, "error: \"??\" requires a testable value, not %1", + prog, t, 0, NULL); + return t; + case Bracket: - return propagate_types(b->right, c, ok, type, 0); + return propagate_types(b->right, c, perr, type, 0); ###### interp binode cases @@ -3814,6 +4370,20 @@ parentheses around an expression converts it into a Term, printf("Unsupported suffix: %.*s\n", tx.len, tx.txt); // UNTESTED break; + case Test: + right = interp_exec(c, b->right, &rtype); + rvtype = Tbool; + rv.bool = !!rtype->test(rtype, &right); + break; + case Choose: + left = interp_exec(c, b->left, <ype); + if (ltype->test(ltype, &left)) { + rv = left; + rvtype = ltype; + ltype = NULL; + } else + rv = interp_exec(c, b->right, &rvtype); + break; ###### value functions @@ -4004,7 +4574,7 @@ the common header for all reductions to use. struct binode *e; for (e = b; e; e = cast(binode, e->right)) { - t = propagate_types(e->left, c, ok, NULL, rules); + t = propagate_types(e->left, c, perr, NULL, rules); if ((rules & Rboolok) && (t == Tbool || t == Tnone)) t = NULL; if (t == Tnone && e->right) @@ -4016,7 +4586,7 @@ the common header for all reductions to use. if (!type) type = t; else if (t != type) - type_err(c, "error: expected %1%r, found %2", + type_err(c, "error: expected %1, found %2", e->left, type, rules, t); } } @@ -4053,19 +4623,19 @@ printed. ###### SimpleStatement Grammar | print ExpressionList ${ - $0 = b = new(binode); + $0 = b = new_pos(binode, $1); b->op = Print; b->right = NULL; b->left = reorder_bilist($op = Print; b->right = reorder_bilist($left = NULL; } }$ | print ${ - $0 = b = new(binode); + $0 = b = new_pos(binode, $1); b->op = Print; b->left = NULL; b->right = NULL; @@ -4093,7 +4663,7 @@ printed. else b = cast(binode, b->right); while (b) { - propagate_types(b->left, c, ok, NULL, Rnolabel); + propagate_types(b->left, c, perr, NULL, 0); b = cast(binode, b->right); } break; @@ -4124,9 +4694,9 @@ An assignment will assign a value to a variable, providing it hasn't been declared as a constant. The analysis phase ensures that the type will be correct so the interpreter just needs to perform the calculation. There is a form of assignment which declares a new -variable as well as assigning a value. If a name is assigned before -it is declared, and error will be raised as the name is created as -`Tlabel` and it is illegal to assign to such names. +variable as well as assigning a value. If a name is used before +it is declared, it is assumed to be a global constant which are allowed to +be declared at any time. ###### Binode types Assign, @@ -4167,9 +4737,9 @@ it is declared, and error will be raised as the name is created as case Assign: do_indent(indent, ""); - print_exec(b->left, indent, bracket); + print_exec(b->left, -1, bracket); printf(" = "); - print_exec(b->right, indent, bracket); + print_exec(b->right, -1, bracket); if (indent >= 0) printf("\n"); break; @@ -4178,7 +4748,7 @@ it is declared, and error will be raised as the name is created as { struct variable *v = cast(var, b->left)->var; do_indent(indent, ""); - print_exec(b->left, indent, bracket); + print_exec(b->left, -1, bracket); if (cast(var, b->left)->var->constant) { printf("::"); if (v->explicit_type) { @@ -4194,7 +4764,7 @@ it is declared, and error will be raised as the name is created as } if (b->right) { printf("= "); - print_exec(b->right, indent, bracket); + print_exec(b->right, -1, bracket); } if (indent >= 0) printf("\n"); @@ -4210,23 +4780,23 @@ it is declared, and error will be raised as the name is created as * For Assign, left must not be constant. * result is Tnone */ - t = propagate_types(b->left, c, ok, NULL, - Rnolabel | (b->op == Assign ? Rnoconstant : 0)); + t = propagate_types(b->left, c, perr, NULL, + (b->op == Assign ? Rnoconstant : 0)); if (!b->right) return Tnone; if (t) { - if (propagate_types(b->right, c, ok, t, 0) != t) + if (propagate_types(b->right, c, perr, t, 0) != t) if (b->left->type == Xvar) type_err(c, "info: variable '%v' was set as %1 here.", cast(var, b->left)->var->where_set, t, rules, NULL); } else { - t = propagate_types(b->right, c, ok, NULL, Rnolabel); + t = propagate_types(b->right, c, perr, NULL, 0); if (t) - propagate_types(b->left, c, ok, t, + propagate_types(b->left, c, perr, t, (b->op == Assign ? Rnoconstant : 0)); } - if (t && t->dup == NULL && t->name.txt[0] != ' ') // HACK + if (t && t->dup == NULL && !(*perr & Emaycopy)) type_err(c, "error: cannot assign value of type %1", b, t, 0, NULL); return Tnone; @@ -4274,17 +4844,6 @@ function which has a return type, and the "condition" code blocks in $0 = b = new_pos(binode, $1); b->op = Use; b->right = $<2; - if (b->right->type == Xvar) { - struct var *v = cast(var, b->right); - if (v->var->type == Tnone) { - /* Convert this to a label */ - struct value *val; - - v->var->type = Tlabel; - val = global_alloc(c, Tlabel, v->var, NULL); - val->label = val; - } - } }$ ###### print binode cases @@ -4300,7 +4859,7 @@ function which has a return type, and the "condition" code blocks in case Use: /* result matches value */ - return propagate_types(b->right, c, ok, type, 0); + return propagate_types(b->right, c, perr, type, 0); ###### interp binode cases @@ -4687,10 +5246,10 @@ casepart` to track a list of case parts. ###### propagate binode cases case Loop: - t = propagate_types(b->right, c, ok, Tnone, 0); + t = propagate_types(b->right, c, perr, Tnone, 0); if (!type_compat(Tnone, t, 0)) - *ok = 0; // UNTESTED - return propagate_types(b->left, c, ok, type, rules); + *perr |= Efail; // UNTESTED + return propagate_types(b->left, c, perr, type, rules); ###### propagate exec cases case Xcond_statement: @@ -4708,51 +5267,51 @@ casepart` to track a list of case parts. struct cond_statement *cs = cast(cond_statement, prog); struct casepart *cp; - t = propagate_types(cs->forpart, c, ok, Tnone, 0); + t = propagate_types(cs->forpart, c, perr, Tnone, 0); if (!type_compat(Tnone, t, 0)) - *ok = 0; // UNTESTED + *perr |= Efail; // UNTESTED if (cs->looppart) { - t = propagate_types(cs->thenpart, c, ok, Tnone, 0); + t = propagate_types(cs->thenpart, c, perr, Tnone, 0); if (!type_compat(Tnone, t, 0)) - *ok = 0; // UNTESTED + *perr |= Efail; // UNTESTED } if (cs->casepart == NULL) { - propagate_types(cs->condpart, c, ok, Tbool, 0); - propagate_types(cs->looppart, c, ok, Tbool, 0); + propagate_types(cs->condpart, c, perr, Tbool, 0); + propagate_types(cs->looppart, c, perr, Tbool, 0); } else { /* Condpart must match case values, with bool permitted */ t = NULL; for (cp = cs->casepart; cp && !t; cp = cp->next) - t = propagate_types(cp->value, c, ok, NULL, 0); + t = propagate_types(cp->value, c, perr, NULL, 0); if (!t && cs->condpart) - t = propagate_types(cs->condpart, c, ok, NULL, Rboolok); // UNTESTED + t = propagate_types(cs->condpart, c, perr, NULL, Rboolok); // UNTESTED if (!t && cs->looppart) - t = propagate_types(cs->looppart, c, ok, NULL, Rboolok); // UNTESTED + t = propagate_types(cs->looppart, c, perr, NULL, Rboolok); // UNTESTED // Now we have a type (I hope) push it down if (t) { for (cp = cs->casepart; cp; cp = cp->next) - propagate_types(cp->value, c, ok, t, 0); - propagate_types(cs->condpart, c, ok, t, Rboolok); - propagate_types(cs->looppart, c, ok, t, Rboolok); + propagate_types(cp->value, c, perr, t, 0); + propagate_types(cs->condpart, c, perr, t, Rboolok); + propagate_types(cs->looppart, c, perr, t, Rboolok); } } // (if)then, else, and case parts must return expected type. if (!cs->looppart && !type) - type = propagate_types(cs->thenpart, c, ok, NULL, rules); + type = propagate_types(cs->thenpart, c, perr, NULL, rules); if (!type) - type = propagate_types(cs->elsepart, c, ok, NULL, rules); + type = propagate_types(cs->elsepart, c, perr, NULL, rules); for (cp = cs->casepart; cp && !type; cp = cp->next) // UNTESTED - type = propagate_types(cp->action, c, ok, NULL, rules); // UNTESTED + type = propagate_types(cp->action, c, perr, NULL, rules); // UNTESTED if (type) { if (!cs->looppart) - propagate_types(cs->thenpart, c, ok, type, rules); - propagate_types(cs->elsepart, c, ok, type, rules); + propagate_types(cs->thenpart, c, perr, type, rules); + propagate_types(cs->elsepart, c, perr, type, rules); for (cp = cs->casepart; cp ; cp = cp->next) - propagate_types(cp->action, c, ok, type, rules); + propagate_types(cp->action, c, perr, type, rules); return type; } else return NULL; @@ -4857,13 +5416,15 @@ various declarations in the parse context. ### The `const` section -As well as being defined in with the code that uses them, constants -can be declared at the top level. These have full-file scope, so they -are always `InScope`. The value of a top level constant can be given -as an expression, and this is evaluated immediately rather than in the -later interpretation stage. Once we add functions to the language, we -will need rules concern which, if any, can be used to define a top -level constant. +As well as being defined in with the code that uses them, constants can +be declared at the top level. These have full-file scope, so they are +always `InScope`, even before(!) they have been declared. The value of +a top level constant can be given as an expression, and this is +evaluated after parsing and before execution. + +A function call can be used to evaluate a constant, but it will not have +access to any program state, once such statement becomes meaningful. +e.g. arguments and filesystem will not be visible. Constants are defined in a section that starts with the reserved word `const` and then has a block with a list of assignment statements. @@ -4872,11 +5433,8 @@ make it clear that they are constants. Type can also be given: if not, the type will be determined during analysis, as with other constants. -As the types constants are inserted at the head of a list, printing -them in the same order that they were read is not straight forward. -We take a quadratic approach here and count the number of constants -(variables of depth 0), then count down from there, each time -searching through for the Nth constant for decreasing N. +###### parse context + struct binode *constlist; ###### top level grammar @@ -4903,69 +5461,119 @@ searching through for the Nth constant for decreasing N. $void Const -> IDENTIFIER :: CType = Expression ${ { - int ok; struct variable *v; + struct binode *bl, *bv; + struct var *var = new_pos(var, $ID); - v = var_decl(c, $1.txt); + v = var_decl(c, $ID.txt); if (v) { - struct var *var = new_pos(var, $1); v->where_decl = var; v->where_set = var; - var->var = v; + v->type = $constant = 1; v->global = 1; } else { - struct variable *vorig = var_ref(c, $1.txt); - tok_err(c, "error: name already declared", &$1); - type_err(c, "info: this is where '%v' was first declared", - vorig->where_decl, NULL, 0, NULL); - } - do { - ok = 1; - propagate_types($5, c, &ok, $3, 0); - } while (ok == 2); - if (!ok) - c->parse_error = 1; - else if (v) { - struct value res = interp_exec(c, $5, &v->type); - global_alloc(c, v->type, v, &res); + v = var_ref(c, $1.txt); + if (v->type == Tnone) { + v->where_decl = var; + v->where_set = var; + v->type = $constant = 1; + v->global = 1; + } else { + tok_err(c, "error: name already declared", &$1); + type_err(c, "info: this is where '%v' was first declared", + v->where_decl, NULL, 0, NULL); + } } + var->var = v; + + bv = new(binode); + bv->op = Declare; + bv->left = var; + bv->right= $op = List; + bl->left = c->constlist; + bl->right = bv; + c->constlist = bl; } }$ -###### print const decls +###### core functions + static void resolve_consts(struct parse_context *c) { - struct variable *v; - int target = -1; - - while (target != 0) { - int i = 0; - for (v = context.in_scope; v; v=v->in_scope) - if (v->depth == 0 && v->constant) { - i += 1; - if (i == target) - break; + struct binode *b; + int retry = 1; + enum { none, some, cannot } progress = none; + + c->constlist = reorder_bilist(c->constlist); + while (retry) { + retry = 0; + for (b = cast(binode, c->constlist); b; + b = cast(binode, b->right)) { + enum prop_err perr; + struct binode *vb = cast(binode, b->left); + struct var *v = cast(var, vb->left); + if (v->var->frame_pos >= 0) + continue; + do { + perr = 0; + propagate_types(vb->right, c, &perr, + v->var->type, 0); + } while (perr & Eretry); + if (perr & Efail) + c->parse_error += 1; + else if (!(perr & Eruntime)) { + progress = some; + struct value res = interp_exec( + c, vb->right, &v->var->type); + global_alloc(c, v->var->type, v->var, &res); + } else { + if (progress == cannot) + type_err(c, "error: const %v cannot be resolved.", + v, NULL, 0, NULL); + else + retry = 1; } - - if (target == -1) { - if (i) - printf("const\n"); - target = i; - } else { - struct value *val = var_value(&context, v); - printf(" %.*s :: ", v->name->name.len, v->name->name.txt); - type_print(v->type, stdout); - printf(" = "); - if (v->type == Tstr) - printf("\""); - print_value(v->type, val, stdout); - if (v->type == Tstr) - printf("\""); - printf("\n"); - target -= 1; + } + switch (progress) { + case cannot: + retry = 0; break; + case none: + progress = cannot; break; + case some: + progress = none; break; } } } +###### print const decls + { + struct binode *b; + int first = 1; + + for (b = cast(binode, context.constlist); b; + b = cast(binode, b->right)) { + struct binode *vb = cast(binode, b->left); + struct var *vr = cast(var, vb->left); + struct variable *v = vr->var; + + if (first) + printf("const\n"); + first = 0; + + printf(" %.*s :: ", v->name->name.len, v->name->name.txt); + type_print(v->type, stdout); + printf(" = "); + print_exec(vb->right, -1, 0); + printf("\n"); + } + } + +###### free const decls + free_binode(context.constlist); + ### Function declarations The code in an Ocean program is all stored in function declarations. @@ -4986,7 +5594,7 @@ is a bit more interesting at this level. * is a list for 'struct var' */ struct type *t = add_anon_type(c, &structure_prototype, - " function result"); + "function result"); int cnt = 0; struct binode *b; @@ -5120,20 +5728,20 @@ is a bit more interesting at this level. for (v = c->in_scope; v; v = v->in_scope) { struct value *val; struct type *ret; - int ok = 1; + enum prop_err perr; if (v->depth != 0 || !v->type || !v->type->check_args) continue; ret = v->type->function.inline_result ? Tnone : v->type->function.return_type; val = var_value(c, v); do { - ok = 1; - propagate_types(val->function, c, &ok, ret, 0); - } while (ok == 2); - if (ok) + perr = 0; + propagate_types(val->function, c, &perr, ret, 0); + } while (!(perr & Efail) && (perr & Eretry)); + if (!(perr & Efail)) /* Make sure everything is still consistent */ - propagate_types(val->function, c, &ok, ret, 0); - if (!ok) + propagate_types(val->function, c, &perr, ret, 0); + if (perr & Efail) all_ok = 0; if (!v->type->function.inline_result && !v->type->function.return_type->dup) { @@ -5150,7 +5758,7 @@ is a bit more interesting at this level. { struct binode *bp = type->function.params; struct binode *b; - int ok = 1; + enum prop_err perr; int arg = 0; struct type *argv_type; @@ -5159,16 +5767,16 @@ is a bit more interesting at this level. argv_type->array.unspec = 1; for (b = bp; b; b = cast(binode, b->right)) { - ok = 1; + perr = 0; switch (arg++) { case 0: /* argv */ - propagate_types(b->left, c, &ok, argv_type, 0); + propagate_types(b->left, c, &perr, argv_type, 0); break; default: /* invalid */ // NOTEST - propagate_types(b->left, c, &ok, Tnone, 0); // NOTEST + propagate_types(b->left, c, &perr, Tnone, 0); // NOTEST } - if (!ok) - c->parse_error = 1; + if (perr & Efail) + c->parse_error += 1; } return !c->parse_error; @@ -5189,12 +5797,12 @@ is a bit more interesting at this level. progp = var_value(c, mainv); if (!progp || !progp->function) { fprintf(stderr, "oceani: no main function found.\n"); - c->parse_error = 1; + c->parse_error += 1; return; } if (!analyse_main(mainv->type, c)) { fprintf(stderr, "oceani: main has wrong type.\n"); - c->parse_error = 1; + c->parse_error += 1; return; } al = mainv->type->function.params; @@ -5327,19 +5935,19 @@ things which will likely grow as the languages grows. while mid := (lo + hi) / 2 if mid == target: - use Found + use .Found if mid < target: lo = mid else hi = mid if hi - lo < 1: lo = mid - use GiveUp + use .GiveUp use True do pass - case Found: + case .Found: print "Yay, I found", target - case GiveUp: + case .GiveUp: print "Closest I found was", lo size::= 10