RemObjects Pascal Script for Delphi

Review 1: patch for unit support

Created:2009-12-11 09:06:17 (3 years 3 months ago)
Updated:3 years 3 months ago
Author:Carlo Kok
Commit:193
Description:patch for unit support

patch from MfG Natter for improved unit support
Reviewers:Carlo Kok, Mason Wheeler,
Files: uPSCompiler.pas (16 diffs, 2 comments)
uPSUtils.pas (2 diffs, 1 comment)
 Archive Download the corresponding diff file
uPSCompiler.pas
OldNew
748 748 
749 749 
750 750 
751 751 
752 752 
753 753 
754 754 
755 755 
756 756 
757 757 
758    ecInvalidnumberOfParameters758    ecInvalidnumberOfParameters
759    {$IFDEF PS_USESSUPPORT}759    {$IFDEF PS_USESSUPPORT}
760    , ecNotAllowed,760    , ecNotAllowed,
761    ecUnitNotFoundOrContainsErrors 
 761    ecUnitNotFoundOrContainsErrors,
 762    ecCrossReference
762    {$ENDIF}763    {$ENDIF}
763    );764    );
764 765 
... ... 
935 936 
936 937 
937 938 
938 939 
939 940 
940 941 
941 942 
942 943 
943 944 
944 945 
945    {$IFDEF PS_USESSUPPORT}946    {$IFDEF PS_USESSUPPORT}
946    FUnitInits : TPSList; //nvds947    FUnitInits : TPSList; //nvds
947    FUnitFinits: TPSList; //nvds948    FUnitFinits: TPSList; //nvds
948    FUses : TIFStringList; 
 949    FUses : TPSStringList;
 950    fUnits : TPSUnitList;
 951    fUnit : TPSUnit;
949    fModule : tbtString;952    fModule : tbtString;
950    {$ENDIF}953    {$ENDIF}
951    fInCompile : Integer;954    fInCompile : Integer;
... ... 
1007 1010 
1008 1011 
1009 1012 
1010 1013 
1011 1014 
1012 1015 
1013 1016 
1014 1017 
1015 1018 
1016 1019 
1017    function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;1020    function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
1018 1021 
1019    function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;1022    function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
 1023    function IsInLokalUnitList(s: tbtString): Boolean;
1020 1024 
1021    function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;1025    function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
1022 1026 
... ... 
1768 1772 
1769 1773 
1770 1774 
1771 1775 
1772 1776 
1773 1777 
1774 1778 
1775 1779 
1776 1780 
1777 1781 
1778  {$IFDEF PS_USESSUPPORT}1782  {$IFDEF PS_USESSUPPORT}
1779  RPS_NotAllowed = '%s is not allowed at this position';1783  RPS_NotAllowed = '%s is not allowed at this position';
1780  RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors';1784  RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors';
 1785  RPS_CrossReference = 'Cross-Reference error of ''%s''';
1781  {$ENDIF}1786  {$ENDIF}
1782 1787 
1783 1788 
... ... 
2252 2257 
2253 2258 
2254 2259 
2255 2260 
2256 2261 
2257 2262 
2258 2263 
2259 2264 
2260 2265 
2261 2266 
2262    else2267    else
2263    begin2268    begin
2264      if (TPSExternalProcedure(x).RegProc.NameHash = h) and2269      if (TPSExternalProcedure(x).RegProc.NameHash = h) and
2265        (TPSExternalProcedure(x).RegProc.Name = Name) then 
 2270        (TPSExternalProcedure(x).RegProc.Name = Name) and
 2271        (IsInLokalUnitList(TPSInternalProcedure(x).DeclareUnit)) then
2266      begin2272      begin
2267        Result := l;2273        Result := l;
2268        exit;2274        exit;
... ... 
3549 3555 
3550 3556 
3551 3557 
3552 3558 
3553 3559 
3554 3560 
3555 3561 
3556 3562 
3557 3563 
3558 3564 
3559    exit;3565    exit;
3560  end;3566  end;
3561  if dcTypes in Check then3567  if dcTypes in Check then
 3568  begin
