Changeset 19 for trunk/Compiler/Produce/UProducerPascal.pas

Timestamp:

Nov 9, 2010, 11:19:28 AM (13 years ago)

Author:

george

Message:

• Added: Support for multiple combined sections var, type, const and functions.
• Modified: Functions for parsing types redone to return Boolean result of success.

File:

• trunk/Compiler/Produce/UProducerPascal.pas (modified) (9 diffs)

trunk/Compiler/Produce/UProducerPascal.pas

@@ -22 +22 @@
     procedure GenerateType(AType: TType; AssignSymbol: Char = ':');
     procedure GenerateTypes(Types: TTypeList);
-    procedure GenerateCommonBlock(CommonBlock: TCommonBlock;
+    procedure GenerateCommonBlockInterface(CommonBlock: TCommonBlock;
+      LabelPrefix: string);
+    procedure GenerateCommonBlockImplementation(CommonBlock: TCommonBlock;
       LabelPrefix: string);
     procedure GenerateFunctions(Functions: TFunctionList);
+    procedure GenerateFunction(AFunction: TFunction);
+    procedure GenerateFunctionHead(AFunction: TFunction);
     procedure GenerateConstants(Constants: TConstantList);
+    procedure GenerateConstant(Constant: TConstant);
     procedure GenerateBeginEnd(BeginEnd: TBeginEnd);
     procedure GenerateVariableList(Variables: TVariableList);
+    procedure GenerateVariable(Variable: TVariable);
     procedure GenerateCommand(Command: TCommand);
     procedure GenerateWhileDo(WhileDo: TWhileDo);
@@ -78 +84 @@
   EmitLn(';');
   Dec(Indetation);
+  EmitLn;
 end;
 
@@ -87 +94 @@
     Module.TargetFile := Module.Name + '.dpr';
     EmitLn('program ' + Name + ';');
+    EmitLn;
     GenerateUses(UsedModules);
-    GenerateCommonBlock(Body, '');
+    GenerateCommonBlockImplementation(Body, '');
     EmitLn('.');
   end else
@@ -102 +110 @@
   EmitLn('interface');
   EmitLn;
-  GenerateCommonBlock(TModuleUnit(Module).Body, '.');
+  GenerateCommonBlockInterface(TModuleUnit(Module).Body, '.');
+  EmitLn;
   EmitLn('implementation');
   EmitLn;
-  EmitLn('end.');
+  GenerateCommonBlockImplementation(TModuleUnit(Module).Body, '.');
+  EmitLn('.');
 end;
 
@@ -196 +206 @@
 var
   I: Integer;
+begin
+  for I := 0 to Functions.Count - 1 do
+    GenerateFunction(TFunction(Functions[I]));
+end;
+
+procedure TProducerPascal.GenerateFunction(AFunction: TFunction);
+var
+  I: Integer;
   P: Integer;
   Line: string;
 begin
-  for I := 0 to Functions.Count - 1 do
-  with TFunction(Functions[I]) do
+  with AFunction do
   if not Internal then
   begin
+    GenerateFunctionHead(AFunction);
+    GenerateBeginEnd(Code);
+    EmitLn(';');
+    EmitLn;
+  end;
+end;
+
+procedure TProducerPascal.GenerateFunctionHead(AFunction: TFunction);
+var
+  Line: string;
+  P: Integer;
+begin
+  with AFunction do begin
     if FunctionType = ftFunction then
       Line := 'function ' + Name
@@ -218 +248 @@
       Line := Line + ': ' + ResultType.Name;
     EmitLn(Line + ';');
-    GenerateBeginEnd(Code);
-    EmitLn(';');
-    EmitLn;
   end;
 end;
@@ -232 +259 @@
     Inc(Indetation);
     for I := 0 to Constants.Count - 1 do
-    with TConstant(Constants[I]) do
-    if not System then begin
-      //Emit(Name + ': ');
-      //if Assigned(ValueType) then Emit(ValueType.Name);
-      //Emit(' = ' + Value + ';');
-    end;
+      GenerateConstant(Constants[I]);
     Dec(Indetation);
     Emit('');
+  end;
+end;
+
+procedure TProducerPascal.GenerateConstant(Constant: TConstant);
+begin
+  with Constant do begin
+    Emit(Name);
+    //if Assigned(ValueType) then Emit(': ' + ValueType.Name);
+    EmitLn(' = ' + Value + ';');
   end;
 end;
@@ -266 +297 @@
   Inc(Indetation);
   for I := 0 to Variables.Count - 1 do
-  with TVariable(Variables[I]) do
+    GenerateVariable(TVariable(Variables[I]));
+  Dec(Indetation);
+  EmitLn;
+end;
+
+procedure TProducerPascal.GenerateVariable(Variable: TVariable);
+begin
+  with Variable do
     EmitLn(Name + ': ' + ValueType.Name + ';');
-  Dec(Indetation);
-  EmitLn;
 end;
 
@@ -362 +398 @@
 end;
 
-procedure TProducerPascal.GenerateCommonBlock(CommonBlock: TCommonBlock; LabelPrefix: string);
+procedure TProducerPascal.GenerateCommonBlockInterface(CommonBlock: TCommonBlock; LabelPrefix: string);
 var
   I: Integer;
   LabelName: string;
-begin
+  Section: TCommonBlockSection;
+begin
+  Inc(Indetation);
   with CommonBlock do begin
-    GenerateTypes(Types);
-    GenerateFunctions(Functions);
-    GenerateConstants(Constants);
-    GenerateVariableList(Variables);
+    for I := 0 to Order.Count - 1 do begin
+      if (Order[I] is TType) and (TType(Order[I]).Exported) then begin
+        if Section <> cbsType then begin
+          EmitLn;
+          Dec(Indetation);
+          EmitLn('type');
+          Inc(Indetation);
+        end;
+        Emit(TType(Order[I]).Name + ' = ');
+        GenerateType(TType(Order[I]));
+        EmitLn(';');
+        Section := cbsType;
+      end else
+      if (Order[I] is TVariable) and (TVariable(Order[I]).Exported) then begin
+        if Section <> cbsVariable then begin
+          EmitLn;
+          Dec(Indetation);
+          EmitLn('var');
+          Inc(Indetation);
+        end;
+        GenerateVariable(TVariable(Order[I]));
+        Section := cbsVariable;
+      end else
+      if (Order[I] is TConstant) and (TConstant(Order[I]).Exported) then begin
+        if Section <> cbsConstant then begin
+          EmitLn;
+          Dec(Indetation);
+          EmitLn('const');
+          Inc(Indetation);
+        end;
+        GenerateConstant(TConstant(Order[I]));
+        Section := cbsConstant;
+      end else
+      if (Order[I] is TFunction) and (TFunction(Order[I]).Exported) then begin
+        GenerateFunctionHead(TFunction(Order[I]));
+      end;
+    end;
+  end;
+  Dec(Indetation);
+end;
+
+procedure TProducerPascal.GenerateCommonBlockImplementation(
+  CommonBlock: TCommonBlock; LabelPrefix: string);
+var
+  I: Integer;
+  LabelName: string;
+  Section: TCommonBlockSection;
+begin
+  with CommonBlock do begin
+    for I := 0 to Order.Count - 1 do begin
+      if (Order[I] is TType) and (not TType(Order[I]).Exported) then begin
+        if Section <> cbsType then begin
+          EmitLn;
+          EmitLn('type');
+        end;
+        Emit(TType(Order[I]).Name + ' = ');
+        GenerateType(TType(Order[I]));
+        EmitLn(';');
+        Section := cbsType;
+      end else
+      if (Order[I] is TVariable) and (not TVariable(Order[I]).Exported) then begin
+        if Section <> cbsVariable then begin
+          EmitLn;
+          EmitLn('var');
+        end;
+        GenerateVariable(TVariable(Order[I]));
+        Section := cbsVariable;
+      end else
+      if (Order[I] is TConstant) and (not TConstant(Order[I]).Exported) then begin
+        if Section <> cbsConstant then begin
+          EmitLn;
+          EmitLn('const');
+        end;
+        GenerateConstant(TConstant(Order[I]));
+        Section := cbsConstant;
+      end else
+      if Order[I] is TFunction then begin
+        GenerateFunction(TFunction(Order[I]));
+      end;
+    end;
     GenerateBeginEnd(Code);
   end;