Добавлены встроенные процедуры

diff --git a/generator.c b/generator.c
index b17a8cd977cf450733a38fe9510b01db8754bd6f..709e5a65cbfb513cd502e2bf7d70383b89468449 100644 (file)
--- a/generator.c
+++ b/generator.c
@@ -519,14 +519,19 @@ struct {
                enum gcc_jit_comparison comp_op;
        };
 } op_table[] = {
-       { 0, .unary_op = GCC_JIT_UNARY_OP_LOGICAL_NEGATE },
        { 0, .unary_op = GCC_JIT_UNARY_OP_MINUS },
+       { 0, .unary_op = GCC_JIT_UNARY_OP_BITWISE_NEGATE },
+       { 0, .unary_op = GCC_JIT_UNARY_OP_LOGICAL_NEGATE },
+       { 0, .unary_op = GCC_JIT_UNARY_OP_ABS },
 
        { 1, .binary_op = GCC_JIT_BINARY_OP_PLUS },
        { 1, .binary_op = GCC_JIT_BINARY_OP_MINUS },
        { 1, .binary_op = GCC_JIT_BINARY_OP_MULT },
        { 1, .binary_op = GCC_JIT_BINARY_OP_DIVIDE },
        { 1, .binary_op = GCC_JIT_BINARY_OP_MODULO },
+       { 1, .binary_op = GCC_JIT_BINARY_OP_BITWISE_AND },
+       { 1, .binary_op = GCC_JIT_BINARY_OP_BITWISE_XOR },
+       { 1, .binary_op = GCC_JIT_BINARY_OP_BITWISE_OR },
        { 1, .binary_op = GCC_JIT_BINARY_OP_LOGICAL_AND },
        { 1, .binary_op = GCC_JIT_BINARY_OP_LOGICAL_OR },
 

diff --git a/notes b/notes
index ec0a69c441200b6244b0b59de931b9deadfd8be3..3c1b0db19f698c2c42cf661374a9d10e55dff6d3 100644 (file)
--- a/notes
+++ b/notes
@@ -1,4 +1,4 @@
-- нужно сделать объявление встроенных процедур
+- нету тестовых процедур для ввода-вывода
 - нету процедуры NEW
 - нету открытых массивов
 
@@ -10,7 +10,7 @@
 - не реализована свёртка констант
 - не протестированы типы разнных размеров
 
-- не реализовано расширение типа record
+- не реализовано расширение типа record (libgccjit не умеет в классы)
 - не работает присваивание к переменным-процедурам.
 - не реализован автокаст (libgccjit сам разруливает)
 - libgccjit не умеет в локальные функции (опять пилить костыли как в jvm)

diff --git a/oberon.c b/oberon.c
index c3a6f86ce77fc9d57002b7263e394f218b2140ce..6dd84f16b6b9c3108973c087636865c661735bc3 100644 (file)
--- a/oberon.c
+++ b/oberon.c
@@ -777,6 +777,76 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
        }
 }
 
