Changeset 233 for branches/xpascal

Timestamp:

Jun 26, 2023, 6:08:23 PM (17 months ago)

Author:

chronos

Message:

• Added: Support for procedures.
• Added: Project pascal file can be opened from main menu. Last file name is remembered.
• Modified: Improved XML output of source structure.

Location:

branches/xpascal

Files:

• Examples/Example.pas (modified) (1 diff)
• Executor.pas (modified) (10 diffs)
• Forms/FormMain.lfm (modified) (3 diffs)
• Forms/FormMain.lrj (modified) (1 diff)
• Forms/FormMain.pas (modified) (14 diffs)
• Generators/GeneratorCSharp.pas (modified) (2 diffs)
• Generators/GeneratorXml.pas (modified) (5 diffs)
• Languages/xpascal.cs.po (modified) (3 diffs)
• Languages/xpascal.pot (modified) (3 diffs)
• Parsers/ParserPascal.pas (modified) (10 diffs)
• Source.pas (modified) (18 diffs)
• Tests.pas (modified) (2 diffs)
• Tokenizer.pas (modified) (5 diffs)

branches/xpascal/Examples/Example.pas

@@ -14 +14 @@
 end;
 
+procedure Print(Text: string);
 begin
+  WriteLn(Text);
+end;
+
+begin
+  Print('Test');
+
   WriteLn('10 * 3 = ' + IntToStr((1 + 2) * (3 + 4)));
 

branches/xpascal/Executor.pas

@@ -71 +71 @@
   end;
 
+  { TExecutorProcedure }
+
+  TExecutorProcedure = class
+    ProcedureDef: TProcedure;
+    Block: TExecutorBlock;
+    Callback: TExecutorFunctionCallback;
+    constructor Create;
+    destructor Destroy; override;
+  end;
+
+  { TExecutorProcedures }
+
+  TExecutorProcedures = class(TObjectList<TExecutorProcedure>)
+    function SearchByProcedure(ProcedureDef: TProcedure): TExecutorProcedure;
+    function AddNew(ProcedureDef: TProcedure): TExecutorProcedure;
+  end;
+
   { TExecutorBlock }
 
@@ -78 +95 @@
     Variables: TExecutorVariables;
     Functions: TExecutorFunctions;
+    Procedures: TExecutorProcedures;
     function GetFunction(FunctionDef: TFunction): TExecutorFunction;
+    function GetProcedure(ProcedureDef: TProcedure): TExecutorProcedure;
     function GetType(TypeDef: TType): TExecutorType;
     function GetVariable(Variable: TVariable): TExecutorVariable;
@@ -144 +163 @@
     procedure ExecuteBlock(ParentBlock: TExecutorBlock; Block: TBlock; ExistingBlock: TExecutorBlock = nil);
     function ExecuteFunctionCall(Block: TExecutorBlock; FunctionCall: TFunctionCall): TValue;
+    function ExecuteProcedureCall(Block: TExecutorBlock; ProcedureCall: TProcedureCall): TValue;
     procedure ExecuteAssignment(Block: TExecutorBlock; Assignment: TAssignment);
     function ExecuteExpression(Block: TExecutorBlock; Expression: TExpression): TValue;
@@ -167 +187 @@
   SExpectedBooleanValue = 'Expected boolean value.';
 
+{ TExecutorProcedures }
+
+function TExecutorProcedures.SearchByProcedure(ProcedureDef: TProcedure
+  ): TExecutorProcedure;
+var
+  I: Integer;
+begin
+  I := 0;
+  while (I < Count) and (TExecutorProcedure(Items[I]).ProcedureDef <> ProcedureDef) do Inc(I);
+  if I < Count then Result := TExecutorProcedure(Items[I])
+    else Result := nil;
+end;
+
+function TExecutorProcedures.AddNew(ProcedureDef: TProcedure
+  ): TExecutorProcedure;
+begin
+  Result := TExecutorProcedure.Create;
+  Result.ProcedureDef := ProcedureDef;
+  Add(Result);
+end;
+
+{ TExecutorProcedure }
+
+constructor TExecutorProcedure.Create;
+begin
+  Block := TExecutorBlock.Create;
+end;
+
+destructor TExecutorProcedure.Destroy;
+begin
+  FreeAndNil(Block);
+  inherited;
+end;
+
 { TExecutorFunctionCallbackParam }
 
@@ -281 +335 @@
 end;
 
+function TExecutorBlock.GetProcedure(ProcedureDef: TProcedure
+  ): TExecutorProcedure;
+begin
+  Result := Procedures.SearchByProcedure(ProcedureDef);
+  if not Assigned(Result) and Assigned(Parent) then
+    Result := Parent.GetProcedure(ProcedureDef);
+end;
+
 function TExecutorBlock.GetType(TypeDef: TType): TExecutorType;
 begin
@@ -315 +377 @@
   Variables := TExecutorVariables.Create;
   Functions := TExecutorFunctions.Create;
+  Procedures := TExecutorProcedures.Create;
 end;
 
@@ -321 +384 @@
   FreeAndNil(Variables);
   FreeAndNil(Functions);
+  FreeAndNil(Procedures);
   FreeAndNil(Types);
   inherited;
@@ -703 +767 @@
 begin
   for I := 0 to BeginEnd.Commands.Count - 1 do
-    ExecuteCommand(Block, TCommand(BeginEnd.Commands[I]));
+    ExecuteCommand(Block, BeginEnd.Commands[I]);
 end;
 
