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; 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; (* 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(output: File); BEGIN WriteChar(output, ';'); WriteLine(output) END write_semicolon; PROCEDURE write_current(lexer: PLexer; output: File); VAR written_bytes: CARDINAL; BEGIN written_bytes := WriteNBytes(output, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start) END write_current; PROCEDURE 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 transpile_import; PROCEDURE 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 transpile_import_part; PROCEDURE 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 transpile_constant; PROCEDURE 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 transpile_constant_part; PROCEDURE 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); write_current(context^.lexer, context^.output); 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 '); token := transpiler_lex(context^.lexer); write_current(context^.lexer, context^.output); token := transpiler_lex(context^.lexer); WriteChar(context^.output, '.'); token := transpiler_lex(context^.lexer); WriteLine(context^.output); RETURN result END transpile_module; PROCEDURE transpile_type_fields(context: PTranspilerContext): PAstFieldDeclaration; VAR token: LexerToken; field_declarations: PAstFieldDeclaration; field_count: CARDINAL; current_field: PAstFieldDeclaration; BEGIN ALLOCATE(field_declarations, TSIZE(AstFieldDeclaration)); token := transpiler_lex(context^.lexer); field_count := 0; WHILE token.kind <> lexerKindEnd DO INC(field_count); REALLOCATE(field_declarations, TSIZE(AstFieldDeclaration) * (field_count + 1)); current_field := field_declarations; INC(current_field , TSIZE(AstFieldDeclaration) * (field_count - 1)); WriteString(context^.output, ' '); write_current(context^.lexer, context^.output); token := transpiler_lex(context^.lexer); current_field^.field_name := token.identifierKind; WriteString(context^.output, ': '); token := transpiler_lex(context^.lexer); current_field^.field_type := transpile_type_expression(context); token := transpiler_lex(context^.lexer); IF token.kind = lexerKindSemicolon THEN token := transpiler_lex(context^.lexer); WriteChar(context^.output, ';') END; WriteLine(context^.output) END; INC(current_field, TSIZE(AstFieldDeclaration)); MemZero(current_field, TSIZE(AstFieldDeclaration)); RETURN field_declarations END transpile_type_fields; PROCEDURE transpile_record_type(context: PTranspilerContext): PAstTypeExpression; VAR result: PAstTypeExpression; BEGIN ALLOCATE(result, TSIZE(AstTypeExpression)); result^.kind := astTypeExpressionKindRecord; WriteString(context^.output, 'RECORD'); WriteLine(context^.output); result^.fields := transpile_type_fields(context); WriteString(context^.output, ' END'); RETURN result END transpile_record_type; PROCEDURE transpile_pointer_type(context: PTranspilerContext): PAstTypeExpression; VAR token: LexerToken; result: PAstTypeExpression; BEGIN ALLOCATE(result, TSIZE(AstTypeExpression)); result^.kind := astTypeExpressionKindPointer; token := lexer_current(context^.lexer); WriteString(context^.output, 'POINTER TO '); IF token.kind = lexerKindPointer THEN token := transpiler_lex(context^.lexer) END; token := lexer_current(context^.lexer); result^.target := transpile_type_expression(context); RETURN result END transpile_pointer_type; PROCEDURE transpile_array_type(context: PTranspilerContext): PAstTypeExpression; VAR token: LexerToken; buffer: ARRAY[1..20] OF CHAR; result: PAstTypeExpression; BEGIN ALLOCATE(result, TSIZE(AstTypeExpression)); result^.kind := astTypeExpressionKindArray; WriteString(context^.output, 'ARRAY'); token := lexer_current(context^.lexer); IF token.kind = lexerKindArray THEN token := transpiler_lex(context^.lexer) END; IF token.kind <> lexerKindOf THEN WriteString(context^.output, '[1..'); token := transpiler_lex(context^.lexer); result^.length := token.integerKind; IntToStr(result^.length, 0, buffer); WriteString(context^.output, buffer); token := transpiler_lex(context^.lexer); WriteChar(context^.output, ']') END; WriteString(context^.output, ' OF '); token := transpiler_lex(context^.lexer); result^.base := transpile_type_expression(context); RETURN result END transpile_array_type; PROCEDURE transpile_enumeration_type(context: PTranspilerContext): PAstTypeExpression; VAR token: LexerToken; result: PAstTypeExpression; current_case: PIdentifier; case_count: CARDINAL; written_bytes: CARDINAL; BEGIN ALLOCATE(result, TSIZE(AstTypeExpression)); result^.kind := astTypeExpressionKindEnumeration; case_count := 1; ALLOCATE(result^.cases, TSIZE(Identifier) * 2); token := transpiler_lex(context^.lexer); current_case := result^.cases; current_case^ := token.identifierKind; token := transpiler_lex(context^.lexer); WHILE token.kind = lexerKindComma DO token := transpiler_lex(context^.lexer); INC(case_count); REALLOCATE(result^.cases, TSIZE(Identifier) * (case_count + 1)); current_case := result^.cases; INC(current_case, TSIZE(Identifier) * (case_count - 1)); current_case^ := token.identifierKind; token := transpiler_lex(context^.lexer) END; INC(current_case, TSIZE(Identifier)); MemZero(current_case, TSIZE(Identifier)); (* Write the cases using the generated identifier list before. *) current_case := result^.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, ' )'); RETURN result END transpile_enumeration_type; PROCEDURE transpile_named_type(context: PTranspilerContext): PAstTypeExpression; VAR token: LexerToken; result: PAstTypeExpression; written_bytes: CARDINAL; BEGIN token := lexer_current(context^.lexer); ALLOCATE(result, TSIZE(AstTypeExpression)); result^.kind := astTypeExpressionKindNamed; result^.name := token.identifierKind; written_bytes := WriteNBytes(context^.output, ORD(result^.name[1]), ADR(result^.name[2])); RETURN result END transpile_named_type; PROCEDURE transpile_procedure_type(context: PTranspilerContext): PAstTypeExpression; VAR token: LexerToken; result: PAstTypeExpression; current_parameter: PPAstTypeExpression; parameter_count: CARDINAL; BEGIN parameter_count := 0; ALLOCATE(result, TSIZE(AstTypeExpression)); result^.kind := astTypeExpressionKindProcedure; ALLOCATE(result^.parameters, 1); token := transpiler_lex(context^.lexer); WriteString(context^.output, 'PROCEDURE('); token := transpiler_lex(context^.lexer); WHILE token.kind <> lexerKindRightParen DO INC(parameter_count); REALLOCATE(result^.parameters, TSIZE(PAstTypeExpression) * (parameter_count + 1)); current_parameter := result^.parameters; INC(current_parameter, TSIZE(PAstTypeExpression) * (parameter_count - 1)); current_parameter^ := transpile_type_expression(context); token := transpiler_lex(context^.lexer); IF token.kind = lexerKindComma THEN token := transpiler_lex(context^.lexer); WriteString(context^.output, ', ') END END; current_parameter := result^.parameters; INC(current_parameter, TSIZE(PAstTypeExpression) * parameter_count); current_parameter^ := NIL; WriteChar(context^.output, ')'); RETURN result END transpile_procedure_type; PROCEDURE transpile_type_expression(context: PTranspilerContext): PAstTypeExpression; VAR token: LexerToken; result: PAstTypeExpression; BEGIN result := NIL; token := lexer_current(context^.lexer); IF token.kind = lexerKindRecord THEN result := transpile_record_type(context) END; IF token.kind = lexerKindLeftParen THEN result := transpile_enumeration_type(context) END; IF (token.kind = lexerKindArray) OR (token.kind = lexerKindLeftSquare) THEN result := transpile_array_type(context) END; IF token.kind = lexerKindHat THEN result := transpile_pointer_type(context) END; IF token.kind = lexerKindProc THEN result := transpile_procedure_type(context) END; IF token.kind = lexerKindIdentifier THEN result := transpile_named_type(context) END; RETURN result END transpile_type_expression; PROCEDURE 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 := transpile_type_expression(context); token := transpiler_lex(context^.lexer); write_semicolon(context^.output); RETURN result END transpile_type_declaration; PROCEDURE 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 transpile_type_part; PROCEDURE 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 := transpile_type_expression(context); token := transpiler_lex(context^.lexer); write_semicolon(context^.output) END transpile_variable_declaration; PROCEDURE 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 transpile_variable_part; PROCEDURE 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 := transpile_type_expression(context); 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 transpile_procedure_heading; PROCEDURE transpile_expression(context: PTranspilerContext; trailing_token: LexerKind); VAR token: LexerToken; written_bytes: CARDINAL; BEGIN token := transpiler_lex(context^.lexer); WHILE (token.kind <> trailing_token) AND (token.kind <> lexerKindEnd) DO written_bytes := 0; IF token.kind = lexerKindNull THEN WriteString(context^.output, 'NIL '); written_bytes := 1 END; IF (token.kind = lexerKindBoolean) AND token.booleanKind THEN WriteString(context^.output, 'TRUE '); written_bytes := 1 END; IF (token.kind = lexerKindBoolean) AND (~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 transpile_expression; PROCEDURE 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 transpile_if_statement; PROCEDURE 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 transpile_while_statement; PROCEDURE transpile_assignment_statement(context: PTranspilerContext); BEGIN WriteString(context^.output, ' := '); transpile_expression(context, lexerKindSemicolon); END transpile_assignment_statement; PROCEDURE transpile_call_statement(context: PTranspilerContext); VAR token: LexerToken; BEGIN WriteString(context^.output, '('); token := transpiler_lex(context^.lexer); WHILE (token.kind <> lexerKindSemicolon) AND (token.kind <> lexerKindEnd) DO write_current(context^.lexer, context^.output); token := transpiler_lex(context^.lexer) END END transpile_call_statement; PROCEDURE 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 transpile_designator_expression; PROCEDURE transpile_return_statement(context: PTranspilerContext); VAR token: LexerToken; BEGIN WriteString(context^.output, ' RETURN '); transpile_expression(context, lexerKindSemicolon) END transpile_return_statement; PROCEDURE 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 transpile_statement; PROCEDURE 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 transpile_statements; PROCEDURE 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 transpile_statement_part; PROCEDURE 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 transpile_procedure_declaration; PROCEDURE 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 transpile_procedure_part; PROCEDURE transpile(lexer: PLexer; output: File); VAR token: LexerToken; context: TranspilerContext; ast_module: PAstModule; BEGIN context.indentation := 0; context.output := output; context.lexer := lexer; ast_module := transpile_module(ADR(context)) END transpile; END Transpiler.