3562  for l := FTypes.Count - 1 downto 0 do3569  for l := FTypes.Count - 1 downto 0 do
3563  begin3570  begin
3564    if (TPSType(FTypes.Data[l]).NameHash = h) and3571    if (TPSType(FTypes.Data[l]).NameHash = h) and
... ... 
7518 7525 
7519 7526 
7520 7527 
7521 7528 
7522 7529 
7523 7530 
7524 7531 
7525 7532 
7526 7533 
7527 7534 
7528    for l := 0 to FVars.Count - 1 do7535    for l := 0 to FVars.Count - 1 do
7529    begin7536    begin
7530      if (TPSVar(FVars[l]).NameHash = h) and7537      if (TPSVar(FVars[l]).NameHash = h) and
7531        (TPSVar(FVars[l]).Name = s) then 
 7538        (TPSVar(FVars[l]).Name = s) and
 7539        (IsInLokalUnitList(TPSVar(FVars[l]).FDeclareUnit)) then
7532      begin7540      begin
7533        TPSVar(FVars[l]).Use;7541        TPSVar(FVars[l]).Use;
7534        Result := TPSValueGlobalVar.Create;7542        Result := TPSValueGlobalVar.Create;
... ... 
7605 7613 
7606 7614 
7607 7615 
7608 7616 
7609 7617 
7610 7618 
7611 7619 
7612 7620 
7613 7621 
7614 7622 
7615    for l := 0 to FConstants.Count -1 do7623    for l := 0 to FConstants.Count -1 do
7616    begin7624    begin
7617      t := TPSConstant(FConstants[l]);7625      t := TPSConstant(FConstants[l]);
7618      if (t.NameHash = h) and (t.Name = s) then 
 7626      if (t.NameHash = h) and (t.Name = s) and
 7627        (IsInLokalUnitList(t.FDeclareUnit)) then
7619      begin7628      begin
7620        if FType <> 0 then7629        if FType <> 0 then
7621        begin7630        begin
... ... 
11094 11103 
11095 11104 
11096 11105 
11097 11106 
11098 11107 
11099 11108 
11100 11109 
11101 11110 
11102 11111 
11103 11112 
11104  OldFileName: tbtString;11113  OldFileName: tbtString;
11105  OldParser : TPSPascalParser;11114  OldParser : TPSPascalParser;
11106  OldIsUnit : Boolean;11115  OldIsUnit : Boolean;
 11116  OldUnit : TPSUnit;
11107  {$ENDIF}11117  {$ENDIF}
11108 11118 
11109  procedure Cleanup;11119  procedure Cleanup;
... ... 
11171 11181 
11172 11182 
11173 11183 
11174 11184 
11175 11185 
11176 11186 
11177 11187 
11178 11188 
11179 11189 
11180 11190 
11181    FUnitFinits.Free; //11191    FUnitFinits.Free; //
11182    FUnitFinits := nil; //11192    FUnitFinits := nil; //
11183 11193 
11184    FUses.Free; 
11185    FUses:=nil; 
 11194    FreeAndNil(fUnits);
 11195    FreeAndNil(FUses);
11186    fInCompile:=0;11196    fInCompile:=0;
11187    {$ENDIF}11197    {$ENDIF}
11188  end;11198  end;
... ... 
11732 11742 
11733 11743 
11734 11744 
11735 11745 
11736 11746 
11737 11747 
11738 11748 
11739 11749 
11740 11750 
11741 11751 
11742          {$ENDIF}11752          {$ENDIF}
11743        end;11753        end;
11744      end;11754      end;
 11755      if fUnits.GetUnit(S).HasUses(fModule) then
 11756      begin
 11757        MakeError('', ecCrossReference, s);
 11758        Result := False;
 11759        exit;
 11760      end;
 11761 
 11762      fUnit.AddUses(S);
 11763 
11745      {$IFDEF PS_USESSUPPORT}11764      {$IFDEF PS_USESSUPPORT}
11746      if Parse then11765      if Parse then
11747      begin11766      begin
... ... 
11828 11847 
11829 11848 
11830 11849 
11831 11850 
11832 11851 
11833 11852 
11834 11853 
11835 11854 
11836 11855 
11837 11856 
11838    FUnitFinits:= TPSList.Create; //nvds11857    FUnitFinits:= TPSList.Create; //nvds
11839 11858 
11840    FUses:=TIFStringList.Create;11859    FUses:=TIFStringList.Create;
 11860    FUnits:=TPSUnitList.Create;
