Changeset 67 for branches/Transpascal/Compiler

Timestamp:

Oct 18, 2010, 12:39:37 PM (15 years ago)

Author:

george

Message:

• Fixed: Parsing of strings.
• Modified: Now supported C target "Dynamic C" dialect.

Location:

branches/Transpascal/Compiler

Files:

• Analyze/UParser.pas (modified) (10 diffs)
• Produce/UProducerC.pas (modified) (6 diffs)
• UCompiler.pas (modified) (3 diffs)

branches/Transpascal/Compiler/Analyze/UParser.pas

@@ -11 +11 @@
 type
   TOnErrorMessage = procedure(Text: string; Position: TPoint; FileName: string) of object;
+
+  TParserState = (psNone, psIdentifier, psConstantNumber, psConstantString,
+    psOperator, psEndOfFile, psLineComment, psBlockComment1, psBlockComment2,
+    psUnknown, psWhiteSpace, psConstantStringEnd);
 
   TTokenType = (ttNone, ttIdentifier, ttConstantNumber, ttConstantString,
@@ -25 +29 @@
     FNextToken: string;
     FNextTokenType: TTokenType;
+    FParserState: TParserState;
     PreviousChar: char;
     CurrentChar: char;
@@ -36 +41 @@
     function ReadCode: string;
     function NextToken: string;
+    function NextTokenType: TTokenType;
     procedure Expect(Code: string);
     function IsWhiteSpace(Character: char): boolean;
@@ -216 +222 @@
   FNextToken := '';
   FNextTokenType := ttNone;
+  FParserState := psNone;
   with SourceCodeText do
     while True do
     begin
-      if CodeStreamPosition < Length(Text) then
-      begin
+      if CodeStreamPosition < Length(Text) then begin
         CurrentChar := Text[CodeStreamPosition];
-      end
-      else
-      begin
+      end else begin
         FNextToken := '';
+        FParserState := psEndOfFile;
         FNextTokenType := ttEndOfFile;
         Break;
       end;
 
-      if FNextTokenType = ttNone then
-      begin
+      if FParserState = psNone then begin
         if IsWhiteSpace(CurrentChar) then
-          FNextTokenType := ttWhiteSpace
+          FParserState := psWhiteSpace
         else
-        if CurrentChar = '{' then
-        begin
-          FNextTokenType := ttBlockComment1;
-        end
-        else
-        if CurrentChar = '''' then
-        begin
-          FNextTokenType := ttConstantString;
-        end
-        else
-        if CurrentChar in SpecChar then
-        begin
-          FNextTokenType := ttOperator;
+        if CurrentChar = '{' then begin
+          FParserState := psBlockComment1;
+        end else
+        if CurrentChar = '''' then begin
+          FParserState := psConstantString;
+        end else
+        if CurrentChar in SpecChar then begin
+          FParserState := psOperator;
           FNextToken := FNextToken + CurrentChar;
-        end
-        else
-        if IsAlphanumeric(CurrentChar) then
-        begin
-          FNextTokenType := ttIdentifier;
+        end else
+        if IsAlphanumeric(CurrentChar) then begin
+          FParserState := psIdentifier;
           FNextToken := FNextToken + CurrentChar;
-        end
-        else
-          FNextTokenType := ttUnknown;
-      end
-      else
-      if FNextTokenType = ttLineComment then
-      begin
+        end else FParserState := psUnknown;
+      end else
+      if FParserState = psLineComment then begin
         if (CurrentChar = #13) or (CurrentChar = #10) then
-          FNextTokenType := ttNone;
-      end
-      else
-      if FNextTokenType = ttBlockComment1 then
-      begin
+          FParserState := psNone;
+      end else
+      if FParserState = psBlockComment1 then begin
         if (CurrentChar = '}') then
-          FNextTokenType := ttNone;
-      end
-      else
-      if FNextTokenType = ttBlockComment2 then
-      begin
+          FParserState := psNone;
+      end else
+      if FParserState = psBlockComment2 then begin
         if (PreviousChar = '*') and (CurrentChar = ')') then
-          FNextTokenType := ttNone;
-      end
-      else
-      if FNextTokenType = ttConstantString then
-      begin
-        if (CurrentChar = '''') and (PreviousChar = '''') then
-          Break
-        else
-          FNextToken := FNextToken + CurrentChar;
-      end
-      else
-      if FNextTokenType = ttOperator then
+          FParserState := psNone;
+      end else
+      if FParserState = psConstantString then
+      begin
+        if (CurrentChar = '''') then begin
+          FParserState := psConstantStringEnd;
+        end else FNextToken := FNextToken + CurrentChar;
+      end else
+      if FParserState = psConstantStringEnd then
+      begin
+        if (CurrentChar = '''') then begin
+          FParserState := psConstantString;
+        end else FParserState := psNone;
+        FNextTokenType := ttConstantString;
+        Break;
+      end else
+      if FParserState = psOperator then
       begin
         if (CurrentChar = '*') and (PreviousChar = '(') then
         begin
           FNextToken := '';
-          FNextTokenType := ttBlockComment2;
-        end
-        else
+          FParserState := psBlockComment2;
+        end else
         if (CurrentChar = '/') and (PreviousChar = '/') then
         begin
           FNextToken := '';
-          FNextTokenType := ttLineComment;
+          FParserState := psLineComment;
+        end else
+        if not (CurrentChar in SpecChar) then begin
+          FNextTokenType := ttOperator;
+          Break;
         end
-        else
-        if not (CurrentChar in SpecChar) then
-          Break
-        else
-        begin
+        else begin
           J := 0;
           while (J < Length(DoubleSpecChar)) and
@@ -310 +303 @@
           if J < Length(DoubleSpecChar) then
             FNextToken := FNextToken + CurrentChar
-          else
+          else begin
+            FNextTokenType := ttOperator;
             Break;
-        end;
+          end;
+        end;
+      end else
+      if FParserState = psIdentifier then
+      begin
+        if not IsAlphanumeric(CurrentChar) then begin
+          FNextTokenType := ttIdentifier;
+          Break;
+        end else FNextToken := FNextToken + CurrentChar;
       end
       else
-      if FNextTokenType = ttIdentifier then
-      begin
-        if not IsAlphanumeric(CurrentChar) then
-          Break
-        else
-          FNextToken := FNextToken + CurrentChar;
-      end
-      else if FNextTokenType = ttWhiteSpace then
-        FNextTokenType := ttNone;
-
-      if FNextTokenType <> ttNone then
-      begin
+      if FParserState = psWhiteSpace then begin
+        FParserState := psNone;
+      end;
+
+      if FParserState <> psNone then begin
         // Update cursor position
         Inc(CodePosition.X);
-        if (CurrentChar = #13) then
-        begin
+        if (CurrentChar = #13) then begin
           CodePosition.X := 1;
           Inc(CodePosition.Y);
@@ -351 +345 @@
 begin
   Result := FNextToken;
+end;
+
+function TBaseParser.NextTokenType: TTokenType;
+begin
+  Result := FNextTokenType;
 end;
 
@@ -397 +396 @@
 var
   Identifier: string;
+  IdentifierType: TTokenType;
   NewVariable: TVariable;
   NewExpression: TExpression;
@@ -409 +409 @@
   Expressions.Add(TExpression.Create);
   with SourceCode do begin
-    while ((FNextToken <> ';') and (FNextToken <> ',') and
-        (not IsKeyWord(FNextToken))) and not
-      (((FNextToken = ')') or (FNextToken = ']'))) do begin
+    while ((NextToken <> ';') and (NextToken <> ',') and (not IsKeyWord(NextToken))) and not
+      (((NextToken = ')') or (NextToken = ']'))) and not (NextTokenType = ttEndOfFile) do begin
+      IdentifierType := NextTokenType;
       Identifier := ReadCode;
       if Identifier = '(' then begin
@@ -506 +506 @@
           TExpression(SubItems[1]).NodeType := ntConstant;
 
-          if Identifier[1] = '''' then begin
+          if IdentifierType = ttConstantString then begin
             TExpression(SubItems[1]).Value := Identifier;
             //SetLength(TExpression(SubItems[1]).Value, Length(Identifier));
@@ -512 +512 @@
             //  TExpression(SubItems[1]).Value[I - 1] := Byte(Identifier[I]);
           end else begin
-            TExpression(SubItems[1]).Value := Identifier;
+            TExpression(SubItems[1]).Value := StrToInt(Identifier);
           end;
         end;

branches/Transpascal/Compiler/Produce/UProducerC.pas

@@ -10 +10 @@
 
 type
+
+  TProducerCDialect = (pdGCC, pdDynamicC);
 
   { TProducerC }
@@ -35 +37 @@
     function GenerateExpression(Expression: TExpression): string;
   public
+    Dialect: TProducerCDialect;
     TextSource: TStringList;
     IndentationLength: Integer;
@@ -53 +56 @@
   FileExtension := '.c';
   IndentationLength := 2;
+  Dialect := pdDynamicC;
 end;
 
@@ -104 +108 @@
 begin
   for I := 0 to UsedModules.Count - 1 do
-    Emit('#include "' + TUsedModule(UsedModules[I]).Name + '.h"');
+    if Dialect = pdDynamicC then
+      Emit('#use "' + TUsedModule(UsedModules[I]).Name + '.lib"')
+      else Emit('#include "' + TUsedModule(UsedModules[I]).Name + '.h"');
   Emit('');
 end;
@@ -110 +116 @@
 procedure TProducerC.GenerateModule(Module: TModule);
 begin
-  Emit('#define int8 char');
-  Emit('#define int16 int');
-  Emit('#define int32 long');
-  Emit('#define uint8 unsigned char');
-  Emit('#define uint16 unsigned int');
-  Emit('#define uint32 unsigned long');
+  if Dialect = pdDynamicC then Emit('#use "platform.lib"')
+    else Emit('#include "platform.h"');
   Emit('');
   if Module is TModuleProgram then begin
+    TModuleProgram(Module).Body.Name := 'main';
     GenerateUses(TModuleProgram(Module).UsedModules);
     GenerateCommonBlock(TModuleProgram(Module).Body, '');
@@ -253 +256 @@
 begin
   case Expression.NodeType of
-    ntConstant: Result := Expression.Value;
+    ntConstant: begin
+      if VarType(Expression.Value) = varString then
+        Result := '"' + Expression.Value + '"'
+        else Result := Expression.Value;
+    end;
     ntVariable: Result := Expression.Variable.Name;
     ntFunction: Result := Expression.Method.Name;

branches/Transpascal/Compiler/UCompiler.pas

@@ -45 +45 @@
     destructor Destroy; override;
     procedure Init;
-    procedure Compile(ModuleName: string; Source: TStringList);
+    procedure Compile(ModuleName: string; Source: TStringList; TargetFolder: string);
     property OnErrorMessage: TOnErrorMessage read FOnErrorMessage
       write FOnErrorMessage;
@@ -54 +54 @@
 { TCompiler }
 
-procedure TCompiler.Compile(ModuleName: string; Source: TStringList);
+procedure TCompiler.Compile(ModuleName: string; Source: TStringList;
+  TargetFolder: string);
 var
   NewModule: TModule;
@@ -70 +71 @@
       Producer.Produce(TModule(ProgramCode.Modules[I]));
       Producer.AssignToStringList(ProducedCode);
-      ForceDirectories(CompiledFolder + DirectorySeparator + Producer.ClassName);
-      ProducedCode.SaveToFile(CompiledFolder + DirectorySeparator + Producer.ClassName +
+      ForceDirectories(TargetFolder + DirectorySeparator +
+        CompiledFolder + DirectorySeparator + Producer.ClassName);
+      ProducedCode.SaveToFile(TargetFolder + DirectorySeparator +
+        CompiledFolder + DirectorySeparator + Producer.ClassName +
         DirectorySeparator + TModule(ProgramCode.Modules[I]).Name + Producer.FileExtension);
     end;