Теперь возможен вызов процедур-переменных из полей записей

diff --git a/notes b/notes
index 2f6fc268841c8c8fb378f328265f345dbe99753f..7431ec7b508b5d28a6652deb57e340be3db5667a 100644 (file)
--- a/notes
+++ b/notes
@@ -1,9 +1,5 @@
-- Нет оператора IS
-- Нужно изменить передачу информации о вызываемой процедуре в MODE_CALL
-   На данный момент конкретная процедура передаётся в поле var, вместо parent
-   Что не позволяет делать процедуры-переменные в полях записей, массивах и т.д.
-
 - нет символов и строк
+- Нет оператора IS
 - нету типа set
 
 - нету операторов if, while и т.д.

diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c
index 8c9d69f61258fb91af3a443771b682692fb7d1ee..d986a8e4cbc9af35a1fcf9361c531238c1de3fa8 100644 (file)
--- a/src/backends/jvm/generator-jvm.c
+++ b/src/backends/jvm/generator-jvm.c
@@ -166,7 +166,7 @@ jvm_generate_push_int(gen_proc_t * p, int64_t i)
        }
        else
        {
-               jvm_generate(p, 0, 2, "ldc2 %li", i);
+               jvm_generate(p, 0, 2, "ldc2_w %li", i);
        }
 }
 
@@ -198,7 +198,7 @@ jvm_generate_push_int_size(gen_proc_t * p, int64_t i, int size)
        else
        {
                pushed_cell = 2;
-               jvm_generate(p, 0, 2, "ldc2 %li", i);
+               jvm_generate(p, 0, 2, "ldc2_w %li", i);
        }
 
        assert(size <= 8);
@@ -258,7 +258,7 @@ jvm_generate_push_float(gen_proc_t * p, double f, int size)
                }
                else
                {
-                       jvm_generate(p, 0, 2, "ldc2 %lf", f);
+                       jvm_generate(p, 0, 2, "ldc2_w %lf", f);
                }
        }
 }
@@ -689,6 +689,9 @@ jvm_generate_push_procedure_pointer(gen_proc_t * p, oberon_object_t * proc)
 // ==========================================
 // ==========================================
 
+static void
+push_item(gen_proc_t * p, oberon_item_t * item);
+
 void
 oberon_generator_init_context(oberon_context_t * ctx)
 {
@@ -1224,30 +1227,39 @@ oberon_generate_end_proc(oberon_context_t * ctx)
 }
 
 static void
