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