elna/source/Transpiler.elna

implementation module Transpiler;

from FIO import WriteNBytes, WriteLine, WriteChar, WriteString;
from SYSTEM import ADR, ADDRESS, TSIZE;

from NumberIO import IntToStr;
from Storage import ALLOCATE, REALLOCATE;
from MemUtils import MemCopy, MemZero;

from Common import Identifier, PIdentifier, ShortString;
from Lexer import Lexer, LexerToken, lexer_current, lexer_lex, LexerKind;
from Parser import AstModule, PAstModule, AstTypeExpressionKind,
  AstConstantDeclaration, PPAstConstantDeclaration,
  AstTypeDeclaration, PAstTypeDeclaration, PPAstTypeDeclaration,
  AstVariableDeclaration, PPAstVariableDeclaration,
  PAstTypeExpression, AstTypeExpression, PPAstTypeExpression, AstFieldDeclaration, PAstFieldDeclaration,
  parse_type_expression;

(* Calls lexer_lex() but skips the comments. *)
proc transpiler_lex(lexer: PLexer) -> LexerToken;
var
  result: LexerToken;
begin
  result := lexer_lex(lexer);

  while result.kind = lexerKindComment do
    result := lexer_lex(lexer)
  end;

  return result
end;

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

proc write_current(lexer: PLexer, output: File);
var
  written_bytes: CARDINAL;
begin
  written_bytes := WriteNBytes(output, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start)
end;

proc transpile_import(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString(context^.output, 'FROM ');
  token := transpiler_lex(context^.lexer);

  write_current(context^.lexer, context^.output);
  token := transpiler_lex(context^.lexer);
  WriteString(context^.output, ' IMPORT ');

  token := transpiler_lex(context^.lexer);
  write_current(context^.lexer, context^.output);

  token := transpiler_lex(context^.lexer);
  while token.kind <> lexerKindSemicolon do
    WriteString(context^.output, ', ');
    token := transpiler_lex(context^.lexer);
    write_current(context^.lexer, context^.output);
    token := transpiler_lex(context^.lexer)
  end;
  write_semicolon(context^.output);
  token := transpiler_lex(context^.lexer)
end;

proc transpile_import_part(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  while token.kind = lexerKindFrom do
    transpile_import(context);
    token := lexer_current(context^.lexer)
  end;
  WriteLine(context^.output)
end;

proc transpile_constant(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString(context^.output, '  ');
  token := lexer_current(context^.lexer);
  write_current(context^.lexer, context^.output);

  token := transpiler_lex(context^.lexer);
  WriteString(context^.output, ' = ');

  token := transpiler_lex(context^.lexer);
  write_current(context^.lexer, context^.output);

  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output)
end;

proc transpile_constant_part(context: PTranspilerContext) -> PPAstConstantDeclaration;
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  if token.kind = lexerKindConst then
    WriteString(context^.output, 'CONST');
    WriteLine(context^.output);
    token := transpiler_lex(context^.lexer);

    while token.kind = lexerKindIdentifier do
      transpile_constant(context);
      token := transpiler_lex(context^.lexer)
    end
  end;
  return nil
end;

proc transpile_module(context: PTranspilerContext) -> PAstModule;
var
  token: LexerToken;
  result: PAstModule;
begin
  ALLOCATE(result, TSIZE(AstModule));
  token := transpiler_lex(context^.lexer);

  if token.kind = lexerKindDefinition then
    WriteString(context^.output, 'DEFINITION ');
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind = lexerKindImplementation then
    WriteString(context^.output, 'IMPLEMENTATION ');
    token := transpiler_lex(context^.lexer)
  end;
  WriteString(context^.output, 'MODULE ');

  (* Write the module name and end the line with a semicolon and newline. *)
  token := transpiler_lex(context^.lexer);
  transpile_module_name(context);

  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output);
  WriteLine(context^.output);

  (* Write the module body. *)
  token := transpiler_lex(context^.lexer);
  transpile_import_part(context);

  result^.constants := transpile_constant_part(context);
  result^.types := transpile_type_part(context);
  result^.variables := transpile_variable_part(context);

  transpile_procedure_part(context);
  transpile_statement_part(context);

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

  token := transpiler_lex(context^.lexer);
  WriteChar(context^.output, '.');

  token := transpiler_lex(context^.lexer);
  WriteLine(context^.output);

  return result
end;

proc 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;

proc 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;

proc transpile_pointer_type(context: PTranspilerContext, type_expression: PAstTypeExpression);
var
  token: LexerToken;
begin
  WriteString(context^.output, 'POINTER TO ');

  transpile_type_expression(context, type_expression^.target)
end;

proc transpile_array_type(context: PTranspilerContext, type_expression: PAstTypeExpression);
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: 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;

proc 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;

proc 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;

proc 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;

proc transpile_type_declaration(context: PTranspilerContext) -> PAstTypeDeclaration;
var
  token: LexerToken;
  result: PAstTypeDeclaration;
  written_bytes: CARDINAL;
begin
  WriteString(context^.output, '  ');
  token := lexer_current(context^.lexer);

  ALLOCATE(result, TSIZE(AstTypeDeclaration));
  result^.identifier := token.identifierKind;

  written_bytes := WriteNBytes(context^.output, ORD(token.identifierKind[1]), ADR(token.identifierKind[2]));

  token := transpiler_lex(context^.lexer);
  WriteString(context^.output, ' = ');
  token := transpiler_lex(context^.lexer);

  result^.type_expression := parse_type_expression(context^.lexer);
  transpile_type_expression(context, result^.type_expression);

  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output);

  return result
