IMPLEMENTATION MODULE Transpiler;

FROM FIO IMPORT WriteNBytes, WriteLine, WriteChar, WriteString;
FROM SYSTEM IMPORT ADR, TSIZE;

FROM NumberIO IMPORT IntToStr;

FROM Common IMPORT Identifier, PIdentifier, ShortString;
FROM Parser IMPORT AstTypeExpressionKind, AstExpressionKind, AstLiteralKind, AstUnaryOperator, AstBinaryOperator,
  PAstModule, PPAstExpression, PAstExpression, PAstLiteral, PPAstProcedureDeclaration,
  PAstConstantDeclaration, PPAstConstantDeclaration, PPAstStatement, PAstStatement, AstStatementKind,
  AstTypedDeclaration, PAstTypedDeclaration, PPAstTypedDeclaration, AstCompoundStatement, PAstProcedureDeclaration,
  PAstVariableDeclaration, PPAstVariableDeclaration, PAstImportStatement, PPAstImportStatement,
  PAstTypeExpression, PPAstTypeExpression, AstFieldDeclaration, PAstFieldDeclaration;

PROCEDURE indent(context: PTranspilerContext);
VAR
  count: CARDINAL;
BEGIN
  count := 0;

  WHILE count < context^.indentation DO
    WriteString(context^.output, '  ');
    INC(count)
  END
END indent;
(* Write a semicolon followed by a newline. *)
PROCEDURE write_semicolon(output: File);
BEGIN
  WriteChar(output, ';');
  WriteLine(output)
END write_semicolon;
PROCEDURE transpile_import_statement(context: PTranspilerContext; import_statement: PAstImportStatement);
VAR
  written_bytes: CARDINAL;
  current_symbol: PIdentifier;
BEGIN
  WriteString(context^.output, 'FROM ');
  written_bytes := WriteNBytes(context^.output, ORD(import_statement^.package[1]), ADR(import_statement^.package[2]));

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

  current_symbol := import_statement^.symbols;
  written_bytes := WriteNBytes(context^.output, ORD(current_symbol^[1]), ADR(current_symbol^[2]));
  INC(current_symbol, TSIZE(Identifier));

  WHILE ORD(current_symbol^[1]) <> 0 DO
    WriteString(context^.output, ', ');
    written_bytes := WriteNBytes(context^.output, ORD(current_symbol^[1]), ADR(current_symbol^[2]));
    INC(current_symbol, TSIZE(Identifier))
  END;
  write_semicolon(context^.output)
END transpile_import_statement;
PROCEDURE transpile_import_part(context: PTranspilerContext; imports: PPAstImportStatement);
VAR
  import_statement: PAstImportStatement;
BEGIN
  WHILE imports^ <> NIL DO
    transpile_import_statement(context, imports^);
    INC(imports, TSIZE(PAstImportStatement))
  END;
  WriteLine(context^.output)
END transpile_import_part;
PROCEDURE transpile_constant_declaration(context: PTranspilerContext; declaration: PAstConstantDeclaration);
VAR
  buffer: ARRAY[1..20] OF CHAR;
  written_bytes: CARDINAL;
BEGIN
  WriteString(context^.output, '  ');
  written_bytes := WriteNBytes(context^.output, ORD(declaration^.constant_name[1]), ADR(declaration^.constant_name[2]));

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

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

  write_semicolon(context^.output)
END transpile_constant_declaration;
PROCEDURE transpile_constant_part(context: PTranspilerContext; declarations: PPAstConstantDeclaration; extra_newline: BOOLEAN);
VAR
  current_declaration: PPAstConstantDeclaration;
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, TSIZE(PAstConstantDeclaration))
    END;
    IF extra_newline THEN
      WriteLine(context^.output)
    END
  END
END transpile_constant_part;
PROCEDURE transpile_module(context: PTranspilerContext; result: PAstModule);
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 transpile_module;
PROCEDURE transpile_type_fields(context: PTranspilerContext; fields: PAstFieldDeclaration);
VAR
  written_bytes: CARDINAL;
  current_field: PAstFieldDeclaration;
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]), ADR(current_field^.field_name[2]));

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

    INC(current_field , TSIZE(AstFieldDeclaration));

    IF ORD(current_field^.field_name[1]) <> 0 THEN
      WriteChar(context^.output, ';')
    END;
    WriteLine(context^.output)
  END
