dws2unitutils.pas

script language

{**********************************************************************}
{                                                                      }
{    "The contents of this file are subject to the Mozilla Public      }
{    License Version 1.1 (the "License"); you may not use this         }
{    file except in compliance with the License. You may obtain        }
{    a copy of the License at                                          }
{                                                                      }
{    http://www.mozilla.org/MPL/                                       }
{                                                                      }
{    Software distributed under the License is distributed on an       }
{    "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express       }
{    or implied. See the License for the specific language             }
{    governing rights and limitations under the License.               }
{                                                                      }
{    The Original Code is dws2UnitUtils source code, released          }
{    October 1, 2002                                                   }
{                                                                      }
{    The Initial Developer of the Original Code is Mark Ericksen       }
{    Portions created by Mark Ericksen are                             }
{    Copyright (C) 2002 Mark Ericksen, United States of America.       }
{    All Rights Reserved.                                              }
{                                                                      }
{**********************************************************************}

{$I dws2.inc}

unit dws2UnitUtils;

interface

uses
{$IFDEF NEWVARIANTS}
  Variants,
{$ENDIF}
  SysUtils, Classes, dws2Symbols, dws2Comp, dws2Exprs;

procedure UnitToScript(AUnit: Tdws2Unit; ScriptLines: TStrings; ClearLines: Boolean = True);
procedure ScriptToUnit(AUnit: Tdws2Unit; AProgram: TProgram; RemoveUndeclared: Boolean = True);
//
procedure GetUnitSymbolText(Symbol: Tdws2Symbol; ScriptLines, ForwardedImpl: TStrings; PreceedingText: string=''; FuncAsForward: Boolean=True);
function GetFunctionText(AClassName: string; Func: Tdws2Function; BareBones: Boolean): string;
procedure AddUpdateSymbolToCollection(Collection: Tdws2Collection; Symbol: TSymbol);
function GetOrCreateSymbolInCollection(Collection: Tdws2Collection; const SymbolName: string): Tdws2Symbol;
procedure PruneCollectionToTable(Collection: Tdws2Collection; SymbolTable: TSymbolTable);
procedure SortUnitToScript(AUnit: Tdws2Unit; AProgram: TProgram);
procedure SortCollectionToScript(Collection: Tdws2Collection;
                                 ATable: TSymbolTable; UsageType: TSymbolUsage;
                                 Dictionary: TSymbolDictionary);
procedure AddWarningsForUnsupportedTypes(AProgram: TProgram);

//
function IndexOfName(Collection: Tdws2Collection; const AName: string): Integer;
function TypesAreEquivalents(ASym: Tdws2Symbol; BSym: TSymbol): Boolean;
function TypeIsSupportedInUnit(Symbol: TSymbol): Boolean;
function MethodClassSymbol(Method: Tdws2Function): Tdws2Class;
function MethodClassSymbolName(Method: Tdws2Function): string;

// Find the function symbol (TFuncSymbol) that matches the unit function symbol (Tdws2Function)
function FindSymbolForUnitFunction(AProgram: TProgram; AUnitFunc: Tdws2Function): TFuncSymbol;

implementation

procedure GetUnitSymbolText(Symbol: Tdws2Symbol; ScriptLines, ForwardedImpl: TStrings; PreceedingText: string; FuncAsForward: Boolean);
var
  DefValue: string;
  ClassAncestor: string;
  j: Integer;
  isAbstract: Boolean;
begin
  { Forward Symbol }
  if Symbol is Tdws2Forward then
    ScriptLines.Add(PreceedingText +
                    Format('type %s = class;', [Symbol.Name]))
  { Constant Symbol }
  else if Symbol is Tdws2Constant then
  begin
    if Tdws2Constant(Symbol).DataType = 'String' then
      DefValue := Format('''%s''',[VarToStr(Tdws2Constant(Symbol).Value)])
    else if Tdws2Constant(Symbol).DataType = 'DateTime' then
      DefValue := Format('DateTime(%f)',[Double(Tdws2Constant(Symbol).Value)])
    else
      DefValue := VarToStr(Tdws2Constant(Symbol).Value);

    ScriptLines.Add(PreceedingText +
                    Format('const %s : %s = %s;', [Tdws2Constant(Symbol).Name,
                                                   Tdws2Constant(Symbol).DataType,
                                                   DefValue]));
  end
  { Enumeration Symbol }
  else if Symbol is Tdws2Enumeration then
  begin
    ScriptLines.Add(PreceedingText +
                    Format('type %s;', [Symbol.DisplayName]));
  end
  { Synonym Symbol }
  else if Symbol is Tdws2Synonym then
  begin
    ScriptLines.Add(PreceedingText +
                    Format('type %s = %s;', [Symbol.Name, Tdws2Synonym(Symbol).DataType]));
  end
  { Array Symbol }
  else if Symbol is Tdws2Array then
  begin
    if Tdws2Array(Symbol).IsDynamic then
      ScriptLines.Add(PreceedingText +
                      Format('type %s = array of %s;',
                             [Tdws2Array(Symbol).Name,
                              Tdws2Array(Symbol).DataType]))
    else
      ScriptLines.Add(PreceedingText +
                      Format('type %s = array[%d..%d] of %s;',
                             [Tdws2Array(Symbol).Name,
                              Tdws2Array(Symbol).LowBound,
                              Tdws2Array(Symbol).HighBound,
                              Tdws2Array(Symbol).DataType]));
  end
  { Record Symbol }
  else if Symbol is Tdws2Record then
  begin
    ScriptLines.Add(PreceedingText +
                    'type');
    ScriptLines.Add(PreceedingText +
                    Format('  %s = record', [Tdws2Record(Symbol).Name]));
    for j := 0 to Tdws2Record(Symbol).Members.Count - 1 do
      GetUnitSymbolText(Tdws2Record(Symbol).Members.Items[j], ScriptLines, nil, PreceedingText + '    ');
    ScriptLines.Add(       '  end;');
  end
  { Record Member Symbol }
  else if Symbol is Tdws2Member then
  begin
    ScriptLines.Add(PreceedingText +
                    Format('%s : %s;', [Tdws2Member(Symbol).Name,
                                        Tdws2Member(Symbol).DataType]));
  end
  { Class Symbol }
  else if Symbol is Tdws2Class then
  begin
    ClassAncestor := Tdws2Class(Symbol).Ancestor;
    if ClassAncestor <> '' then
      ClassAncestor := '('+ClassAncestor+')';
    ScriptLines.Add(PreceedingText +
                           'type');
    ScriptLines.Add(PreceedingText +
                    Format('  %s = class%s', [Tdws2Class(Symbol).Name, ClassAncestor]));
    // Class fields
    for j := 0 to Tdws2Class(Symbol).Fields.Count - 1 do
      GetUnitSymbolText(Tdws2Class(Symbol).Fields.Items[j], ScriptLines, nil, PreceedingText + '    ');
    // Class Constructors
    for j := 0 to Tdws2Class(Symbol).Constructors.Count - 1 do
      GetUnitSymbolText(Tdws2Class(Symbol).Constructors.Items[j], ScriptLines, ForwardedImpl, PreceedingText, FuncAsForward);
    // Class Methods
    for j := 0 to Tdws2Class(Symbol).Methods.Count - 1 do
      GetUnitSymbolText(Tdws2Class(Symbol).Methods.Items[j], ScriptLines, ForwardedImpl, PreceedingText, FuncAsForward);
    // Class Properties
    for j := 0 to Tdws2Class(Symbol).Properties.Count - 1 do
      GetUnitSymbolText(Tdws2Class(Symbol).Properties.Items[j], ScriptLines, nil, PreceedingText +'    ');
    ScriptLines.Add(PreceedingText +'  end;');
  end
  { Class Field Symbol }
  else if Symbol is Tdws2Field then
  begin
    ScriptLines.Add(PreceedingText +
                    Format('%s : %s;', [Tdws2Field(Symbol).Name,
                                        Tdws2Field(Symbol).DataType]));
  end
  { Class Method Symbol - Should be before Function Symbol (FuncSymbol is an ancestor type) }
  else if (Symbol is Tdws2Method) or (Symbol is Tdws2Constructor) then
  begin
    // get method name for Class declaration
    ScriptLines.Add(PreceedingText +'    '+GetFunctionText('', Tdws2Function(Symbol), False));
    if Symbol is Tdws2Method then
      isAbstract := (maAbstract in Tdws2Method(Symbol).Attributes)
    else if Symbol is Tdws2Constructor then
      isAbstract := (maAbstract in Tdws2Constructor(Symbol).Attributes)
    else
      isAbstract := False;

    // get method name for method implementation if NOT abstract
    if Assigned(ForwardedImpl) and (not isAbstract) then
    begin
      ForwardedImpl.Add(GetFunctionText(MethodClassSymbolName(Tdws2Method(Symbol)), Tdws2Method(Symbol), True));
      ForwardedImpl.Add('begin');
      ForwardedImpl.Add('  // Do NOT put code here. This is here to make script valid.');
      ForwardedImpl.Add('end;');
      ForwardedImpl.Add('');
    end;
  end
  { Class Property Symbol }
  else if Symbol is Tdws2Property then
  begin
    ScriptLines.Add(PreceedingText +
                    Format('%s', [Symbol.DisplayName]));
  end
  { Function Symbol }
  else if (Symbol is Tdws2Function) and not (Symbol is Tdws2Constructor) then
  begin
    DefValue := PreceedingText + GetFunctionText('',  Tdws2Function(Symbol), False);
    if FuncAsForward then
      DefValue := DefValue + ' forward;';  // make it a forward declaration
    ScriptLines.Add(DefValue);

    if Assigned(ForwardedImpl) then
    begin
      ForwardedImpl.Add(GetFunctionText('',  Tdws2Function(Symbol), False));
      ForwardedImpl.Add('begin');
      ForwardedImpl.Add('  // Do NOT put code here. This is here to make script valid.');
      ForwardedImpl.Add('end;');
      ForwardedImpl.Add('');
    end;
  end
  { Variable Symbol }
  else if Symbol is Tdws2Variable then
  begin
    ScriptLines.Add(PreceedingText +
                    Format('var %s : %s;', [Tdws2Variable(Symbol).Name,
                                            Tdws2Variable(Symbol).DataType]));
  end;
end;

function GetFunctionText(AClassName: string; Func: Tdws2Function; BareBones: Boolean): string;
var
  i: Integer;
  TypeText: string;
  Params: string;
  Attrib: TMethodAttributes;
begin
  { Assemble the method text piece-wise. }

  // if a method of an object
  if (Func is Tdws2Method) or (Func is Tdws2Constructor) then
  begin
    Params := '';
    if not BareBones then
    begin
      for i := 0 to Func.Parameters.Count - 1 do
      begin
        // if not the first one, add ';' to end
        if i > 0 then
          Params := Params + '; ';
        // add param name (prepend prefix)
        Params := Params + Func.Parameters.Items[i].DisplayName;
      end;
      // Put '()' around parameters if used.
      if Params <> '' then
        Params := '(' + Params + ')';      // wrap up parameters
    end;

    { Get the method kind and build the base }
    TypeText := '';
    if (Func is Tdws2Method) then
    begin
      case Tdws2Method(Func).Kind of
        mkClassProcedure, mkProcedure: TypeText := 'procedure';
        mkClassFunction, mkFunction:   TypeText := 'function';
        mkConstructor:  TypeText := 'constructor';
        mkDestructor:   TypeText := 'destructor';
      else
        Assert(false); // if triggered, this func needs upgrade !
      end;
    end
    else if Func is Tdws2Constructor then
      TypeText := 'constructor';

    { if a class name is provided, add the '.' to the end (used in implementations) }
    if AClassName <> '' then
      AClassName := AClassName + '.';

    { Assemble method with method type, ClassName(if desired), Method name and parameters. }
    Result := Format('%s %s%s', [TypeText, AClassName, Func.Name + Params]);
    { If method kind is a 'class' method, add the 'class' directive }
    if Func is Tdws2Method then
    begin
      if Tdws2Method(Func).Kind in [mkClassProcedure, mkClassFunction] then
        Result := 'class '+Result;
      { If method has a result, add the result type }
      if (Tdws2Method(Func).ResultType <> '') and (not BareBones) then
        Result := Result + ' : ' + Tdws2Method(Func).ResultType;
    end;
    { Method declaration complete. Add trailing semi-colon }
    Result := Result + ';';

    { Add method attributes only if for class declaration }
    if AClassName = '' then begin
      if Func is Tdws2Method then
        Attrib := Tdws2Method(Func).Attributes
      else
        Attrib := Tdws2Constructor(Func).Attributes;

      if maOverride in Attrib then   // overrides will also be marked as virtual
        Result := Result + ' override;'
      else if maVirtual in Attrib then
        Result := Result + ' virtual;';
      if maReintroduce in Attrib then
        Result := Result + ' reintroduce;';
      if maAbstract in Attrib then
        Result := Result + ' abstract;';
    end;
  end
  // if a plain function (not method)
  else
    Result := Func.DisplayName;
end;

procedure AddUpdateSymbolToCollection(Collection: Tdws2Collection; Symbol: TSymbol);
var
  UseSym: Tdws2Symbol;
  i: Integer;
//  funcSym: TFuncSymbol; // pointer for easier use
begin
  { Create or update the Unit declarations based on script symbols. }

  { Get or create the symbol in the desired collection. Settings will follow. }
  UseSym := GetOrCreateSymbolInCollection(Collection, Symbol.Name);// is not called here because of

  { Symbol is Array }
  if Symbol is TCustomArraySymbol then begin
    with Tdws2Array(UseSym) do begin
      DataType  := TArraySymbol(Symbol).Typ.Name;
      if Symbol is TDynamicArraySymbol then
        IsDynamic := True
      else
      begin
        LowBound  := TArraySymbol(Symbol).LowBound;
        HighBound := TArraySymbol(Symbol).HighBound;
      end;
    end;
  end;
  { Symbol is Class (Classes or Forwards) }
  if Symbol is TClassSymbol then begin
    { If collection is Classes (no additional processing for forwards) }
    if Collection is Tdws2Classes then begin
      with UseSym as Tdws2Class do begin
        { Ancestor }
          { NOTE: Class will never have a 'nil' parent. If parent is TObject, don't write out the ancestor name.
             This has the side effect of explicitly declared TObject ancestors will be changed to implied. }
        Ancestor  := TClassSymbol(Symbol).Parent.Name;
        if Ancestor = 'TObject' then
          Ancestor  := '';
        { Synch members of class (Fields, Methods, Properties }
        for i := 0 to TClassSymbol(Symbol).Members.Count - 1 do begin
          { Synch Fields }
          if TClassSymbol(Symbol).Members[i] is TFieldSymbol then
            AddUpdateSymbolToCollection(Fields, TClassSymbol(Symbol).Members[i]);
          { Synch Methods }
          if TClassSymbol(Symbol).Members[i] is TMethodSymbol then
          begin
            { Synch Constructors - write to Constructors collection }
            if TMethodSymbol(TClassSymbol(Symbol).Members[i]).Kind = fkConstructor then
              AddUpdateSymbolToCollection(Constructors, TClassSymbol(Symbol).Members[i])
            { Synch Methods - regular methods get written }