Changeset 233


Ignore:
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:
13 edited

Legend:

Unmodified
Added
Removed
  • branches/xpascal/Examples/Example.pas

    r230 r233  
    1414end;
    1515
     16procedure Print(Text: string);
    1617begin
     18  WriteLn(Text);
     19end;
     20
     21begin
     22  Print('Test');
     23
    1724  WriteLn('10 * 3 = ' + IntToStr((1 + 2) * (3 + 4)));
    1825
  • branches/xpascal/Executor.pas

    r231 r233  
    7171  end;
    7272
     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
    7390  { TExecutorBlock }
    7491
     
    7895    Variables: TExecutorVariables;
    7996    Functions: TExecutorFunctions;
     97    Procedures: TExecutorProcedures;
    8098    function GetFunction(FunctionDef: TFunction): TExecutorFunction;
     99    function GetProcedure(ProcedureDef: TProcedure): TExecutorProcedure;
    81100    function GetType(TypeDef: TType): TExecutorType;
    82101    function GetVariable(Variable: TVariable): TExecutorVariable;
     
    144163    procedure ExecuteBlock(ParentBlock: TExecutorBlock; Block: TBlock; ExistingBlock: TExecutorBlock = nil);
    145164    function ExecuteFunctionCall(Block: TExecutorBlock; FunctionCall: TFunctionCall): TValue;
     165    function ExecuteProcedureCall(Block: TExecutorBlock; ProcedureCall: TProcedureCall): TValue;
    146166    procedure ExecuteAssignment(Block: TExecutorBlock; Assignment: TAssignment);
    147167    function ExecuteExpression(Block: TExecutorBlock; Expression: TExpression): TValue;
     
    167187  SExpectedBooleanValue = 'Expected boolean value.';
    168188
     189{ TExecutorProcedures }
     190
     191function TExecutorProcedures.SearchByProcedure(ProcedureDef: TProcedure
     192  ): TExecutorProcedure;
     193var
     194  I: Integer;
     195begin
     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;
     200end;
     201
     202function TExecutorProcedures.AddNew(ProcedureDef: TProcedure
     203  ): TExecutorProcedure;
     204begin
     205  Result := TExecutorProcedure.Create;
     206  Result.ProcedureDef := ProcedureDef;
     207  Add(Result);
     208end;
     209
     210{ TExecutorProcedure }
     211
     212constructor TExecutorProcedure.Create;
     213begin
     214  Block := TExecutorBlock.Create;
     215end;
     216
     217destructor TExecutorProcedure.Destroy;
     218begin
     219  FreeAndNil(Block);
     220  inherited;
     221end;
     222
    169223{ TExecutorFunctionCallbackParam }
    170224
     
    281335end;
    282336
     337function TExecutorBlock.GetProcedure(ProcedureDef: TProcedure
     338  ): TExecutorProcedure;
     339begin
     340  Result := Procedures.SearchByProcedure(ProcedureDef);
     341  if not Assigned(Result) and Assigned(Parent) then
     342    Result := Parent.GetProcedure(ProcedureDef);
     343end;
     344
    283345function TExecutorBlock.GetType(TypeDef: TType): TExecutorType;
    284346begin
     
    315377  Variables := TExecutorVariables.Create;
    316378  Functions := TExecutorFunctions.Create;
     379  Procedures := TExecutorProcedures.Create;
    317380end;
    318381
     
    321384  FreeAndNil(Variables);
    322385  FreeAndNil(Functions);
     386  FreeAndNil(Procedures);
    323387  FreeAndNil(Types);
    324388  inherited;
     
    703767begin
    704768  for I := 0 to BeginEnd.Commands.Count - 1 do
    705     ExecuteCommand(Block, TCommand(BeginEnd.Commands[I]));
     769    ExecuteCommand(Block, BeginEnd.Commands[I]);
    706770end;
    707771
     
    710774  if Command is TBeginEnd then ExecuteBeginEnd(Block, TBeginEnd(Command))
    711775  else if Command is TFunctionCall then ExecuteFunctionCall(Block, TFunctionCall(Command))
     776  else if Command is TProcedureCall then ExecuteProcedureCall(Block, TProcedureCall(Command))
    712777  else if Command is TAssignment then ExecuteAssignment(Block, TAssignment(Command))
    713778  else if Command is TIfThenElse then ExecuteIfThenElse(Block, TIfThenElse(Command))
     
    899964end;
    900965
     966function TExecutor.ExecuteProcedureCall(Block: TExecutorBlock;
     967  ProcedureCall: TProcedureCall): TValue;
     968var
     969  ExecutorProcedure: TExecutorProcedure;
     970  Params: array of TExecutorFunctionCallbackParam;
     971  I: Integer;
     972  ExecutorVariable: TExecutorVariable;
     973  Variable: TVariable;
     974begin
     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.');
     1011end;
     1012
    9011013procedure TExecutor.ExecuteAssignment(Block: TExecutorBlock;
    9021014  Assignment: TAssignment);
  • branches/xpascal/Forms/FormMain.lfm

    r230 r233  
    1010  Menu = MainMenu1
    1111  OnActivate = FormActivate
     12  OnClose = FormClose
    1213  OnCreate = FormCreate
    1314  OnDestroy = FormDestroy
     
    4950  object MainMenu1: TMainMenu
    5051    Left = 744
    51     Top = 760
     52    Top = 759
    5253    object MenuItemFile: TMenuItem
    5354      Caption = 'File'
     55      object MenuItem10: TMenuItem
     56        Action = AFileOpen
     57      end
    5458      object MenuItem6: TMenuItem
    5559        Action = AExit
     
    129133      OnExecute = AConsoleExecute
    130134    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
    131160  end
    132161end
  • branches/xpascal/Forms/FormMain.lrj

    r230 r233  
    1313{"hash":209392028,"name":"tformmain.ageneratexml.caption","sourcebytes":[71,101,110,101,114,97,116,101,32,88,77,76],"value":"Generate XML"},
    1414{"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"}
    1618]}
  • branches/xpascal/Forms/FormMain.pas

    r230 r233  
    44
    55uses
    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;
    910
    1011type
     
    1516    ACompile: TAction;
    1617    AConsole: TAction;
     18    AFileOpen: TAction;
     19    ApplicationInfo1: TApplicationInfo;
    1720    ATest: TAction;
    1821    AGenerateXml: TAction;
     
    2528    MainMenu1: TMainMenu;
    2629    MenuItem1: TMenuItem;
     30    MenuItem10: TMenuItem;
    2731    MenuItem2: TMenuItem;
    2832    MenuItem3: TMenuItem;
     
    3640    MenuItemGenerate: TMenuItem;
    3741    MenuItemFile: TMenuItem;
     42    OpenDialog1: TOpenDialog;
    3843    PanelOutput: TPanel;
    3944    PanelSource: TPanel;
     
    4348    procedure AConsoleExecute(Sender: TObject);
    4449    procedure AExitExecute(Sender: TObject);
     50    procedure AFileOpenExecute(Sender: TObject);
    4551    procedure AGenerateCSharpExecute(Sender: TObject);
    4652    procedure AGeneratePascalExecute(Sender: TObject);
     
    5157    procedure ARunExecute(Sender: TObject);
    5258    procedure FormActivate(Sender: TObject);
     59    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    5360    procedure FormCreate(Sender: TObject);
    5461    procedure FormDestroy(Sender: TObject);
    5562    procedure FormShow(Sender: TObject);
    5663  private
     64    LastFileName: string;
    5765    Prog: TProgram;
    5866    Initialized: Boolean;
     
    6169    FormOutput: TFormOutput;
    6270    FormConsole: TFormConsole;
     71    procedure LoadFromRegistry;
     72    procedure SaveToRegistry;
     73    procedure ProjectOpen(FileName: string);
    6374    procedure Generate(GeneratorClass: TGeneratorClass);
    6475    procedure ExecutorOutput(Text: string);
     
    8798  if not Initialized then begin
    8899    Initialized := True;
    89     FormSource.SynEditSource.Lines.LoadFromFile('Examples' + DirectorySeparator +
    90       'Example.pas');
    91     ARun.Execute;
     100    ProjectOpen(LastFileName);
     101    //ARun.Execute;
    92102  end;
    93103end;
     
    104114procedure TFormMain.FormShow(Sender: TObject);
    105115begin
     116  LoadFromRegistry;
    106117  FormMessages := TFormMessages.Create(nil);
    107118  FormMessages.Show;
     
    119130end;
    120131
     132procedure TFormMain.LoadFromRegistry;
     133begin
     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;
     141end;
     142
     143procedure TFormMain.SaveToRegistry;
     144begin
     145  with TRegistryEx.Create do
     146  try
     147    CurrentContext := ApplicationInfo1.GetRegistryContext;
     148    WriteString('LastFileName', LastFileName);
     149  finally
     150    Free;
     151  end;
     152end;
     153
     154procedure TFormMain.ProjectOpen(FileName: string);
     155begin
     156  LastFileName := FileName;
     157  FormSource.SynEditSource.Lines.LoadFromFile(FileName);
     158end;
     159
    121160procedure TFormMain.Generate(GeneratorClass: TGeneratorClass);
    122161var
     
    130169    FormOutput.SetText(Generator.Output);
    131170    TargetFileName := 'Generated' + DirectorySeparator +
    132       Generator.Name + DirectorySeparator + 'Example' + Generator.FileExt;
     171      Generator.Name + DirectorySeparator + ExtractFileNameOnly(LastFileName) + Generator.FileExt;
    133172    ForceDirectories(ExtractFileDir(TargetFileName));
    134173    FormOutput.SynEditOutput.Lines.SaveToFile(TargetFileName);
     
    141180begin
    142181  Close;
     182end;
     183
     184procedure TFormMain.AFileOpenExecute(Sender: TObject);
     185begin
     186  OpenDialog1.InitialDir := ExtractFileDir(LastFileName);
     187  OpenDialog1.FileName := ExtractFileName(LastFileName);
     188  if OpenDialog1.Execute then begin
     189    ProjectOpen(OpenDialog1.FileName);
     190  end;
    143191end;
    144192
     
    224272end;
    225273
     274procedure TFormMain.FormClose(Sender: TObject; var CloseAction: TCloseAction);
     275begin
     276  FormConsole.Terminated := True;
     277  SaveToRegistry;
     278end;
     279
    226280procedure TFormMain.FormCreate(Sender: TObject);
    227281begin
     
    248302begin
    249303  ACompile.Execute;
    250   FormOutput.SynEditOutput.Highlighter := nil;
    251   FormOutput.SynEditOutput.Lines.Clear;
     304  FormConsole.Memo1.Lines.Clear;
    252305  if Assigned(Prog) then begin
    253306    Executor := TExecutor.Create;
  • branches/xpascal/Generators/GeneratorCSharp.pas

    r230 r233  
    227227
    228228procedure TGeneratorCSharp.GenerateProgram(Block: TBlock; Prog: TProgram);
    229 begin
     229var
     230  MainClass: string;
     231begin
     232  if Prog.Name <> '' then MainClass := Prog.Name
     233    else MainClass := 'App';
    230234  AddTextLine('using System;');
    231235  AddTextLine;
    232   AddTextLine('public class ' + Prog.Name);
     236  AddTextLine('public class ' + MainClass);
    233237  AddTextLine('{');
    234238  Indent := Indent + 1;
     
    237241  AddTextLine('public static void Main()');
    238242  AddTextLine('{');
    239   AddTextLine('  ' + Prog.Name + ' app = new ' + Prog.Name + '();');
     243  AddTextLine('  ' + MainClass + ' app = new ' + MainClass + '();');
    240244  AddTextLine('  app.Entry();');
    241245  AddTextLine('}');
  • branches/xpascal/Generators/GeneratorXml.pas

    r232 r233  
    1111  TGeneratorXml = class(TGenerator)
    1212  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);
    1516  public
    1617    procedure Generate; override;
     
    2627{ TGeneratorXml }
    2728
    28 procedure TGeneratorXml.GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>);
     29procedure TGeneratorXml.GenerateNodes(SourceNodes: TSourceNodeList<TSourceNode>;
     30  NodeName: string);
    2931var
    3032  I: Integer;
     
    3234  for I := 0 to SourceNodes.Count - 1 do begin
    3335    if SourceNodes[I] is TSourceNode then begin
    34       GenerateNode(TSourceNode(SourceNodes[I]));
     36      GenerateNode(TSourceNode(SourceNodes[I]), NodeName);
    3537    end else raise Exception.Create(SUnsupportedNodeType);
    3638  end;
    3739end;
    3840
    39 procedure TGeneratorXml.GenerateNode(SourceNode: TSourceNode);
     41procedure TGeneratorXml.GenerateNode(SourceNode: TSourceNode; NodeName: string);
    4042var
    4143  I: Integer;
     
    4547begin
    4648  if SourceNode is TSourceNode then begin
    47     AddTextLine('<' + SourceNode.ClassName + '>');
     49    AddTextLine('<' + NodeName + '>');
    4850    Indent := Indent + 1;
    4951    for I := 0 to SourceNode.FieldsCount - 1 do begin
    5052      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;
    6271      end;
    63       Field.Free;
    6472    end;
    6573    Indent := Indent - 1;
    66     AddTextLine('</' + SourceNode.ClassName + '>');
     74    AddTextLine('</' + NodeName + '>');
    6775  end else
    6876    raise Exception.Create(SUnsupportedNodeType);
     
    7179procedure TGeneratorXml.Generate;
    7280begin
    73   GenerateNode(Prog);
     81  AddTextLine('<?xml version="1.0" encoding="UTF-8"?>');
     82  GenerateNode(Prog, 'Program');
    7483end;
    7584
  • branches/xpascal/Languages/xpascal.cs.po

    r231 r233  
    8282msgstr "Odejít"
    8383
     84#: tformmain.afileopen.caption
     85msgid "Open..."
     86msgstr "Otevřít..."
     87
    8488#: tformmain.ageneratecsharp.caption
    8589msgid "Generate C#"
     
    97101msgid "Generate XML"
    98102msgstr "Generovat XML"
     103
     104#: tformmain.applicationinfo1.description
     105msgid "Pascal mutli language transpiler and interpreter"
     106msgstr "Více jazykovÃœ paskalovÃœ převaděč zdrojového kódu a interpreter"
    99107
    100108#: tformmain.arun.caption
     
    152160msgid "Source:"
    153161msgstr "Zdroj:"
     162
     163#: tokenizer.sexpectedbutfound
     164#, object-pascal-format
     165msgid "Expected %s but %s found."
     166msgstr "Očekáváno %s, ale nalezeno %s."
     167
     168#: tokenizer.sunknowntoken
     169#, object-pascal-format
     170msgid "Unknown token %s"
     171msgstr "NeznámÃœ token %s"
     172
     173#: tokenizer.sunsupportedtokenizerstate
     174msgid "Unsupported tokenizer state."
     175msgstr "NepodporovanÃœ stav tokenizeru."
  • branches/xpascal/Languages/xpascal.pot

    r231 r233  
    7272msgstr ""
    7373
     74#: tformmain.afileopen.caption
     75msgid "Open..."
     76msgstr ""
     77
    7478#: tformmain.ageneratecsharp.caption
    7579msgid "Generate C#"
     
    8690#: tformmain.ageneratexml.caption
    8791msgid "Generate XML"
     92msgstr ""
     93
     94#: tformmain.applicationinfo1.description
     95msgid "Pascal mutli language transpiler and interpreter"
    8896msgstr ""
    8997
     
    143151msgstr ""
    144152
     153#: tokenizer.sexpectedbutfound
     154#, object-pascal-format
     155msgid "Expected %s but %s found."
     156msgstr ""
     157
     158#: tokenizer.sunknowntoken
     159#, object-pascal-format
     160msgid "Unknown token %s"
     161msgstr ""
     162
     163#: tokenizer.sunsupportedtokenizerstate
     164msgid "Unsupported tokenizer state."
     165msgstr ""
     166
  • branches/xpascal/Parsers/ParserPascal.pas

    r230 r233  
    1414    function ParseBeginEnd(Block: TBlock; out BeginEnd: TBeginEnd): Boolean;
    1515    function ParseFunctionCall(Block: TBlock; out FunctionCall: TFunctionCall): Boolean;
     16    function ParseProcedureCall(Block: TBlock; out ProcedureCall: TProcedureCall): Boolean;
    1617    function ParseCommand(Block: TBlock; out Command: TCommand): Boolean;
    1718    function ParseProgram(SystemBlock: TBlock; out Prog: TProgram): Boolean; override;
     
    2021    function ParseBlockConst(Block: TBlock): Boolean;
    2122    function ParseFunction(Block: TBlock; out Func: TFunction): Boolean;
     23    function ParseFunctionParameters(Block: TBlock; out Params: TFunctionParameters): Boolean;
    2224    function ParseFunctionParameter(Block: TBlock; out Parameter: TFunctionParameter): Boolean;
     25    function ParseProcedure(Block: TBlock; out Proc: TProcedure): Boolean;
    2326    function ParseAssignment(Block: TBlock; out Assignment: TAssignment): Boolean;
    2427    function ParseExpression(Block: TBlock; out Expression: TExpression;
     
    101104end;
    102105
     106function TParserPascal.ParseProcedureCall(Block: TBlock; out
     107  ProcedureCall: TProcedureCall): Boolean;
     108var
     109  Token: TToken;
     110  LastPos: TTokenizerPos;
     111  ProcedureDef: TProcedure;
     112  Expression: TExpression;
     113  I: Integer;
     114begin
     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;
     142end;
     143
    103144function TParserPascal.ParseCommand(Block: TBlock; out Command: TCommand): Boolean;
    104145var
    105146  BeginEnd: TBeginEnd;
    106147  FunctionCall: TFunctionCall;
     148  ProcedureCall: TProcedureCall;
    107149  Assignment: TAssignment;
    108150  IfThenElse: TIfThenElse;
     
    132174    Result := True;
    133175    Command := FunctionCall;
     176  end else
     177  if ParseProcedureCall(Block, ProcedureCall) then begin
     178    Result := True;
     179    Command := ProcedureCall;
    134180  end else
    135181  if ParseRepeatUntil(Block, RepeatUntil) then begin
     
    183229  BeginEnd: TBeginEnd;
    184230  Func: TFunction;
     231  Proc: TProcedure;
    185232begin
    186233  Result := False;
     
    195242    if ParseFunction(Block, Func) then begin
    196243      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
    198249      Break;
    199250    end;
     
    291342var
    292343  Token: TToken;
    293   FunctionParameter: TFunctionParameter;
    294344  NewBlock: TBlock;
    295345  TypeRef: TType;
    296346  Variable: TVariable;
    297   I: Integer;
     347  FunctionParameters: TFunctionParameters;
    298348begin
    299349  Result := False;
     
    304354    if Token.Kind = tkIdentifier then begin
    305355      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
    322362      if Tokenizer.CheckNextAndRead(':', tkSpecialSymbol) then begin
    323363        Token := Tokenizer.GetNext;
     
    339379      end else Error('Expected function block');
    340380    end else Error('Expected function name');
     381  end;
     382end;
     383
     384function TParserPascal.ParseFunctionParameters(Block: TBlock;
     385  out Params: TFunctionParameters): Boolean;
     386var
     387  FunctionParameter: TFunctionParameter;
     388  I: Integer;
     389  Variable: TVariable;
     390begin
     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;
    341409  end;
    342410end;
     
    368436    end else Error('Expected parameter type');
    369437  end else Error('Expected parameter name');
     438end;
     439
     440function TParserPascal.ParseProcedure(Block: TBlock; out Proc: TProcedure
     441  ): Boolean;
     442var
     443  Token: TToken;
     444  NewBlock: TBlock;
     445  FunctionParameters: TFunctionParameters;
     446begin
     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;
    370466end;
    371467
  • branches/xpascal/Source.pas

    r232 r233  
    148148  end;
    149149
     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
    150176  TCommand = class(TSourceNode)
    151177  end;
     
    164190  public
    165191    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;
    166207    Params: TExpressions;
    167208    procedure GetValue(Index: Integer; out Value); override;
     
    365406    Constants: TConstants;
    366407    Functions: TFunctions;
     408    Procedures: TProcedures;
    367409    Types: TTypes;
    368410    BeginEnd: TBeginEnd;
     
    375417    function GetVariable(Name: string): TVariable;
    376418    function GetFunction(Name: string): TFunction;
     419    function GetProcedure(Name: string): TProcedure;
    377420    constructor Create;
    378421    destructor Destroy; override;
     
    426469end;
    427470
     471{ TProcedureCall }
     472
     473function TProcedureCall.GetFieldsCount: Integer;
     474begin
     475  Result := 2;
     476end;
     477
     478procedure TProcedureCall.GetValue(Index: Integer; out Value);
     479begin
     480  if Index = 0 then TProcedure(Value) := ProcedureDef
     481  else if Index = 1 then TExpressions(Value) := Params
     482  else inherited;
     483end;
     484
     485function TProcedureCall.GetField(Index: Integer): TField;
     486begin
     487  if Index = 0 then Result := TField.Create(dtObject, 'Procedure')
     488  else if Index = 1 then Result := TField.Create(dtObject, 'Parameters')
     489  else inherited;
     490end;
     491
     492procedure TProcedureCall.SetValue(Index: Integer; var Value);
     493begin
     494  if Index = 0 then ProcedureDef := TProcedure(Value)
     495  else if Index = 1 then Params := TExpressions(Value)
     496  else inherited;
     497end;
     498
     499constructor TProcedureCall.Create;
     500begin
     501  Params := TExpressions.Create;
     502end;
     503
     504destructor TProcedureCall.Destroy;
     505begin
     506  FreeAndNil(Params);
     507  inherited;
     508end;
     509
     510{ TProcedure }
     511
     512function TProcedures.SearchByName(Name: string): TProcedure;
     513var
     514  I: Integer;
     515begin
     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;
     520end;
     521
     522function TProcedures.AddNew(Name: string): TProcedure;
     523begin
     524  Result := TProcedure.Create;
     525  Result.Name := Name;
     526  Result.ParentType := ParentType;
     527  Add(Result);
     528end;
     529
     530function TProcedure.GetFieldsCount: Integer;
     531begin
     532  Result := 3;
     533end;
     534
     535procedure TProcedure.GetValue(Index: Integer; out Value);
     536begin
     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;
     541end;
     542
     543function TProcedure.GetField(Index: Integer): TField;
     544begin
     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;
     549end;
     550
     551procedure TProcedure.SetValue(Index: Integer; var Value);
     552begin
     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;
     557end;
     558
     559constructor TProcedure.Create;
     560begin
     561  Params := TFunctionParameters.Create;
     562  Block := TBlock.Create;
     563end;
     564
     565destructor TProcedure.Destroy;
     566begin
     567  FreeAndNil(Block);
     568  FreeAndNil(Params);
     569  inherited;
     570end;
     571
    428572{ TExpressionBrackets }
    429573
     
    771915  if Index = 0 then TBlock(Value) := Block
    772916  else if Index = 1 then TFunctionParameters(Value) := Params
    773   else if Index = 2 then TType(Value) := ResultType
    774   else if Index = 3 then string(Value) := Name
     917  else if Index = 2 then string(Value) := Name
     918  else if Index = 3 then TType(Value) := ResultType
    775919  else inherited;
    776920end;
     
    780924  if Index = 0 then Result := TField.Create(dtObject, 'Block')
    781925  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
    782   else if Index = 2 then Result := TField.Create(dtObject, 'ResultType')
    783   else if Index = 3 then Result := TField.Create(dtString, 'Name')
     926  else if Index = 2 then Result := TField.Create(dtString, 'Name')
     927  else if Index = 3 then Result := TField.Create(dtObject, 'ResultType')
    784928  else inherited;
    785929end;
     
    794938  if Index = 0 then Block := TBlock(Value)
    795939  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)
    798942  else inherited;
    799943end;
     
    10521196begin
    10531197  if Index = 0 then Result := TField.Create(dtObject, 'Function')
    1054   else if Index = 1 then Result := TField.Create(dtObject, 'Parameters')
     1198  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
    10551199  else inherited;
    10561200end;
     
    11391283  else if Index = 3 then TConstants(Value) := Constants
    11401284  else if Index = 4 then TFunctions(Value) := Functions
     1285  else if Index = 5 then TProcedures(Value) := Procedures
    11411286  else inherited;
    11421287end;
     
    11441289function TBlock.GetField(Index: Integer): TField;
    11451290begin
    1146   if Index = 0 then Result := TField.Create(dtObject, 'Block')
     1291  if Index = 0 then Result := TField.Create(dtObject, 'BeginEnd')
    11471292  else if Index = 1 then Result := TField.Create(dtList, 'Types')
    11481293  else if Index = 2 then Result := TField.Create(dtList, 'Variables')
    11491294  else if Index = 3 then Result := TField.Create(dtList, 'Constants')
    11501295  else if Index = 4 then Result := TField.Create(dtList, 'Functions')
     1296  else if Index = 5 then Result := TField.Create(dtList, 'Procedures')
    11511297  else inherited;
    11521298end;
     
    11541300function TBlock.GetFieldsCount: Integer;
    11551301begin
    1156   Result := 5;
     1302  Result := 6;
    11571303end;
    11581304
     
    11641310  else if Index = 3 then Constants := TConstants(Value)
    11651311  else if Index = 4 then Functions := TFunctions(Value)
     1312  else if Index = 5 then Procedures := TProcedures(Value)
    11661313  else inherited;
    11671314end;
     
    11701317begin
    11711318  Functions.Clear;
     1319  Procedures.Clear;
    11721320  Constants.Clear;
    11731321  Variables.Clear;
     
    12011349  if not Assigned(Result) and Assigned(ParentBlock) then
    12021350    Result := ParentBlock.GetFunction(Name);
     1351end;
     1352
     1353function TBlock.GetProcedure(Name: string): TProcedure;
     1354begin
     1355  Result := Procedures.SearchByName(Name);
     1356  if not Assigned(Result) and Assigned(ParentBlock) then
     1357    Result := ParentBlock.GetProcedure(Name);
    12031358end;
    12041359
     
    12111366  Functions := TFunctions.Create;
    12121367  Functions.Parent := Self;
     1368  Procedures := TProcedures.Create;
     1369  Procedures.Parent := Self;
    12131370  Types := TTypes.Create;
    12141371  Types.Parent := Self;
     
    12241381  FreeAndNil(Constants);
    12251382  FreeAndNil(Functions);
     1383  FreeAndNil(Procedures);
    12261384  inherited;
    12271385end;
     
    12371395function TBeginEnd.GetField(Index: Integer): TField;
    12381396begin
    1239   if Index = 0 then Result := TField.Create(dtList, 'Command')
     1397  if Index = 0 then Result := TField.Create(dtList, 'Commands')
    12401398  else inherited;
    12411399end;
  • branches/xpascal/Tests.pas

    r230 r233  
    158158    ExpectedOutput := '-1' + LineEnding + '0' + LineEnding;
    159159  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;
    160192end;
    161193
     
    169201procedure TTestRun.InterpreterError(Pos: TPoint; Text: string);
    170202begin
    171   Error := Error + Text;
     203  Error := Error + '[' + IntToStr(Pos.X) + ', ' + IntToStr(Pos.Y) + '] ' + Text + LineEnding;
    172204end;
    173205
  • branches/xpascal/Tokenizer.pas

    r224 r233  
    6262implementation
    6363
     64resourcestring
     65  SUnknownToken = 'Unknown token %s';
     66  SUnsupportedTokenizerState = 'Unsupported tokenizer state.';
     67  SExpectedButFound = 'Expected %s but %s found.';
     68
    6469{ TToken }
    6570
     
    155160  (Text = 'else') or (Text = 'while') or (Text = 'do') or (Text = 'for') or
    156161  (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');
    158163end;
    159164
     
    203208        Pos.Increment;
    204209      end else begin
    205         Error('Unknown token ' + C);
     210        Error(Format(SUnknownToken, [C]));
    206211        Break;
    207212      end;
     
    260265      end;
    261266    end else
    262       raise Exception.Create('Unsupported tokenizer state.');
     267      raise Exception.Create(SUnsupportedTokenizerState);
    263268  end;
    264269end;
     
    314319  Token := GetNext;
    315320  if (Token.Text <> Text) or (Token.Kind <> Kind) then
    316     Error('Expected ' + Text + ' but ' + Token.Text + ' found.');
     321    Error(Format(SExpectedButFound, [Text, Token.Text]));
    317322end;
    318323
Note: See TracChangeset for help on using the changeset viewer.