-jvm_generate_call_proc(gen_proc_t * p, oberon_expr_t * desig)
+jvm_generate_call_proc(gen_proc_t * p, oberon_item_t * desig)
 {
-       assert(desig -> is_item);
-       assert(desig -> item.mode == MODE_CALL);
-       
-       oberon_object_t * proc;
-       char * fullname;
-       char * signature;
+       assert(desig -> var == NULL);
+       assert(desig -> mode == MODE_CALL);
 
-       proc = desig -> item.var;
-       fullname = jvm_get_field_full_name(proc);
-       signature = jvm_get_procedure_signature(proc -> type);
+       char * signature = NULL;
+
+       bool direct_call = false;
+       if(desig -> parent -> mode == MODE_VAR)
+       {
+               if(desig -> parent -> var -> class == OBERON_CLASS_PROC)
+               {
+                       direct_call = true;
+               }
+       }
+
+       printf("direct_call == %i\n", direct_call);
+
+       oberon_type_t * procsig;
+       procsig = desig -> parent -> result;
+       signature = jvm_get_procedure_signature(procsig);
 
-       if(proc -> class != OBERON_CLASS_PROC)
+       if(direct_call == false)
        {
                /* Загружаем указатель на процедуру */
-               jvm_generate_load(p, proc -> type, proc -> gen_var);
+               push_item(p, desig -> parent);
        }
 
        int args_cells = 0;
-       int result_cells = jvm_cell_size_for_type(proc -> type -> base);
+       int result_cells = jvm_cell_size_for_type(procsig -> base);
 
-       int num = desig -> item.num_args;
-       oberon_expr_t * arg = desig -> item.args;
+       int num = desig -> num_args;
+       oberon_expr_t * arg = desig -> args;
        for(int i = 0; i < num; i++)
        {
                args_cells += jvm_cell_size_for_type(arg -> result);
@@ -1255,23 +1267,23 @@ jvm_generate_call_proc(gen_proc_t * p, oberon_expr_t * desig)
                arg = arg -> next;
        }
 
-       if(proc -> class == OBERON_CLASS_PROC)
+       if(direct_call)
        {
-               /* Обычная статическая процедура */
-               jvm_generate(p, args_cells, result_cells, "invokestatic %s%s", fullname, signature);            
+               char * full_name = jvm_get_field_full_name(desig -> parent -> var);
+               jvm_generate(p, args_cells, result_cells, "invokestatic %s%s", full_name, signature);
        }
        else
        {
-               /* Процедура-переменная */
-               char * class = jvm_get_class_full_name(proc -> type);
-               jvm_generate(p, 1 + args_cells, result_cells, "invokevirtual %s/invoke%s", class, signature);
+               char * cname = jvm_get_class_full_name(procsig);
+               jvm_generate(p, 1 + args_cells, result_cells, "invokevirtual %s/invoke%s", cname, signature);
        }
 }
 
 void
 oberon_generate_call_proc(oberon_context_t * ctx, oberon_expr_t * desig)
 {
-       jvm_generate_call_proc(ctx -> mod -> gen_mod -> class -> p, desig);
+       assert(desig -> is_item);
+       jvm_generate_call_proc(ctx -> mod -> gen_mod -> class -> p, (oberon_item_t *) desig);
 }
 
 void
@@ -1360,7 +1372,7 @@ push_item(gen_proc_t * p, oberon_item_t * item)
                        jvm_generate_push_int_size(p, item -> boolean, item -> result -> size);
                        break;
                case MODE_CALL:
-                       jvm_generate_call_proc(p, (oberon_expr_t *) item);
+                       jvm_generate_call_proc(p, item);
                        break;
                case MODE_INDEX:
                        ;
@@ -1390,10 +1402,6 @@ push_item(gen_proc_t * p, oberon_item_t * item)
                case MODE_REAL:
                        jvm_generate_push_float(p, item -> real, item -> result -> size);
                        break;
-               case MODE_CAST:
-                       push_expr(p, item -> parent);
-                       jvm_generate_cast_type(p, item -> parent -> result, item -> result);
-                       break;
                default:
                        gen_error("push_item: unk mode %i", item -> mode);
                        break;
@@ -1573,6 +1581,10 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper)
        int op = oper -> op;
        switch(op)
        {
+               case OP_CAST:
+                       push_expr(p, oper -> left);
+                       jvm_generate_cast_type(p, oper -> left -> result, oper -> result);
+                       break;
                case OP_UNARY_MINUS:
                case OP_BITWISE_NOT:
                case OP_LOGIC_NOT:

diff --git a/src/oberon-internals.h b/src/oberon-internals.h
index 1e92de1763923d410e342e0d21cb29ab68c2961e..c28cfa5b80761a1d42992a32ffa5d49fa31dce76 100644 (file)
--- a/src/oberon-internals.h
+++ b/src/oberon-internals.h
@@ -44,6 +44,9 @@ enum
        OBERON_TYPE_REAL
 };
 
+typedef oberon_expr_t * (*GenerateFuncCallback)(oberon_context_t *, int, oberon_expr_t *);
+typedef void (*GenerateProcCallback)(oberon_context_t *, int, oberon_expr_t *);
+
 struct oberon_type_t
 {
        int class;
@@ -54,6 +57,10 @@ struct oberon_type_t
        oberon_object_t * decl;
        oberon_scope_t * scope;
 
+       bool sysproc;
+       GenerateFuncCallback genfunc;
+       GenerateProcCallback genproc;
+
        oberon_module_t * module;
 
        int recursive;
@@ -73,9 +80,6 @@ enum
        OBERON_CLASS_MODULE
 };
 
