elna/source/Transpiler.elna

(* This Source Code Form is subject to the terms of the Mozilla Public License,
  v. 2.0. If a copy of the MPL was not distributed with this file, You can
  obtain one at https://mozilla.org/MPL/2.0/. *)
module;

from FIO import File, WriteNBytes, WriteLine, WriteChar, WriteString;
from NumberIO import IntToStr;

import common, Parser;

type
  TranspilerContext* = record
    input_name: String;
    output: File;
    definition: File;
    indentation: Word
  end;

proc indent(context: ^TranspilerContext);
var
  count: Word;
begin
  count := 0;

  while count < context^.indentation do
    WriteString(context^.output, "  ");
    count := count + 1u
  end
end;

(* Write a semicolon followed by a newline. *)
proc write_semicolon(output: File);
begin
  WriteChar(output, ';');
  WriteLine(output)
end;

proc transpile_import_statement(context: ^TranspilerContext, import_statement: ^AstImportStatement);
var
  written_bytes: Word;
  current_symbol: ^Identifier;
begin
  WriteString(context^.output, "FROM ");
  written_bytes := WriteNBytes(context^.output, ORD(import_statement^.package[1]), @import_statement^.package[2]);

  WriteString(context^.output, " IMPORT ");

  current_symbol := import_statement^.symbols;
  written_bytes := WriteNBytes(context^.output, ORD(current_symbol^[1]), @current_symbol^[2]);
  current_symbol := current_symbol + 1;

  while current_symbol^[1] <> '\0' do
    WriteString(context^.output, ", ");
    written_bytes := WriteNBytes(context^.output, ORD(current_symbol^[1]), @current_symbol^[2]);
    current_symbol := current_symbol + 1;
  end;
  write_semicolon(context^.output)
end;

proc transpile_import_part(context: ^TranspilerContext, imports: ^^AstImportStatement);
var
  import_statement: ^AstImportStatement;
begin
  while imports^ <> nil do
    transpile_import_statement(context, imports^);
    imports := imports + 1
  end;
  WriteLine(context^.output)
end;

proc transpile_constant_declaration(context: ^TranspilerContext, declaration: ^AstConstantDeclaration);
var
  buffer: [20]CHAR;
  written_bytes: Word;
begin
  WriteString(context^.output, "  ");
  written_bytes := WriteNBytes(context^.output, ORD(declaration^.constant_name[1]), @declaration^.constant_name[2]);

  WriteString(context^.output, " = ");

  IntToStr(declaration^.constant_value, 0, buffer);
  WriteString(context^.output, buffer);

  write_semicolon(context^.output)
end;

proc transpile_constant_part(context: ^TranspilerContext, declarations: ^^AstConstantDeclaration, extra_newline: Bool);
var
  current_declaration: ^^AstConstantDeclaration;
begin
  if declarations^ <> nil then
    WriteString(context^.output, "CONST");
    WriteLine(context^.output);

    current_declaration := declarations;
    while current_declaration^ <> nil do
      transpile_constant_declaration(context, current_declaration^);

      current_declaration := current_declaration + 1
    end;
    if extra_newline then
      WriteLine(context^.output)
    end
  end
end;

proc transpile_module(context: ^TranspilerContext, result: ^AstModule);
begin
  if result^.main = false then
    WriteString(context^.output, "IMPLEMENTATION ")
  end;
  WriteString(context^.output, "MODULE ");

  (* Write the module name and end the line with a semicolon and newline. *)
  transpile_module_name(context);

  write_semicolon(context^.output);
  WriteLine(context^.output);

  (* Write the module body. *)

  transpile_import_part(context, result^.imports);
  transpile_constant_part(context, result^.constants, true);
  transpile_type_part(context, result^.types);
  transpile_variable_part(context, result^.variables, true);
  transpile_procedure_part(context, result^.procedures);
  transpile_statement_part(context, result^.statements);

  WriteString(context^.output, "END ");
  transpile_module_name(context);

  WriteChar(context^.output, ".");
  WriteLine(context^.output)
end;

proc transpile_type_fields(context: ^TranspilerContext, fields: ^AstFieldDeclaration);
var
  written_bytes: Word;
  current_field: ^AstFieldDeclaration;
begin
  current_field := fields;

  while current_field^.field_name[1] <> '\0' do
    WriteString(context^.output, "    ");
    written_bytes := WriteNBytes(context^.output, ORD(current_field^.field_name[1]), @current_field^.field_name[2]);

    WriteString(context^.output, ": ");
    transpile_type_expression(context, current_field^.field_type);

    current_field := current_field + 1;

    if current_field^.field_name[1] <> '\0' then
      WriteChar(context^.output, ';')
    end;
    WriteLine(context^.output)
  end
end;

proc transpile_record_type(context: ^TranspilerContext, type_expression: ^AstTypeExpression);
begin
  WriteString(context^.output, "RECORD");
  WriteLine(context^.output);
  transpile_type_fields(context, type_expression^.fields);
  WriteString(context^.output, "  END")
end;

proc transpile_pointer_type(context: ^TranspilerContext, type_expression: ^AstTypeExpression);
begin
  WriteString(context^.output, "POINTER TO ");

  transpile_type_expression(context, type_expression^.target)
end;

proc transpile_array_type(context: ^TranspilerContext, type_expression: ^AstTypeExpression);
var
  buffer: [20]CHAR;
begin
  WriteString(context^.output, "ARRAY");

  if type_expression^.length <> 0 then
    WriteString(context^.output, "[1..");

    IntToStr(type_expression^.length, 0, buffer);
    WriteString(context^.output, buffer);

    WriteChar(context^.output, ']')
  end;
  WriteString(context^.output, " OF ");

  transpile_type_expression(context, type_expression^.base)
end;

proc transpile_enumeration_type(context: ^TranspilerContext, type_expression: ^AstTypeExpression);
var
  current_case: ^Identifier;
  written_bytes: Word;
begin
  current_case := type_expression^.cases;

  WriteString(context^.output, "(");
  WriteLine(context^.output);
  WriteString(context^.output, "    ");
  written_bytes := WriteNBytes(context^.output, ORD(current_case^[1]), @current_case^[2]);
  current_case := current_case + 1;

  while current_case^[1] <> '\0' do
    WriteChar(context^.output, ',');
    WriteLine(context^.output);
    WriteString(context^.output, "    ");
    written_bytes := WriteNBytes(context^.output, ORD(current_case^[1]), @current_case^[2]);

    current_case := current_case + 1
  end;
  WriteLine(context^.output);
  WriteString(context^.output, "  )")
end;

proc transpile_named_type(context: ^TranspilerContext, type_expression: ^AstTypeExpression);
var
  written_bytes: Word;
begin
  written_bytes := WriteNBytes(context^.output, ORD(type_expression^.name[1]), @type_expression^.name[2])
end;

proc transpile_procedure_type(context: ^TranspilerContext, type_expression: ^AstTypeExpression);
var
  result: ^AstTypeExpression;
  current_parameter: ^^AstTypeExpression;
  parameter_count: Word;
begin
  WriteString(context^.output, "PROCEDURE(");
  current_parameter := type_expression^.parameters;

  while current_parameter^ <> nil do
    transpile_type_expression(context, current_parameter^);

    current_parameter := current_parameter + 1;

    if current_parameter^ <> nil then
      WriteString(context^.output, ", ")
    end
  end;
  WriteChar(context^.output, ')')
end;

proc transpile_type_expression(context: ^TranspilerContext, type_expression: ^AstTypeExpression);
begin
  if type_expression^.kind = astTypeExpressionKindRecord then
    transpile_record_type(context, type_expression)
  end;
  if type_expression^.kind = astTypeExpressionKindEnumeration then
    transpile_enumeration_type(context, type_expression)
  end;
  if type_expression^.kind = astTypeExpressionKindArray then
    transpile_array_type(context, type_expression)
  end;
  if type_expression^.kind = astTypeExpressionKindPointer then
    transpile_pointer_type(context, type_expression)
  end;
  if type_expression^.kind = astTypeExpressionKindProcedure then
    transpile_procedure_type(context, type_expression)
  end;
  if type_expression^.kind = astTypeExpressionKindNamed then
    transpile_named_type(context, type_expression)
  end
end;

proc transpile_type_declaration(context: ^TranspilerContext, declaration: ^AstTypedDeclaration);
var
  written_bytes: Word;
begin
  WriteString(context^.output, "  ");

  written_bytes := WriteNBytes(context^.output, ORD(declaration^.identifier[1]), @declaration^.identifier[2]);
  WriteString(context^.output, " = ");

  transpile_type_expression(context, declaration^.type_expression);
  write_semicolon(context^.output)
end;

proc transpile_type_part(context: ^TranspilerContext, declarations: ^^AstTypedDeclaration);
var
  current_declaration: ^^AstTypedDeclaration;
begin
  if declarations^ <> nil then
    WriteString(context^.output, "TYPE");
    WriteLine(context^.output);

    current_declaration := declarations;
    while current_declaration^ <> nil do
      transpile_type_declaration(context, current_declaration^);

      current_declaration := current_declaration + 1
    end;
    WriteLine(context^.output)
  end
end;

proc transpile_variable_declaration(context: ^TranspilerContext, declaration: ^AstVariableDeclaration);
var
  written_bytes: Word;
begin
  WriteString(context^.output, "  ");
  written_bytes := WriteNBytes(context^.output, ORD(declaration^.variable_name[1]), @declaration^.variable_name[2]);

  WriteString(context^.output, ": ");

  transpile_type_expression(context, declaration^.variable_type);
  write_semicolon(context^.output)
end;

proc transpile_variable_part(context: ^TranspilerContext, declarations: ^^AstVariableDeclaration, extra_newline: Bool);
var
  current_declaration: ^^AstVariableDeclaration;
begin
  if declarations^ <> nil then
    WriteString(context^.output, "VAR");
    WriteLine(context^.output);

    current_declaration := declarations;
    while current_declaration^ <> nil do
      transpile_variable_declaration(context, current_declaration^);

      current_declaration := current_declaration + 1
    end;
    if extra_newline then
      WriteLine(context^.output)
    end
  end
end;

proc transpile_procedure_heading(context: ^TranspilerContext, declaration: ^AstProcedureDeclaration);
var
  written_bytes: Word;
  parameter_index: Word;
  current_parameter: ^AstTypedDeclaration;
begin
  WriteString(context^.output, "PROCEDURE ");
  written_bytes := WriteNBytes(context^.output, ORD(declaration^.name[1]), @declaration^.name[2]);
  WriteChar(context^.output, '(');

  parameter_index := 0;
  current_parameter := declaration^.parameters;

  while parameter_index < declaration^.parameter_count do
    written_bytes := WriteNBytes(context^.output, ORD(current_parameter^.identifier[1]), @current_parameter^.identifier[2]);
    WriteString(context^.output, ": ");
    transpile_type_expression(context, current_parameter^.type_expression);

    parameter_index := parameter_index + 1u;
    current_parameter := current_parameter + 1;

    if parameter_index <> declaration^.parameter_count then
      WriteString(context^.output, "; ")
    end
  end;

  WriteString(context^.output, ")");

  (* Check for the return type and write it. *)
  if declaration^.return_type <> nil then
    WriteString(context^.output, ": ");
    transpile_type_expression(context, declaration^.return_type)
  end;
  write_semicolon(context^.output)
end;

proc transpile_unary_operator(context: ^TranspilerContext, operator: AstUnaryOperator);
begin
  if operator = AstUnaryOperator.minus then
    WriteChar(context^.output, '-')
  end;
  if operator = AstUnaryOperator.not then
    WriteChar(context^.output, '~')
  end
end;

proc transpile_binary_operator(context: ^TranspilerContext, operator: AstBinaryOperator);
begin
  case operator of
  	AstBinaryOperator.sum: WriteChar(context^.output, '+')
  	| AstBinaryOperator.subtraction: WriteChar(context^.output, '-')
  	| AstBinaryOperator.multiplication: WriteChar(context^.output, '*')
	| AstBinaryOperator.equals: WriteChar(context^.output, '=')
	| AstBinaryOperator.not_equals: WriteChar(context^.output, '#')
	| AstBinaryOperator.less: WriteChar(context^.output, '<')
	| AstBinaryOperator.greater: WriteChar(context^.output, '>')
  	| AstBinaryOperator.less_equal: WriteString(context^.output, "<=")
  	| AstBinaryOperator.greater_equal: WriteString(context^.output, ">=")
  	| AstBinaryOperator.disjunction: WriteString(context^.output, "OR")
	| AstBinaryOperatorConjunction: WriteString(context^.output, "AND")
  end
end;

proc transpile_expression(context: ^TranspilerContext, expression: ^AstExpression);
var
  literal: ^AstLiteral;
  buffer: [20]CHAR;
  written_bytes: Word;
  argument_index: Word;
  current_argument: ^^AstExpression;
begin
  if expression^.kind = astExpressionKindLiteral then
    literal := expression^.literal;

    if literal^.kind = AstLiteralKind.integer then
      IntToStr(literal^.integer, 0, buffer);
      WriteString(context^.output, buffer)
    end;
    if literal^.kind = AstLiteralKind.string then
      WriteString(context^.output, literal^.string)
    end;
    if literal^.kind = AstLiteralKind.null then
      WriteString(context^.output, "NIL")
    end;
    if (literal^.kind = AstLiteralKind.boolean) & literal^.boolean then
      WriteString(context^.output, "TRUE")
    end;
    if (literal^.kind = AstLiteralKind.boolean) & (literal^.boolean = false) then
      WriteString(context^.output, "FALSE")
    end
  end;
  if expression^.kind = astExpressionKindIdentifier then
    written_bytes := WriteNBytes(context^.output, ORD(expression^.identifier[1]), @expression^.identifier[2])
  end;
  if expression^.kind = astExpressionKindDereference then
    transpile_expression(context, expression^.reference);
    WriteChar(context^.output, '^')
  end;
  if expression^.kind = astExpressionKindArrayAccess then
    transpile_expression(context, expression^.array);
    WriteChar(context^.output, '[');
    transpile_expression(context, expression^.index);
    WriteChar(context^.output, ']')
  end;
  if expression^.kind = astExpressionKindFieldAccess then
    transpile_expression(context, expression^.aggregate);
    WriteChar(context^.output, '.');
    written_bytes := WriteNBytes(context^.output, ORD(expression^.field[1]), @expression^.field[2])
  end;
  if expression^.kind = astExpressionKindUnary then
    transpile_unary_operator(context, expression^.unary_operator);
    transpile_expression(context, expression^.unary_operand)
  end;
  if expression^.kind = astExpressionKindBinary then
    WriteChar(context^.output, '(');
    transpile_expression(context, expression^.lhs);
    WriteChar(context^.output, ' ');
    transpile_binary_operator(context, expression^.binary_operator);
    WriteChar(context^.output, ' ');
    transpile_expression(context, expression^.rhs);
    WriteChar(context^.output, ')')
  end;
  if expression^.kind = astExpressionKindCall then
    transpile_expression(context, expression^.callable);
    WriteChar(context^.output, '(');

    current_argument := expression^.arguments;
    if expression^.argument_count > 0 then
      transpile_expression(context, current_argument^);

      argument_index := 1u;
      current_argument := current_argument + 1;

      while argument_index < expression^.argument_count do
        WriteString(context^.output, ", ");

        transpile_expression(context, current_argument^);

        current_argument := current_argument + 1;
        argument_index := argument_index + 1u
      end
    end;
    WriteChar(context^.output, ')')
  end
end;

proc transpile_if_statement(context: ^TranspilerContext, statement: ^AstStatement);
begin
  WriteString(context^.output, "IF ");
  transpile_expression(context, statement^.if_condition);

  WriteString(context^.output, " THEN");
  WriteLine(context^.output);
  context^.indentation := context^.indentation + 1u;

  transpile_compound_statement(context, statement^.if_branch);
  context^.indentation := context^.indentation - 1u;
  indent(context);
  WriteString(context^.output, "END")
end;

proc transpile_while_statement(context: ^TranspilerContext, statement: ^AstStatement);
begin
  WriteString(context^.output, "WHILE ");
  transpile_expression(context, statement^.while_condition);

  WriteString(context^.output, " DO");
  WriteLine(context^.output);
  context^.indentation := context^.indentation + 1u;

  transpile_compound_statement(context, statement^.while_body);
  context^.indentation := context^.indentation - 1u;
  indent(context);
  WriteString(context^.output, "END")
end;

proc transpile_assignment_statement(context: ^TranspilerContext, statement: ^AstStatement);
begin
  transpile_expression(context, statement^.assignee);
  WriteString(context^.output, " := ");
  transpile_expression(context, statement^.assignment)
end;

proc transpile_return_statement(context: ^TranspilerContext, statement: ^AstStatement);
begin
  WriteString(context^.output, "RETURN ");

  transpile_expression(context, statement^.returned)
end;

proc transpile_compound_statement(context: ^TranspilerContext, statement: AstCompoundStatement);
var
  current_statement: ^^AstStatement;
  index: Word;
begin
  index := 0;
  current_statement := statement.statements;

  while index < statement.count do
    transpile_statement(context, current_statement^);

    current_statement := current_statement + 1;
    index := index + 1u;

    if index <> statement.count then
      WriteChar(context^.output, ';')
    end;
    WriteLine(context^.output)
  end
end;

proc transpile_statement(context: ^TranspilerContext, statement: ^AstStatement);
begin
  indent(context);

  if statement^.kind = astStatementKindIf then
    transpile_if_statement(context, statement)
  end;
  if statement^.kind = astStatementKindWhile then
    transpile_while_statement(context, statement)
  end;
  if statement^.kind = astStatementKindReturn then
    transpile_return_statement(context, statement)
  end;
  if statement^.kind = astStatementKindAssignment then
    transpile_assignment_statement(context, statement)
  end;
  if statement^.kind = astStatementKindCall then
    transpile_expression(context, statement^.call)
  end
end;

proc transpile_statement_part(context: ^TranspilerContext, compound: AstCompoundStatement);
begin
  if compound.count > 0 then
    WriteString(context^.output, "BEGIN");
    WriteLine(context^.output);

    context^.indentation := context^.indentation + 1u;
    transpile_compound_statement(context, compound);
    context^.indentation := context^.indentation - 1u;
  end
end;

proc transpile_procedure_declaration(context: ^TranspilerContext, declaration: ^AstProcedureDeclaration);
var
  written_bytes: Word;
begin
  transpile_procedure_heading(context, declaration);

  transpile_constant_part(context, declaration^.constants, false);
  transpile_variable_part(context, declaration^.variables, false);
  transpile_statement_part(context, declaration^.statements);

  WriteString(context^.output, "END ");
  written_bytes := WriteNBytes(context^.output, ORD(declaration^.name[1]), @declaration^.name[2]);

  write_semicolon(context^.output)
end;

proc transpile_procedure_part(context: ^TranspilerContext, declaration: ^^AstProcedureDeclaration);
begin
  while declaration^ <> nil do
    transpile_procedure_declaration(context, declaration^);
    WriteLine(context^.output);

    declaration := declaration + 1
  end
end;

proc transpile_module_name(context: ^TranspilerContext);
var
  counter: Word;
  last_slash: Word;
begin
  counter := 1u;
  last_slash := 0u;

  while context^.input_name[counter] <> '.' & context^.input_name[counter] <> '\0' do
    if context^.input_name[counter] = '/' then
      last_slash := counter
    end;
    counter := counter + 1u
  end;

  if last_slash = 0u then
    counter := 1u
  end;
  if last_slash <> 0u then
    counter := last_slash + 1u
  end;
  while context^.input_name[counter] <> '.' & context^.input_name[counter] <> '\0' do
    WriteChar(context^.output, context^.input_name[counter]);
    counter := counter + 1u
  end
end;

proc transpile*(ast_module: ^AstModule, output: File, definition: File, input_name: String);
var
  context: TranspilerContext;
begin
  context.input_name := input_name;
  context.output := output;
  context.definition := definition;
  context.indentation := 0u;

  transpile_module(@context, ast_module)
end;

end.