test.c

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