-typedef oberon_expr_t * (*GenerateFuncCallback)(oberon_context_t *, int, oberon_expr_t *);
-typedef void (*GenerateProcCallback)(oberon_context_t *, int, oberon_expr_t *);
-
 struct oberon_object_t
 {
        char * name;
@@ -92,9 +96,6 @@ struct oberon_object_t
 
        oberon_scope_t * scope; // for proc
        int has_return; // for proc
-       int sysproc;
-       GenerateFuncCallback genfunc;
-       GenerateProcCallback genproc;
 
        oberon_type_t * type;
        oberon_item_t * value;
@@ -167,7 +168,6 @@ enum
        MODE_NIL,
        MODE_NEW,
        MODE_REAL,
-       MODE_CAST
 };
 
 enum
@@ -193,7 +193,9 @@ enum
        OP_LSS,
        OP_LEQ,
        OP_GRT,
-       OP_GEQ
+       OP_GEQ,
+
+       OP_CAST
 };
 
 struct oberon_item_t
@@ -209,7 +211,7 @@ struct oberon_item_t
        int boolean;
        oberon_object_t * var;
 
-       oberon_expr_t * parent;
+       oberon_item_t * parent;
 
        int num_args;
        oberon_expr_t * args;

diff --git a/src/oberon.c b/src/oberon.c
index cefd46928194b60c17099c25211692000f067ff4..570db39df1417efe4ffde397dc3f600ab2cc9e22 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -33,6 +33,8 @@ enum {
        LEQ,
        GREAT,
        GEQ,
+       IN,
+       IS,
        PLUS,
        MINUS,
        OR,
@@ -350,6 +352,14 @@ oberon_read_ident(oberon_context_t * ctx)
        {
                ctx -> token = IMPORT;
        }
+       else if(strcmp(ident, "IN") == 0)
+       {
+               ctx -> token = IN;
+       }
+       else if(strcmp(ident, "IS") == 0)
+       {
+               ctx -> token = IS;
+       }
 }
 
 static void
@@ -760,11 +770,7 @@ oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first,
 static oberon_expr_t *
 oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
 {
-       oberon_expr_t * cast;
-       cast = oberon_new_item(MODE_CAST, pref, expr -> read_only);
-       cast -> item.parent = expr;
-       cast -> next = expr -> next;
-       return cast;
+       return oberon_new_operator(OP_CAST, pref, expr, NULL);
 }
 
 static oberon_expr_t *
@@ -893,25 +899,15 @@ oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_ex
 }
 
 static void
-oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
+oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig)
 {
-       if(desig -> is_item == 0)
-       {
-               oberon_error(ctx, "expected item");
-       }
-
-       if(desig -> item.mode != MODE_CALL)
+       if(desig -> mode != MODE_CALL)
        {
                oberon_error(ctx, "expected mode CALL");
        }
 
-       if(desig -> item.var -> type -> class != OBERON_TYPE_PROCEDURE)
-       {
-               oberon_error(ctx, "only procedures can be called");
-       }
-
-       oberon_type_t * fn = desig -> item.var -> type;
-       int num_args = desig -> item.num_args;
+       oberon_type_t * fn = desig -> parent -> result;
+       int num_args = desig -> num_args;
        int num_decl = fn -> num_decl;
 
        if(num_args < num_decl)
@@ -925,7 +921,7 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
 
        /* Делаем проверку на запись и делаем автокаст */
        oberon_expr_t * casted[num_args];
-       oberon_expr_t * arg = desig -> item.args;
+       oberon_expr_t * arg = desig -> args;
        oberon_object_t * param = fn -> decl;
        for(int i = 0; i < num_args; i++)
        {
@@ -950,62 +946,84 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
                {
                        casted[i] -> next = casted[i + 1];
                }
-               desig -> item.args = arg;
+               desig -> args = arg;
        }
 }
 
 static oberon_expr_t *
-oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
+oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
 {
-       switch(proc -> class)
+       oberon_type_t * signature = item -> result;
+       if(signature -> class != OBERON_TYPE_PROCEDURE)
        {
-               case OBERON_CLASS_PROC:
-                       if(proc -> class != OBERON_CLASS_PROC)
-                       {
-                               oberon_error(ctx, "not a procedure");
-                       }
-                       break;
-               case OBERON_CLASS_VAR:
-               case OBERON_CLASS_VAR_PARAM:
-               case OBERON_CLASS_PARAM:
-                       if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
-                       {
-                               oberon_error(ctx, "not a procedure");
-                       }
-                       break;
-               default:
-                       oberon_error(ctx, "not a procedure");
-                       break;
+               oberon_error(ctx, "not a procedure");
        }
 
        oberon_expr_t * call;
 
-       if(proc -> sysproc)
+       if(signature -> sysproc)
        {
-               if(proc -> genfunc == NULL)
+               if(signature -> genfunc == NULL)
                {
                        oberon_error(ctx, "not a function-procedure");
                }
 
-               call = proc -> genfunc(ctx, num_args, list_args);
+               call = signature -> genfunc(ctx, num_args, list_args);
        }
        else
        {
-               if(proc -> type -> base -> class == OBERON_TYPE_VOID)
+               if(signature -> base -> class == OBERON_TYPE_VOID)
                {
                        oberon_error(ctx, "attempt to call procedure in expression");
                }
 
-               call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
-               call -> item.var = proc;
+               call = oberon_new_item(MODE_CALL, signature -> base, true);
+               call -> item.parent = item;
                call -> item.num_args = num_args;
                call -> item.args = list_args;
-               oberon_autocast_call(ctx, call);
+               oberon_autocast_call(ctx, (oberon_item_t *) call);
        }
 
        return call;
 }
 
+static void
+oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
+{
+       oberon_type_t * signature = item -> result;
+       if(signature -> class != OBERON_TYPE_PROCEDURE)
+       {
+               oberon_error(ctx, "not a procedure");
+       }
+
+       oberon_expr_t * call;
+
+       if(signature -> sysproc)
+       {
+               if(signature -> genproc == NULL)
+               {
+                       oberon_error(ctx, "not a procedure");
+               }
+
+               signature -> genproc(ctx, num_args, list_args);
+       }
+       else
+       {
+               if(signature -> base -> class != OBERON_TYPE_VOID)
+               {
+                       oberon_error(ctx, "attempt to call function as non-typed procedure");
+               }
+
+               call = oberon_new_item(MODE_CALL, signature -> base, true);
+               call -> item.parent = item;
+               call -> item.num_args = num_args;
+               call -> item.args = list_args;
+               oberon_autocast_call(ctx, (oberon_item_t *) call);
+               oberon_generate_call_proc(ctx, call);
+       }
+}
+
+/*
 static void
 oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
 {
@@ -1055,6 +1073,7 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_ar
                oberon_generate_call_proc(ctx, call);
        }
 }
+*/
 
 #define ISEXPR(x) \
        (((x) == PLUS) \
@@ -1078,7 +1097,7 @@ oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
 
        oberon_expr_t * selector;
        selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
-       selector -> item.parent = expr;
+       selector -> item.parent = (oberon_item_t *) expr;
 
        return selector;
 }
@@ -1125,7 +1144,7 @@ oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon
 
        oberon_expr_t * selector;
        selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
-       selector -> item.parent = desig;
+       selector -> item.parent = (oberon_item_t *) desig;
        selector -> item.num_args = 1;
        selector -> item.args = index;
 
@@ -1140,7 +1159,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char *
                expr = oberno_make_dereferencing(ctx, expr);
        }
 
-       assert(expr -> is_item == 1);
+       assert(expr -> is_item);
 
        if(expr -> result -> class != OBERON_TYPE_RECORD)
        {
@@ -1172,7 +1191,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char *
        oberon_expr_t * selector;
        selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
        selector -> item.var = field;
-       selector -> item.parent = expr;
+       selector -> item.parent = (oberon_item_t *) expr;
 
        return selector;
 }
@@ -1254,7 +1273,8 @@ oberon_designator(oberon_context_t * ctx)
        }
        expr -> item.var = var;
 