+static oberon_expr_t *
+oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
+{
+       if(proc -> class != OBERON_CLASS_PROC)
+       {
+               oberon_error(ctx, "not a procedure");
+       }
+
+       oberon_expr_t * call;
+
+       if(proc -> sysproc)
+       {
+               if(proc -> genfunc == NULL)
+               {
+                       oberon_error(ctx, "not a function-procedure");
+               }
+
+               call = proc -> genfunc(ctx, num_args, list_args);
+       }
+       else
+       {
+               if(proc -> type -> base -> class == OBERON_TYPE_VOID)
+               {
+                       oberon_error(ctx, "attempt to call procedure in expression");
+               }
+
+               call = oberon_new_item(MODE_CALL, proc -> type -> base);
+               call -> item.var = proc;
+               call -> item.num_args = num_args;
+               call -> item.args = list_args;
+               oberon_autocast_call(ctx, call);
+       }
+
+       return call;
+}
+
+static void
+oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
+{
+       if(proc -> class != OBERON_CLASS_PROC)
+       {
+               oberon_error(ctx, "not a procedure");
+       }
+
+       if(proc -> sysproc)
+       {
+               if(proc -> genproc == NULL)
+               {
+                       oberon_error(ctx, "requres non-typed procedure");
+               }
+
+               proc -> genproc(ctx, num_args, list_args);
+       }
+       else
+       {
+               if(proc -> type -> base -> class != OBERON_TYPE_VOID)
+               {
+                       oberon_error(ctx, "attempt to call function as non-typed procedure");
+               }
+
+               oberon_expr_t * call;
+               call = oberon_new_item(MODE_CALL, proc -> type -> base);
+               call -> item.var = proc;
+               call -> item.num_args = num_args;
+               call -> item.args = list_args;
+               oberon_autocast_call(ctx, call);
+               oberon_generate_call_proc(ctx, call);
+       }
+}
+
 #define ISEXPR(x) \
        (((x) == PLUS) \
        || ((x) == MINUS) \
@@ -905,6 +975,7 @@ oberon_designator(oberon_context_t * ctx)
                        expr = oberon_new_item(MODE_VAR, var -> type);
                        break;
                case OBERON_CLASS_PROC:
+                       //expr = oberon_make_call_expr(var, 0, NULL);
                        expr = oberon_new_item(MODE_CALL, var -> type);
                        break;
                default:
@@ -948,17 +1019,37 @@ oberon_designator(oberon_context_t * ctx)
 }
 
 static oberon_expr_t *
-oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
+oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 {
        assert(expr -> is_item == 1);
 
        if(ctx -> token == LPAREN)
        {
-               if(expr -> result -> class != OBERON_TYPE_PROCEDURE)
+               oberon_assert_token(ctx, LPAREN);
+
+               int num_args = 0;
+               oberon_expr_t * arguments = NULL;
+
+               if(ISEXPR(ctx -> token))
                {
-                       oberon_error(ctx, "not a procedure");
+                       oberon_expr_list(ctx, &num_args, &arguments, 0);
                }
 
+               expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
+
+               oberon_assert_token(ctx, RPAREN);
+       }
+
+       return expr;
+}
+
+static void
+oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
+{
+       assert(expr -> is_item == 1);
+
+       if(ctx -> token == LPAREN)
+       {
                oberon_assert_token(ctx, LPAREN);
 
                int num_args = 0;
@@ -969,16 +1060,10 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
                        oberon_expr_list(ctx, &num_args, &arguments, 0);
                }
 
-               expr -> result = expr -> item.var -> type -> base;
-               expr -> item.mode = MODE_CALL;
-               expr -> item.num_args = num_args;
-               expr -> item.args = arguments;
-               oberon_assert_token(ctx, RPAREN);
+               oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
 
-               oberon_autocast_call(ctx, expr);
+               oberon_assert_token(ctx, RPAREN);
        }
-
-       return expr;
 }
 
 static oberon_expr_t *
@@ -990,7 +1075,7 @@ oberon_factor(oberon_context_t * ctx)
        {
                case IDENT:
                        expr = oberon_designator(ctx);
-                       expr = oberon_opt_proc_parens(ctx, expr);
+                       expr = oberon_opt_func_parens(ctx, expr);
                        break;
                case INTEGER:
                        expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
@@ -2118,21 +2203,6 @@ oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
        oberon_generate_assign(ctx, src, dst);
 }
 
-static void
-oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
-{
-       if(desig -> result -> class != OBERON_TYPE_VOID)
-       {
-               if(desig -> result -> class != OBERON_TYPE_PROCEDURE)
-               {
-                       oberon_error(ctx, "procedure with result");
-               }
-       }
-
-       oberon_autocast_call(ctx, desig);
-       oberon_generate_call_proc(ctx, desig);
-}
-
 static void
 oberon_statement(oberon_context_t * ctx)
 {
@@ -2150,8 +2220,7 @@ oberon_statement(oberon_context_t * ctx)
                }
                else
                {
-                       item1 = oberon_opt_proc_parens(ctx, item1);
-                       oberon_make_call(ctx, item1);
+                       oberon_opt_proc_parens(ctx, item1);
                }
        }
        else if(ctx -> token == RETURN)
