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(ALexer: PLexer): LexerToken;
VAR
  Result: LexerToken;
BEGIN
  Result := lexer_lex(ALexer);

  WHILE Result.Kind = lexerKindComment DO
    Result := lexer_lex(ALexer)
  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(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('FROM ');
  Token := transpiler_lex(ALexer);

  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);
  WriteString(' IMPORT ');

  Token := transpiler_lex(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);
  WHILE Token.Kind <> lexerKindSemicolon DO
    WriteString(', ');
    Token := transpiler_lex(ALexer);
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
    Token := transpiler_lex(ALexer)
  END;
  write_semicolon();
  Token := transpiler_lex(ALexer)
END transpile_import;
PROCEDURE transpile_import_part(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
BEGIN
  Token := lexer_current(ALexer);

  WHILE Token.Kind = lexerKindFrom DO
    transpile_import(AContext, ALexer);
    Token := lexer_current(ALexer)
  END;
  WriteLn()
END transpile_import_part;
PROCEDURE transpile_constant(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('  ');
  Token := lexer_current(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);
  WriteString(' = ');

  Token := transpiler_lex(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);
  write_semicolon()
END transpile_constant;
PROCEDURE transpile_constant_part(AContext: PTranspilerContext; ALexer: PLexer): BOOLEAN;
VAR
  Token: LexerToken;
  Result: BOOLEAN;
BEGIN
  Token := lexer_current(ALexer);
  Result := Token.Kind = lexerKindConst;

  IF Result THEN
    WriteString('CONST');
    WriteLn();
    Token := transpiler_lex(ALexer);

    WHILE Token.Kind = lexerKindIdentifier DO
      transpile_constant(AContext, ALexer);
      Token := transpiler_lex(ALexer)
    END
  END;
  RETURN Result
END transpile_constant_part;
PROCEDURE transpile_module(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  Token := transpiler_lex(ALexer);

  IF Token.Kind = lexerKindDefinition THEN
    WriteString('DEFINITION ');
    Token := transpiler_lex(ALexer)
  END;
  IF Token.Kind = lexerKindImplementation THEN
    WriteString('IMPLEMENTATION ');
    Token := transpiler_lex(ALexer)
  END;
  WriteString('MODULE ');

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

  Token := transpiler_lex(ALexer);
  write_semicolon();
  WriteLn();

  (* Write the module body. *)
  Token := transpiler_lex(ALexer);
  transpile_import_part(AContext, ALexer);
  IF transpile_constant_part(AContext, ALexer) THEN
    WriteLn()
  END;
  transpile_type_part(AContext, ALexer);
  IF transpile_variable_part(AContext, ALexer) THEN
    WriteLn()
  END;
  transpile_procedure_part(AContext, ALexer);
  transpile_statement_part(AContext, ALexer);

  WriteString('END ');

  Token := transpiler_lex(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);
  Write('.');

  Token := transpiler_lex(ALexer);
  WriteLn()
END transpile_module;
PROCEDURE transpile_type_fields(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  Token := transpiler_lex(ALexer);

  WHILE Token.Kind <> lexerKindEnd DO
    WriteString('    ');
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
    Token := transpiler_lex(ALexer);
    WriteString(': ');
    transpile_type_expression(AContext, ALexer);
    Token := transpiler_lex(ALexer);

    IF Token.Kind = lexerKindSemicolon THEN
      Token := transpiler_lex(ALexer);
      Write(';')
    END;
    WriteLn()
  END
END transpile_type_fields;
PROCEDURE transpile_record_type(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
BEGIN
  WriteString('RECORD');
  WriteLn();
  transpile_type_fields(AContext, ALexer);
  WriteString('  END')
END transpile_record_type;
PROCEDURE transpile_pointer_type(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  Token := lexer_current(ALexer);
  WriteString('POINTER TO ');
  IF Token.Kind = lexerKindPointer THEN
    Token := transpiler_lex(ALexer)
  END;
  transpile_type_expression(AContext, ALexer)
END transpile_pointer_type;
PROCEDURE transpile_array_type(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('ARRAY');
  Token := transpiler_lex(ALexer);

  IF Token.Kind <> lexerKindOf THEN
    Write('[');
    Token := transpiler_lex(ALexer);
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
    Token := transpiler_lex(ALexer);
    WriteString('..');
    Token := transpiler_lex(ALexer);
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
    Token := transpiler_lex(ALexer);
    Write(']');
    Token := transpiler_lex(ALexer)
  END;
  WriteString(' OF ');
  transpile_type_expression(AContext, ALexer)
END transpile_array_type;
PROCEDURE transpile_enumeration_type(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('(');
  WriteLn();
  WriteString('    ');

  Token := transpiler_lex(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);

  WHILE Token.Kind = lexerKindComma DO
    Write(',');
    WriteLn();
    WriteString('    ');
    Token := transpiler_lex(ALexer);
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

    Token := transpiler_lex(ALexer)
  END;
  WriteLn();
  WriteString('  )')
END transpile_enumeration_type;
PROCEDURE transpile_union_type(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
END transpile_union_type;
PROCEDURE transpile_procedure_type(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  Token := transpiler_lex(ALexer);
  WriteString('PROCEDURE(');

  Token := transpiler_lex(ALexer);

  WHILE Token.Kind <> lexerKindRightParen DO
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

    Token := transpiler_lex(ALexer);
    IF Token.Kind = lexerKindComma THEN
      Token := transpiler_lex(ALexer);
      WriteString(', ')
    END
  END;
  Write(')')
END transpile_procedure_type;
PROCEDURE transpile_type_expression(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  Token := transpiler_lex(ALexer);
  IF Token.Kind = lexerKindRecord THEN
    transpile_record_type(AContext, ALexer)
  END;
  IF Token.Kind = lexerKindLeftParen THEN
    transpile_enumeration_type(AContext, ALexer)
  END;
  IF Token.Kind = lexerKindArray THEN
    transpile_array_type(AContext, ALexer)
  END;
  IF (Token.Kind = lexerKindPointer) OR (Token.Kind = lexerKindHat) THEN
    transpile_pointer_type(AContext, ALexer)
  END;
  IF Token.Kind = lexerKindProc THEN
    transpile_procedure_type(AContext, ALexer)
  END;
  IF Token.Kind = lexerKindIdentifier THEN
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start)
  END
END transpile_type_expression;
PROCEDURE transpile_type_declaration(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('  ');
  Token := lexer_current(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);
  WriteString(' = ');
  transpile_type_expression(AContext, ALexer);
  Token := transpiler_lex(ALexer);
  write_semicolon();
END transpile_type_declaration;
PROCEDURE transpile_type_part(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
BEGIN
  Token := lexer_current(ALexer);

  IF Token.Kind = lexerKindType THEN
    WriteString('TYPE');
    WriteLn();
    Token := transpiler_lex(ALexer);

    WHILE Token.Kind = lexerKindIdentifier DO
      transpile_type_declaration(AContext, ALexer);
      Token := transpiler_lex(ALexer)
    END;
    WriteLn()
  END
END transpile_type_part;
PROCEDURE transpile_variable_declaration(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('  ');
  Token := lexer_current(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);
  WriteString(': ');
  transpile_type_expression(AContext, ALexer);
  Token := transpiler_lex(ALexer);
  write_semicolon()
END transpile_variable_declaration;
PROCEDURE transpile_variable_part(AContext: PTranspilerContext; ALexer: PLexer): BOOLEAN;
VAR
  Token: LexerToken;
  Result: BOOLEAN;
BEGIN
  Token := lexer_current(ALexer);
  Result := Token.Kind = lexerKindVar;

  IF Result THEN
    WriteString('VAR');
    WriteLn();
    Token := transpiler_lex(ALexer);

    WHILE Token.Kind = lexerKindIdentifier DO
      transpile_variable_declaration(AContext, ALexer);
      Token := transpiler_lex(ALexer)
    END
  END;
  RETURN Result
END transpile_variable_part;
PROCEDURE transpile_procedure_heading(AContext: PTranspilerContext; ALexer: PLexer): LexerToken;
VAR
  Token: LexerToken;
  Result: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('PROCEDURE ');

  Result := transpiler_lex(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

  Token := transpiler_lex(ALexer);
  Write('(');

  Token := transpiler_lex(ALexer);
  WHILE Token.Kind <> lexerKindRightParen DO
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);

    Token := transpiler_lex(ALexer);
    WriteString(': ');

    transpile_type_expression(AContext, ALexer);

    Token := transpiler_lex(ALexer);
    IF Token.Kind = lexerKindSemicolon THEN
      WriteString('; ');
      Token := transpiler_lex(ALexer)
    END
  END;
  WriteString(')');
  Token := transpiler_lex(ALexer);

  (* Check for the return type and write it. *)
  IF Token.Kind = lexerKindColon THEN
    WriteString(': ');
    Token := transpiler_lex(ALexer);
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
    Token := transpiler_lex(ALexer)
  END;
  Token := transpiler_lex(ALexer);
  write_semicolon();

  RETURN Result
END transpile_procedure_heading;
PROCEDURE transpile_expression(AContext: PTranspilerContext; ALexer: PLexer; TrailingToken: LexerKind);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  Token := transpiler_lex(ALexer);

  WHILE (Token.Kind <> TrailingToken) AND (Token.Kind <> lexerKindEnd) DO
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
    Write(' ');
    Token := transpiler_lex(ALexer)
  END
END transpile_expression;
PROCEDURE transpile_if_statement(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('  IF ');
  transpile_expression(AContext, ALexer, lexerKindThen);

  WriteString('THEN');
  WriteLn();
  transpile_statements(AContext, ALexer);
  WriteString('  END');
  Token := transpiler_lex(ALexer)
END transpile_if_statement;
PROCEDURE transpile_while_statement(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('  WHILE ');
  transpile_expression(AContext, ALexer, lexerKindDo);

  WriteString('DO');
  WriteLn();
  transpile_statements(AContext, ALexer);
  WriteString('  END');
  Token := transpiler_lex(ALexer)
END transpile_while_statement;
PROCEDURE transpile_assignment_statement(AContext: PTranspilerContext; ALexer: PLexer);
BEGIN
  WriteString(' := ');
  transpile_expression(AContext, ALexer, lexerKindSemicolon);
END transpile_assignment_statement;
PROCEDURE transpile_call_statement(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('(');
  Token := transpiler_lex(ALexer);

  WHILE (Token.Kind <> lexerKindSemicolon) AND (Token.Kind <> lexerKindEnd) DO
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
    Token := transpiler_lex(ALexer)
  END
END transpile_call_statement;
PROCEDURE transpile_return_statement(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  WriteString('  RETURN ');
  Token := transpiler_lex(ALexer);
  WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
  Token := transpiler_lex(ALexer)
END transpile_return_statement;
PROCEDURE transpile_statement(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
BEGIN
  Token := transpiler_lex(ALexer);

  IF Token.Kind = lexerKindIf THEN
    transpile_if_statement(AContext, ALexer)
  END;
  IF Token.Kind = lexerKindWhile THEN
    transpile_while_statement(AContext, ALexer)
  END;
  IF Token.Kind = lexerKindReturn THEN
    transpile_return_statement(AContext, ALexer)
  END;
  IF Token.Kind = lexerKindIdentifier THEN
    WriteString('  ');
    WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
    Token := transpiler_lex(ALexer);

    WHILE Token.Kind = lexerKindLeftSquare DO
      Write('[');
      Token := transpiler_lex(ALexer);
      WHILE Token.Kind <> lexerKindRightSquare DO
        WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
        Token := transpiler_lex(ALexer)
      END;
      Write(']');
      Token := transpiler_lex(ALexer);
    END;
    IF Token.Kind = lexerKindHat THEN
      Write('^');
      Token := transpiler_lex(ALexer)
    END;
    IF Token.Kind = lexerKindDot THEN
      Write('.');
      Token := transpiler_lex(ALexer);
      WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
      Token := transpiler_lex(ALexer);
    END;
    IF Token.Kind = lexerKindHat THEN
      Write('^');
      Token := transpiler_lex(ALexer)
    END;
    WHILE Token.Kind = lexerKindLeftSquare DO
      Write('[');
      Token := transpiler_lex(ALexer);
      WHILE Token.Kind <> lexerKindRightSquare DO
        WrittenBytes := WriteNBytes(StdOut, ADDRESS(ALexer^.Current - ALexer^.Start), ALexer^.Start);
        Token := transpiler_lex(ALexer)
      END;
      Write(']');
      Token := transpiler_lex(ALexer);
    END;

    IF Token.Kind = lexerKindAssignment THEN
      transpile_assignment_statement(AContext, ALexer)
    END;
    IF Token.Kind = lexerKindLeftParen THEN
      transpile_call_statement(AContext, ALexer)
    END
  END
END transpile_statement;
PROCEDURE transpile_statements(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
BEGIN
  Token := lexer_current(ALexer);

  WHILE Token.Kind <> lexerKindEnd DO
    transpile_statement(AContext, ALexer);
    Token := lexer_current(ALexer);

    IF Token.Kind = lexerKindSemicolon THEN
      Write(';')
    END;
    WriteLn()
  END
END transpile_statements;
PROCEDURE transpile_statement_part(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
BEGIN
  Token := lexer_current(ALexer);
  IF Token.Kind = lexerKindBegin THEN
    WriteString('BEGIN');
    WriteLn();
    transpile_statements(AContext, ALexer)
  END
END transpile_statement_part;
PROCEDURE transpile_procedure_declaration(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
  SeenPart: BOOLEAN;
  WrittenBytes: CARDINAL;
BEGIN
  Token := transpile_procedure_heading(AContext, ALexer);
  SeenPart := transpile_constant_part(AContext, ALexer);
  SeenPart := transpile_variable_part(AContext, ALexer);
  transpile_statement_part(AContext, ALexer);

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

  Token := transpiler_lex(ALexer);
  write_semicolon();
  Token := transpiler_lex(ALexer)
END transpile_procedure_declaration;
PROCEDURE transpile_procedure_part(AContext: PTranspilerContext; ALexer: PLexer);
VAR
  Token: LexerToken;
BEGIN
  Token := lexer_current(ALexer);

  WHILE Token.Kind = lexerKindProc DO
    transpile_procedure_declaration(AContext, ALexer);
    Token := lexer_current(ALexer);
    WriteLn()
  END
END transpile_procedure_part;
PROCEDURE transpile(ALexer: PLexer);
VAR
  Token: LexerToken;
  WrittenBytes: CARDINAL;
  Context: TranspilerContext;
BEGIN
  transpile_module(ADR(Context), ALexer)
END transpile;
END Transpiler.