-       while(ISSELECTOR(ctx -> token))
+       bool brk = false;
+       while(brk == false && ISSELECTOR(ctx -> token))
        {
                switch(ctx -> token)
                {
@@ -1281,6 +1301,11 @@ oberon_designator(oberon_context_t * ctx)
                                expr = oberno_make_dereferencing(ctx, expr);
                                break;
                        case LPAREN:
+                               if(expr -> result -> class == OBERON_TYPE_PROCEDURE)
+                               {
+                                       brk = true;
+                                       break;
+                               }
                                oberon_assert_token(ctx, LPAREN);
                                oberon_object_t * objtype = oberon_qualident(ctx, NULL, 1);
                                if(objtype -> class != OBERON_CLASS_TYPE)
@@ -1316,7 +1341,7 @@ oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
                        oberon_expr_list(ctx, &num_args, &arguments, 0);
                }
 
-               expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
+               expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);
 
                oberon_assert_token(ctx, RPAREN);
        }
@@ -1345,7 +1370,7 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
        }
 
        /* Вызов происходит даже без скобок */
-       oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
+       oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments);
 }
 
 static oberon_type_t *
@@ -1629,7 +1654,7 @@ oberon_simple_expr(oberon_context_t * ctx)
 }
 
 #define ISRELATION(x) \
-       ((x) >= EQUAL && (x) <= GEQ)
+       ((x) >= EQUAL && (x) <= IS)
 
 static oberon_expr_t *
 oberon_expr(oberon_context_t * ctx)
@@ -2870,10 +2895,10 @@ oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f
 {
        oberon_object_t * proc;
        proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
-       proc -> sysproc = 1;
-       proc -> genfunc = f;
-       proc -> genproc = p;
        proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
+       proc -> type -> sysproc = true;
+       proc -> type -> genfunc = f;
+       proc -> type -> genproc = p;
 }
 
 static oberon_expr_t *

diff --git a/src/test.c b/src/test.c
index c6d49e48cb3b54951d1ce87cb7ce6f3b255f7789..3305807bbb3fa1c87b0cbd508aaec7e6787ebbfb 100644 (file)
--- a/src/test.c
+++ b/src/test.c
@@ -9,24 +9,38 @@ static char source_test[] =
        "MODULE Test;"
        "IMPORT Out;"
        "TYPE"
-       "  Baser = RECORD a : INTEGER; END;"
-       "  R1 = RECORD (Baser)"
-       "    b : R2;"
-       "  END;"
-       "  "
-       "  R2 = RECORD"
-       "    a : POINTER TO R1;"
+       "  Callback = PROCEDURE;"
+       "  Callfront = PROCEDURE(x : LONGINT) : LONGINT;"
+       "  RecDesc = RECORD"
+       "    cb : Callback;"
+       "    cf : Callfront;"
        "  END;"
        ""
        "VAR"
-       "  baser : Baser;"
-       "  r     : R1;"
-       "  inv   : R2;"
+       "  r : RecDesc;"
+       "  i : LONGINT;"
+       ""
+       "PROCEDURE Stuff;"
+       "BEGIN"
+       "  Out.Int(0123456789, 0); Out.Ln;"
+       "END Stuff;"
+       ""
+       "PROCEDURE Ffuts (x : LONGINT) : LONGINT;"
+       "BEGIN"
+       "  RETURN 9876543210 + x;"
+       "END Ffuts;"
        ""
        "BEGIN"
-       "  r.a := 1;"
-       "  baser := baser;"
-       "  baser := r;"
+       "  Out.Open;"
+       "  Out.Int(1, 0); Out.Ln;"
+       "  r.cb := Stuff;"
+       "  Out.Int(2, 0); Out.Ln;"
+       "  r.cb();"
+       "  Out.Int(3, 0); Out.Ln;"
+       "  r.cf := Ffuts;"
+       "  Out.Int(4, 0); Out.Ln;"
+       "  i := r.cf(0123456789);"
+       "  Out.Int(i, 0); Out.Ln;"
        "END Test."
 ;