END transpile_type_fields;
PROCEDURE transpile_record_type(context: PTranspilerContext; type_expression: PAstTypeExpression);
BEGIN
  WriteString(context^.output, 'RECORD');
  WriteLine(context^.output);
  transpile_type_fields(context, type_expression^.fields);
  WriteString(context^.output, '  END')
END transpile_record_type;
PROCEDURE transpile_pointer_type(context: PTranspilerContext; type_expression: PAstTypeExpression);
BEGIN
  WriteString(context^.output, 'POINTER TO ');

  transpile_type_expression(context, type_expression^.target)
END transpile_pointer_type;
PROCEDURE transpile_array_type(context: PTranspilerContext; type_expression: PAstTypeExpression);
VAR
  buffer: ARRAY[1..20] OF 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 transpile_array_type;
PROCEDURE transpile_enumeration_type(context: PTranspilerContext; type_expression: PAstTypeExpression);
VAR
  current_case: PIdentifier;
  written_bytes: CARDINAL;
BEGIN
  current_case := type_expression^.cases;

  WriteString(context^.output, '(');
  WriteLine(context^.output);
  WriteString(context^.output, '    ');
  written_bytes := WriteNBytes(context^.output, ORD(current_case^[1]), ADR(current_case^[2]));
  INC(current_case, TSIZE(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]), ADR(current_case^[2]));

    INC(current_case, TSIZE(Identifier))
  END;
  WriteLine(context^.output);
  WriteString(context^.output, '  )')
END transpile_enumeration_type;
PROCEDURE transpile_named_type(context: PTranspilerContext; type_expression: PAstTypeExpression);
VAR
  written_bytes: CARDINAL;
BEGIN
  written_bytes := WriteNBytes(context^.output, ORD(type_expression^.name[1]), ADR(type_expression^.name[2]))
END transpile_named_type;
PROCEDURE transpile_procedure_type(context: PTranspilerContext; type_expression: PAstTypeExpression);
VAR
  result: PAstTypeExpression;
  current_parameter: PPAstTypeExpression;
  parameter_count: CARDINAL;
BEGIN
  WriteString(context^.output, 'PROCEDURE(');
  current_parameter := type_expression^.parameters;

  WHILE current_parameter^ <> NIL DO
    transpile_type_expression(context, current_parameter^);

    INC(current_parameter, TSIZE(PAstTypeExpression));

    IF current_parameter^ <> NIL THEN
      WriteString(context^.output, ', ')
    END
  END;
  WriteChar(context^.output, ')')
END transpile_procedure_type;
PROCEDURE transpile_type_expression(context: PTranspilerContext; type_expression: PAstTypeExpression);
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 transpile_type_expression;
PROCEDURE transpile_type_declaration(context: PTranspilerContext; declaration: PAstTypedDeclaration);
VAR
  written_bytes: CARDINAL;
BEGIN
  WriteString(context^.output, '  ');

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

  transpile_type_expression(context, declaration^.type_expression);
  write_semicolon(context^.output)
END transpile_type_declaration;
PROCEDURE transpile_type_part(context: PTranspilerContext; declarations: PPAstTypedDeclaration);
VAR
  current_declaration: PPAstTypedDeclaration;
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, TSIZE(PAstTypedDeclaration))
    END;
    WriteLine(context^.output)
  END
END transpile_type_part;
PROCEDURE transpile_variable_declaration(context: PTranspilerContext; declaration: PAstVariableDeclaration);
VAR
  written_bytes: CARDINAL;
BEGIN
  WriteString(context^.output, '  ');
  written_bytes := WriteNBytes(context^.output, ORD(declaration^.variable_name[1]), ADR(declaration^.variable_name[2]));

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

  transpile_type_expression(context, declaration^.variable_type);
  write_semicolon(context^.output)
END transpile_variable_declaration;
PROCEDURE transpile_variable_part(context: PTranspilerContext; declarations: PPAstVariableDeclaration; extra_newline: BOOLEAN);
VAR
  current_declaration: PPAstVariableDeclaration;
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, TSIZE(PAstVariableDeclaration))
    END;
    IF extra_newline THEN
      WriteLine(context^.output)
    END
  END