11841    {$ENDIF}11861    {$ENDIF}
11842  {$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF}11862  {$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF}
11843 11863 
... ... 
11866 11886 
11867 11887 
11868 11888 
11869 11889 
11870 11890 
11871 11891 
11872 11892 
11873 11893 
11874 11894 
11875 11895 
11876  {$IFDEF PS_USESSUPPORT}11896  {$IFDEF PS_USESSUPPORT}
11877    fModule:=OldFileName;11897    fModule:=OldFileName;
11878    OldParser:=nil;11898    OldParser:=nil;
 11899    OldUnit:=nil;
11879    OldIsUnit:=false; // defaults11900    OldIsUnit:=false; // defaults
11880  end11901  end
11881  else11902  else
11882  begin11903  begin
11883    OldParser:=FParser;11904    OldParser:=FParser;
11884    OldIsUnit:=FIsUnit;11905    OldIsUnit:=FIsUnit;
 11906    OldUnit:=fUnit;
11885    FParser:=TPSPascalParser.Create;11907    FParser:=TPSPascalParser.Create;
11886    FParser.SetText(s);11908    FParser.SetText(s);
11887  end;11909  end;
11888 11910 
 11911  fUnit:=fUnits.GetUnit(fModule);
 11912 
11889  inc(fInCompile);11913  inc(fInCompile);
11890  {$ENDIF}11914  {$ENDIF}
11891 11915 
... ... 
12172 12196 
12173 12197 
12174 12198 
12175 12199 
12176 12200 
12177 12201 
12178 12202 
12179 12203 
12180 12204 
12181 12205 
12182    fParser.Free;12206    fParser.Free;
12183    fParser:=OldParser;12207    fParser:=OldParser;
12184    fIsUnit:=OldIsUnit;12208    fIsUnit:=OldIsUnit;
 12209    fUnit:=OldUnit;
12185    result:=true;12210    result:=true;
12186  end;12211  end;
12187  {$ENDIF}12212  {$ENDIF}
... ... 
13561 13586 
13562 13587 
13563 13588 
13564 13589 
13565 13590 
13566 13591 
13567 13592 
13568 13593 
13569 13594 
13570 13595 
13571  result := nil;13596  result := nil;
13572end;13597end;
13573 13598 
 13599function TPSPascalCompiler.IsInLokalUnitList(s: string): Boolean;
 13600begin
 13601  s:=FastUpperCase(s);
 13602  if (s=FastUpperCase(fModule)) or (s='SYSTEM') then
 13603  begin
 13604    result:=true;
 13605    exit;
 13606  end;
 13607  result:=fUnit.HasUses(S);
 13608end;
 13609 
13574{ TPSType }13610{ TPSType }
13575 13611 
13576constructor TPSType.Create;13612constructor TPSType.Create;
... ... 
13986 14022 
13987 14023 
13988 14024 
13989 14025 
13990 14026 
13991 14027 
13992 14028 
13993 14029 
13994 14030 
13995 14031 
13996    {$IFDEF PS_USESSUPPORT}14032    {$IFDEF PS_USESSUPPORT}
13997    ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param]));14033    ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param]));
13998    ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param]));14034    ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param]));
 14035    ecCrossReference: Result:=Format(RPS_CrossReference,[Param]);
13999    {$ENDIF}14036    {$ENDIF}
14000  else14037  else
14001    Result := tbtstring(RPS_UnknownError);14038    Result := tbtstring(RPS_UnknownError);

Comment 1 by Carlo Kok, Dec 11, 2009

IsInLokalUnitList should be IsInLocalUnitList but besides that it 
looks quite.

Comment 2 by Mason Wheeler, Dec 12, 2009

This is helpful, but it doesn't solve the fundamental problem with 
the way USES has been implemented.  To demonstrate the problem, 
create two units, both containing a procedure in the interface 
section named "DoSomething".  Create a program file that 
uses both units.  This is perfectly valid Pascal, but it gives a 
duplicate identifier error and won't compile under PascalScript.

The USES code has to be rearchitected to make this work correctly.
uPSUtils.pas
OldNew
395 395 
396 396 
397 397 
398 398 
399 399 
400 400 
401 401 
402 402 
403 403 
404 404 
405  end;405  end;
406  TIFStringList = TPsStringList;406  TIFStringList = TPsStringList;
407 407 
 408  TPSUnitList = class;
