Changeset 119 for branches/generator/URules.pas

Timestamp:

Nov 29, 2017, 12:31:26 PM (7 years ago)

Author:

chronos

Message:

• Added: New rules flag directing if source node should be generated for them.
• Added: New and Save menu actions.

File:

• branches/generator/URules.pas (modified) (21 diffs)

branches/generator/URules.pas

@@ -6 +6 @@
 
 uses
-  Classes, SysUtils, fgl, DOM, XmlRead, XmlWrite, UXMLUtils;
+  Classes, SysUtils, fgl, DOM, XmlRead, XmlWrite, UXMLUtils, Math;
 
 type
@@ -32 +32 @@
     NonTerminal: TRule;
     SubItems: TRuleItems;
+    function GetCharLength: Integer;
     procedure LoadFromXmlNode(Node: TDOMNode);
     procedure SaveToXmlNode(Node: TDOMNode);
-    function GetBNF: string;
+    function GetString: string;
     constructor Create;
     destructor Destroy; override;
@@ -52 +53 @@
     Grammer: TGrammer;
     RuleType: TRuleType;
+    function GetCharLength: Integer;
     procedure LoadFromXmlNode(Node: TDOMNode);
     procedure SaveToXmlNode(Node: TDOMNode);
     procedure UpdateRuleReference;
-    function GetBNF: string;
+    function GetString: string;
     property ParentRule: TRule read FParentRule write SetParentRule;
   end;
@@ -78 +80 @@
   public
     Name: string;
+    CreateSourceNode: Boolean;
     Items: TRuleItems;
     Links: TRuleLinks;
@@ -85 +88 @@
     procedure LoadFromXmlNode(Node: TDOMNode);
     procedure SaveToXmlNode(Node: TDOMNode);
-    function GetBNF: string;
+    function GetString: string;
   end;
 
@@ -95 +98 @@
     procedure LoadFromXmlNode(Node: TDOMNode);
     procedure SaveToXmlNode(Node: TDOMNode);
-    function GetBNF: string;
+    function GetString: string;
   end;
 
@@ -101 +104 @@
 
   TGrammer = class
+  private
+    FModified: Boolean;
+    procedure SetModified(AValue: Boolean);
+    procedure BuildMain(FileName: string);
+    procedure BuildSource(FileName: string);
+  public
     FileName: string;
     Rules: TRules;
@@ -107 +116 @@
     constructor Create;
     destructor Destroy; override;
-    function GetBNF: string;
+    procedure BuildCompiler;
+    function GetString: string;
+    property Modified: Boolean read FModified write SetModified;
   end;
 
@@ -113 +124 @@
 
 { TGrammer }
