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;

from Common import Identifier, ShortString;
from Parser import AstTypeExpressionKind, AstExpressionKind, AstLiteralKind, AstUnaryOperator, AstBinaryOperator,
  AstModule, AstExpression, AstLiteral, AstConstantDeclaration, AstStatement, AstStatementKind,
  AstTypedDeclaration, AstCompoundStatement, AstProcedureDeclaration,
  AstVariableDeclaration, AstImportStatement, AstTypeExpression, AstFieldDeclaration;

type
  TranspilerContext* = record
    input_name: ShortString;
    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]);
  INC(current_symbol, #size(Identifier));

  while ORD(current_symbol^[1]) <> 0 do
    WriteString(context^.output, ', ');
    written_bytes := WriteNBytes(context^.output, ORD(current_symbol^[1]), @current_symbol^[2]);
    INC(current_symbol, #size(Identifier))
  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^);
    INC(imports, #size(^AstImportStatement))
  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^);

      INC(current_declaration, #size(^AstConstantDeclaration))
    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 ORD(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);

    INC(current_field , #size(AstFieldDeclaration));

    if ORD(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]);
  INC(current_case, #size(Identifier));

  while ORD(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]);

    INC(current_case, #size(Identifier))
  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^);

    INC(current_parameter, #size(^AstTypeExpression));

    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^);

      INC(current_declaration, #size(^AstTypedDeclaration))
    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^);

      INC(current_declaration, #size(^AstVariableDeclaration))
    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;
    INC(current_parameter, #size(AstTypedDeclaration));

    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;
      INC(current_argument, #size(^AstExpression));

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

        transpile_expression(context, current_argument^);

        INC(current_argument, #size(^AstExpression));
        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^);

    INC(current_statement, #size(^AstStatement));
    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);

    INC(declaration, #size(^AstProcedureDeclaration))
  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] <> '.') & (ORD(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] <> '.') & (ORD(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: ShortString);
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.