408 409 
 410  TPSUnit = class(TObject)
 411  private
 412    fList : TPSUnitList;
 413    fUnits : TPSList;
 414    fUnitName : TbtString;
 415    procedure SetUnitName(const Value: TbtString);
 416  public
 417    constructor Create(List: TPSUnitList);
 418 
 419    destructor Destroy; override;
 420 
 421    procedure AddUses(pUnitName: TbtString);
 422 
 423    function HasUses(pUnitName: TbtString): Boolean;
 424 
 425    property UnitName: TbtString read fUnitName write SetUnitName;
 426  end;
 427 
 428  TPSUnitList = class
 429  private
 430    fList: TPSList;
 431    function Add: TPSUnit;
 432 
 433  public
 434    constructor Create;
 435 
 436    function GetUnit(UnitName: TbtString): TPSUnit;
 437 
 438    destructor Destroy; override;
 439  end;
 440 
 441 
 442 
409type443type
410 444 
411  TPSPasToken = (445  TPSPasToken = (
... ... 
1577 1611 
1578 1612 
1579 1613 
1580 1614 
1581 1615 
1582 1616 
1583 1617 
1584 1618 
1585 1619 
1586 1620 
1587  result := -1;1621  result := -1;
1588end;1622end;
1589 1623 
 1624{ TPSUnitList }
 1625 
 1626function TPSUnitList.Add: TPSUnit;
 1627begin
 1628  result:=TPSUnit.Create(Self);
 1629 
 1630  fList.Add(result);
 1631end;
 1632 
 1633constructor TPSUnitList.Create;
 1634begin
 1635  fList:=TPSList.Create;
 1636end;
 1637 
 1638destructor TPSUnitList.Destroy;
 1639var
 1640  Dummy: Integer;
 1641begin
 1642  for Dummy:=0 to fList.Count-1 do
 1643    TObject(fList[Dummy]).Free;
 1644 
 1645  FreeAndNil(fList);
 1646  
 1647  inherited;
 1648end;
 1649 
 1650function TPSUnitList.GetUnit(UnitName: TbtString): TPSUnit;
 1651var
 1652  Dummy: Integer;
 1653begin
 1654  UnitName:=FastUpperCase(UnitName);
 1655  for Dummy:=0 to fList.Count-1 do
 1656  begin
 1657    if TPSUnit(fList[Dummy]).UnitName=UnitName then
 1658    begin
 1659      result:=TPSUnit(fList[Dummy]);
 1660      exit;
 1661    end;
 1662  end;
 1663 
 1664  result:=Add;
 1665 
 1666  result.UnitName:=UnitName;
 1667end;
 1668 
 1669{ TPSUnit }
 1670 
 1671procedure TPSUnit.AddUses(pUnitName: TbtString);
 1672var
 1673  UsesUnit: TPSUnit;
 1674begin
 1675  UsesUnit:=fList.GetUnit(pUnitName);
 1676  fUnits.Add(UsesUnit);
 1677end;
 1678 
 1679constructor TPSUnit.Create(List: TPSUnitList);
 1680begin
 1681  fUnits:=TPSList.Create;
 1682 
 1683  fList:=List;
 1684end;
 1685 
 1686destructor TPSUnit.Destroy;
 1687begin
 1688  FreeAndNIl(fUnits);
 1689  inherited;
 1690end;
 1691 
 1692function TPSUnit.HasUses(pUnitName: TbtString): Boolean;
 1693var
 1694  Dummy: Integer;
 1695begin
 1696  pUnitName:=FastUpperCase(pUnitName);
 1697 
 1698  if fUnitName=pUnitName then
 1699  begin
 1700    result:=true;
 1701    exit;
 1702  end;
 1703 
 1704  result:=false;
 1705 
 1706  for Dummy:=0 to fUnits.Count-1 do
 1707  begin
 1708    result:=TPSUnit(fUnits[Dummy]).HasUses(pUnitName);
 1709 
 1710    if result then
 1711      exit;
 1712  end;
 1713end;
 1714 
 1715procedure TPSUnit.SetUnitName(const Value: TbtString);
 1716begin
 1717  fUnitName := FastUpperCase(Value);
 1718end;
 1719 
 1720 
1590end.1721end.
1591 1722 
1592 1723 

Comment 1 by Carlo Kok, Dec 18, 2009

k

General Comments

Comment 1 by Carlo Kok, Dec 11, 2009

some minor typo in uPSCompiler but besides that it looks good.

Comment 2 by Mason Wheeler, Dec 12, 2009

See my review of uPSCompiler, above

Comment 3 by Carlo Kok, Dec 18, 2009

patch applied. Rev 195
Status: Fixed