src/test.c

   1 #include <stdio.h>
   2 #include <string.h>
   3 #include <assert.h>
   4
   5 #include "../include/oberon.h"
   6
   7 static char source_test[] =
   8         "(* Main module *)"
   9         "MODULE Test;"
  10         "IMPORT Out;"
  11         ""
  12         "VAR i : INTEGER;"
  13         ""
  14         "PROCEDURE X(VAR x : INTEGER; y : INTEGER);"
  15         "  VAR"
  16         "    q, w, r : INTEGER;"
  17         "  PROCEDURE Y;"
  18         "    VAR levY : INTEGER;"
  19         "  BEGIN"
  20         "    x := 3345;"
  21         "    q := 666;"
  22         "  END Y;"
  23         "BEGIN"
  24         "  x := 54646;"
  25         "  q := 1;"
  26         "  Y;"
  27         "  Out.String('Pos Y: q = '); Out.Int(q, 0); Out.Ln;"
  28         "END X;"
  29         ""
  30         "BEGIN;"
  31         "  i := 1;"
  32         "  X(i, i);"
  33         "  Out.Int(i, 0); Out.Ln;"
  34         "END Test."
  35 ;
  36
  37 static char source_out[] =
  38         "MODULE Out;"
  39         "  PROCEDURE Open*;"
  40         "  END Open;"
  41         ""
  42         "  PROCEDURE Char* (ch : CHAR);"
  43         "  END Char;"
  44         ""
  45         "  PROCEDURE String* (str : ARRAY OF CHAR);"
  46         "  END String;"
  47         ""
  48         "  PROCEDURE Int*(i, n : LONGINT);"
  49         "  END Int;"
  50         ""
  51         "  PROCEDURE Real*(x : REAL; n : INTEGER);"
  52         "  END Real;"
  53         ""
  54         "  PROCEDURE LongReal*(x : LONGREAL; n : INTEGER);"
  55         "  END LongReal;"
  56         ""
  57         "  PROCEDURE Ln*;"
  58         "  END Ln;"
  59         ""
  60         "END Out."
  61 ;
  62
  63 static oberon_context_t * ctx;
  64 static oberon_module_t * mod;
  65
  66 static const char *
  67 import_module(const char * name)
  68 {
  69         if(strcmp(name, "Test") == 0)
  70         {
  71                 return source_test;
  72         }
  73         else if(strcmp(name, "Out") == 0)
  74         {
  75                 return source_out;
  76         }
  77         else
  78         {
  79                 return NULL;
  80         }
  81 }
  82
  83 typedef void (*TOutOpen)();
  84 static TOutOpen * OutOpenPtr;
  85 void ImplOutOpen()
  86 {
  87 }
  88
  89 typedef void (*TOutInt)(int, int);
  90 static TOutInt * OutIntPtr;
  91 void ImplOutInt(int i, int n)
  92 {
  93         char number[22];
  94         snprintf(number, 22, "%d", i);
  95         int len = strlen(number);
  96         for(int i = 0; i < n - len; i++)
  97         {
  98                 putchar(' ');
  99         }
 100         printf("%s", number);
 101 }
 102
 103 typedef void (*TOutReal)(float, int);
 104 static TOutReal * OutRealPtr;
 105 void ImplOutReal(float i, int n)
 106 {
 107         char number[32];
 108         snprintf(number, 32, "%F", i);
 109         int len = strlen(number);
 110         for(int i = 0; i < n - len; i++)
 111         {
 112                 putchar(' ');
 113         }
 114         printf("%s", number);
 115 }
 116
 117 typedef void (*TOutLn)();
 118 static TOutLn * OutLnPtr;
 119 void ImplOutLn()
 120 {
 121         putchar('\n');
 122 }
 123
 124 void init_system_modules()
 125 {
 126         OutOpenPtr = oberon_generator_get_var(ctx, "Out_Open");
 127         *OutOpenPtr = ImplOutOpen;
 128         OutIntPtr = oberon_generator_get_var(ctx, "Out_Int");
 129         *OutIntPtr = ImplOutInt;
 130         OutRealPtr = oberon_generator_get_var(ctx, "Out_Real");
 131         *OutRealPtr = ImplOutReal;
 132         OutLnPtr = oberon_generator_get_var(ctx, "Out_Ln");
 133         *OutLnPtr = ImplOutLn;
 134 }
 135
 136 void start_module()
 137 {
 138         void (*begin)() = oberon_generator_get_procedure(ctx, "Test_BEGIN");
 139         begin();
 140 }
 141
 142 int
 143 main(int argc, char ** argv)
 144 {
 145         ctx = oberon_create_context(import_module);
 146         mod = oberon_compile_module(ctx, source_test);
 147
 148         oberon_generate_code(ctx);
 149
 150 //      init_system_modules();
 151
 152 //      oberon_generator_dump(ctx, "dump.txt");
 153
 154 //      start_module();
 155
 156         oberon_destroy_context(ctx);
 157         return 0;
 158 }