end;

proc transpile_type_part(context: PTranspilerContext) -> PPAstTypeDeclaration;
var
  token: LexerToken;
  result: PPAstTypeDeclaration;
  current_declaration: PPAstTypeDeclaration;
  declaration_count: CARDINAL;
begin
  token := lexer_current(context^.lexer);

  ALLOCATE(result, TSIZE(PAstTypeDeclaration));
  current_declaration := result;
  declaration_count := 0;

  if token.kind = lexerKindType then
    WriteString(context^.output, 'TYPE');
    WriteLine(context^.output);
    token := transpiler_lex(context^.lexer);

    while token.kind = lexerKindIdentifier do
      INC(declaration_count);

      REALLOCATE(result, TSIZE(PAstTypeDeclaration) * (declaration_count + 1));
      current_declaration := result;
      INC(current_declaration, TSIZE(PAstTypeDeclaration) * (declaration_count - 1));

      current_declaration^ := transpile_type_declaration(context);
      token := transpiler_lex(context^.lexer)
    end;
    WriteLine(context^.output)
  end;
  if declaration_count <> 0 then
    INC(current_declaration, TSIZE(PAstTypeDeclaration))
  end;
  current_declaration^ := nil;
  return result
end;

proc transpile_variable_declaration(context: PTranspilerContext);
var
  token: LexerToken;
  type_expression: PAstTypeExpression;
begin
  WriteString(context^.output, '  ');
  token := lexer_current(context^.lexer);
  write_current(context^.lexer, context^.output);

  token := transpiler_lex(context^.lexer);
  WriteString(context^.output, ': ');
  token := transpiler_lex(context^.lexer);
  type_expression := parse_type_expression(context^.lexer);
  transpile_type_expression(context, type_expression);
  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output)
end;

proc transpile_variable_part(context: PTranspilerContext) -> PPAstVariableDeclaration;
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  if token.kind = lexerKindVar then
    WriteString(context^.output, 'VAR');
    WriteLine(context^.output);
    token := transpiler_lex(context^.lexer);

    while token.kind = lexerKindIdentifier do
      transpile_variable_declaration(context);
      token := transpiler_lex(context^.lexer)
    end
  end;
  return nil