+
+procedure TGrammer.SetModified(AValue: Boolean);
+begin
+  if FModified = AValue then Exit;
+  FModified := AValue;
+end;
+
+procedure TGrammer.BuildMain(FileName: string);
+var
+  ParserFile: TStringList;
+begin
+  ParserFile := TStringList.Create;
+  with ParserFile do begin
+    Add('program Compiler;');
+    Add('');
+    Add('{$MODE Delphi}');
+    Add('');
+    Add('uses');
+    Add('  Source;');
+    Add('');
+    Add('procedure Compile;');
+    Add('begin');
+    Add('end;');
+    Add('');
+    Add('begin');
+    Add('  Compile;');
+    Add('end.');
+    SaveToFile(FileName);
+  end;
+  FreeAndNil(ParserFile);
+end;
+
+procedure TGrammer.BuildSource(FileName: string);
+var
+  Rule: TRule;
+  Item: TRuleItem;
+  Line: string;
+  I: Integer;
+  SourceFile: TStringList;
+begin
+  SourceFile := TStringList.Create;
+  with SourceFile do begin
+    Add('unit Source;');
+    Add('');
+    Add('{$MODE Delphi}');
+    Add('');
+    Add('interface');
+    Add('');
+    Add('uses');
+    Add('  fgl;');
+    Add('');
+    Add('type');
+    for Rule in Rules do begin
+      Add('  T' + Rule.Name + ' = class;');
+    end;
+    Add('');
+    for Rule in Rules do begin
+      Add('  T' + Rule.Name + ' = class');
+      for Item in Rule.Items do begin
+        if Item.RuleItemType = ritNonTerminal then
+          if Item.Repetitive then
+          Add('    ' + Item.NonTerminal.Name + ': TFPGObjectList<T' + Item.NonTerminal.Name + '>;')
+          else Add('    ' + Item.NonTerminal.Name + ': T' + Item.NonTerminal.Name + ';');
+      end;
+      Add('  end;' + LineEnding);
+    end;
+    Add('');
+    Add('implementation');
+    Add('');
+    for Rule in Rules do
+    if Rule.CreateSourceNode then begin
+      Add('function Parse' + Rule.Name + ': Boolean;');
+      Add('begin');
+      I := 0;
+      for Item in Rule.Items do begin
+        Line := '  ';
+        if Rule.Items.RuleType = rtOr then begin
+          if I > 0 then Line := Line + 'else ';
+          Line := Line + 'if ';
+        end else
+        if Rule.Items.RuleType = rtAnd then begin
+          Line := Line + '';
+        end;
+        if Item.RuleItemType = ritTerminal then
+          Line := Line + 'Expect(''' + Item.Terminal + ''')'
+        else if Item.RuleItemType = ritNonTerminal then
+          Line := Line + 'Parse' + Item.NonTerminal.Name;
+        if Rule.Items.RuleType = rtOr then begin
+          Line := Line + ' then ';
+        end else
+        if Rule.Items.RuleType = rtAnd then begin
+          Line := Line + ';';
+        end;
+        Add(Line);
+        Inc(I);
+      end;
+      if Rule.Items.RuleType = rtOr then begin
+        Add('  else ShowError(''Unexpected token'');');
+      end;
+      Add('end;');
+      Add('');
+    end;
+
+    Add('end.');
+
+    SaveToFile(FileName);
+  end;
+  FreeAndNil(SourceFile);
+end;
 
 procedure TGrammer.LoadFromXmlFile(FileName: string);
@@ -159 +279 @@
 
     WriteXMLFile(Doc, FileName);
+    Modified := False;
   finally
     Doc.Free;
@@ -176 +297 @@
 end;
 
-function TGrammer.GetBNF: string;
-begin
-  Result := Rules.GetBNF;
+procedure TGrammer.BuildCompiler;
+var
+  OutputDir: string;
+begin
+  OutputDir := 'Generated';
+  ForceDirectories(OutputDir);
+
+  BuildMain(OutputDir + DirectorySeparator + 'Compiler.pas');
+  BuildSource(OutputDir + DirectorySeparator +'Source.pas');
+end;
+
+function TGrammer.GetString: string;
+begin
+  Result := Rules.GetString;
 end;
 
@@ -202 +334 @@
 end;
 
-function TRuleItem.GetBNF: string;
+function TRuleItem.GetString: string;
 begin
   case RuleItemType of
     ritTerminal: Result := '"' + Terminal + '"';
     ritNonTerminal: Result := NonTerminal.Name;
-    ritSubItems: Result := '(' + SubItems.GetBNF + ')';
+    ritSubItems: Result := '(' + SubItems.GetString + ')';
   end;
   if Optional then Result := '+' + Result;
@@ -230 +362 @@
   FParentRule := AValue;
   SubItems.ParentRule := AValue;
+end;
+
+function TRuleItem.GetCharLength: Integer;
+begin
+  case RuleItemType of
+    ritTerminal: Result := Length(Terminal);
+    ritNonTerminal: Result := Length(NonTerminal.Name);
+    ritSubItems: Result := SubItems.GetCharLength;
+  end;
 end;
 
@@ -283 +424 @@
 end;
 
-function TRuleItems.GetBNF: string;
+function TRuleItems.GetString: string;
 var
   Item: TRuleItem;
@@ -293 +434 @@
       else if RuleType = rtOr then Result := Result + ' | ';
     end;
-    Result := Result + Item.GetBNF;
+    Result := Result + Item.GetString;
   end;
 end;
@@ -301 +442 @@
   if FParentRule = AValue then Exit;
   FParentRule := AValue;
+end;
+
+function TRuleItems.GetCharLength: Integer;
+var
+  Item: TRuleItem;
+begin
+  Result := 0;
+  if RuleType = rtOr then begin
+    for Item in Self do
+      Result := Max(Result, Item.GetCharLength);
+  end else
+  if RuleType = rtAnd then begin
+    for Item in Self do
+      Result := Result + Item.GetCharLength;
+  end;
 end;
 
@@ -330 +486 @@
 begin
   WriteString(Node, 'Name', Name);
+  WriteBoolean(Node, 'CreateSourceNode', CreateSourceNode);
 
   RuleItemsNode := Node.OwnerDocument.CreateElement('RuleItems');
@@ -336 +493 @@
 end;
 
-function TRule.GetBNF: string;
-begin
-  Result := Name + ' ::= ' + Items.GetBNF;
+function TRule.GetString: string;
+begin
+  Result := Name + ' ::= ' + Items.GetString;
 end;
 
@@ -370 +527 @@
 begin
   Name := ReadString(Node, 'Name', '');
+  CreateSourceNode := ReadBoolean(Node, 'CreateSourceNode', False);
 
   ItemsNode := Node.FindNode('RuleItems');
@@ -418 +576 @@
 end;
 
-function TRules.GetBNF: string;
+function TRules.GetString: string;
 var
   Rule: TRule;
@@ -424 +582 @@
   Result := '';
   for Rule in Self do begin
-    Result := Result + Rule.GetBNF + LineEnding;
+    Result := Result + Rule.GetString + LineEnding;
   end;
 end;