elna/source/Transpiler.mod

IMPLEMENTATION MODULE Transpiler;

FROM FIO IMPORT WriteNBytes, StdOut;
FROM SYSTEM IMPORT ADR, ADDRESS;

FROM Terminal IMPORT Write, WriteLn, WriteString;
FROM Lexer IMPORT Lexer, LexerToken, lexer_current, lexer_lex, LexerKind;

TYPE
  PTranspilerContext = POINTER TO TranspilerContext;
  TranspilerContext = RECORD
    Indentation: CARDINAL
  END;

(* Calls lexer_lex() but skips the comments. *)
PROCEDURE 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 transpiler_lex;
(* Write a semicolon followed by a newline. *)
PROCEDURE write_semicolon();
BEGIN
  WriteString(';');
  WriteLn()
END write_semicolon;
PROCEDURE transpile_import(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('FROM ');
  token := transpiler_lex(lexer);

  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  WriteString(' IMPORT ');

  token := transpiler_lex(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  WHILE token.kind <> lexerKindSemicolon DO
    WriteString(', ');
    token := transpiler_lex(lexer);
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
    token := transpiler_lex(lexer)
  END;
  write_semicolon();
  token := transpiler_lex(lexer)
END transpile_import;
PROCEDURE transpile_import_part(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
BEGIN
  token := lexer_current(lexer);

  WHILE token.kind = lexerKindFrom DO
    transpile_import(context, lexer);
    token := lexer_current(lexer)
  END;
  WriteLn()
END transpile_import_part;
PROCEDURE transpile_constant(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('  ');
  token := lexer_current(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  WriteString(' = ');

  token := transpiler_lex(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  write_semicolon()
END transpile_constant;
PROCEDURE transpile_constant_part(context: PTranspilerContext;  lexer: PLexer): BOOLEAN;
VAR
  token: LexerToken;
  result: BOOLEAN;
BEGIN
  token := lexer_current(lexer);
  result := token.kind = lexerKindConst;

  IF result THEN
    WriteString('CONST');
    WriteLn();
    token := transpiler_lex(lexer);

    WHILE token.kind = lexerKindIdentifier DO
      transpile_constant(context, lexer);
      token := transpiler_lex(lexer)
    END
  END;
  RETURN result
END transpile_constant_part;
PROCEDURE transpile_module(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  token := transpiler_lex(lexer);

  IF token.kind = lexerKindDefinition THEN
    WriteString('DEFINITION ');
    token := transpiler_lex(lexer)
  END;
  IF token.kind = lexerKindImplementation THEN
    WriteString('IMPLEMENTATION ');
    token := transpiler_lex(lexer)
  END;
  WriteString('MODULE ');

  (* Write the module name and end the line with a semicolon and newline. *)
  token := transpiler_lex(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  write_semicolon();
  WriteLn();

  (* Write the module body. *)
  token := transpiler_lex(lexer);
  transpile_import_part(context, lexer);
  IF transpile_constant_part(context, lexer) THEN
    WriteLn()
  END;
  transpile_type_part(context, lexer);
  IF transpile_variable_part(context, lexer) THEN
    WriteLn()
  END;
  transpile_procedure_part(context, lexer);
  transpile_statement_part(context, lexer);

  WriteString('END ');

  token := transpiler_lex(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  Write('.');

  token := transpiler_lex(lexer);
  WriteLn()
END transpile_module;
PROCEDURE transpile_type_fields(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  token := transpiler_lex(lexer);

  WHILE token.kind <> lexerKindEnd DO
    WriteString('    ');
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
    token := transpiler_lex(lexer);
    WriteString(': ');
    transpile_type_expression(context, lexer);
    token := transpiler_lex(lexer);

    IF token.kind = lexerKindSemicolon THEN
      token := transpiler_lex(lexer);
      Write(';')
    END;
    WriteLn()
  END
END transpile_type_fields;
PROCEDURE transpile_record_type(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
BEGIN
  WriteString('RECORD');
  WriteLn();
  transpile_type_fields(context, lexer);
  WriteString('  END')
END transpile_record_type;
PROCEDURE transpile_pointer_type(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  token := lexer_current(lexer);
  WriteString('POINTER TO ');
  IF token.kind = lexerKindPointer THEN
    token := transpiler_lex(lexer)
  END;
  transpile_type_expression(context, lexer)
END transpile_pointer_type;
PROCEDURE transpile_array_type(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('ARRAY');
  token := lexer_current(lexer);

  IF token.kind = lexerKindArray THEN
    token := transpiler_lex(lexer)
  END;
  IF token.kind <> lexerKindOf THEN
    WriteString('[1..');
    token := transpiler_lex(lexer);
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
    token := transpiler_lex(lexer);
    Write(']')
  END;
  WriteString(' OF ');
  transpile_type_expression(context, lexer)
END transpile_array_type;
PROCEDURE transpile_enumeration_type(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('(');
  WriteLn();
  WriteString('    ');

  token := transpiler_lex(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);

  WHILE token.kind = lexerKindComma DO
    Write(',');
    WriteLn();
    WriteString('    ');
    token := transpiler_lex(lexer);
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

    token := transpiler_lex(lexer)
  END;
  WriteLn();
  WriteString('  )')
END transpile_enumeration_type;
PROCEDURE transpile_union_type(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
END transpile_union_type;
PROCEDURE transpile_procedure_type(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  token := transpiler_lex(lexer);
  WriteString('PROCEDURE(');

  token := transpiler_lex(lexer);

  WHILE token.kind <> lexerKindRightParen DO
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

    token := transpiler_lex(lexer);
    IF token.kind = lexerKindComma THEN
      token := transpiler_lex(lexer);
      WriteString(', ')
    END
  END;
  Write(')')
END transpile_procedure_type;
PROCEDURE transpile_type_expression(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  token := transpiler_lex(lexer);
  IF token.kind = lexerKindRecord THEN
    transpile_record_type(context, lexer)
  END;
  IF token.kind = lexerKindLeftParen THEN
    transpile_enumeration_type(context, lexer)
  END;
  IF (token.kind = lexerKindArray) OR (token.kind = lexerKindLeftSquare) THEN
    transpile_array_type(context, lexer)
  END;
  IF token.kind = lexerKindHat THEN
    transpile_pointer_type(context, lexer)
  END;
  IF token.kind = lexerKindProc THEN
    transpile_procedure_type(context, lexer)
  END;
  IF token.kind = lexerKindIdentifier THEN
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start)
  END
END transpile_type_expression;
PROCEDURE transpile_type_declaration(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('  ');
  token := lexer_current(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  WriteString(' = ');
  transpile_type_expression(context, lexer);
  token := transpiler_lex(lexer);
  write_semicolon();
END transpile_type_declaration;
PROCEDURE transpile_type_part(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
BEGIN
  token := lexer_current(lexer);

  IF token.kind = lexerKindType THEN
    WriteString('TYPE');
    WriteLn();
    token := transpiler_lex(lexer);

    WHILE token.kind = lexerKindIdentifier DO
      transpile_type_declaration(context, lexer);
      token := transpiler_lex(lexer)
    END;
    WriteLn()
  END
END transpile_type_part;
PROCEDURE transpile_variable_declaration(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('  ');
  token := lexer_current(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  WriteString(': ');
  transpile_type_expression(context, lexer);
  token := transpiler_lex(lexer);
  write_semicolon()
END transpile_variable_declaration;
PROCEDURE transpile_variable_part(context: PTranspilerContext;  lexer: PLexer): BOOLEAN;
VAR
  token: LexerToken;
  result: BOOLEAN;
BEGIN
  token := lexer_current(lexer);
  result := token.kind = lexerKindVar;

  IF result THEN
    WriteString('VAR');
    WriteLn();
    token := transpiler_lex(lexer);

    WHILE token.kind = lexerKindIdentifier DO
      transpile_variable_declaration(context, lexer);
      token := transpiler_lex(lexer)
    END
  END;
  RETURN result
END transpile_variable_part;
PROCEDURE transpile_procedure_heading(context: PTranspilerContext; lexer: PLexer): LexerToken;
VAR
  token: LexerToken;
  result: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('PROCEDURE ');

  result := transpiler_lex(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

  token := transpiler_lex(lexer);
  Write('(');

  token := transpiler_lex(lexer);
  WHILE token.kind <> lexerKindRightParen DO
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);

    token := transpiler_lex(lexer);
    WriteString(': ');

    transpile_type_expression(context, lexer);

    token := transpiler_lex(lexer);
    IF (token.kind = lexerKindSemicolon) OR (token.kind = lexerKindComma) THEN
      WriteString('; ');
      token := transpiler_lex(lexer)
    END
  END;
  WriteString(')');
  token := transpiler_lex(lexer);

  (* Check for the return type and write it. *)
  IF token.kind = lexerKindArrow THEN
    WriteString(': ');
    token := transpiler_lex(lexer);
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
    token := transpiler_lex(lexer)
  END;
  token := transpiler_lex(lexer);
  write_semicolon();

  RETURN result
END transpile_procedure_heading;
PROCEDURE transpile_expression(context: PTranspilerContext;  lexer: PLexer; trailing_token: LexerKind);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  token := transpiler_lex(lexer);

  WHILE (token.kind <> trailing_token) AND (token.kind <> lexerKindEnd) DO
    written_bytes := 0;
    IF token.kind = lexerKindNull THEN
      WriteString('NIL ');
      written_bytes := 1
    END;
    IF token.kind = lexerKindOr THEN
      WriteString('OR ');
      written_bytes := 1
    END;
    IF token.kind = lexerKindAnd THEN
      WriteString('AND ');
      written_bytes := 1
    END;
    IF token.kind = lexerKindNot THEN
      WriteString('NOT ');
      written_bytes := 1
    END;
    IF written_bytes = 0 THEN
      written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
      Write(' ')
    END;
    token := transpiler_lex(lexer)
  END
END transpile_expression;
PROCEDURE transpile_if_statement(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('  IF ');
  transpile_expression(context, lexer, lexerKindThen);

  WriteString('THEN');
  WriteLn();
  transpile_statements(context, lexer);
  WriteString('  END');
  token := transpiler_lex(lexer)
END transpile_if_statement;
PROCEDURE transpile_while_statement(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('  WHILE ');
  transpile_expression(context, lexer, lexerKindDo);

  WriteString('DO');
  WriteLn();
  transpile_statements(context, lexer);
  WriteString('  END');
  token := transpiler_lex(lexer)
END transpile_while_statement;
PROCEDURE transpile_assignment_statement(context: PTranspilerContext;  lexer: PLexer);
BEGIN
  WriteString(' := ');
  transpile_expression(context, lexer, lexerKindSemicolon);
END transpile_assignment_statement;
PROCEDURE transpile_call_statement(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('(');
  token := transpiler_lex(lexer);

  WHILE (token.kind <> lexerKindSemicolon) AND (token.kind <> lexerKindEnd) DO
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
    token := transpiler_lex(lexer)
  END
END transpile_call_statement;
PROCEDURE transpile_designator_expression(context: PTranspilerContext; lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('  ');
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
  token := transpiler_lex(lexer);

  WHILE token.kind = lexerKindLeftSquare DO
    Write('[');
    token := transpiler_lex(lexer);
    WHILE token.kind <> lexerKindRightSquare DO
      written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
      token := transpiler_lex(lexer)
    END;
    Write(']');
    token := transpiler_lex(lexer)
  END;
  IF token.kind = lexerKindHat THEN
    Write('^');
    token := transpiler_lex(lexer)
  END;
  IF token.kind = lexerKindDot THEN
    Write('.');
    token := transpiler_lex(lexer);
    written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
    token := transpiler_lex(lexer)
  END;
  IF token.kind = lexerKindHat THEN
    Write('^');
    token := transpiler_lex(lexer)
  END;
  WHILE token.kind = lexerKindLeftSquare DO
    Write('[');
    token := transpiler_lex(lexer);
    WHILE token.kind <> lexerKindRightSquare DO
      written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
      token := transpiler_lex(lexer)
    END;
    Write(']');
    token := transpiler_lex(lexer)
  END
END transpile_designator_expression;
PROCEDURE transpile_return_statement(context: PTranspilerContext; lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  WriteString('  RETURN ');
  token := transpiler_lex(lexer);
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start);
  token := transpiler_lex(lexer)
END transpile_return_statement;
PROCEDURE transpile_statement(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
BEGIN
  token := transpiler_lex(lexer);

  IF token.kind = lexerKindIf THEN
    transpile_if_statement(context, lexer)
  END;
  IF token.kind = lexerKindWhile THEN
    transpile_while_statement(context, lexer)
  END;
  IF token.kind = lexerKindReturn THEN
    transpile_return_statement(context, lexer)
  END;
  IF token.kind = lexerKindIdentifier THEN
    transpile_designator_expression(context, lexer);
    token := lexer_current(lexer);

    IF token.kind = lexerKindAssignment THEN
      transpile_assignment_statement(context, lexer)
    END;
    IF token.kind = lexerKindLeftParen THEN
      transpile_call_statement(context, lexer)
    END
  END
END transpile_statement;
PROCEDURE transpile_statements(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
BEGIN
  token := lexer_current(lexer);

  WHILE token.kind <> lexerKindEnd DO
    transpile_statement(context, lexer);
    token := lexer_current(lexer);

    IF token.kind = lexerKindSemicolon THEN
      Write(';')
    END;
    WriteLn()
  END
END transpile_statements;
PROCEDURE transpile_statement_part(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
BEGIN
  token := lexer_current(lexer);
  IF token.kind = lexerKindBegin THEN
    WriteString('BEGIN');
    WriteLn();
    transpile_statements(context, lexer)
  END
END transpile_statement_part;
PROCEDURE transpile_procedure_declaration(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
  seen_part: BOOLEAN;
  written_bytes: CARDINAL;
BEGIN
  token := transpile_procedure_heading(context, lexer);
  seen_part := transpile_constant_part(context, lexer);
  seen_part := transpile_variable_part(context, lexer);
  transpile_statement_part(context, lexer);

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

  token := transpiler_lex(lexer);
  write_semicolon();
  token := transpiler_lex(lexer)
END transpile_procedure_declaration;
PROCEDURE transpile_procedure_part(context: PTranspilerContext;  lexer: PLexer);
VAR
  token: LexerToken;
BEGIN
  token := lexer_current(lexer);

  WHILE token.kind = lexerKindProc DO
    transpile_procedure_declaration(context, lexer);
    token := lexer_current(lexer);
    WriteLn()
  END
END transpile_procedure_part;
PROCEDURE transpile(lexer: PLexer);
VAR
  token: LexerToken;
  written_bytes: CARDINAL;
  context: TranspilerContext;
BEGIN
  transpile_module(ADR(context), lexer)
END transpile;
END Transpiler.