end;

proc transpile_procedure_heading(context: PTranspilerContext) -> LexerToken;
var
  token: LexerToken;
  result: LexerToken;
  type_expression: PAstTypeExpression;
begin
  WriteString(context^.output, 'PROCEDURE ');

  result := transpiler_lex(context^.lexer);
  write_current(context^.lexer, context^.output);

  token := transpiler_lex(context^.lexer);
  WriteChar(context^.output, '(');

  token := transpiler_lex(context^.lexer);
  while token.kind <> lexerKindRightParen do
    write_current(context^.lexer, context^.output);

    token := transpiler_lex(context^.lexer);
    WriteString(context^.output, ': ');
    token := transpiler_lex(context^.lexer);

    type_expression := parse_type_expression(context^.lexer);
	transpile_type_expression(context, type_expression);

    token := transpiler_lex(context^.lexer);
    if (token.kind = lexerKindSemicolon) or (token.kind = lexerKindComma) then
      WriteString(context^.output, '; ');
      token := transpiler_lex(context^.lexer)
    end
  end;
  WriteString(context^.output, ')');
  token := transpiler_lex(context^.lexer);

  (* Check for the return type and write it. *)
  if token.kind = lexerKindArrow then
    WriteString(context^.output, ': ');
    token := transpiler_lex(context^.lexer);
    write_current(context^.lexer, context^.output);
    token := transpiler_lex(context^.lexer)
  end;
  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output);

  return result
end;

proc transpile_expression(context: PTranspilerContext, trailing_token: LexerKind);
var
  token: LexerToken;
  written_bytes: CARDINAL;
begin
  token := transpiler_lex(context^.lexer);

  while (token.kind <> trailing_token) & (token.kind <> lexerKindEnd) do
    written_bytes := 0;
    if token.kind = lexerKindNull then
      WriteString(context^.output, 'NIL ');
      written_bytes := 1
    end;
    if (token.kind = lexerKindBoolean) & token.booleanKind then
      WriteString(context^.output, 'TRUE ');
      written_bytes := 1
    end;
    if (token.kind = lexerKindBoolean) & (~token.booleanKind) then
      WriteString(context^.output, 'FALSE ');
      written_bytes := 1
    end;
    if token.kind = lexerKindOr then
      WriteString(context^.output, 'OR ');
      written_bytes := 1
    end;
    if token.kind = lexerKindAnd then
      WriteString(context^.output, 'AND ');
      written_bytes := 1
    end;
    if token.kind = lexerKindNot then
      WriteString(context^.output, 'NOT ');
      written_bytes := 1
    end;
    if written_bytes = 0 then
      write_current(context^.lexer, context^.output);
      WriteChar(context^.output, ' ')
    end;
    token := transpiler_lex(context^.lexer)
  end
end;

proc transpile_if_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString(context^.output, '  IF ');
  transpile_expression(context, lexerKindThen);

  WriteString(context^.output, 'THEN');
  WriteLine(context^.output);
  transpile_statements(context);
  WriteString(context^.output, '  END');
  token := transpiler_lex(context^.lexer)
end;

proc transpile_while_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString(context^.output, '  WHILE ');
  transpile_expression(context, lexerKindDo);

  WriteString(context^.output, 'DO');
  WriteLine(context^.output);
  transpile_statements(context);
  WriteString(context^.output, '  END');
  token := transpiler_lex(context^.lexer)
end;

proc transpile_assignment_statement(context: PTranspilerContext);
begin
  WriteString(context^.output, ' := ');
  transpile_expression(context, lexerKindSemicolon);
end;

proc transpile_call_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString(context^.output, '(');
  token := transpiler_lex(context^.lexer);

  while (token.kind <> lexerKindSemicolon) & (token.kind <> lexerKindEnd) do
    write_current(context^.lexer, context^.output);
    token := transpiler_lex(context^.lexer)
  end
end;

