Changeset 233
- Timestamp:
- Jun 26, 2023, 6:08:23 PM (17 months ago)
- Location:
- branches/xpascal
- Files:
-
- 13 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/xpascal/Examples/Example.pas
r230 r233 14 14 end; 15 15 16 procedure Print(Text: string); 16 17 begin 18 WriteLn(Text); 19 end; 20 21 begin 22 Print('Test'); 23 17 24 WriteLn('10 * 3 = ' + IntToStr((1 + 2) * (3 + 4))); 18 25 -
branches/xpascal/Executor.pas
r231 r233 71 71 end; 72 72 73 { TExecutorProcedure } 74 75 TExecutorProcedure = class 76 ProcedureDef: TProcedure; 77 Block: TExecutorBlock; 78 Callback: TExecutorFunctionCallback; 79 constructor Create; 80 destructor Destroy; override; 81 end; 82 83 { TExecutorProcedures } 84 85 TExecutorProcedures = class(TObjectList<TExecutorProcedure>) 86 function SearchByProcedure(ProcedureDef: TProcedure): TExecutorProcedure; 87 function AddNew(ProcedureDef: TProcedure): TExecutorProcedure; 88 end; 89 73 90 { TExecutorBlock } 74 91 … … 78 95 Variables: TExecutorVariables; 79 96 Functions: TExecutorFunctions; 97 Procedures: TExecutorProcedures; 80 98 function GetFunction(FunctionDef: TFunction): TExecutorFunction; 99 function GetProcedure(ProcedureDef: TProcedure): TExecutorProcedure; 81 100 function GetType(TypeDef: TType): TExecutorType; 82 101 function GetVariable(Variable: TVariable): TExecutorVariable; … … 144 163 procedure ExecuteBlock(ParentBlock: TExecutorBlock; Block: TBlock; ExistingBlock: TExecutorBlock = nil); 145 164 function ExecuteFunctionCall(Block: TExecutorBlock; FunctionCall: TFunctionCall): TValue; 165 function ExecuteProcedureCall(Block: TExecutorBlock; ProcedureCall: TProcedureCall): TValue; 146 166 procedure ExecuteAssignment(Block: TExecutorBlock; Assignment: TAssignment); 147 167 function ExecuteExpression(Block: TExecutorBlock; Expression: TExpression): TValue; … … 167 187 SExpectedBooleanValue = 'Expected boolean value.'; 168 188 189 { TExecutorProcedures } 190 191 function TExecutorProcedures.SearchByProcedure(ProcedureDef: TProcedure 192 ): TExecutorProcedure; 193 var 194 I: Integer; 195 begin 196 I := 0; 197 while (I < Count) and (TExecutorProcedure(Items[I]).ProcedureDef <> ProcedureDef) do Inc(I); 198 if I < Count then Result := TExecutorProcedure(Items[I]) 199 else Result := nil; 200 end; 201 202 function TExecutorProcedures.AddNew(ProcedureDef: TProcedure 203 ): TExecutorProcedure; 204 begin 205 Result := TExecutorProcedure.Create; 206 Result.ProcedureDef := ProcedureDef; 207 Add(Result); 208 end; 209 210 { TExecutorProcedure } 211 212 constructor TExecutorProcedure.Create; 213 begin 214 Block := TExecutorBlock.Create; 215 end; 216 217 destructor TExecutorProcedure.Destroy; 218 begin 219 FreeAndNil(Block); 220 inherited; 221 end; 222 169 223 { TExecutorFunctionCallbackParam } 170 224 … … 281 335 end; 282 336 337 function TExecutorBlock.GetProcedure(ProcedureDef: TProcedure 338 ): TExecutorProcedure; 339 begin 340 Result := Procedures.SearchByProcedure(ProcedureDef); 341 if not Assigned(Result) and Assigned(Parent) then 342 Result := Parent.GetProcedure(ProcedureDef); 343 end; 344 283 345 function TExecutorBlock.GetType(TypeDef: TType): TExecutorType; 284 346 begin … … 315 377 Variables := TExecutorVariables.Create; 316 378 Functions := TExecutorFunctions.Create; 379 Procedures := TExecutorProcedures.Create; 317 380 end; 318 381 … … 321 384 FreeAndNil(Variables); 322 385 FreeAndNil(Functions); 386 FreeAndNil(Procedures); 323 387 FreeAndNil(Types); 324 388 inherited; … … 703 767 begin 704 768 for I := 0 to BeginEnd.Commands.Count - 1 do 705 ExecuteCommand(Block, TCommand(BeginEnd.Commands[I]));769 ExecuteCommand(Block, BeginEnd.Commands[I]); 706 770 end; 707 771 … … 710 774 if Command is TBeginEnd then ExecuteBeginEnd(Block, TBeginEnd(Command)) 711 775 else if Command is TFunctionCall then ExecuteFunctionCall(Block, TFunctionCall(Command)) 776 else if Command is TProcedureCall then ExecuteProcedureCall(Block, TProcedureCall(Command)) 712 777 else if Command is TAssignment then ExecuteAssignment(Block, TAssignment(Command)) 713 778 else if Command is TIfThenElse then ExecuteIfThenElse(Block, TIfThenElse(Command)) … … 899 964 end; 900 965 966 function TExecutor.ExecuteProcedureCall(Block: TExecutorBlock; 967 ProcedureCall: TProcedureCall): TValue; 968 var 969 ExecutorProcedure: TExecutorProcedure; 970 Params: array of TExecutorFunctionCallbackParam; 971 I: Integer; 972 ExecutorVariable: TExecutorVariable; 973 Variable: TVariable; 974 begin 975 Result := nil; 976 ExecutorProcedure := Block.GetProcedure(ProcedureCall.ProcedureDef); 977 if Assigned(ExecutorProcedure) then begin 978 if ProcedureCall.ProcedureDef.InternalName <> '' then begin 979 SetLength(Params, ProcedureCall.Params.Count); 980 for I := 0 to ProcedureCall.Params.Count - 1 do begin 981 Params[I] := TExecutorFunctionCallbackParam.Create; 982 Params[I].Kind := ProcedureCall.ProcedureDef.Params[I].Kind; 983 if ProcedureCall.ProcedureDef.Params[I].Kind = pkVar then begin 984 Variable := TExpressionOperand(ProcedureCall.Params[I]).VariableRef; 985 //InitExecutorBlock(ExecutorFunction.Block, FunctionCall.FunctionDef.Block); 986 ExecutorVariable := Block.GetVariable(Variable); 987 Params[I].Variable := ExecutorVariable; 988 end 989 else Params[I].Value := ExecuteExpression(Block, ProcedureCall.Params[I]); 990 end; 991 Result := ExecutorProcedure.Callback(Params); 992 for I := 0 to ProcedureCall.Params.Count - 1 do begin 993 //if FunctionCall.Params[I]. 994 Params[I].Free; 995 end; 996 end else begin 997 InitExecutorBlock(ExecutorProcedure.Block, ProcedureCall.ProcedureDef.Block); 998 for I := 0 to ProcedureCall.Params.Count - 1 do begin 999 Variable := ProcedureCall.ProcedureDef.Block.Variables.SearchByName( 1000 TFunctionParameter(ProcedureCall.ProcedureDef.Params[I]).Name); 1001 ExecutorVariable := ExecutorProcedure.Block.Variables.SearchByVariable(Variable); 1002 ExecutorVariable.Value.Free; 1003 ExecutorVariable.Value := ExecuteExpression(Block, TExpression(ProcedureCall.Params[I])); 1004 end; 1005 ExecuteBlock(Block, ProcedureCall.ProcedureDef.Block, ExecutorProcedure.Block); 1006 ExecutorVariable := ExecutorProcedure.Block.Variables.SearchByVariable( 1007 TVariable(ProcedureCall.ProcedureDef.Block.Variables.SearchByName('Result'))); 1008 Result := ExecutorVariable.Value.Clone; 1009 end; 1010 end else raise Exception.Create('No executor for ' + ProcedureCall.ProcedureDef.Name + ' function.'); 1011 end; 1012 901 1013 procedure TExecutor.ExecuteAssignment(Block: TExecutorBlock; 902 1014 Assignment: TAssignment); -
branches/xpascal/Forms/FormMain.lfm
r230 r233 10 10 Menu = MainMenu1 11 11 OnActivate = FormActivate 12 OnClose = FormClose 12 13 OnCreate = FormCreate 13 14 OnDestroy = FormDestroy … … 49 50 object MainMenu1: TMainMenu 50 51 Left = 744 51 Top = 7 6052 Top = 759 52 53 object MenuItemFile: TMenuItem 53 54 Caption = 'File' 55 object MenuItem10: TMenuItem 56 Action = AFileOpen 57 end 54 58 object MenuItem6: TMenuItem 55 59 Action = AExit … … 129 133 OnExecute = AConsoleExecute 130 134 end 135 object AFileOpen: TAction 136 Caption = 'Open...' 137 OnExecute = AFileOpenExecute 138 end 139 end 140 object OpenDialog1: TOpenDialog 141 DefaultExt = '.pas' 142 Filter = 'Pascal file (.pas)|*.pas|Any file|*.*' 143 Left = 536 144 Top = 759 145 end 146 object ApplicationInfo1: TApplicationInfo 147 Identification = 1 148 VersionMajor = 1 149 VersionMinor = 0 150 VersionBugFix = 0 151 AuthorsName = 'Chronosoft' 152 EmailContact = 'robie@centrum.cz' 153 AppName = 'xPascal' 154 Description = 'Pascal mutli language transpiler and interpreter' 155 RegistryKey = '\Software\xpascal' 156 RegistryRoot = rrKeyCurrentUser 157 License = 'CC0' 158 Left = 348 159 Top = 274 131 160 end 132 161 end -
branches/xpascal/Forms/FormMain.lrj
r230 r233 13 13 {"hash":209392028,"name":"tformmain.ageneratexml.caption","sourcebytes":[71,101,110,101,114,97,116,101,32,88,77,76],"value":"Generate XML"}, 14 14 {"hash":371876,"name":"tformmain.atest.caption","sourcebytes":[84,101,115,116],"value":"Test"}, 15 {"hash":174433893,"name":"tformmain.aconsole.caption","sourcebytes":[67,111,110,115,111,108,101],"value":"Console"} 15 {"hash":174433893,"name":"tformmain.aconsole.caption","sourcebytes":[67,111,110,115,111,108,101],"value":"Console"}, 16 {"hash":107745630,"name":"tformmain.afileopen.caption","sourcebytes":[79,112,101,110,46,46,46],"value":"Open..."}, 17 {"hash":239474242,"name":"tformmain.applicationinfo1.description","sourcebytes":[80,97,115,99,97,108,32,109,117,116,108,105,32,108,97,110,103,117,97,103,101,32,116,114,97,110,115,112,105,108,101,114,32,97,110,100,32,105,110,116,101,114,112,114,101,116,101,114],"value":"Pascal mutli language transpiler and interpreter"} 16 18 ]} -
branches/xpascal/Forms/FormMain.pas
r230 r233 4 4 5 5 uses 6 Classes, SysUtils, Forms, Controls, Graphics, Dialogs, Menus, 7 ActnList, ExtCtrls, SynHighlighterPas, SynEdit, Source, Optimizer, 8 Generator, FormSource, FormMessages, FormOutput, FormConsole, FormEx; 6 Classes, SysUtils, Forms, Controls, Graphics, Dialogs, Menus, LazFileUtils, 7 ActnList, ExtCtrls, SynHighlighterPas, SynEdit, Source, Optimizer, RegistryEx, 8 Generator, FormSource, FormMessages, FormOutput, FormConsole, FormEx, 9 ApplicationInfo; 9 10 10 11 type … … 15 16 ACompile: TAction; 16 17 AConsole: TAction; 18 AFileOpen: TAction; 19 ApplicationInfo1: TApplicationInfo; 17 20 ATest: TAction; 18 21 AGenerateXml: TAction; … … 25 28 MainMenu1: TMainMenu; 26 29 MenuItem1: TMenuItem; 30 MenuItem10: TMenuItem; 27 31 MenuItem2: TMenuItem; 28 32 MenuItem3: TMenuItem; … … 36 40 MenuItemGenerate: TMenuItem; 37 41 MenuItemFile: TMenuItem; 42 OpenDialog1: TOpenDialog; 38 43 PanelOutput: TPanel; 39 44 PanelSource: TPanel; … … 43 48 procedure AConsoleExecute(Sender: TObject); 44 49 procedure AExitExecute(Sender: TObject); 50 procedure AFileOpenExecute(Sender: TObject); 45 51 procedure AGenerateCSharpExecute(Sender: TObject); 46 52 procedure AGeneratePascalExecute(Sender: TObject); … … 51 57 procedure ARunExecute(Sender: TObject); 52 58 procedure FormActivate(Sender: TObject); 59 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 53 60 procedure FormCreate(Sender: TObject); 54 61 procedure FormDestroy(Sender: TObject); 55 62 procedure FormShow(Sender: TObject); 56 63 private 64 LastFileName: string; 57 65 Prog: TProgram; 58 66 Initialized: Boolean; … … 61 69 FormOutput: TFormOutput; 62 70 FormConsole: TFormConsole; 71 procedure LoadFromRegistry; 72 procedure SaveToRegistry; 73 procedure ProjectOpen(FileName: string); 63 74 procedure Generate(GeneratorClass: TGeneratorClass); 64 75 procedure ExecutorOutput(Text: string); … … 87 98 if not Initialized then begin 88 99 Initialized := True; 89 FormSource.SynEditSource.Lines.LoadFromFile('Examples' + DirectorySeparator + 90 'Example.pas'); 91 ARun.Execute; 100 ProjectOpen(LastFileName); 101 //ARun.Execute; 92 102 end; 93 103 end; … … 104 114 procedure TFormMain.FormShow(Sender: TObject); 105 115 begin 116 LoadFromRegistry; 106 117 FormMessages := TFormMessages.Create(nil); 107 118 FormMessages.Show; … … 119 130 end; 120 131 132 procedure TFormMain.LoadFromRegistry; 133 begin 134 with TRegistryEx.Create do 135 try 136 CurrentContext := ApplicationInfo1.GetRegistryContext; 137 LastFileName := ReadStringWithDefault('LastFileName', 'Examples' + DirectorySeparator + 'Example.pas'); 138 finally 139 Free; 140 end; 141 end; 142 143 procedure TFormMain.SaveToRegistry; 144 begin 145 with TRegistryEx.Create do 146 try 147 CurrentContext := ApplicationInfo1.GetRegistryContext; 148 WriteString('LastFileName', LastFileName); 149 finally 150 Free; 151 end; 152 end; 153 154 procedure TFormMain.ProjectOpen(FileName: string); 155 begin 156 LastFileName := FileName; 157 FormSource.SynEditSource.Lines.LoadFromFile(FileName); 158 end; 159 121 160 procedure TFormMain.Generate(GeneratorClass: TGeneratorClass); 122 161 var … … 130 169 FormOutput.SetText(Generator.Output); 131 170 TargetFileName := 'Generated' + DirectorySeparator + 132 Generator.Name + DirectorySeparator + 'Example'+ Generator.FileExt;171 Generator.Name + DirectorySeparator + ExtractFileNameOnly(LastFileName) + Generator.FileExt; 133 172 ForceDirectories(ExtractFileDir(TargetFileName)); 134 173 FormOutput.SynEditOutput.Lines.SaveToFile(TargetFileName); … … 141 180 begin 142 181 Close; 182 end; 183 184 procedure TFormMain.AFileOpenExecute(Sender: TObject); 185 begin 186 OpenDialog1.InitialDir := ExtractFileDir(LastFileName); 187 OpenDialog1.FileName := ExtractFileName(LastFileName); 188 if OpenDialog1.Execute then begin 189 ProjectOpen(OpenDialog1.FileName); 190 end; 143 191 end; 144 192 … … 224 272 end; 225 273 274 procedure TFormMain.FormClose(Sender: TObject; var CloseAction: TCloseAction); 275 begin 276 FormConsole.Terminated := True; 277 SaveToRegistry; 278 end; 279 226 280 procedure TFormMain.FormCreate(Sender: TObject); 227 281 begin … … 248 302 begin 249 303 ACompile.Execute; 250 FormOutput.SynEditOutput.Highlighter := nil; 251 FormOutput.SynEditOutput.Lines.Clear; 304 FormConsole.Memo1.Lines.Clear; 252 305 if Assigned(Prog) then begin 253 306 Executor := TExecutor.Create; -
branches/xpascal/Generators/GeneratorCSharp.pas
r230 r233 227 227 228 228 procedure TGeneratorCSharp.GenerateProgram(Block: TBlock; Prog: TProgram); 229 begin 229 var 230 MainClass: string; 231 begin 232 if Prog.Name <> '' then MainClass := Prog.Name 233 else MainClass := 'App'; 230 234 AddTextLine('using System;'); 231 235 AddTextLine; 232 AddTextLine('public class ' + Prog.Name);236 AddTextLine('public class ' + MainClass); 233 237 AddTextLine('{'); 234 238 Indent := Indent + 1; … … 237 241 AddTextLine('public static void Main()'); 238 242 AddTextLine('{'); 239 AddTextLine(' ' + Prog.Name + ' app = new ' + Prog.Name+ '();');243 AddTextLine(' ' + MainClass + ' app = new ' + MainClass + '();'); 240 244 AddTextLine(' app.Entry();'); 241 245 AddTextLine('}'); -
branches/xpascal/Generators/GeneratorXml.pas
r232 r233 11 11 TGeneratorXml = class(TGenerator) 12 12 private 13 procedure GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>); 14 procedure GenerateNode(SourceNode: TSourceNode); 13 procedure GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>; 14 NodeName: string); 15 procedure GenerateNode(SourceNode: TSourceNode; NodeName: string); 15 16 public 16 17 procedure Generate; override; … … 26 27 { TGeneratorXml } 27 28 28 procedure TGeneratorXml.GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>); 29 procedure TGeneratorXml.GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>; 30 NodeName: string); 29 31 var 30 32 I: Integer; … … 32 34 for I := 0 to SourceNodes.Count - 1 do begin 33 35 if SourceNodes[I] is TSourceNode then begin 34 GenerateNode(TSourceNode(SourceNodes[I]) );36 GenerateNode(TSourceNode(SourceNodes[I]), NodeName); 35 37 end else raise Exception.Create(SUnsupportedNodeType); 36 38 end; 37 39 end; 38 40 39 procedure TGeneratorXml.GenerateNode(SourceNode: TSourceNode );41 procedure TGeneratorXml.GenerateNode(SourceNode: TSourceNode; NodeName: string); 40 42 var 41 43 I: Integer; … … 45 47 begin 46 48 if SourceNode is TSourceNode then begin 47 AddTextLine('<' + SourceNode.ClassName + '>');49 AddTextLine('<' + NodeName + '>'); 48 50 Indent := Indent + 1; 49 51 for I := 0 to SourceNode.FieldsCount - 1 do begin 50 52 Field := SourceNode.GetField(I); 51 if Field.DataType = dtObject then begin 52 Obj := SourceNode.GetValueObject(I); 53 if Obj is TSourceNode then 54 GenerateNode(TSourceNode(Obj)); 55 end else 56 if Field.DataType = dtList then begin 57 SourceNode.GetValue(I, List); 58 GenerateNodes(List); 59 end else 60 if Field.DataType = dtString then begin 61 AddTextLine('<' + Field.Name + '>' + SourceNode.GetValueString(I) + '<' + Field.Name + '>'); 53 try 54 if Field.DataType = dtObject then begin 55 Obj := SourceNode.GetValueObject(I); 56 if Obj is TSourceNode then 57 GenerateNode(TSourceNode(Obj), Field.Name); 58 end else 59 if Field.DataType = dtList then begin 60 SourceNode.GetValue(I, List); 61 if List.Count > 0 then 62 GenerateNodes(List, Field.Name); 63 end else 64 if Field.DataType = dtString then begin 65 if SourceNode.GetValueString(I) <> '' then 66 AddTextLine('<' + Field.Name + '>' + SourceNode.GetValueString(I) + 67 '</' + Field.Name + '>'); 68 end; 69 finally 70 Field.Free; 62 71 end; 63 Field.Free;64 72 end; 65 73 Indent := Indent - 1; 66 AddTextLine('</' + SourceNode.ClassName + '>');74 AddTextLine('</' + NodeName + '>'); 67 75 end else 68 76 raise Exception.Create(SUnsupportedNodeType); … … 71 79 procedure TGeneratorXml.Generate; 72 80 begin 73 GenerateNode(Prog); 81 AddTextLine('<?xml version="1.0" encoding="UTF-8"?>'); 82 GenerateNode(Prog, 'Program'); 74 83 end; 75 84 -
branches/xpascal/Languages/xpascal.cs.po
r231 r233 82 82 msgstr "OdejÃt" 83 83 84 #: tformmain.afileopen.caption 85 msgid "Open..." 86 msgstr "OtevÅÃt..." 87 84 88 #: tformmain.ageneratecsharp.caption 85 89 msgid "Generate C#" … … 97 101 msgid "Generate XML" 98 102 msgstr "Generovat XML" 103 104 #: tformmain.applicationinfo1.description 105 msgid "Pascal mutli language transpiler and interpreter" 106 msgstr "VÃce jazykovÃœ paskalovÃœ pÅevadÄÄ zdrojového kódu a interpreter" 99 107 100 108 #: tformmain.arun.caption … … 152 160 msgid "Source:" 153 161 msgstr "Zdroj:" 162 163 #: tokenizer.sexpectedbutfound 164 #, object-pascal-format 165 msgid "Expected %s but %s found." 166 msgstr "OÄekáváno %s, ale nalezeno %s." 167 168 #: tokenizer.sunknowntoken 169 #, object-pascal-format 170 msgid "Unknown token %s" 171 msgstr "NeznámÃœ token %s" 172 173 #: tokenizer.sunsupportedtokenizerstate 174 msgid "Unsupported tokenizer state." 175 msgstr "NepodporovanÃœ stav tokenizeru." -
branches/xpascal/Languages/xpascal.pot
r231 r233 72 72 msgstr "" 73 73 74 #: tformmain.afileopen.caption 75 msgid "Open..." 76 msgstr "" 77 74 78 #: tformmain.ageneratecsharp.caption 75 79 msgid "Generate C#" … … 86 90 #: tformmain.ageneratexml.caption 87 91 msgid "Generate XML" 92 msgstr "" 93 94 #: tformmain.applicationinfo1.description 95 msgid "Pascal mutli language transpiler and interpreter" 88 96 msgstr "" 89 97 … … 143 151 msgstr "" 144 152 153 #: tokenizer.sexpectedbutfound 154 #, object-pascal-format 155 msgid "Expected %s but %s found." 156 msgstr "" 157 158 #: tokenizer.sunknowntoken 159 #, object-pascal-format 160 msgid "Unknown token %s" 161 msgstr "" 162 163 #: tokenizer.sunsupportedtokenizerstate 164 msgid "Unsupported tokenizer state." 165 msgstr "" 166 -
branches/xpascal/Parsers/ParserPascal.pas
r230 r233 14 14 function ParseBeginEnd(Block: TBlock; out BeginEnd: TBeginEnd): Boolean; 15 15 function ParseFunctionCall(Block: TBlock; out FunctionCall: TFunctionCall): Boolean; 16 function ParseProcedureCall(Block: TBlock; out ProcedureCall: TProcedureCall): Boolean; 16 17 function ParseCommand(Block: TBlock; out Command: TCommand): Boolean; 17 18 function ParseProgram(SystemBlock: TBlock; out Prog: TProgram): Boolean; override; … … 20 21 function ParseBlockConst(Block: TBlock): Boolean; 21 22 function ParseFunction(Block: TBlock; out Func: TFunction): Boolean; 23 function ParseFunctionParameters(Block: TBlock; out Params: TFunctionParameters): Boolean; 22 24 function ParseFunctionParameter(Block: TBlock; out Parameter: TFunctionParameter): Boolean; 25 function ParseProcedure(Block: TBlock; out Proc: TProcedure): Boolean; 23 26 function ParseAssignment(Block: TBlock; out Assignment: TAssignment): Boolean; 24 27 function ParseExpression(Block: TBlock; out Expression: TExpression; … … 101 104 end; 102 105 106 function TParserPascal.ParseProcedureCall(Block: TBlock; out 107 ProcedureCall: TProcedureCall): Boolean; 108 var 109 Token: TToken; 110 LastPos: TTokenizerPos; 111 ProcedureDef: TProcedure; 112 Expression: TExpression; 113 I: Integer; 114 begin 115 LastPos := Tokenizer.Pos; 116 Token := Tokenizer.GetNext; 117 if Token.Kind = tkIdentifier then begin 118 ProcedureDef := Block.GetProcedure(Token.Text); 119 if Assigned(ProcedureDef) then begin 120 ProcedureCall := TProcedureCall.Create; 121 ProcedureCall.ProcedureDef := ProcedureDef; 122 if Tokenizer.CheckNextAndRead('(', tkSpecialSymbol) then begin 123 for I := 0 to ProcedureDef.Params.Count - 1 do begin 124 if I > 0 then Tokenizer.Expect(',', tkSpecialSymbol); 125 if ParseExpression(Block, Expression) then begin 126 if Expression.GetType = TFunctionParameter(ProcedureDef.Params[I]).TypeRef then 127 ProcedureCall.Params.Add(Expression) 128 else Error('Function parameter mismatch.'); 129 end else Error('Expected procedure parameter.'); 130 end; 131 Tokenizer.Expect(')', tkSpecialSymbol); 132 end; 133 Result := True; 134 end else begin 135 Result := False; 136 Tokenizer.Pos := LastPos; 137 end; 138 end else begin 139 Result := False; 140 Tokenizer.Pos := LastPos; 141 end; 142 end; 143 103 144 function TParserPascal.ParseCommand(Block: TBlock; out Command: TCommand): Boolean; 104 145 var 105 146 BeginEnd: TBeginEnd; 106 147 FunctionCall: TFunctionCall; 148 ProcedureCall: TProcedureCall; 107 149 Assignment: TAssignment; 108 150 IfThenElse: TIfThenElse; … … 132 174 Result := True; 133 175 Command := FunctionCall; 176 end else 177 if ParseProcedureCall(Block, ProcedureCall) then begin 178 Result := True; 179 Command := ProcedureCall; 134 180 end else 135 181 if ParseRepeatUntil(Block, RepeatUntil) then begin … … 183 229 BeginEnd: TBeginEnd; 184 230 Func: TFunction; 231 Proc: TProcedure; 185 232 begin 186 233 Result := False; … … 195 242 if ParseFunction(Block, Func) then begin 196 243 Block.Functions.Add(Func); 197 end else begin 244 end else 245 if ParseProcedure(Block, Proc) then begin 246 Block.Procedures.Add(Proc); 247 end else 248 begin 198 249 Break; 199 250 end; … … 291 342 var 292 343 Token: TToken; 293 FunctionParameter: TFunctionParameter;294 344 NewBlock: TBlock; 295 345 TypeRef: TType; 296 346 Variable: TVariable; 297 I: Integer;347 FunctionParameters: TFunctionParameters; 298 348 begin 299 349 Result := False; … … 304 354 if Token.Kind = tkIdentifier then begin 305 355 Func.Name := Token.Text; 306 if Tokenizer.CheckNextAndRead('(', tkSpecialSymbol) then begin 307 while not Tokenizer.CheckNext(')', tkSpecialSymbol) do begin 308 if Func.Params.Count > 0 then Tokenizer.Expect(',', tkSpecialSymbol); 309 if ParseFunctionParameter(Block, FunctionParameter) then begin 310 Func.Params.Add(FunctionParameter); 311 end else Error('Expected function parameter.'); 312 end; 313 Tokenizer.Expect(')', tkSpecialSymbol); 314 for I := 0 to Func.Params.Count - 1 do begin 315 Variable := TVariable.Create; 316 Variable.Name := TFunctionParameter(Func.Params[I]).Name; 317 Variable.TypeRef := TFunctionParameter(Func.Params[I]).TypeRef; 318 Variable.Internal := True; 319 Func.Block.Variables.Add(Variable); 320 end; 321 end; 356 Func.Block.ParentBlock := Block; 357 if ParseFunctionParameters(Func.Block, FunctionParameters) then begin 358 Func.Params.Free; 359 Func.Params := FunctionParameters; 360 end; 361 322 362 if Tokenizer.CheckNextAndRead(':', tkSpecialSymbol) then begin 323 363 Token := Tokenizer.GetNext; … … 339 379 end else Error('Expected function block'); 340 380 end else Error('Expected function name'); 381 end; 382 end; 383 384 function TParserPascal.ParseFunctionParameters(Block: TBlock; 385 out Params: TFunctionParameters): Boolean; 386 var 387 FunctionParameter: TFunctionParameter; 388 I: Integer; 389 Variable: TVariable; 390 begin 391 Result := False; 392 Params := TFunctionParameters.Create; 393 if Tokenizer.CheckNextAndRead('(', tkSpecialSymbol) then begin 394 while not Tokenizer.CheckNext(')', tkSpecialSymbol) do begin 395 if Params.Count > 0 then Tokenizer.Expect(',', tkSpecialSymbol); 396 if ParseFunctionParameter(Block, FunctionParameter) then begin 397 Params.Add(FunctionParameter); 398 end else Error('Expected function parameter.'); 399 end; 400 Tokenizer.Expect(')', tkSpecialSymbol); 401 for I := 0 to Params.Count - 1 do begin 402 Variable := TVariable.Create; 403 Variable.Name := Params[I].Name; 404 Variable.TypeRef := Params[I].TypeRef; 405 Variable.Internal := True; 406 Block.Variables.Add(Variable); 407 end; 408 Result := True; 341 409 end; 342 410 end; … … 368 436 end else Error('Expected parameter type'); 369 437 end else Error('Expected parameter name'); 438 end; 439 440 function TParserPascal.ParseProcedure(Block: TBlock; out Proc: TProcedure 441 ): Boolean; 442 var 443 Token: TToken; 444 NewBlock: TBlock; 445 FunctionParameters: TFunctionParameters; 446 begin 447 Result := False; 448 if Tokenizer.CheckNextAndRead('procedure', tkKeyword) then begin 449 Result := True; 450 Proc := TProcedure.Create; 451 Token := Tokenizer.GetNext; 452 if Token.Kind = tkIdentifier then begin 453 Proc.Name := Token.Text; 454 Proc.Block.ParentBlock := Block; 455 if ParseFunctionParameters(Proc.Block, FunctionParameters) then begin 456 Proc.Params.Free; 457 Proc.Params := FunctionParameters; 458 end; 459 460 Tokenizer.Expect(';', tkSpecialSymbol); 461 if ParseBlock(Block, NewBlock, Proc.Block) then begin 462 Tokenizer.Expect(';', tkSpecialSymbol); 463 end else Error('Expected procedure block'); 464 end else Error('Expected procedure name'); 465 end; 370 466 end; 371 467 -
branches/xpascal/Source.pas
r232 r233 148 148 end; 149 149 150 { TProcedure } 151 152 TProcedure = class(TSourceNode) 153 protected 154 function GetFieldsCount: Integer; override; 155 public 156 Name: string; 157 InternalName: string; 158 Params: TFunctionParameters; 159 Block: TBlock; 160 ParentType: TType; 161 procedure GetValue(Index: Integer; out Value); override; 162 function GetField(Index: Integer): TField; override; 163 procedure SetValue(Index: Integer; var Value); override; 164 constructor Create; 165 destructor Destroy; override; 166 end; 167 168 { TProcedures } 169 170 TProcedures = class(TSourceNodeList<TProcedure>) 171 ParentType: TType; 172 function SearchByName(Name: string): TProcedure; 173 function AddNew(Name: string): TProcedure; 174 end; 175 150 176 TCommand = class(TSourceNode) 151 177 end; … … 164 190 public 165 191 FunctionDef: TFunction; 192 Params: TExpressions; 193 procedure GetValue(Index: Integer; out Value); override; 194 function GetField(Index: Integer): TField; override; 195 procedure SetValue(Index: Integer; var Value); override; 196 constructor Create; 197 destructor Destroy; override; 198 end; 199 200 { TProcedureCall } 201 202 TProcedureCall = class(TCommand) 203 protected 204 function GetFieldsCount: Integer; override; 205 public 206 ProcedureDef: TProcedure; 166 207 Params: TExpressions; 167 208 procedure GetValue(Index: Integer; out Value); override; … … 365 406 Constants: TConstants; 366 407 Functions: TFunctions; 408 Procedures: TProcedures; 367 409 Types: TTypes; 368 410 BeginEnd: TBeginEnd; … … 375 417 function GetVariable(Name: string): TVariable; 376 418 function GetFunction(Name: string): TFunction; 419 function GetProcedure(Name: string): TProcedure; 377 420 constructor Create; 378 421 destructor Destroy; override; … … 426 469 end; 427 470 471 { TProcedureCall } 472 473 function TProcedureCall.GetFieldsCount: Integer; 474 begin 475 Result := 2; 476 end; 477 478 procedure TProcedureCall.GetValue(Index: Integer; out Value); 479 begin 480 if Index = 0 then TProcedure(Value) := ProcedureDef 481 else if Index = 1 then TExpressions(Value) := Params 482 else inherited; 483 end; 484 485 function TProcedureCall.GetField(Index: Integer): TField; 486 begin 487 if Index = 0 then Result := TField.Create(dtObject, 'Procedure') 488 else if Index = 1 then Result := TField.Create(dtObject, 'Parameters') 489 else inherited; 490 end; 491 492 procedure TProcedureCall.SetValue(Index: Integer; var Value); 493 begin 494 if Index = 0 then ProcedureDef := TProcedure(Value) 495 else if Index = 1 then Params := TExpressions(Value) 496 else inherited; 497 end; 498 499 constructor TProcedureCall.Create; 500 begin 501 Params := TExpressions.Create; 502 end; 503 504 destructor TProcedureCall.Destroy; 505 begin 506 FreeAndNil(Params); 507 inherited; 508 end; 509 510 { TProcedure } 511 512 function TProcedures.SearchByName(Name: string): TProcedure; 513 var 514 I: Integer; 515 begin 516 I := 0; 517 while (I < Count) and (TProcedure(Items[I]).Name <> Name) do Inc(I); 518 if I < Count then Result := TProcedure(Items[I]) 519 else Result := nil; 520 end; 521 522 function TProcedures.AddNew(Name: string): TProcedure; 523 begin 524 Result := TProcedure.Create; 525 Result.Name := Name; 526 Result.ParentType := ParentType; 527 Add(Result); 528 end; 529 530 function TProcedure.GetFieldsCount: Integer; 531 begin 532 Result := 3; 533 end; 534 535 procedure TProcedure.GetValue(Index: Integer; out Value); 536 begin 537 if Index = 0 then TBlock(Value) := Block 538 else if Index = 1 then TFunctionParameters(Value) := Params 539 else if Index = 2 then string(Value) := Name 540 else inherited; 541 end; 542 543 function TProcedure.GetField(Index: Integer): TField; 544 begin 545 if Index = 0 then Result := TField.Create(dtObject, 'Block') 546 else if Index = 1 then Result := TField.Create(dtList, 'Parameters') 547 else if Index = 2 then Result := TField.Create(dtString, 'Name') 548 else inherited; 549 end; 550 551 procedure TProcedure.SetValue(Index: Integer; var Value); 552 begin 553 if Index = 0 then Block := TBlock(Value) 554 else if Index = 1 then Params := TFunctionParameters(Value) 555 else if Index = 2 then Name := string(Value) 556 else inherited; 557 end; 558 559 constructor TProcedure.Create; 560 begin 561 Params := TFunctionParameters.Create; 562 Block := TBlock.Create; 563 end; 564 565 destructor TProcedure.Destroy; 566 begin 567 FreeAndNil(Block); 568 FreeAndNil(Params); 569 inherited; 570 end; 571 428 572 { TExpressionBrackets } 429 573 … … 771 915 if Index = 0 then TBlock(Value) := Block 772 916 else if Index = 1 then TFunctionParameters(Value) := Params 773 else if Index = 2 then TType(Value) := ResultType774 else if Index = 3 then string(Value) := Name917 else if Index = 2 then string(Value) := Name 918 else if Index = 3 then TType(Value) := ResultType 775 919 else inherited; 776 920 end; … … 780 924 if Index = 0 then Result := TField.Create(dtObject, 'Block') 781 925 else if Index = 1 then Result := TField.Create(dtList, 'Parameters') 782 else if Index = 2 then Result := TField.Create(dt Object, 'ResultType')783 else if Index = 3 then Result := TField.Create(dt String, 'Name')926 else if Index = 2 then Result := TField.Create(dtString, 'Name') 927 else if Index = 3 then Result := TField.Create(dtObject, 'ResultType') 784 928 else inherited; 785 929 end; … … 794 938 if Index = 0 then Block := TBlock(Value) 795 939 else if Index = 1 then Params := TFunctionParameters(Value) 796 else if Index = 2 then ResultType := TType(Value)797 else if Index = 3 then Name := string(Value)940 else if Index = 2 then Name := string(Value) 941 else if Index = 3 then ResultType := TType(Value) 798 942 else inherited; 799 943 end; … … 1052 1196 begin 1053 1197 if Index = 0 then Result := TField.Create(dtObject, 'Function') 1054 else if Index = 1 then Result := TField.Create(dt Object, 'Parameters')1198 else if Index = 1 then Result := TField.Create(dtList, 'Parameters') 1055 1199 else inherited; 1056 1200 end; … … 1139 1283 else if Index = 3 then TConstants(Value) := Constants 1140 1284 else if Index = 4 then TFunctions(Value) := Functions 1285 else if Index = 5 then TProcedures(Value) := Procedures 1141 1286 else inherited; 1142 1287 end; … … 1144 1289 function TBlock.GetField(Index: Integer): TField; 1145 1290 begin 1146 if Index = 0 then Result := TField.Create(dtObject, 'B lock')1291 if Index = 0 then Result := TField.Create(dtObject, 'BeginEnd') 1147 1292 else if Index = 1 then Result := TField.Create(dtList, 'Types') 1148 1293 else if Index = 2 then Result := TField.Create(dtList, 'Variables') 1149 1294 else if Index = 3 then Result := TField.Create(dtList, 'Constants') 1150 1295 else if Index = 4 then Result := TField.Create(dtList, 'Functions') 1296 else if Index = 5 then Result := TField.Create(dtList, 'Procedures') 1151 1297 else inherited; 1152 1298 end; … … 1154 1300 function TBlock.GetFieldsCount: Integer; 1155 1301 begin 1156 Result := 5;1302 Result := 6; 1157 1303 end; 1158 1304 … … 1164 1310 else if Index = 3 then Constants := TConstants(Value) 1165 1311 else if Index = 4 then Functions := TFunctions(Value) 1312 else if Index = 5 then Procedures := TProcedures(Value) 1166 1313 else inherited; 1167 1314 end; … … 1170 1317 begin 1171 1318 Functions.Clear; 1319 Procedures.Clear; 1172 1320 Constants.Clear; 1173 1321 Variables.Clear; … … 1201 1349 if not Assigned(Result) and Assigned(ParentBlock) then 1202 1350 Result := ParentBlock.GetFunction(Name); 1351 end; 1352 1353 function TBlock.GetProcedure(Name: string): TProcedure; 1354 begin 1355 Result := Procedures.SearchByName(Name); 1356 if not Assigned(Result) and Assigned(ParentBlock) then 1357 Result := ParentBlock.GetProcedure(Name); 1203 1358 end; 1204 1359 … … 1211 1366 Functions := TFunctions.Create; 1212 1367 Functions.Parent := Self; 1368 Procedures := TProcedures.Create; 1369 Procedures.Parent := Self; 1213 1370 Types := TTypes.Create; 1214 1371 Types.Parent := Self; … … 1224 1381 FreeAndNil(Constants); 1225 1382 FreeAndNil(Functions); 1383 FreeAndNil(Procedures); 1226 1384 inherited; 1227 1385 end; … … 1237 1395 function TBeginEnd.GetField(Index: Integer): TField; 1238 1396 begin 1239 if Index = 0 then Result := TField.Create(dtList, 'Command ')1397 if Index = 0 then Result := TField.Create(dtList, 'Commands') 1240 1398 else inherited; 1241 1399 end; -
branches/xpascal/Tests.pas
r230 r233 158 158 ExpectedOutput := '-1' + LineEnding + '0' + LineEnding; 159 159 end; 160 with TTestRun(Result.AddNew('procedure', TTestRun)) do begin 161 Source.Add('procedure Print(Text: string);'); 162 Source.Add('begin'); 163 Source.Add(' WriteLn(Text);'); 164 Source.Add('end;'); 165 Source.Add(''); 166 Source.Add('begin'); 167 Source.Add(' Print(''Test'');'); 168 Source.Add('end.'); 169 ExpectedOutput := 'Test' + LineEnding; 170 end; 171 with TTestRun(Result.AddNew('procedure var parameter', TTestRun)) do begin 172 Source.Add('procedure Test(var A: Integer);'); 173 Source.Add('begin'); 174 Source.Add(' A := 10;'); 175 Source.Add('end;'); 176 Source.Add(''); 177 Source.Add('var'); 178 Source.Add(' B: Integer;'); 179 Source.Add('begin'); 180 Source.Add(' B := 1;'); 181 Source.Add(' Test(B);'); 182 Source.Add(' WriteLn(IntToStr(B));'); 183 Source.Add('end.'); 184 ExpectedOutput := '10' + LineEnding; 185 end; 186 with TTestRun(Result.AddNew('Single line comment', TTestRun)) do begin 187 Source.Add('begin'); 188 Source.Add(' // WriteLn(''Test'');'); 189 Source.Add('end.'); 190 ExpectedOutput := ''; 191 end; 160 192 end; 161 193 … … 169 201 procedure TTestRun.InterpreterError(Pos: TPoint; Text: string); 170 202 begin 171 Error := Error + Text;203 Error := Error + '[' + IntToStr(Pos.X) + ', ' + IntToStr(Pos.Y) + '] ' + Text + LineEnding; 172 204 end; 173 205 -
branches/xpascal/Tokenizer.pas
r224 r233 62 62 implementation 63 63 64 resourcestring 65 SUnknownToken = 'Unknown token %s'; 66 SUnsupportedTokenizerState = 'Unsupported tokenizer state.'; 67 SExpectedButFound = 'Expected %s but %s found.'; 68 64 69 { TToken } 65 70 … … 155 160 (Text = 'else') or (Text = 'while') or (Text = 'do') or (Text = 'for') or 156 161 (Text = 'to') or (Text = 'repeat') or (Text = 'until') or (Text = 'break') or 157 (Text = 'continue') or (Text = 'function') ;162 (Text = 'continue') or (Text = 'function') or (Text = 'procedure'); 158 163 end; 159 164 … … 203 208 Pos.Increment; 204 209 end else begin 205 Error( 'Unknown token ' + C);210 Error(Format(SUnknownToken, [C])); 206 211 Break; 207 212 end; … … 260 265 end; 261 266 end else 262 raise Exception.Create( 'Unsupported tokenizer state.');267 raise Exception.Create(SUnsupportedTokenizerState); 263 268 end; 264 269 end; … … 314 319 Token := GetNext; 315 320 if (Token.Text <> Text) or (Token.Kind <> Kind) then 316 Error( 'Expected ' + Text + ' but ' + Token.Text + ' found.');321 Error(Format(SExpectedButFound, [Text, Token.Text])); 317 322 end; 318 323
Note:
See TracChangeset
for help on using the changeset viewer.