Добавлен тип SYSTEM.PTR

diff --git a/Test.obn b/Test.obn
index fa347cddf19074ac48f9ac84d99c4993074f5aef..0bad0ad763fe3b298b127518a3af3fbc2e878678 100644 (file)
--- a/Test.obn
+++ b/Test.obn
@@ -1,21 +1,12 @@
 MODULE Test;
 
-IMPORT Files, Out;
+IMPORT SYSTEM;
 
 VAR
-  f : Files.File;
-  r : Files.Rider;
-  len : LONGINT;
-  x : POINTER TO ARRAY OF CHAR;
+  ptr : SYSTEM.PTR;
+  arr : POINTER TO ARRAY OF INTEGER;
 
 BEGIN
-  f := Files.Old("Test.obn");
-  ASSERT(f # NIL);
-  Files.Set(r, f, 0);
-
-  len := Files.Length(f);
-  NEW(x, len + 1);
-
-  Files.ReadBytes(r, x, len);
-  Out.String(x^); Out.Ln;
+  NEW(arr, 20);
+  ptr := arr;
 END Test.

diff --git a/notes b/notes
index f2ee7c350144e7df30751c5d85c8a14be7b68bad..14f5f21b1640e4c46947a0e1c7d93d897ea23051 100644 (file)
--- a/notes
+++ b/notes
@@ -1,6 +1,5 @@
 - Перепроверить конверсию строк единичного размера в символ.
 - Не полная реализация модуля SYSTEM
-    * Нет типа SYSTEM.PTR
     * Нет процедур CC LSH ROT VAL
     * Процедуры GETREG PUTREG впринципе вписываются в jvm
       и могут быть полезны при реализции рефлекции

diff --git a/src/backends/jvm/generator-jvm-basic.c b/src/backends/jvm/generator-jvm-basic.c
index 478a92c6f38cb91acb3c03c3f939c3158023d5f3..2baed6556849dc01aa1d61d9fda6836cccf7642c 100644 (file)
--- a/src/backends/jvm/generator-jvm-basic.c
+++ b/src/backends/jvm/generator-jvm-basic.c
@@ -149,6 +149,9 @@ jvm_get_descriptor(oberon_type_t * type)
                                        break;
                        }
                        break;
+               case OBERON_TYPE_SYSTEM_PTR:
+                       return new_string("Ljava/lang/Object;");
+                       break;
                default:
                        gen_error("jvm_get_descriptor: unsupported type class %i", type -> class);
                        break;
@@ -172,6 +175,9 @@ jvm_get_descriptor_safe(oberon_type_t * type)
                case OBERON_TYPE_ARRAY:
                        return new_string("A%s", jvm_get_descriptor_safe(type -> base));
                        break;
+               case OBERON_TYPE_SYSTEM_PTR:
+                       return new_string("SYSPTR");
+                       break;
                default:
                        return jvm_get_descriptor(type);
                        break;
@@ -199,6 +205,7 @@ jvm_get_prefix(oberon_type_t * type)
                case OBERON_TYPE_POINTER:
                case OBERON_TYPE_STRING:
                case OBERON_TYPE_NIL:
+               case OBERON_TYPE_SYSTEM_PTR:
                        return 'a';
                        break;
                case OBERON_TYPE_REAL:
@@ -270,6 +277,7 @@ jvm_get_postfix(oberon_type_t * type)
                case OBERON_TYPE_POINTER:
                case OBERON_TYPE_STRING:
                case OBERON_TYPE_NIL:
+               case OBERON_TYPE_SYSTEM_PTR:
                        return 'a';
                        break;
                case OBERON_TYPE_REAL:
@@ -386,6 +394,9 @@ jvm_get_class_full_name(oberon_type_t * type)
                        rec_id = type -> gen_type -> rec_id;
                        name = new_string("%s$RECORD%i", type -> module -> name, rec_id);
                        break;
+               case OBERON_TYPE_SYSTEM_PTR:
+                       name = new_string("java/lang/Object");
+                       break;
                default:
                        gen_error("jvm_get_class_full_name: unk type class %i", type -> class);
                        break;

diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c
index 1ba25c9afe28ee69e957cb10b6c9572814f06176..feace6fe30e44ea9568b6c9f39ef7846a5286cde 100644 (file)
--- a/src/backends/jvm/generator-jvm.c
+++ b/src/backends/jvm/generator-jvm.c
@@ -493,6 +493,7 @@ oberon_generator_init_type(oberon_context_t * ctx, oberon_type_t * type)
                case OBERON_TYPE_SET:
                case OBERON_TYPE_NIL:
                case OBERON_TYPE_SYSTEM_BYTE:
+               case OBERON_TYPE_SYSTEM_PTR:
                        break;
                case OBERON_TYPE_RECORD:
                        m = type -> module -> gen_mod;

diff --git a/src/oberon-internals.h b/src/oberon-internals.h
index c1454d433ff77e38c97ad35569bec8e8a4dd2a15..0a97386fda71b126636f70500fe0643fa3597862 100644 (file)
--- a/src/oberon-internals.h
+++ b/src/oberon-internals.h
@@ -48,7 +48,8 @@ enum oberon_type_kind
        OBERON_TYPE_STRING,
        OBERON_TYPE_SET,
        OBERON_TYPE_NIL,
-       OBERON_TYPE_SYSTEM_BYTE
+       OBERON_TYPE_SYSTEM_BYTE,
+       OBERON_TYPE_SYSTEM_PTR
 };
 
 typedef oberon_expr_t * (*GenerateFuncCallback)(oberon_context_t *, int, oberon_expr_t *);
@@ -166,6 +167,7 @@ struct oberon_context_t
 
        oberon_module_t * system_module;
        oberon_type_t * system_byte_type;