END transpile_variable_part;
PROCEDURE transpile_procedure_heading(context: PTranspilerContext; declaration: PAstProcedureDeclaration);
VAR
  written_bytes: CARDINAL;
  parameter_index: CARDINAL;
  current_parameter: PAstTypedDeclaration;
BEGIN
  WriteString(context^.output, 'PROCEDURE ');
  written_bytes := WriteNBytes(context^.output, ORD(declaration^.name[1]), ADR(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]), ADR(current_parameter^.identifier[2]));
    WriteString(context^.output, ': ');
    transpile_type_expression(context, current_parameter^.type_expression);

    INC(parameter_index);
    INC(current_parameter, TSIZE(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 transpile_procedure_heading;
PROCEDURE transpile_unary_operator(context: PTranspilerContext; operator: AstUnaryOperator);
BEGIN
  IF operator = astUnaryOperatorMinus THEN
    WriteChar(context^.output, '-')
  END;
  IF operator = astUnaryOperatorNot THEN
    WriteChar(context^.output, '~')
  END
END transpile_unary_operator;
PROCEDURE transpile_binary_operator(context: PTranspilerContext; operator: AstBinaryOperator);
BEGIN
  IF operator = astBinaryOperatorSum THEN
    WriteChar(context^.output, '+')
  END;
  IF operator = astBinaryOperatorSubtraction THEN
    WriteChar(context^.output, '-')
  END;
  IF operator = astBinaryOperatorMultiplication THEN
    WriteChar(context^.output, '*')
  END;
  IF operator = astBinaryOperatorEquals THEN
    WriteChar(context^.output, '=')
  END;
  IF operator = astBinaryOperatorNotEquals THEN
    WriteChar(context^.output, '#')
  END;
  IF operator = astBinaryOperatorLess THEN
    WriteChar(context^.output, '<')
  END;
  IF operator = astBinaryOperatorGreater THEN
    WriteChar(context^.output, '>')
  END;
  IF operator = astBinaryOperatorLessEqual THEN
    WriteString(context^.output, '<=')
  END;
  IF operator = astBinaryOperatorGreaterEqual THEN
    WriteString(context^.output, '>=')
  END;
  IF operator = astBinaryOperatorDisjunction THEN
    WriteString(context^.output, 'OR')
  END;
  IF operator = astBinaryOperatorConjunction THEN
    WriteString(context^.output, 'AND')
  END
END transpile_binary_operator;
PROCEDURE transpile_expression(context: PTranspilerContext; expression: PAstExpression);
VAR
  literal: PAstLiteral;
  buffer: ARRAY[1..20] OF CHAR;
  written_bytes: CARDINAL;
  argument_index: CARDINAL;
  current_argument: PPAstExpression;
BEGIN
  IF expression^.kind = astExpressionKindLiteral THEN
    literal := expression^.literal;

    IF literal^.kind = astLiteralKindInteger THEN
      IntToStr(literal^.integer, 0, buffer);
      WriteString(context^.output, buffer)
    END;
    IF literal^.kind = astLiteralKindString THEN
      WriteString(context^.output, literal^.string)
    END;
    IF literal^.kind = astLiteralKindNull THEN
      WriteString(context^.output, 'NIL')
    END;
    IF (literal^.kind = astLiteralKindBoolean) AND literal^.boolean THEN
      WriteString(context^.output, 'TRUE')
    END;
    IF (literal^.kind = astLiteralKindBoolean) AND (literal^.boolean = FALSE) THEN
      WriteString(context^.output, 'FALSE')
    END
  END;
  IF expression^.kind = astExpressionKindIdentifier THEN
    written_bytes := WriteNBytes(context^.output, ORD(expression^.identifier[1]), ADR(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]), ADR(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 := 1;
      INC(current_argument, TSIZE(PAstExpression));

      WHILE argument_index < expression^.argument_count DO
        WriteString(context^.output, ', ');

        transpile_expression(context, current_argument^);

        INC(current_argument, TSIZE(PAstExpression));
        INC(argument_index)
      END
    END;
    WriteChar(context^.output, ')')
  END
END transpile_expression;
PROCEDURE transpile_if_statement(context: PTranspilerContext; statement: PAstStatement);
BEGIN
  WriteString(context^.output, 'IF ');
  transpile_expression(context, statement^.if_condition);

  WriteString(context^.output, ' THEN');
  WriteLine(context^.output);
  INC(context^.indentation);

  transpile_compound_statement(context, statement^.if_branch);
  DEC(context^.indentation);
  indent(context);
  WriteString(context^.output, 'END')
END transpile_if_statement;
PROCEDURE transpile_while_statement(context: PTranspilerContext; statement: PAstStatement);
BEGIN
  WriteString(context^.output, 'WHILE ');
  transpile_expression(context, statement^.while_condition);

  WriteString(context^.output, ' DO');
  WriteLine(context^.output);
  INC(context^.indentation);

  transpile_compound_statement(context, statement^.while_body);
  DEC(context^.indentation);
  indent(context);
  WriteString(context^.output, 'END')
END transpile_while_statement;
PROCEDURE transpile_assignment_statement(context: PTranspilerContext; statement: PAstStatement);
BEGIN
  transpile_expression(context, statement^.assignee);
  WriteString(context^.output, ' := ');
  transpile_expression(context, statement^.assignment)
END transpile_assignment_statement;
PROCEDURE transpile_return_statement(context: PTranspilerContext; statement: PAstStatement);
BEGIN
  WriteString(context^.output, 'RETURN ');

  transpile_expression(context, statement^.returned)
END transpile_return_statement;
PROCEDURE transpile_compound_statement(context: PTranspilerContext; statement: AstCompoundStatement);
VAR
  current_statement: PPAstStatement;
  index: CARDINAL;
BEGIN
  index := 0;
  current_statement := statement.statements;

  WHILE index < statement.count DO
    transpile_statement(context, current_statement^);

    INC(current_statement, TSIZE(PAstStatement));
    INC(index);

    IF index <> statement.count THEN
      WriteChar(context^.output, ';')
    END;
    WriteLine(context^.output)
  END
END transpile_compound_statement;
PROCEDURE transpile_statement(context: PTranspilerContext; statement: PAstStatement);
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 transpile_statement;
PROCEDURE transpile_statement_part(context: PTranspilerContext; compound: AstCompoundStatement);
BEGIN
  IF compound.count > 0 THEN
    WriteString(context^.output, 'BEGIN');
    WriteLine(context^.output);

    INC(context^.indentation);
    transpile_compound_statement(context, compound);
    DEC(context^.indentation)
  END
END transpile_statement_part;
PROCEDURE transpile_procedure_declaration(context: PTranspilerContext; declaration: PAstProcedureDeclaration);
VAR
  written_bytes: CARDINAL;
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]), ADR(declaration^.name[2]));

  write_semicolon(context^.output)