@@ -710 +774 @@
   if Command is TBeginEnd then ExecuteBeginEnd(Block, TBeginEnd(Command))
   else if Command is TFunctionCall then ExecuteFunctionCall(Block, TFunctionCall(Command))
+  else if Command is TProcedureCall then ExecuteProcedureCall(Block, TProcedureCall(Command))
   else if Command is TAssignment then ExecuteAssignment(Block, TAssignment(Command))
   else if Command is TIfThenElse then ExecuteIfThenElse(Block, TIfThenElse(Command))
@@ -899 +964 @@
 end;
 
+function TExecutor.ExecuteProcedureCall(Block: TExecutorBlock;
+  ProcedureCall: TProcedureCall): TValue;
+var
+  ExecutorProcedure: TExecutorProcedure;
+  Params: array of TExecutorFunctionCallbackParam;
+  I: Integer;
+  ExecutorVariable: TExecutorVariable;
+  Variable: TVariable;
+begin
+  Result := nil;
+  ExecutorProcedure := Block.GetProcedure(ProcedureCall.ProcedureDef);
+  if Assigned(ExecutorProcedure) then begin
+    if ProcedureCall.ProcedureDef.InternalName <> '' then begin
+      SetLength(Params, ProcedureCall.Params.Count);
+      for I := 0 to ProcedureCall.Params.Count - 1 do begin
+        Params[I] := TExecutorFunctionCallbackParam.Create;
+        Params[I].Kind := ProcedureCall.ProcedureDef.Params[I].Kind;
+        if ProcedureCall.ProcedureDef.Params[I].Kind = pkVar then begin
+          Variable := TExpressionOperand(ProcedureCall.Params[I]).VariableRef;
+          //InitExecutorBlock(ExecutorFunction.Block, FunctionCall.FunctionDef.Block);
+          ExecutorVariable := Block.GetVariable(Variable);
+          Params[I].Variable := ExecutorVariable;
+        end
+        else Params[I].Value := ExecuteExpression(Block, ProcedureCall.Params[I]);
+      end;
+      Result := ExecutorProcedure.Callback(Params);
+      for I := 0 to ProcedureCall.Params.Count - 1 do begin
+        //if FunctionCall.Params[I].
+        Params[I].Free;
+      end;
+    end else begin
+      InitExecutorBlock(ExecutorProcedure.Block, ProcedureCall.ProcedureDef.Block);
+      for I := 0 to ProcedureCall.Params.Count - 1 do begin
+        Variable := ProcedureCall.ProcedureDef.Block.Variables.SearchByName(
+          TFunctionParameter(ProcedureCall.ProcedureDef.Params[I]).Name);
+        ExecutorVariable := ExecutorProcedure.Block.Variables.SearchByVariable(Variable);
+        ExecutorVariable.Value.Free;
+        ExecutorVariable.Value := ExecuteExpression(Block, TExpression(ProcedureCall.Params[I]));
+      end;
+      ExecuteBlock(Block, ProcedureCall.ProcedureDef.Block, ExecutorProcedure.Block);
+      ExecutorVariable := ExecutorProcedure.Block.Variables.SearchByVariable(
+        TVariable(ProcedureCall.ProcedureDef.Block.Variables.SearchByName('Result')));
+      Result := ExecutorVariable.Value.Clone;
+    end;
+  end else raise Exception.Create('No executor for ' + ProcedureCall.ProcedureDef.Name + ' function.');
+end;
+
 procedure TExecutor.ExecuteAssignment(Block: TExecutorBlock;
   Assignment: TAssignment);

branches/xpascal/Forms/FormMain.lfm

@@ -10 +10 @@
   Menu = MainMenu1
   OnActivate = FormActivate
+  OnClose = FormClose
   OnCreate = FormCreate
   OnDestroy = FormDestroy
@@ -49 +50 @@
   object MainMenu1: TMainMenu
     Left = 744
-    Top = 760
+    Top = 759
     object MenuItemFile: TMenuItem
       Caption = 'File'
+      object MenuItem10: TMenuItem
+        Action = AFileOpen
+      end
       object MenuItem6: TMenuItem
         Action = AExit
@@ -129 +133 @@
       OnExecute = AConsoleExecute
     end
+    object AFileOpen: TAction
+      Caption = 'Open...'
+      OnExecute = AFileOpenExecute
+    end
+  end
+  object OpenDialog1: TOpenDialog
+    DefaultExt = '.pas'
+    Filter = 'Pascal file (.pas)|*.pas|Any file|*.*'
+    Left = 536
+    Top = 759
+  end
+  object ApplicationInfo1: TApplicationInfo
+    Identification = 1
+    VersionMajor = 1
+    VersionMinor = 0
+    VersionBugFix = 0
+    AuthorsName = 'Chronosoft'
+    EmailContact = 'robie@centrum.cz'
+    AppName = 'xPascal'
+    Description = 'Pascal mutli language transpiler and interpreter'
+    RegistryKey = '\Software\xpascal'
+    RegistryRoot = rrKeyCurrentUser
+    License = 'CC0'
+    Left = 348
+    Top = 274
   end
 end

branches/xpascal/Forms/FormMain.lrj

@@ -13 +13 @@
 {"hash":209392028,"name":"tformmain.ageneratexml.caption","sourcebytes":[71,101,110,101,114,97,116,101,32,88,77,76],"value":"Generate XML"},
 {"hash":371876,"name":"tformmain.atest.caption","sourcebytes":[84,101,115,116],"value":"Test"},