@@ -2233,6 +2302,58 @@ register_default_types(oberon_context_t * ctx)
        oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
 }
 
+static void
+oberon_new_intrinsic_function(oberon_context_t * ctx, char * name, GenerateFuncCallback generate)
+{
+       oberon_object_t * proc;
+       proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC);
+       proc -> sysproc = 1;
+       proc -> genfunc = generate;
+       proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
+}
+
+/*
+static void
+oberon_new_intrinsic_procedure(oberon_context_t * ctx, char * name, GenerateProcCallback generate)
+{
+       oberon_object_t * proc;
+       proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC);
+       proc -> sysproc = 1;
+       proc -> genproc = generate;
+       proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
+}
+*/
+
+static oberon_expr_t *
+oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
+{
+       if(num_args < 1)
+       {
+               oberon_error(ctx, "too few arguments");
+       }
+
+       if(num_args > 1)
+       {
+               oberon_error(ctx, "too mach arguments");
+       }
+
+       oberon_expr_t * arg;
+       arg = list_args;
+
+       oberon_type_t * result_type;
+       result_type = arg -> result;
+       
+       if(result_type -> class != OBERON_TYPE_INTEGER)
+       {
+               oberon_error(ctx, "ABS accepts only integers");
+       }
+
+
+       oberon_expr_t * expr;
+       expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
+       return expr;
+}
+
 oberon_context_t *
 oberon_create_context()
 {
@@ -2245,7 +2366,8 @@ oberon_create_context()
 
        oberon_generator_init_context(ctx);
 
-       register_default_types(ctx);    
+       register_default_types(ctx);
+       oberon_new_intrinsic_function(ctx, "ABS", oberon_make_abs_call);
 
        return ctx;
 }

diff --git a/oberon.h b/oberon.h
index 30c4cbe47e3bf7b847aab2a5ea966f2f484fa31b..09a24c98caeaa08f59b50e8b562035b261acd9d7 100644 (file)
--- a/oberon.h
+++ b/oberon.h
@@ -139,6 +139,11 @@ enum
        OBERON_CLASS_FIELD
 };
 
+enum
+{
+       OBERON_SYSPROC_ABS
+};
+
 /*
  * Структура oberon_object_s (oberon_object_t) описывает все
  * объявления которые могут иметь имя. От констант, до процедур.
@@ -149,6 +154,9 @@ enum
  *   next -- ссылка на следующий объект в списке.
  */
 
+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_s
 {
        char * name;
@@ -159,9 +167,12 @@ struct oberon_object_s
        int initialized;
 
        oberon_object_t * parent;
+
        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;
@@ -241,15 +252,22 @@ enum
 
 enum
 {
-       OP_LOGIC_NOT,
        OP_UNARY_MINUS,
+       OP_BITWISE_NOT,
+       OP_LOGIC_NOT,
+       OP_ABS,
+
        OP_ADD,
        OP_SUB,
        OP_MUL,
        OP_DIV,
        OP_MOD,
+       OP_BITWISE_AND,
+       OP_BITWISE_XOR,
+       OP_BITWISE_OP,
        OP_LOGIC_AND,
        OP_LOGIC_OR,
+
        OP_EQ,
        OP_NEQ,
        OP_LSS,

diff --git a/test.c b/test.c
index b07a08d0898a7f2816a6bb281c9f6050ac31d9bb..914764e39d2d3c25382be63f5fe5dada0b9aa4b9 100644 (file)
--- a/test.c
+++ b/test.c
@@ -21,8 +21,9 @@ static const char source[] =
        "PROCEDURE ^ Tier(x : INTEGER);"
        ""
        "BEGIN;"
-       "       i := 666;"
-       "       Tier(1);"
+       "       i := ABS(-666);"
+       "       Tier(i);"
+       "       ABS(1);"
        "END Test."
 ;