proc transpile_designator_expression(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString(context^.output, '  ');
  write_current(context^.lexer, context^.output);
  token := transpiler_lex(context^.lexer);

  while token.kind = lexerKindLeftSquare do
    WriteChar(context^.output, '[');
    token := transpiler_lex(context^.lexer);
    while token.kind <> lexerKindRightSquare do
      write_current(context^.lexer, context^.output);
      token := transpiler_lex(context^.lexer)
    end;
    WriteChar(context^.output, ']');
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind = lexerKindHat then
    WriteChar(context^.output, '^');
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind = lexerKindDot then
    WriteChar(context^.output, '.');
    token := transpiler_lex(context^.lexer);
    write_current(context^.lexer, context^.output);
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind = lexerKindHat then
    WriteChar(context^.output, '^');
    token := transpiler_lex(context^.lexer)
  end;
  while token.kind = lexerKindLeftSquare do
    WriteChar(context^.output, '[');
    token := transpiler_lex(context^.lexer);
    while token.kind <> lexerKindRightSquare do
      write_current(context^.lexer, context^.output);
      token := transpiler_lex(context^.lexer)
    end;
    WriteChar(context^.output, ']');
    token := transpiler_lex(context^.lexer)
  end
end;

proc transpile_return_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString(context^.output, '  RETURN ');
  transpile_expression(context, lexerKindSemicolon)
end;

proc transpile_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := transpiler_lex(context^.lexer);

  if token.kind = lexerKindIf then
    transpile_if_statement(context)
  end;
  if token.kind = lexerKindWhile then
    transpile_while_statement(context)
  end;
  if token.kind = lexerKindReturn then
    transpile_return_statement(context)
  end;
  if token.kind = lexerKindIdentifier then
    transpile_designator_expression(context);
    token := lexer_current(context^.lexer);

    if token.kind = lexerKindAssignment then
      transpile_assignment_statement(context)
    end;
    if token.kind = lexerKindLeftParen then
      transpile_call_statement(context)
    end
  end
end;

proc transpile_statements(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  while token.kind <> lexerKindEnd do
    transpile_statement(context);
    token := lexer_current(context^.lexer);

    if token.kind = lexerKindSemicolon then
      WriteChar(context^.output, ';')
    end;
    WriteLine(context^.output)
  end
end;

proc transpile_statement_part(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);
  if token.kind = lexerKindBegin then
    WriteString(context^.output, 'BEGIN');
    WriteLine(context^.output);
    transpile_statements(context)
  end
end;

proc transpile_procedure_declaration(context: PTranspilerContext);
var
  token: LexerToken;
  seen_variables: PPAstVariableDeclaration;
  written_bytes: CARDINAL;
  seen_constants: PPAstConstantDeclaration;
begin
  token := transpile_procedure_heading(context);
  seen_constants := transpile_constant_part(context);
  seen_variables := transpile_variable_part(context);
  transpile_statement_part(context);

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

  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output);
  token := transpiler_lex(context^.lexer)
end;

proc transpile_procedure_part(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  while token.kind = lexerKindProc do
    transpile_procedure_declaration(context);
    token := lexer_current(context^.lexer);
    WriteLine(context^.output)
  end
end;

proc transpile_module_name(context: PTranspilerContext);
var
  counter: CARDINAL;
  last_slash: CARDINAL;
begin
  counter := 1;
  last_slash := 0;

  while (context^.input_name[counter] <> '.') & (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] <> '.') & (ORD(context^.input_name[counter]) <> 0) do
    WriteChar(context^.output, context^.input_name[counter]);
	INC(counter)
  end;
end;

proc transpile(lexer: PLexer, output: File, input_name: ShortString);
var
  token: LexerToken;
  context: TranspilerContext;
  ast_module: PAstModule;
begin
  context.input_name := input_name;
  context.output := output;
  context.lexer := lexer;

  ast_module := transpile_module(ADR(context))
end;

end.