-{"hash":174433893,"name":"tformmain.aconsole.caption","sourcebytes":[67,111,110,115,111,108,101],"value":"Console"}
+{"hash":174433893,"name":"tformmain.aconsole.caption","sourcebytes":[67,111,110,115,111,108,101],"value":"Console"},
+{"hash":107745630,"name":"tformmain.afileopen.caption","sourcebytes":[79,112,101,110,46,46,46],"value":"Open..."},
+{"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"}
 ]}

branches/xpascal/Forms/FormMain.pas

@@ -4 +4 @@
 
 uses
-  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, Menus,
-  ActnList, ExtCtrls, SynHighlighterPas, SynEdit, Source, Optimizer,
-  Generator, FormSource, FormMessages, FormOutput, FormConsole, FormEx;
+  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, Menus, LazFileUtils,
+  ActnList, ExtCtrls, SynHighlighterPas, SynEdit, Source, Optimizer, RegistryEx,
+  Generator, FormSource, FormMessages, FormOutput, FormConsole, FormEx,
+  ApplicationInfo;
 
 type
@@ -15 +16 @@
     ACompile: TAction;
     AConsole: TAction;
+    AFileOpen: TAction;
+    ApplicationInfo1: TApplicationInfo;
     ATest: TAction;
     AGenerateXml: TAction;
@@ -25 +28 @@
     MainMenu1: TMainMenu;
     MenuItem1: TMenuItem;
+    MenuItem10: TMenuItem;
     MenuItem2: TMenuItem;
     MenuItem3: TMenuItem;
@@ -36 +40 @@
     MenuItemGenerate: TMenuItem;
     MenuItemFile: TMenuItem;
+    OpenDialog1: TOpenDialog;
     PanelOutput: TPanel;
     PanelSource: TPanel;
@@ -43 +48 @@
     procedure AConsoleExecute(Sender: TObject);
     procedure AExitExecute(Sender: TObject);
+    procedure AFileOpenExecute(Sender: TObject);
     procedure AGenerateCSharpExecute(Sender: TObject);
     procedure AGeneratePascalExecute(Sender: TObject);
@@ -51 +57 @@
     procedure ARunExecute(Sender: TObject);
     procedure FormActivate(Sender: TObject);
+    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure FormShow(Sender: TObject);
   private
+    LastFileName: string;
     Prog: TProgram;
     Initialized: Boolean;
@@ -61 +69 @@
     FormOutput: TFormOutput;
     FormConsole: TFormConsole;
+    procedure LoadFromRegistry;
+    procedure SaveToRegistry;
+    procedure ProjectOpen(FileName: string);
     procedure Generate(GeneratorClass: TGeneratorClass);
     procedure ExecutorOutput(Text: string);
@@ -87 +98 @@
   if not Initialized then begin
     Initialized := True;
-    FormSource.SynEditSource.Lines.LoadFromFile('Examples' + DirectorySeparator +
-      'Example.pas');
-    ARun.Execute;
+    ProjectOpen(LastFileName);
+    //ARun.Execute;
   end;
 end;
@@ -104 +114 @@
 procedure TFormMain.FormShow(Sender: TObject);
 begin
+  LoadFromRegistry;
   FormMessages := TFormMessages.Create(nil);
   FormMessages.Show;
@@ -119 +130 @@
 end;
 
+procedure TFormMain.LoadFromRegistry;
+begin
+  with TRegistryEx.Create do
+  try
+    CurrentContext := ApplicationInfo1.GetRegistryContext;
+    LastFileName := ReadStringWithDefault('LastFileName', 'Examples' + DirectorySeparator + 'Example.pas');
+  finally
+    Free;
+  end;
+end;
+
+procedure TFormMain.SaveToRegistry;
+begin
+  with TRegistryEx.Create do
+  try
+    CurrentContext := ApplicationInfo1.GetRegistryContext;
+    WriteString('LastFileName', LastFileName);
+  finally
+    Free;
+  end;
+end;
+
+procedure TFormMain.ProjectOpen(FileName: string);
+begin
+  LastFileName := FileName;
+  FormSource.SynEditSource.Lines.LoadFromFile(FileName);
+end;
+
 procedure TFormMain.Generate(GeneratorClass: TGeneratorClass);
 var
@@ -130 +169 @@
     FormOutput.SetText(Generator.Output);
     TargetFileName := 'Generated' + DirectorySeparator +
-      Generator.Name + DirectorySeparator + 'Example' + Generator.FileExt;
+      Generator.Name + DirectorySeparator + ExtractFileNameOnly(LastFileName) + Generator.FileExt;
     ForceDirectories(ExtractFileDir(TargetFileName));
     FormOutput.SynEditOutput.Lines.SaveToFile(TargetFileName);
@@ -141 +180 @@
 begin
   Close;
+end;
+
+procedure TFormMain.AFileOpenExecute(Sender: TObject);
+begin
+  OpenDialog1.InitialDir := ExtractFileDir(LastFileName);
+  OpenDialog1.FileName := ExtractFileName(LastFileName);
+  if OpenDialog1.Execute then begin
+    ProjectOpen(OpenDialog1.FileName);
+  end;
 end;
 
@@ -224 +272 @@
 end;
 
+procedure TFormMain.FormClose(Sender: TObject; var CloseAction: TCloseAction);
+begin
+  FormConsole.Terminated := True;
+  SaveToRegistry;
+end;
+
 procedure TFormMain.FormCreate(Sender: TObject);
 begin
