Changeset 13
- Timestamp:
- Apr 9, 2009, 9:53:40 AM (16 years ago)
- Location:
- branches/DelphiToC
- Files:
-
- 3 added
- 4 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/DelphiToC
-
Property svn:ignore
set to
*.dsk
*.exe
*.res
*.~dsk
*.dcu
-
Property svn:ignore
set to
-
branches/DelphiToC/DelphiToC.dpr
r12 r13 7 7 UPascalSource in 'UPascalSource.pas', 8 8 UCSource in 'UCSource.pas', 9 UAssemblerSource in 'UAssemblerSource.pas'; 9 UAssemblerSource in 'UAssemblerSource.pas', 10 UCodeProducer in 'UCodeProducer.pas', 11 UPascalCompiler in 'UPascalCompiler.pas', 12 UPascalParser in 'UPascalParser.pas'; 10 13 11 14 {$R *.res} 12 15 16 {$WARN SYMBOL_PLATFORM OFF} 13 17 begin 14 18 ReportMemoryLeaksOnShutdown := DebugHook <> 0; -
branches/DelphiToC/UAssemblerSource.pas
r12 r13 2 2 3 3 interface 4 5 uses 6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 Dialogs, StdCtrls, UPascalSource, UCodeProducer; 4 8 5 9 type … … 11 15 end; 12 16 17 TAssemblerLine = class 18 LabelName: string; 19 Instruction: string; 20 Operand1: string; 21 Operand2: string; 22 SourceCode: string; 23 function AsString: string; 24 end; 25 26 TAssemblerProducer = class(TCodeProducer) 27 AssemblyCode: TList; // TList<TAssemblerLine> 28 destructor Destroy; override; 29 private 30 procedure AddInstruction(LabelName, Instruction, Operand1, 31 Operand2: string); 32 procedure GenerateCommonBlock(CommonBlock: TCommonBlock; LabelPrefix: string); 33 procedure GenerateExpression(Expression: TExpression; LabelPrefix: string); 34 procedure GenerateProgram(ProgramBlock: TProgram); 35 end; 36 37 13 38 implementation 39 40 41 { TAssemblerLine } 42 43 function TAssemblerLine.AsString: string; 44 begin 45 if LabelName = '' then LabelName := #9 else 46 LabelName := LabelName + ':'#9; 47 if Operand2 <> '' then Operand1 := Operand1 + ', '; 48 49 Result := LabelName + Instruction + ' ' + Operand1 + Operand2; 50 end; 51 52 { TAssemblerProducer } 53 54 procedure TAssemblerProducer.AddInstruction(LabelName, Instruction, Operand1, 55 Operand2: string); 56 var 57 NewLine: TAssemblerLine; 58 begin 59 NewLine := TAssemblerLine.Create; 60 AssemblyCode.Add(NewLine); 61 NewLine.LabelName := LabelName; 62 NewLine.Instruction := Instruction; 63 NewLine.Operand1 := Operand1; 64 NewLine.Operand2 := Operand2; 65 end; 66 14 67 15 68 (* … … 43 96 *) 44 97 98 destructor TAssemblerProducer.Destroy; 99 var 100 I: Integer; 101 begin 102 for I := 0 to AssemblyCode.Count - 1 do 103 TAssemblerLine(AssemblyCode[I]).Free; 104 AssemblyCode.Free; 105 inherited; 106 end; 107 108 procedure TAssemblerProducer.GenerateCommonBlock(CommonBlock: TCommonBlock; LabelPrefix: string); 109 var 110 I: Integer; 111 LabelName: string; 112 begin 113 with CommonBlock do 114 for I := 0 to Operations.Count - 1 do 115 with TOperation(Operations[I]) do begin 116 if Referenced then LabelName := Name + '_L' + IntToStr(I) 117 else LabelName := ''; 118 case Instruction of 119 inJump: begin 120 AddInstruction(LabelName, 'JMP', Name + '_L' + IntToStr(GotoAddress), ''); 121 end; 122 inConditionalJump: begin 123 GenerateExpression(ExpressionTree, LabelPrefix + '_L' + IntToStr(GotoAddress)); 124 AddInstruction(LabelName, 'BRCS', Name + '_L' + IntToStr(GotoAddress), ''); 125 end; 126 inExpressionEvaluation: begin 127 if LabelName <> '' then AddInstruction(LabelName, '', '', ''); 128 GenerateExpression(ExpressionTree, Name + '_L' + IntToStr(GotoAddress)); 129 end; 130 inReturn: 131 AddInstruction(LabelName, 'RET', '', ''); 132 end; 133 end; 134 end; 135 136 procedure TAssemblerProducer.GenerateExpression(Expression: TExpression; LabelPrefix: string); 137 var 138 I: Integer; 139 begin 140 with Expression do 141 case NodeType of 142 ntNone: ; 143 ntVariable: if Assigned(Variable) then AddInstruction('', 'GETVAR', Variable.Name, ''); 144 nTFunction: AddInstruction('', 'CALL', Method.Name, ''); 145 ntConstant: AddInstruction('', 'CONST', '', ''); 146 ntOperator: begin 147 for I := 0 to SubItems.Count - 1 do 148 GenerateExpression(TExpression(SubItems[I]), LabelPrefix); 149 if OperatorName = '+' then AddInstruction('', 'ADD', '', '') 150 else if OperatorName = '-' then AddInstruction('', 'SUB', '', '') 151 else if OperatorName = '*' then AddInstruction('', 'MUL', '', '') 152 else if OperatorName = '/' then AddInstruction('', 'DIV', '', '') 153 else if OperatorName = 'div' then AddInstruction('', 'DIV', '', '') 154 else if OperatorName = 'mod' then AddInstruction('', 'MOD', '', '') 155 else if OperatorName = 'xor' then AddInstruction('', 'XOR', '', '') 156 else if OperatorName = 'or' then AddInstruction('', 'OR', '', '') 157 else if OperatorName = 'and' then AddInstruction('', 'AND', '', '') 158 else if OperatorName = 'not' then AddInstruction('', 'NEG', '', '') 159 else if OperatorName = ':=' then AddInstruction('', 'ST', '', '') 160 else if OperatorName = '>' then AddInstruction('', 'CP', '', '') 161 else if OperatorName = '>=' then AddInstruction('', 'CP', '', '') 162 else if OperatorName = '<' then AddInstruction('', 'CP', '', '') 163 else if OperatorName = '<=' then AddInstruction('', 'CP', '', '') 164 else if OperatorName = '=' then AddInstruction('', 'TST', '', '') 165 else if OperatorName = '<>' then AddInstruction('', 'CP', '', ''); 166 end; 167 end; 168 end; 169 170 procedure TAssemblerProducer.GenerateProgram(ProgramBlock: TProgram); 171 var 172 I: Integer; 173 begin 174 with ProgramBlock do 175 for I := 0 to Modules.Count - 1 do 176 GenerateCommonBlock(TModule(Modules[I]), ''); 177 end; 178 179 180 181 45 182 end. -
branches/DelphiToC/UPascalSource.pas
r12 r13 15 15 inReturn); 16 16 17 TNodeType = (ntNone, ntVariable, n TFunction, ntConstant, ntOperator);17 TNodeType = (ntNone, ntVariable, ntFunction, ntConstant, ntOperator); 18 18 19 19 TValue = array of Byte; 20 20 21 TCompiler = class;22 21 TCommonBlock = class; 23 22 TTypeList = class; … … 42 41 Methods: TFunctionList; 43 42 Operations: TOperationList; 44 procedure AllocateMemory;45 43 constructor Create; virtual; 46 44 destructor Destroy; override; 47 procedure ParseDefinitions(Compiler: TCompiler);48 function ParseExpression(Compiler: TCompiler): TExpression;49 procedure ParseProgramCode(Compiler: TCompiler);50 procedure ParseOperation(Compiler: TCompiler);51 procedure GenerateAssembler(Compiler: TCompiler; LabelPrefix: string);52 45 procedure CheckReferences; 53 46 end; … … 58 51 Size: Integer; 59 52 UsedType: TType; 60 procedure Parse(Compiler: TCompiler);61 53 end; 62 54 63 55 TTypeList = class(TList) 64 56 Parent: TCommonBlock; 65 procedure Parse(Compiler: TCompiler);66 57 function Search(Name: string): TType; 67 58 end; … … 71 62 ValueType: TType; 72 63 Value: TValue; 73 procedure Parse(Compiler: TCompiler);74 64 end; 75 65 … … 77 67 Parent: TCommonBlock; 78 68 function Search(Name: string): TConstant; 79 procedure Parse(Compiler: TCompiler);80 69 end; 81 70 … … 84 73 ValueType: TType; 85 74 Value: TValue; 86 procedure Parse(Compiler: TCompiler);87 75 end; 88 76 89 77 TVariableList = class(TList) 90 78 Parent: TCommonBlock; 91 procedure Parse(Compiler: TCompiler);92 79 function Search(Name: string): TVariable; 93 80 end; … … 103 90 constructor Create; 104 91 destructor Destroy; override; 105 procedure GenerateAssembler(Compiler: TCompiler; LabelPrefix: string);106 92 end; 107 93 … … 112 98 Negative: Boolean; 113 99 Referenced: Boolean; 100 destructor Destroy; override; 114 101 end; 115 102 116 103 TOperationList = class(TList) 117 104 destructor Destroy; override; 118 105 end; 119 106 120 107 TFunction = class(TCommonBlock) 108 public 121 109 Parameters: TList; // TList<TParameter> 122 110 ResultType: TType; 123 111 constructor Create; override; 124 112 destructor Destroy; override; 125 procedure Parse(Compiler: TCompiler);126 113 end; 127 114 128 115 TFunctionList = class(TList) 129 116 Parent: TCommonBlock; 130 procedure Parse(Compiler: TCompiler);131 117 function Search(Name: string): TFunction; 132 118 end; 133 119 134 120 TModule = class(TCommonBlock) 121 public 135 122 ModuleType: TModuleType; 136 123 UsedModules: TList; // TList<TModule> 137 124 constructor Create; override; 138 destructor Destroy; override;139 procedure Parse(Compiler: TCompiler);140 private141 procedure ParseUnit(Compiler: TCompiler);142 procedure ParseProgram(Compiler: TCompiler);143 125 procedure Clear; 126 destructor Destroy; override; 144 127 end; 145 128 … … 149 132 constructor Create; 150 133 destructor Destroy; override; 151 procedure Parse(Compiler: TCompiler);152 procedure AllocateMemory;153 procedure GenerateAssembler(Compiler: TCompiler);154 end;155 156 TAssemblerLine = class157 LabelName: string;158 Instruction: string;159 Operand1: string;160 Operand2: string;161 SourceCode: string;162 function AsString: string;163 end;164 165 TOnErrorMessage = procedure (Text: string) of object;166 167 TCompiler = class168 private169 SourceCode: TStringList;170 CodePosition: Integer;171 ProgramCode: TProgram;172 FOnErrorMessage: TOnErrorMessage;173 procedure ErrorMessage(Text: string);174 function IsAlphanumeric(Character: Char): Boolean;175 function NextCode(Shift: Boolean = False): string;176 function ReadCode: string;177 procedure Expect(Code: string);178 function IsWhiteSpace(Character: Char): Boolean;179 function IsAlphabetic(Character: Char): Boolean;180 function IsIdentificator(Text: string): Boolean;181 function IsKeyword(Text: string): Boolean;182 function IsOperator(Text: string): Boolean;183 procedure GenerateAssemblyCode;184 procedure AddInstruction(LabelName, Instruction, Operand1, Operand2: string);185 public186 AssemblyCode: TList; // TList<TAssemblerLine>187 constructor Create;188 procedure Compile(SourceCode: TStrings);189 destructor Destroy; override;190 property OnErrorMessage: TOnErrorMessage read FOnErrorMessage write FOnErrorMessage;191 134 end; 192 135 … … 204 147 implementation 205 148 206 { TCompiler }207 208 procedure TCompiler.AddInstruction(LabelName, Instruction, Operand1,209 Operand2: string);210 var211 NewLine: TAssemblerLine;212 begin213 NewLine := TAssemblerLine.Create;214 AssemblyCode.Add(NewLine);215 NewLine.LabelName := LabelName;216 NewLine.Instruction := Instruction;217 NewLine.Operand1 := Operand1;218 NewLine.Operand2 := Operand2;219 end;220 221 procedure TCompiler.Compile(SourceCode: TStrings);222 begin223 Self.SourceCode.Assign(SourceCode);224 CodePosition := 1;225 ProgramCode.Parse(Self);226 ProgramCode.AllocateMemory;227 AssemblyCode.Clear;228 GenerateAssemblyCode;229 end;230 231 constructor TCompiler.Create;232 begin233 SourceCode := TStringList.Create;234 AssemblyCode := TList.Create;235 ProgramCode := TProgram.Create;236 end;237 238 destructor TCompiler.Destroy;239 begin240 ProgramCode.Free;241 AssemblyCode.Free;242 SourceCode.Free;243 end;244 245 procedure TCompiler.ErrorMessage(Text: string);246 begin247 if Assigned(FOnErrorMessage) then FOnErrorMessage(Text);248 end;249 250 procedure TCompiler.Expect(Code: string);251 begin252 if NextCode <> Code then begin253 ErrorMessage('Expected ' + Code + ' but ' + NextCode + ' found.');254 end;255 ReadCode;256 end;257 258 procedure TCompiler.GenerateAssemblyCode;259 begin260 ProgramCode.GenerateAssembler(Self);261 end;262 263 function TCompiler.IsAlphabetic(Character: Char): Boolean;264 begin265 Result := (Character in ['a'..'z']) or (Character in ['A'..'Z']);266 end;267 268 function TCompiler.IsAlphanumeric(Character: Char): Boolean;269 begin270 Result := IsAlphabetic(Character) or (Character in ['0'..'9']);271 end;272 273 function TCompiler.IsKeyword(Text: string): Boolean;274 var275 I: Integer;276 begin277 Result := False;278 for I := 0 to High(Keywords) do279 if Keywords[I] = Text then280 Result := True;281 end;282 283 function TCompiler.IsOperator(Text: string): Boolean;284 var285 I: Integer;286 begin287 Result := False;288 for I := 0 to High(Operators) do289 if Operators[I] = Text then290 Result := True;291 end;292 293 function TCompiler.IsIdentificator(Text: string): Boolean;294 var295 I: Integer;296 begin297 Result := True;298 if Length(Text) = 0 then Result := False;299 if IsKeyWord(Text) then Result := False;300 if Length(Text) > 0 then301 if not (Text[1] in ['a'..'z', 'A'..'Z', '%', '_']) then302 Result := False;303 for I := 2 to Length(Text) do304 if not (Text[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) then305 Result := False;306 end;307 308 function TCompiler.IsWhiteSpace(Character: Char): Boolean;309 begin310 Result := (Character = ' ') or (Character = #13) or (Character = #10);311 end;312 313 function TCompiler.NextCode(Shift: Boolean = False): string;314 var315 I: Integer;316 // II: Integer;317 J: Integer;318 const319 SpecChar: set of char = [';', '.', ',', ':', '(', ')', '[', ']', '+', '-', '/', '*',320 '^', '=', '<' , '>' , '@'];321 DoubleSpecChar : array[1..7] of string = (':=', '..', '<=', '>=', '<>', '+=', '-=');322 begin323 Result := '';324 J := CodePosition;325 I := CodePosition;326 with SourceCode do327 while Result = '' do begin328 while IsWhiteSpace(Text[I]) do Inc(I);329 J := I;330 if Copy(Text, J, 1) = '//' then begin331 while (Text[I] <> #13) and (Text[I] <> #10) do Inc(I);332 Result := '';333 end else334 if Copy(Text, J, 1) = '{' then begin335 while (Text[I] <> '}') do Inc(I);336 Result := '';337 end else338 if Copy(Text, J, 1) = '(*' then begin339 while not((Text[I] = '*') and (Text[I + 1] = ')')) do Inc(I);340 Result := '';341 end else342 if Text[J] = '''' then begin343 I := J + 1;344 while not ((Text[I] = '''') and (Text[I + 1] <> '''')) do Inc(I);345 Inc(I);346 Result := Copy(Text, J, I - J );347 end else348 if (Text[J] in SpecChar) then begin349 if (Text[J + 1] in SpecChar) then begin350 for I := 0 to High(DoubleSpecChar) do351 if Copy(Text, J, 2) = DoubleSpecChar[I] then begin352 Result := Copy(Text, J, 2);353 Inc(J, 2);354 Break;355 end;356 I := J;357 end;358 if Result = '' then begin359 Result := Text[J];360 Inc(I);361 end;362 end else begin363 while IsAlphanumeric(Text[I]) do Inc(I);364 Result := LowerCase(Copy(Text, J, I - J));365 end;366 J := I;367 end;368 if Shift then CodePosition := J;369 end;370 371 procedure TModule.ParseUnit(Compiler: TCompiler);372 begin373 with Compiler do begin374 Expect('unit');375 with TModule(ProgramCode.Modules[0]) do begin376 Name := ReadCode;377 ModuleType := mdUnit;378 end;379 Expect(';');380 //ParseInterface;381 //ParseImplementation;382 end;383 end;384 385 function TCompiler.ReadCode: string;386 begin387 Result := NextCode(True);388 end;389 390 149 { TFunction } 391 150 … … 404 163 end; 405 164 406 procedure TFunction.Parse(Compiler: TCompiler);407 begin408 with Compiler do begin409 if NextCode = 'var' then TVariableList(Variables).Parse(Compiler)410 else if NextCode = 'const' then TConstantList(Constants).Parse(Compiler)411 else if NextCode = 'type' then TTypeList(Types).Parse(Compiler)412 else ProgramCode.Parse(Compiler);413 end;414 end;415 416 165 { TProgram } 417 418 procedure TProgram.AllocateMemory;419 var420 I: Integer;421 begin422 for I := 0 to Modules.Count - 1 do423 TModule(Modules[I]).AllocateMemory;424 end;425 166 426 167 constructor TProgram.Create; … … 431 172 432 173 destructor TProgram.Destroy; 433 begin434 435 end;436 437 procedure TProgram.GenerateAssembler(Compiler: TCompiler);438 174 var 439 175 I: Integer; 440 176 begin 441 177 for I := 0 to Modules.Count - 1 do 442 TModule(Modules[I]).GenerateAssembler(Compiler, ''); 443 end; 444 445 procedure TProgram.Parse(Compiler: TCompiler); 446 var 447 I: Integer; 448 begin 449 for I := 0 to Modules.Count - 1 do 450 TModule(Modules[I]).Clear; 451 Modules.Clear; 452 with TModule(Modules[Modules.Add(TModule.Create)]) do begin 453 Name := 'main'; 454 with TType(Types[Types.Add(TType.Create)]) do begin 455 Name := 'byte'; 456 Size := 1; 457 UsedType := nil; 458 end; 459 end; 460 TModule(Modules[0]).Parse(Compiler); 178 TModule(Modules[I]).Free; 179 Device.Free; 461 180 end; 462 181 463 182 { TConstant } 464 183 465 procedure TConstant.Parse(Compiler: TCompiler);466 begin467 468 end;469 184 470 185 { TConstantList } 471 472 procedure TConstantList.Parse(Compiler: TCompiler);473 begin474 // Compiler.Expect('const');475 // while Compiler.IsIdentificator(Compiler.NextCode) do476 // TConstant(Items[Add(TConstant.Create)]).Parse(Compiler);477 end;478 186 479 187 function TConstantList.Search(Name: string): TConstant; … … 511 219 UsedModules.Destroy; 512 220 inherited; 513 end;514 515 procedure TModule.ParseProgram(Compiler: TCompiler);516 var517 Identifier: string;518 begin519 with Compiler do begin520 if NextCode = 'program' then begin521 Expect('program');522 Name := ReadCode;523 ModuleType := mdProgram;524 Expect(';');525 end else Name := '';526 527 // Uses section528 if NextCode = 'uses' then begin529 Identifier := ReadCode;530 while NextCode = ',' do begin531 Identifier := ReadCode;532 533 end;534 end;535 ParseDefinitions(Compiler);536 end;537 end;538 539 procedure TModule.Parse(Compiler: TCompiler);540 begin541 with Compiler do begin542 if NextCode = 'program' then ParseProgram(Compiler)543 else if NextCode = 'unit' then ParseUnit(Compiler)544 else ParseProgram(Compiler);545 end;546 end;547 548 procedure TCommonBlock.AllocateMemory;549 begin550 // for I := 0 to Variables - 1 do551 552 221 end; 553 222 … … 586 255 end; 587 256 588 procedure TCommonBlock.GenerateAssembler(Compiler: TCompiler; LabelPrefix: string);589 var590 I: Integer;591 LabelName: string;592 begin593 with Compiler do594 for I := 0 to Operations.Count - 1 do595 with TOperation(Operations[I]) do begin596 if Referenced then LabelName := Name + '_L' + IntToStr(I)597 else LabelName := '';598 case Instruction of599 inJump: begin600 AddInstruction(LabelName, 'JMP', Name + '_L' + IntToStr(GotoAddress), '');601 end;602 inConditionalJump: begin603 ExpressionTree.GenerateAssembler(Compiler, LabelPrefix + '_L' + IntToStr(GotoAddress));604 AddInstruction(LabelName, 'BRCS', Name + '_L' + IntToStr(GotoAddress), '');605 end;606 inExpressionEvaluation: begin607 if LabelName <> '' then AddInstruction(LabelName, '', '', '');608 ExpressionTree.GenerateAssembler(Compiler, Name + '_L' + IntToStr(GotoAddress));609 end;610 inReturn:611 AddInstruction(LabelName, 'RET', '', '');612 end;613 end;614 end;615 616 procedure TCommonBlock.ParseDefinitions(Compiler: TCompiler);617 begin618 with Compiler do begin619 while NextCode <> '.' do begin620 if NextCode = 'var' then TVariableList(Variables).Parse(Compiler)621 else if NextCode = 'const' then TConstantList(Constants).Parse(Compiler)622 else if NextCode = 'type' then TTypeList(Types).Parse(Compiler)623 else begin624 ParseProgramCode(Compiler);625 Break;626 end;627 end;628 end;629 end;630 631 function TCommonBlock.ParseExpression(Compiler: TCompiler): TExpression;632 var633 Identifier: string;634 NewVariable: TVariable;635 Method: TFunction;636 Constant: TConstant;637 // Brackets: Integer;638 Expressions: TList; // TList<TExpression>;639 I: Integer;640 II: Integer;641 begin642 Expressions := TList.Create;643 Expressions.Add(TExpression.Create);644 with Compiler do begin645 while ((NextCode <> ';') and (NextCode <> ',') and (not IsKeyWord(NextCode))) and646 not (((NextCode = ')') or (NextCode = ']'))) do begin647 Identifier := ReadCode;648 if Identifier = '(' then begin649 with TExpression(Expressions[Expressions.Count - 1]) do begin650 SubItems[1] := ParseExpression(Compiler);651 end;652 with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin653 SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];654 end;655 Expect(')');656 end else657 if IsOperator(Identifier) then begin658 TExpression(Expressions[Expressions.Count - 1]).OperatorName := Identifier;659 TExpression(Expressions[Expressions.Count - 1]).NodeType := ntOperator;660 end else661 if IsIdentificator(Identifier) then begin662 NewVariable := Variables.Search(Identifier);663 if Assigned(NewVariable) then begin664 with TExpression(Expressions[Expressions.Count - 1]) do begin665 SubItems[1] := TExpression.Create;666 TExpression(SubItems[1]).NodeType := ntVariable;667 TExpression(SubItems[1]).Variable := NewVariable;668 end;669 with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin670 SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];671 end;672 end else begin673 Method := Methods.Search(Identifier);674 if Assigned(Method) then begin675 with TExpression(Expressions[Expressions.Count - 1]) do begin676 SubItems[1] := TExpression.Create;677 if NextCode = '(' then // Method with parameters678 with TExpression(SubItems[1]) do begin679 Expect('(');680 SubItems.Add(ParseExpression(Compiler));681 while NextCode = ',' do begin682 Expect(',');683 SubItems.Add(ParseExpression(Compiler));684 end;685 Expect(')');686 end;687 TExpression(SubItems[1]).NodeType := nTFunction;688 TExpression(SubItems[1]).Method := Method;689 end;690 with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin691 SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];692 end;693 end else begin694 Constant := Constants.Search(Identifier);695 if Assigned(Constant) then begin696 with TExpression(Expressions[Expressions.Count - 1]) do begin697 SubItems[1] := TExpression.Create;698 TExpression(SubItems[1]).NodeType := ntConstant;699 TExpression(SubItems[1]).Value := Constant.Value;700 end;701 with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin702 SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];703 end;704 end else begin705 ErrorMessage('Neznámý identifikátor: ' + Identifier);706 end;707 end;708 end;709 end else710 begin711 with TExpression(Expressions[Expressions.Count - 1]) do begin712 SubItems[1] := TExpression.Create;713 TExpression(SubItems[1]).NodeType := ntConstant;714 715 if Identifier[1] = '''' then begin716 SetLength(TExpression(SubItems[1]).Value, Length(Identifier));717 for I := 1 to Length(Identifier) do TExpression(SubItems[1]).Value[I - 1] := Byte(Identifier[I]);718 end else begin719 SetLength(TExpression(SubItems[1]).Value, 1);720 TExpression(SubItems[1]).Value[0] := StrToInt(Identifier);721 end;722 end;723 with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin724 SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];725 end;726 end;727 end;728 729 // Build expression tree730 for II := 0 to High(Operators) do begin731 I := 1;732 while (I < Expressions.Count - 1) do begin733 if not TExpression(Expressions[I]).Associated and734 (TExpression(Expressions[I]).OperatorName = Operators[II]) then begin735 TExpression(Expressions[I]).Associated := True;736 TExpression(Expressions[I - 1]).SubItems[1] := Expressions[I];737 TExpression(Expressions[I + 1]).SubItems[0] := Expressions[I];738 Expressions.Delete(I);739 end else Inc(I);740 end;741 end;742 end;743 Result := TExpression(Expressions[0]).SubItems[1];744 TExpression(Expressions[0]).Destroy;745 TExpression(Expressions[1]).Destroy;746 Expressions.Destroy;747 end;748 749 procedure TCommonBlock.ParseOperation(Compiler: TCompiler);750 var751 Identifier: string;752 Variable: TVariable;753 Method: TFunction;754 First: TOperation;755 Second: TOperation;756 StartIndex: Integer;757 LoopVaraible: TVariable;758 begin759 with Compiler do begin760 if NextCode = 'begin' then ParseProgramCode(Compiler)761 else if NextCode = 'if' then begin762 Expect('if');763 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin764 Instruction := inConditionalJump;765 ExpressionTree := ParseExpression(Compiler);766 Negative := True;767 end;768 First := Operations[Operations.Count - 1];769 Expect('then');770 ParseOperation(Compiler);771 if NextCode = 'else' then begin772 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin773 Instruction := inJump;774 end;775 Second := Operations[Operations.Count - 1];776 First.GotoAddress := Operations.Count;777 Expect('else');778 ParseOperation(Compiler);779 Second.GotoAddress := Operations.Count;780 end else First.GotoAddress := Operations.Count;781 end782 else if NextCode = 'repeat' then begin783 Expect('repeat');784 StartIndex := Operations.Count;785 ParseOperation(Compiler);786 Expect('until');787 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin788 Instruction := inConditionalJump;789 ExpressionTree := ParseExpression(Compiler);790 GotoAddress := StartIndex;791 end;792 end793 else if NextCode = 'while' then begin794 Expect('while');795 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin796 Instruction := inConditionalJump;797 ExpressionTree := ParseExpression(Compiler);798 end;799 First := Operations[Operations.Count - 1];800 StartIndex := Operations.Count - 1;801 Expect('do');802 ParseOperation(Compiler);803 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin804 Instruction := inJump;805 GotoAddress := StartIndex;806 end;807 First.GotoAddress := Operations.Count;808 end809 else if NextCode = 'for' then begin810 Expect('for');811 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin812 Instruction := inExpressionEvaluation;813 ExpressionTree := ParseExpression(Compiler);814 if (ExpressionTree.NodeType <> ntOperator) and815 (ExpressionTree.OperatorName <> ':=') then ErrorMessage('Expected assigment in for loop');816 if TExpression(TExpression(ExpressionTree).SubItems[0]).NodeType <> ntVariable then817 ErrorMessage('Index in FOR loop have to be variable');818 LoopVaraible := TExpression(TExpression(ExpressionTree).SubItems[0]).Variable;819 end;820 Expect('to');821 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin822 Instruction := inExpressionEvaluation;823 ExpressionTree := TExpression.Create;824 with ExpressionTree do begin825 NodeType := ntOperator;826 OperatorName := '=';827 SubItems[0] := TExpression.Create;828 with TExpression(SubItems[0]) do begin829 NodeType := ntVariable;830 Variable := LoopVaraible;831 end;832 SubItems[1] := ParseExpression(Compiler);833 end;834 Negative := True;835 end;836 First := Operations[Operations.Count - 1];837 StartIndex := Operations.Count - 1;838 Expect('do');839 ParseOperation(Compiler);840 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin841 Instruction := inExpressionEvaluation;842 ExpressionTree := TExpression.Create;843 with ExpressionTree do begin844 NodeType := ntOperator;845 OperatorName := ':=';846 SubItems[0] := TExpression.Create;847 with TExpression(SubItems[0]) do begin848 NodeType := ntVariable;849 Variable := LoopVaraible;850 end;851 SubItems[1] := TExpression.Create;852 with TExpression(SubItems[1]) do begin853 NodeType := ntOperator;854 OperatorName := '+';855 SubItems[0] := TExpression.Create;856 with TExpression(SubItems[0]) do begin857 NodeType := ntVariable;858 Variable := LoopVaraible;859 end;860 SubItems[1] := TExpression.Create;861 with TExpression(SubItems[1]) do begin862 NodeType := ntConstant;863 SetLength(Value, 1);864 Value[0] := 1;865 end;866 end;867 end;868 end;869 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin870 Instruction := inJump;871 GotoAddress := StartIndex;872 end;873 First.GotoAddress := Operations.Count;874 end875 else begin876 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin877 Instruction := inExpressionEvaluation;878 ExpressionTree := ParseExpression(Compiler);879 end;880 end;881 end;882 end;883 884 procedure TCommonBlock.ParseProgramCode(Compiler: TCompiler);885 begin886 with Compiler do begin887 Expect('begin');888 while NextCode <> 'end' do begin889 ParseOperation(Compiler);890 Expect(';');891 end;892 Expect('end');893 with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin894 Instruction := inReturn;895 end;896 end;897 CheckReferences;898 end;899 900 257 { TTypeList } 901 902 procedure TTypeList.Parse(Compiler: TCompiler);903 begin904 with Compiler do begin905 Expect('type');906 while IsIdentificator(NextCode) do907 with TType(Items[Add(TType.Create)]) do begin908 Parent := Self;909 Parse(Compiler);910 end;911 end;912 end;913 258 914 259 function TTypeList.Search(Name: string): TType; … … 928 273 { TVariableList } 929 274 930 procedure TVariableList.Parse(Compiler: TCompiler);931 var932 Identifiers: TStringList;933 NewValueType: TType;934 TypeName: string;935 VariableName: string;936 Variable: TVariable;937 I: Integer;938 begin939 Identifiers := TStringList.Create;940 with Compiler do begin941 Expect('var');942 while IsIdentificator(NextCode) do begin943 VariableName := ReadCode;944 Variable := Search(VariableName);945 if not Assigned(Variable) then begin946 Identifiers.Add(VariableName);947 while NextCode = ',' do begin948 Expect(',');949 Identifiers.Add(ReadCode);950 end;951 end else ErrorMessage('Pøedefinování existující promìnné.');952 Expect(':');953 TypeName := ReadCode;954 NewValueType := Parent.Types.Search(TypeName);955 if NewValueType = nil then ErrorMessage('Typ ' + TypeName + ' nebyl definován.')956 else for I := 0 to Identifiers.Count - 1 do957 with TVariable(Items[Add(TVariable.Create)]) do begin958 Name := Identifiers[I];959 ValueType := NewValueType;960 end;961 Expect(';');962 end;963 end;964 Identifiers.Destroy;965 end;966 967 275 function TVariableList.Search(Name: string): TVariable; 968 276 var … … 981 289 { TVariable } 982 290 983 procedure TVariable.Parse(Compiler: TCompiler);984 begin985 end;986 987 291 { TType } 988 292 989 procedure TType.Parse(Compiler: TCompiler);990 begin991 with Compiler do begin992 Name := NextCode;993 Expect('=');994 UsedType := Parent.Search(NextCode);995 end;996 end;997 293 998 294 { TFunctionList } 999 1000 procedure TFunctionList.Parse(Compiler: TCompiler);1001 begin1002 1003 end;1004 295 1005 296 function TFunctionList.Search(Name: string): TFunction; … … 1031 322 end; 1032 323 1033 procedure TExpression.GenerateAssembler(Compiler: TCompiler; LabelPrefix: string); 1034 var 1035 I: Integer; 1036 begin 1037 with Compiler do 1038 case NodeType of 1039 ntNone: ; 1040 ntVariable: if Assigned(Variable) then AddInstruction('', 'GETVAR', Variable.Name, ''); 1041 nTFunction: AddInstruction('', 'CALL', Method.Name, ''); 1042 ntConstant: AddInstruction('', 'CONST', '', ''); 1043 ntOperator: begin 1044 for I := 0 to SubItems.Count - 1 do 1045 TExpression(SubItems[I]).GenerateAssembler(Compiler, LabelPrefix); 1046 if OperatorName = '+' then AddInstruction('', 'ADD', '', '') 1047 else if OperatorName = '-' then AddInstruction('', 'SUB', '', '') 1048 else if OperatorName = '*' then AddInstruction('', 'MUL', '', '') 1049 else if OperatorName = '/' then AddInstruction('', 'DIV', '', '') 1050 else if OperatorName = 'div' then AddInstruction('', 'DIV', '', '') 1051 else if OperatorName = 'mod' then AddInstruction('', 'MOD', '', '') 1052 else if OperatorName = 'xor' then AddInstruction('', 'XOR', '', '') 1053 else if OperatorName = 'or' then AddInstruction('', 'OR', '', '') 1054 else if OperatorName = 'and' then AddInstruction('', 'AND', '', '') 1055 else if OperatorName = 'not' then AddInstruction('', 'NEG', '', '') 1056 else if OperatorName = ':=' then AddInstruction('', 'ST', '', '') 1057 else if OperatorName = '>' then AddInstruction('', 'CP', '', '') 1058 else if OperatorName = '>=' then AddInstruction('', 'CP', '', '') 1059 else if OperatorName = '<' then AddInstruction('', 'CP', '', '') 1060 else if OperatorName = '<=' then AddInstruction('', 'CP', '', '') 1061 else if OperatorName = '=' then AddInstruction('', 'TST', '', '') 1062 else if OperatorName = '<>' then AddInstruction('', 'CP', '', ''); 1063 end; 1064 end; 1065 end; 1066 1067 { TAssemblerLine } 1068 1069 function TAssemblerLine.AsString: string; 1070 begin 1071 if LabelName = '' then LabelName := #9 else 1072 LabelName := LabelName + ':'#9; 1073 if Operand2 <> '' then Operand1 := Operand1 + ', '; 1074 1075 Result := LabelName + Instruction + ' ' + Operand1 + Operand2; 324 { TOperationList } 325 326 destructor TOperationList.Destroy; 327 var 328 I: Integer; 329 begin 330 for I := 0 to Count - 1 do 331 TOperation(Items[I]).Free; 332 inherited; 333 end; 334 335 { TOperation } 336 337 destructor TOperation.Destroy; 338 begin 339 inherited; 340 ExpressionTree.Free; 1076 341 end; 1077 342
Note:
See TracChangeset
for help on using the changeset viewer.