+       oberon_type_t * system_ptr_type;
 
        oberon_module_t * module_list;
        ModuleImportCallback import_module;

diff --git a/src/oberon-type-compat.c b/src/oberon-type-compat.c
index a99a04d37c70652f3add5a483b0ca5b0bf1edbfd..4291f6c5f402d97b9e5c859056dd107099b31895 100644 (file)
--- a/src/oberon-type-compat.c
+++ b/src/oberon-type-compat.c
@@ -45,6 +45,12 @@ oberon_is_system_byte_type(oberon_type_t * t)
        return t -> class == OBERON_TYPE_SYSTEM_BYTE;
 }
 
+bool
+oberon_is_system_ptr_type(oberon_type_t * t)
+{
+       return t -> class == OBERON_TYPE_SYSTEM_PTR;
+}
+
 bool
 oberon_is_byte_type(oberon_type_t * t)
 {
@@ -291,24 +297,10 @@ oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * T
        /* Доп: Tv - символ, е - строковая константа из одного символа */
 
        /* SYSTEM: переменным типа BYTE можно присваивать значения переменных типа CHAR или SHORTINT. */
+       /* SYSTEM: Переменным типа PTR могут быть присвоены значения переменных-указателей любого типа. */
 
        oberon_type_t * Te = e -> result;
 
-/*
-       printf("<<< oberon_is_assignment_compatible_expressions ===\n");
-       printf(": Te -> class == %i\n", Te -> class);
-       printf(": Tv -> class == %i\n", Tv -> class);
-       printf(":: oberon_is_some_types(Te, Tv) == %i\n", oberon_is_some_types(Te, Tv));
-       printf("::: oberon_is_number_type(Te) == %i\n", oberon_is_number_type(Te));
-       printf("::: oberon_is_number_type(Tv) == %i\n", oberon_is_number_type(Tv));
-       printf("::: oberon_incluses_type(Tv, Te) == %i\n", oberon_incluses_type(Tv, Te));
-       printf(":::: oberon_is_record_type(Te) == %i\n", oberon_is_record_type(Te));
-       printf(":::: oberon_is_record_type(Tv) == %i\n", oberon_is_record_type(Tv));
-//     printf(":::: oberon_extension_of(Te, Tv) == %i\n", oberon_extension_of(Te, Tv));
-       printf(":::: oberon_extension_of(Tv, Te) == %i\n", oberon_extension_of(Tv, Te));
-       printf("=== oberon_is_assignment_compatible_expressions >>>\n");
-*/
-
        return oberon_is_some_types(Te, Tv)
                || (oberon_is_number_type(Te) && oberon_is_number_type(Tv) && oberon_incluses_type(Tv, Te))
                || (oberon_is_record_type(Te) && oberon_is_record_type(Tv) && oberon_extension_of(Tv, Te))
@@ -317,7 +309,8 @@ oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * T
                || (oberon_is_array_of_char_type(Tv) && !oberon_is_open_array(Tv) && oberon_is_const_string(e) && (strlen(e -> item.string) < Tv -> size))
                || (oberon_is_procedure_type(Tv) && e -> is_item && e -> item.var -> class == OBERON_CLASS_PROC && oberon_is_some_procedure_signatures(Tv, e -> result))
                || (oberon_is_char_type(Tv) && oberon_is_const_string(e) && strlen(e -> item.string) == 1)
-               || (oberon_is_system_byte_type(Tv) && (oberon_is_char_type(Te) || oberon_is_byte_type(Te)));
+               || (oberon_is_system_byte_type(Tv) && (oberon_is_char_type(Te) || oberon_is_byte_type(Te)))
+               || (oberon_is_system_ptr_type(Tv) && oberon_is_pointer_type(Te));
 }
 
 static bool
@@ -452,10 +445,13 @@ oberon_is_compatible_var_param(oberon_type_t * Tf, oberon_type_t * Ta)
 
        /* SYSTEM: Если формальный параметр-переменная имеет тип ARRAY OF BYTE, */
        /* то соответствующий фактический параметр может иметь любой тип. */
+       /* SYSTEM: Если формальный параметр-переменная имеет тип PTR, */
+       /* фактический параметр может быть указателем любого типа. */
 
        return oberon_is_some_types(Tf, Ta)
                || (oberon_is_record_type(Tf) && oberon_extension_of(Ta, Tf))
-               || (oberon_is_array_of_system_byte_type(Tf));
+               || (oberon_is_array_of_system_byte_type(Tf))
+               || (oberon_is_system_ptr_type(Tf));
 }
 
 void

diff --git a/src/oberon.c b/src/oberon.c
index fbf0c455fabcf926d582592fe5f23c86a726d928..07c83c28643623df555292ca429fa5eba776ae9d 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -4490,6 +4490,9 @@ register_default_types(oberon_context_t * ctx)
        ctx -> system_byte_type = oberon_new_type_ptr(OBERON_TYPE_SYSTEM_BYTE);
        oberon_generator_init_type(ctx, ctx -> system_byte_type);
 
+       ctx -> system_ptr_type = oberon_new_type_ptr(OBERON_TYPE_SYSTEM_PTR);
+       oberon_generator_init_type(ctx, ctx -> system_ptr_type);
+
        /* LONG / SHORT support */
        ctx -> byte_type -> shorter = NULL;
        ctx -> byte_type -> longer = ctx -> shortint_type;
@@ -4618,6 +4621,7 @@ oberon_create_context(ModuleImportCallback import_module)
 
                /* Types */
                oberon_new_intrinsic_type(ctx, "BYTE", ctx -> system_byte_type);
+               oberon_new_intrinsic_type(ctx, "PTR", ctx -> system_ptr_type);
 
        oberon_end_intrinsic_module(ctx, ctx -> system_module);