@@ -248 +302 @@
 begin
   ACompile.Execute;
-  FormOutput.SynEditOutput.Highlighter := nil;
-  FormOutput.SynEditOutput.Lines.Clear;
+  FormConsole.Memo1.Lines.Clear;
   if Assigned(Prog) then begin
     Executor := TExecutor.Create;

branches/xpascal/Generators/GeneratorCSharp.pas

@@ -227 +227 @@
 
 procedure TGeneratorCSharp.GenerateProgram(Block: TBlock; Prog: TProgram);
-begin
+var
+  MainClass: string;
+begin
+  if Prog.Name <> '' then MainClass := Prog.Name
+    else MainClass := 'App';
   AddTextLine('using System;');
   AddTextLine;
-  AddTextLine('public class ' + Prog.Name);
+  AddTextLine('public class ' + MainClass);
   AddTextLine('{');
   Indent := Indent + 1;
@@ -237 +241 @@
   AddTextLine('public static void Main()');
   AddTextLine('{');
-  AddTextLine('  ' + Prog.Name + ' app = new ' + Prog.Name + '();');
+  AddTextLine('  ' + MainClass + ' app = new ' + MainClass + '();');
   AddTextLine('  app.Entry();');
   AddTextLine('}');

branches/xpascal/Generators/GeneratorXml.pas

@@ -11 +11 @@
   TGeneratorXml = class(TGenerator)
   private
-    procedure GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>);
-    procedure GenerateNode(SourceNode: TSourceNode);
+    procedure GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>;
+      NodeName: string);
+    procedure GenerateNode(SourceNode: TSourceNode; NodeName: string);
   public
     procedure Generate; override;
@@ -26 +27 @@
 { TGeneratorXml }
 
-procedure TGeneratorXml.GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>);
+procedure TGeneratorXml.GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>;
+  NodeName: string);
 var
   I: Integer;
@@ -32 +34 @@
   for I := 0 to SourceNodes.Count - 1 do begin
     if SourceNodes[I] is TSourceNode then begin
-      GenerateNode(TSourceNode(SourceNodes[I]));
+      GenerateNode(TSourceNode(SourceNodes[I]), NodeName);
     end else raise Exception.Create(SUnsupportedNodeType);
   end;
 end;
 
-procedure TGeneratorXml.GenerateNode(SourceNode: TSourceNode);
+procedure TGeneratorXml.GenerateNode(SourceNode: TSourceNode; NodeName: string);
 var
   I: Integer;
@@ -45 +47 @@
 begin
   if SourceNode is TSourceNode then begin
-    AddTextLine('<' + SourceNode.ClassName + '>');
+    AddTextLine('<' + NodeName + '>');
     Indent := Indent + 1;
     for I := 0 to SourceNode.FieldsCount - 1 do begin
       Field := SourceNode.GetField(I);
-      if Field.DataType = dtObject then begin
-        Obj := SourceNode.GetValueObject(I);
-        if Obj is TSourceNode then
-          GenerateNode(TSourceNode(Obj));
-      end else
-      if Field.DataType = dtList then begin
-        SourceNode.GetValue(I, List);
-        GenerateNodes(List);
-      end else
-      if Field.DataType = dtString then begin
-        AddTextLine('<' + Field.Name + '>' + SourceNode.GetValueString(I) + '<' + Field.Name + '>');
+      try
+        if Field.DataType = dtObject then begin
+          Obj := SourceNode.GetValueObject(I);
+          if Obj is TSourceNode then
+            GenerateNode(TSourceNode(Obj), Field.Name);
+        end else
+        if Field.DataType = dtList then begin
+          SourceNode.GetValue(I, List);
+          if List.Count > 0 then
+            GenerateNodes(List, Field.Name);
+        end else
+        if Field.DataType = dtString then begin
+          if SourceNode.GetValueString(I) <> '' then
+            AddTextLine('<' + Field.Name + '>' + SourceNode.GetValueString(I) +
+              '</' + Field.Name + '>');
+        end;
+      finally
+        Field.Free;
       end;
-      Field.Free;
     end;
     Indent := Indent - 1;
-    AddTextLine('</' + SourceNode.ClassName + '>');
+    AddTextLine('</' + NodeName + '>');
   end else
     raise Exception.Create(SUnsupportedNodeType);
@@ -71 +79 @@
 procedure TGeneratorXml.Generate;
 begin
-  GenerateNode(Prog);
+  AddTextLine('<?xml version="1.0" encoding="UTF-8"?>');
+  GenerateNode(Prog, 'Program');
 end;
 

branches/xpascal/Languages/xpascal.cs.po

@@ -82 +82 @@
 msgstr "Odejít"
 
+#: tformmain.afileopen.caption
+msgid "Open..."
+msgstr "Otevřít..."
+
 #: tformmain.ageneratecsharp.caption
 msgid "Generate C#"
@@ -97 +101 @@
 msgid "Generate XML"
 msgstr "Generovat XML"
+
+#: tformmain.applicationinfo1.description
+msgid "Pascal mutli language transpiler and interpreter"
+msgstr "Více jazykovÃœ paskalovÃœ převaděč zdrojového kódu a interpreter"
 
 #: tformmain.arun.caption
@@ -152 +160 @@
 msgid "Source:"
 msgstr "Zdroj:"