END transpile_procedure_declaration;
PROCEDURE transpile_procedure_part(context: PTranspilerContext; declaration: PPAstProcedureDeclaration);
BEGIN
  WHILE declaration^ <> NIL DO
    transpile_procedure_declaration(context, declaration^);
    WriteLine(context^.output);

    INC(declaration, TSIZE(PAstProcedureDeclaration))
  END
END transpile_procedure_part;
PROCEDURE transpile_module_name(context: PTranspilerContext);
VAR
  counter: CARDINAL;
  last_slash: CARDINAL;
BEGIN
  counter := 1;
  last_slash := 0;

  WHILE (context^.input_name[counter] <> '.') AND (ORD(context^.input_name[counter]) <> 0) DO
    IF context^.input_name[counter] = '/' THEN
      last_slash := counter
    END;
    INC(counter)
  END;

  IF last_slash = 0 THEN
    counter := 1
  END;
  IF last_slash <> 0 THEN
    counter := last_slash + 1
  END;
  WHILE (context^.input_name[counter] <> '.') AND (ORD(context^.input_name[counter]) <> 0) DO
    WriteChar(context^.output, context^.input_name[counter]);
    INC(counter)
  END
END transpile_module_name;
PROCEDURE transpile(ast_module: PAstModule; output: File; input_name: ShortString);
VAR
  context: TranspilerContext;
BEGIN
  context.input_name := input_name;
  context.output := output;
  context.indentation := 0;

  transpile_module(ADR(context), ast_module)
END transpile;
END Transpiler.