+
+#: tokenizer.sexpectedbutfound
+#, object-pascal-format
+msgid "Expected %s but %s found."
+msgstr "Očekáváno %s, ale nalezeno %s."
+
+#: tokenizer.sunknowntoken
+#, object-pascal-format
+msgid "Unknown token %s"
+msgstr "NeznámÜ token %s"
+
+#: tokenizer.sunsupportedtokenizerstate
+msgid "Unsupported tokenizer state."
+msgstr "NepodporovanÜ stav tokenizeru."

branches/xpascal/Languages/xpascal.pot

@@ -72 +72 @@
 msgstr ""
 
+#: tformmain.afileopen.caption
+msgid "Open..."
+msgstr ""
+
 #: tformmain.ageneratecsharp.caption
 msgid "Generate C#"
@@ -86 +90 @@
 #: tformmain.ageneratexml.caption
 msgid "Generate XML"
+msgstr ""
+
+#: tformmain.applicationinfo1.description
+msgid "Pascal mutli language transpiler and interpreter"
 msgstr ""
 
@@ -143 +151 @@
 msgstr ""
 
+#: tokenizer.sexpectedbutfound
+#, object-pascal-format
+msgid "Expected %s but %s found."
+msgstr ""
+
+#: tokenizer.sunknowntoken
+#, object-pascal-format
+msgid "Unknown token %s"
+msgstr ""
+
+#: tokenizer.sunsupportedtokenizerstate
+msgid "Unsupported tokenizer state."
+msgstr ""
+

branches/xpascal/Parsers/ParserPascal.pas

@@ -14 +14 @@
     function ParseBeginEnd(Block: TBlock; out BeginEnd: TBeginEnd): Boolean;
     function ParseFunctionCall(Block: TBlock; out FunctionCall: TFunctionCall): Boolean;
+    function ParseProcedureCall(Block: TBlock; out ProcedureCall: TProcedureCall): Boolean;
     function ParseCommand(Block: TBlock; out Command: TCommand): Boolean;
     function ParseProgram(SystemBlock: TBlock; out Prog: TProgram): Boolean; override;
@@ -20 +21 @@
     function ParseBlockConst(Block: TBlock): Boolean;
     function ParseFunction(Block: TBlock; out Func: TFunction): Boolean;
+    function ParseFunctionParameters(Block: TBlock; out Params: TFunctionParameters): Boolean;
     function ParseFunctionParameter(Block: TBlock; out Parameter: TFunctionParameter): Boolean;
+    function ParseProcedure(Block: TBlock; out Proc: TProcedure): Boolean;
     function ParseAssignment(Block: TBlock; out Assignment: TAssignment): Boolean;
     function ParseExpression(Block: TBlock; out Expression: TExpression;
@@ -101 +104 @@
 end;
 
+function TParserPascal.ParseProcedureCall(Block: TBlock; out
+  ProcedureCall: TProcedureCall): Boolean;
+var
+  Token: TToken;
+  LastPos: TTokenizerPos;
+  ProcedureDef: TProcedure;
+  Expression: TExpression;
+  I: Integer;
+begin
+  LastPos := Tokenizer.Pos;
+  Token := Tokenizer.GetNext;
+  if Token.Kind = tkIdentifier then begin
+    ProcedureDef := Block.GetProcedure(Token.Text);
+    if Assigned(ProcedureDef) then begin
+      ProcedureCall := TProcedureCall.Create;
+      ProcedureCall.ProcedureDef := ProcedureDef;
+      if Tokenizer.CheckNextAndRead('(', tkSpecialSymbol) then begin
+        for I := 0 to ProcedureDef.Params.Count - 1 do begin
+          if I > 0 then Tokenizer.Expect(',', tkSpecialSymbol);
+          if ParseExpression(Block, Expression) then begin
+            if Expression.GetType = TFunctionParameter(ProcedureDef.Params[I]).TypeRef then
+              ProcedureCall.Params.Add(Expression)
+              else Error('Function parameter mismatch.');
+          end else Error('Expected procedure parameter.');
+        end;
+        Tokenizer.Expect(')', tkSpecialSymbol);
+      end;
+      Result := True;
+    end else begin
+      Result := False;
+      Tokenizer.Pos := LastPos;
+    end;
+  end else begin
+    Result := False;
+    Tokenizer.Pos := LastPos;
+  end;
+end;
+
 function TParserPascal.ParseCommand(Block: TBlock; out Command: TCommand): Boolean;
 var
   BeginEnd: TBeginEnd;
   FunctionCall: TFunctionCall;
+  ProcedureCall: TProcedureCall;
   Assignment: TAssignment;
   IfThenElse: TIfThenElse;
@@ -132 +174 @@
     Result := True;
     Command := FunctionCall;
+  end else
+  if ParseProcedureCall(Block, ProcedureCall) then begin
+    Result := True;
+    Command := ProcedureCall;
   end else
   if ParseRepeatUntil(Block, RepeatUntil) then begin
@@ -183 +229 @@
   BeginEnd: TBeginEnd;
   Func: TFunction;
+  Proc: TProcedure;
 begin
   Result := False;
@@ -195 +242 @@
     if ParseFunction(Block, Func) then begin
       Block.Functions.Add(Func);
-    end else begin
+    end else
+    if ParseProcedure(Block, Proc) then begin
+      Block.Procedures.Add(Proc);
+    end else
+    begin
       Break;
     end;
@@ -291 +342 @@
 var
   Token: TToken;
-  FunctionParameter: TFunctionParameter;
   NewBlock: TBlock;
   TypeRef: TType;
   Variable: TVariable;
-  I: Integer;
+  FunctionParameters: TFunctionParameters;
 begin
   Result := False;
@@ -304 +354 @@
     if Token.Kind = tkIdentifier then begin
       Func.Name := Token.Text;
-      if Tokenizer.CheckNextAndRead('(', tkSpecialSymbol) then begin
-        while not Tokenizer.CheckNext(')', tkSpecialSymbol) do begin
-          if Func.Params.Count > 0 then Tokenizer.Expect(',', tkSpecialSymbol);
-          if ParseFunctionParameter(Block, FunctionParameter) then begin
-            Func.Params.Add(FunctionParameter);
-          end else Error('Expected function parameter.');
-        end;
-        Tokenizer.Expect(')', tkSpecialSymbol);
-        for I := 0 to Func.Params.Count - 1 do begin
-          Variable := TVariable.Create;
-          Variable.Name := TFunctionParameter(Func.Params[I]).Name;
-          Variable.TypeRef := TFunctionParameter(Func.Params[I]).TypeRef;
-          Variable.Internal := True;
-          Func.Block.Variables.Add(Variable);
-        end;
-      end;
+      Func.Block.ParentBlock := Block;
+      if ParseFunctionParameters(Func.Block, FunctionParameters) then begin
+        Func.Params.Free;
+        Func.Params := FunctionParameters;
+      end;
+
       if Tokenizer.CheckNextAndRead(':', tkSpecialSymbol) then begin
         Token := Tokenizer.GetNext;
@@ -339 +379 @@
       end else Error('Expected function block');
     end else Error('Expected function name');
+  end;
+end;
+
+function TParserPascal.ParseFunctionParameters(Block: TBlock;
+  out Params: TFunctionParameters): Boolean;
+var
+  FunctionParameter: TFunctionParameter;
+  I: Integer;
+  Variable: TVariable;
+begin
+  Result := False;
+  Params := TFunctionParameters.Create;
+  if Tokenizer.CheckNextAndRead('(', tkSpecialSymbol) then begin
+    while not Tokenizer.CheckNext(')', tkSpecialSymbol) do begin
+      if Params.Count > 0 then Tokenizer.Expect(',', tkSpecialSymbol);
+      if ParseFunctionParameter(Block, FunctionParameter) then begin
+        Params.Add(FunctionParameter);
+      end else Error('Expected function parameter.');
+    end;
+    Tokenizer.Expect(')', tkSpecialSymbol);
+    for I := 0 to Params.Count - 1 do begin
+      Variable := TVariable.Create;
+      Variable.Name := Params[I].Name;
+      Variable.TypeRef := Params[I].TypeRef;
+      Variable.Internal := True;
+      Block.Variables.Add(Variable);
+    end;
+    Result := True;
   end;
 end;
@@ -368 +436 @@
     end else Error('Expected parameter type');
   end else Error('Expected parameter name');
+end;
+
+function TParserPascal.ParseProcedure(Block: TBlock; out Proc: TProcedure
+  ): Boolean;
+var
+  Token: TToken;
+  NewBlock: TBlock;
+  FunctionParameters: TFunctionParameters;
+begin
+  Result := False;
+  if Tokenizer.CheckNextAndRead('procedure', tkKeyword) then begin
+    Result := True;
+    Proc := TProcedure.Create;
+    Token := Tokenizer.GetNext;
+    if Token.Kind = tkIdentifier then begin
+      Proc.Name := Token.Text;
+      Proc.Block.ParentBlock := Block;
+      if ParseFunctionParameters(Proc.Block, FunctionParameters) then begin
+        Proc.Params.Free;
+        Proc.Params := FunctionParameters;
+      end;
+
+      Tokenizer.Expect(';', tkSpecialSymbol);
+      if ParseBlock(Block, NewBlock, Proc.Block) then begin
+        Tokenizer.Expect(';', tkSpecialSymbol);
+      end else Error('Expected procedure block');
+    end else Error('Expected procedure name');
+  end;
 end;
 

branches/xpascal/Source.pas

@@ -148 +148 @@
   end;
 
+  { TProcedure }
+
+  TProcedure = class(TSourceNode)
+  protected
+    function GetFieldsCount: Integer; override;
+  public
+    Name: string;
+    InternalName: string;
+    Params: TFunctionParameters;
+    Block: TBlock;
+    ParentType: TType;
+    procedure GetValue(Index: Integer; out Value); override;
+    function GetField(Index: Integer): TField; override;
+    procedure SetValue(Index: Integer; var Value); override;
+    constructor Create;
+    destructor Destroy; override;
+  end;
+
+  { TProcedures }
+
+  TProcedures = class(TSourceNodeList<TProcedure>)
+    ParentType: TType;
+    function SearchByName(Name: string): TProcedure;
+    function AddNew(Name: string): TProcedure;
+  end;
+
   TCommand = class(TSourceNode)
   end;
@@ -164 +190 @@
   public
     FunctionDef: TFunction;
+    Params: TExpressions;
+    procedure GetValue(Index: Integer; out Value); override;
+    function GetField(Index: Integer): TField; override;
+    procedure SetValue(Index: Integer; var Value); override;
+    constructor Create;
+    destructor Destroy; override;
+  end;
+
+  { TProcedureCall }
+
+  TProcedureCall = class(TCommand)
+  protected
+    function GetFieldsCount: Integer; override;
+  public
+    ProcedureDef: TProcedure;
     Params: TExpressions;
     procedure GetValue(Index: Integer; out Value); override;
@@ -365 +406 @@
     Constants: TConstants;
     Functions: TFunctions;
+    Procedures: TProcedures;
     Types: TTypes;
     BeginEnd: TBeginEnd;
@@ -375 +417 @@
     function GetVariable(Name: string): TVariable;
     function GetFunction(Name: string): TFunction;
+    function GetProcedure(Name: string): TProcedure;
     constructor Create;
     destructor Destroy; override;
@@ -426 +469 @@
 end;
 
+{ TProcedureCall }
+
+function TProcedureCall.GetFieldsCount: Integer;
+begin
+  Result := 2;
+end;
+
+procedure TProcedureCall.GetValue(Index: Integer; out Value);
+begin
+  if Index = 0 then TProcedure(Value) := ProcedureDef
+  else if Index = 1 then TExpressions(Value) := Params
+  else inherited;
+end;
+
+function TProcedureCall.GetField(Index: Integer): TField;
+begin
+  if Index = 0 then Result := TField.Create(dtObject, 'Procedure')
+  else if Index = 1 then Result := TField.Create(dtObject, 'Parameters')
+  else inherited;
+end;
+
+procedure TProcedureCall.SetValue(Index: Integer; var Value);
+begin
+  if Index = 0 then ProcedureDef := TProcedure(Value)
+  else if Index = 1 then Params := TExpressions(Value)
+  else inherited;
+end;
+
+constructor TProcedureCall.Create;
+begin
+  Params := TExpressions.Create;
+end;
+
+destructor TProcedureCall.Destroy;
+begin
+  FreeAndNil(Params);
+  inherited;
+end;
+
+{ TProcedure }
+
+function TProcedures.SearchByName(Name: string): TProcedure;
+var
+  I: Integer;
+begin
+  I := 0;
+  while (I < Count) and (TProcedure(Items[I]).Name <> Name) do Inc(I);
+  if I < Count then Result := TProcedure(Items[I])
+    else Result := nil;
+end;
+
+function TProcedures.AddNew(Name: string): TProcedure;
+begin
+  Result := TProcedure.Create;
+  Result.Name := Name;
+  Result.ParentType := ParentType;
+  Add(Result);
+end;
+
+function TProcedure.GetFieldsCount: Integer;
+begin
+  Result := 3;
+end;
+
+procedure TProcedure.GetValue(Index: Integer; out Value);
+begin
+  if Index = 0 then TBlock(Value) := Block
+  else if Index = 1 then TFunctionParameters(Value) := Params
+  else if Index = 2 then string(Value) := Name
+  else inherited;
+end;
+
+function TProcedure.GetField(Index: Integer): TField;
+begin
+  if Index = 0 then Result := TField.Create(dtObject, 'Block')
+  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
+  else if Index = 2 then Result := TField.Create(dtString, 'Name')
+  else inherited;
+end;
+
+procedure TProcedure.SetValue(Index: Integer; var Value);
+begin
+  if Index = 0 then Block := TBlock(Value)
+  else if Index = 1 then Params := TFunctionParameters(Value)
+  else if Index = 2 then Name := string(Value)
+  else inherited;
+end;
+
+constructor TProcedure.Create;
+begin
+  Params := TFunctionParameters.Create;
+  Block := TBlock.Create;
+end;
+
+destructor TProcedure.Destroy;
+begin
+  FreeAndNil(Block);
+  FreeAndNil(Params);
+  inherited;
+end;
+
 { TExpressionBrackets }
 
@@ -771 +915 @@
   if Index = 0 then TBlock(Value) := Block
   else if Index = 1 then TFunctionParameters(Value) := Params
-  else if Index = 2 then TType(Value) := ResultType
-  else if Index = 3 then string(Value) := Name
+  else if Index = 2 then string(Value) := Name
+  else if Index = 3 then TType(Value) := ResultType
   else inherited;
 end;
@@ -780 +924 @@
   if Index = 0 then Result := TField.Create(dtObject, 'Block')
   else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
-  else if Index = 2 then Result := TField.Create(dtObject, 'ResultType')
-  else if Index = 3 then Result := TField.Create(dtString, 'Name')
+  else if Index = 2 then Result := TField.Create(dtString, 'Name')
+  else if Index = 3 then Result := TField.Create(dtObject, 'ResultType')
   else inherited;
 end;
@@ -794 +938 @@
   if Index = 0 then Block := TBlock(Value)
   else if Index = 1 then Params := TFunctionParameters(Value)
-  else if Index = 2 then ResultType := TType(Value)
-  else if Index = 3 then Name := string(Value)
+  else if Index = 2 then Name := string(Value)
+  else if Index = 3 then ResultType := TType(Value)
   else inherited;
 end;
@@ -1052 +1196 @@
 begin
   if Index = 0 then Result := TField.Create(dtObject, 'Function')
-  else if Index = 1 then Result := TField.Create(dtObject, 'Parameters')
+  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
   else inherited;
 end;
@@ -1139 +1283 @@
   else if Index = 3 then TConstants(Value) := Constants
   else if Index = 4 then TFunctions(Value) := Functions
+  else if Index = 5 then TProcedures(Value) := Procedures
   else inherited;
 end;
@@ -1144 +1289 @@
 function TBlock.GetField(Index: Integer): TField;
 begin
-  if Index = 0 then Result := TField.Create(dtObject, 'Block')
+  if Index = 0 then Result := TField.Create(dtObject, 'BeginEnd')
   else if Index = 1 then Result := TField.Create(dtList, 'Types')
   else if Index = 2 then Result := TField.Create(dtList, 'Variables')
   else if Index = 3 then Result := TField.Create(dtList, 'Constants')
   else if Index = 4 then Result := TField.Create(dtList, 'Functions')
+  else if Index = 5 then Result := TField.Create(dtList, 'Procedures')
   else inherited;
 end;
@@ -1154 +1300 @@
 function TBlock.GetFieldsCount: Integer;
 begin
-  Result := 5;
+  Result := 6;
 end;
 
@@ -1164 +1310 @@
   else if Index = 3 then Constants := TConstants(Value)
   else if Index = 4 then Functions := TFunctions(Value)
+  else if Index = 5 then Procedures := TProcedures(Value)
   else inherited;
 end;
@@ -1170 +1317 @@
 begin
   Functions.Clear;
+  Procedures.Clear;
   Constants.Clear;
   Variables.Clear;
@@ -1201 +1349 @@
   if not Assigned(Result) and Assigned(ParentBlock) then
     Result := ParentBlock.GetFunction(Name);
+end;
+
+function TBlock.GetProcedure(Name: string): TProcedure;
+begin
+  Result := Procedures.SearchByName(Name);
+  if not Assigned(Result) and Assigned(ParentBlock) then
+    Result := ParentBlock.GetProcedure(Name);
 end;
 
@@ -1211 +1366 @@
   Functions := TFunctions.Create;
   Functions.Parent := Self;
+  Procedures := TProcedures.Create;
+  Procedures.Parent := Self;
   Types := TTypes.Create;
   Types.Parent := Self;
@@ -1224 +1381 @@
   FreeAndNil(Constants);
   FreeAndNil(Functions);
+  FreeAndNil(Procedures);
   inherited;
 end;
@@ -1237 +1395 @@
 function TBeginEnd.GetField(Index: Integer): TField;
 begin
-  if Index = 0 then Result := TField.Create(dtList, 'Command')
+  if Index = 0 then Result := TField.Create(dtList, 'Commands')
   else inherited;
 end;

branches/xpascal/Tests.pas

@@ -158 +158 @@
     ExpectedOutput := '-1' + LineEnding + '0' + LineEnding;
   end;
+  with TTestRun(Result.AddNew('procedure', TTestRun)) do begin
+    Source.Add('procedure Print(Text: string);');
+    Source.Add('begin');
+    Source.Add('  WriteLn(Text);');
+    Source.Add('end;');
+    Source.Add('');
+    Source.Add('begin');
+    Source.Add('  Print(''Test'');');
+    Source.Add('end.');
+    ExpectedOutput := 'Test' + LineEnding;
+  end;
+  with TTestRun(Result.AddNew('procedure var parameter', TTestRun)) do begin
+    Source.Add('procedure Test(var A: Integer);');
+    Source.Add('begin');
+    Source.Add('  A := 10;');
+    Source.Add('end;');
+    Source.Add('');
+    Source.Add('var');
+    Source.Add('  B: Integer;');
+    Source.Add('begin');
+    Source.Add('  B := 1;');
+    Source.Add('  Test(B);');
+    Source.Add('  WriteLn(IntToStr(B));');
+    Source.Add('end.');
+    ExpectedOutput := '10' + LineEnding;
+  end;
+  with TTestRun(Result.AddNew('Single line comment', TTestRun)) do begin
+    Source.Add('begin');
+    Source.Add('  // WriteLn(''Test'');');
+    Source.Add('end.');
+    ExpectedOutput := '';
+  end;
 end;
 
@@ -169 +201 @@
 procedure TTestRun.InterpreterError(Pos: TPoint; Text: string);
 begin
-  Error := Error + Text;
+  Error := Error + '[' + IntToStr(Pos.X) + ', ' + IntToStr(Pos.Y) + '] ' + Text + LineEnding;
 end;
 

branches/xpascal/Tokenizer.pas

@@ -62 +62 @@
 implementation
 
+resourcestring
+  SUnknownToken = 'Unknown token %s';
+  SUnsupportedTokenizerState = 'Unsupported tokenizer state.';
+  SExpectedButFound = 'Expected %s but %s found.';
+
 { TToken }
 
@@ -155 +160 @@
   (Text = 'else') or (Text = 'while') or (Text = 'do') or (Text = 'for') or
   (Text = 'to') or (Text = 'repeat') or (Text = 'until') or (Text = 'break') or
-  (Text = 'continue') or (Text = 'function');
+  (Text = 'continue') or (Text = 'function') or (Text = 'procedure');
 end;
 
@@ -203 +208 @@
         Pos.Increment;
       end else begin
-        Error('Unknown token ' + C);
+        Error(Format(SUnknownToken, [C]));
         Break;
       end;
@@ -260 +265 @@
       end;
     end else
-      raise Exception.Create('Unsupported tokenizer state.');
+      raise Exception.Create(SUnsupportedTokenizerState);
   end;
 end;
@@ -314 +319 @@
   Token := GetNext;
   if (Token.Text <> Text) or (Token.Kind <> Kind) then
-    Error('Expected ' + Text + ' but ' + Token.Text + ' found.');
+    Error(Format(SExpectedButFound, [Text, Token.Text]));
 end;