Ignore:
Timestamp:
May 10, 2018, 9:39:53 AM (7 years ago)
Author:
chronos
Message:
  • Modified: Updated Common package.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/Packages/Common/UMemory.pas

    r37 r38  
    1010type
    1111
    12   { TBlock }
     12  { TMemory }
    1313
    14   TBlock = class
     14  TMemory = class
    1515  private
    1616    FData: PByte;
    1717    FSize: Integer;
    18     function GetItem(Index: Integer): Byte; virtual; abstract;
    19     procedure SetItem(Index: Integer; AValue: Byte); virtual; abstract;
    20     procedure SetSize(AValue: Integer); virtual; abstract;
     18    function GetItem(Index: Integer): Byte;
     19    procedure SetItem(Index: Integer; AValue: Byte);
     20    procedure SetSize(AValue: Integer); virtual;
    2121  public
    22     procedure ReadBlock(Block: TBlock; Position: Integer); virtual;
    23     procedure WriteBlock(Block: TBlock; Position: Integer); virtual;
    24     procedure Clear(Value: Byte = 0); virtual;
    25     procedure Assign(Source: TBlock); virtual;
    26     property Size: Integer read FSize write SetSize;
    27     property Items[Index: Integer]: Byte read GetItem write SetItem; default;
    28   end;
    29 
    30   { TMemory }
    31 
    32   TMemory = class(TBlock)
    33   private
    34     FData: PByte;
    35     FSize: Integer;
    36     function GetItem(Index: Integer): Byte; override;
    37     procedure SetItem(Index: Integer; AValue: Byte); override;
    38     procedure SetSize(AValue: Integer); override;
    39   public
    40     procedure Clear(Value: Byte = 0); override;
    41     procedure Assign(Source: TBlock); override;
     22    procedure Clear(Value: Byte = 0);
     23    procedure Assign(Source: TMemory);
    4224    constructor Create;
    4325    destructor Destroy; override;
    4426    property Data: PByte read FData;
     27    property Size: Integer read FSize write SetSize;
     28    property Items[Index: Integer]: Byte read GetItem write SetItem; default;
    4529  end;
    4630
    … …  
    5842  end;
    5943
    60   { TBitBlock }
    61 
    62   TBitBlock = class
    63   private
    64     function GetItem(Index: Integer): Byte; virtual;
    65     function GetSize: Integer; virtual;
    66     procedure SetItem(Index: Integer; AValue: Byte); virtual;
    67     procedure SetSize(AValue: Integer); virtual;
    68   public
    69     procedure Invert; virtual;
    70     function GetInteger: Integer; virtual;
    71     procedure SetInteger(Value: Integer); virtual;
    72     procedure ReadBlock(Block: TBitBlock; Position: Integer); virtual;
    73     procedure WriteBlock(Block: TBitBlock; Position: Integer); virtual;
    74     procedure Clear(Value: Byte = 0); virtual;
    75     procedure Assign(Source: TBlock); virtual;
    76     property Size: Integer read GetSize write SetSize;
    77     property Items[Index: Integer]: Byte read GetItem write SetItem; default;
    78   end;
    79 
    80   { TBitMemory }
    81 
    82   TBitMemory = class(TBitBlock)
    83   private
    84     FData: PByte;
    85     FSize: Integer;
    86     function GetSize: Integer; override;
    87     procedure SetSize(AValue: Integer); override;
    88     function GetItem(Index: Integer): Byte; override;
    89     procedure SetItem(Index: Integer; AValue: Byte); override;
    90   public
    91     constructor Create;
    92     destructor Destroy; override;
    93     function GetInteger: Integer; override;
    94     procedure SetInteger(Value: Integer); override;
    95     procedure Clear(Value: Byte = 0); override;
    96     procedure ReadBlock(Block: TBitBlock; Position: Integer); override;
    97     procedure WriteBlock(Block: TBitBlock; Position: Integer); override;
    98     property Data: PByte read FData;
    99     procedure Invert; override;
    100   end;
    101 
    102 
    10344implementation
    104 
    105 { TBitMemory }
    106 
    107 procedure TBitMemory.Clear(Value: Byte);
    108 begin
    109   if (Size and 7) = 0 then begin
    110     if Value = 0 then FillChar(FData^, Size shr 3, 0)
    111       else FillChar(FData^, Size shr 3, $ff);
    112   end else inherited;
    113 end;
    114 
    115 procedure TBitMemory.ReadBlock(Block: TBitBlock; Position: Integer);
    116 begin
    117   if Block is TBitMemory then begin
    118     if (Position and 7) = 0 then begin
    119       if (Block.Size and 7) = 0 then
    120         Move(PByte(FData + Position shr 3)^, TBitMemory(Block).Data^, Block.Size shr 3)
    121         else inherited;
    122     end else inherited;
    123   end else inherited;
    124 end;
    125 
    126 procedure TBitMemory.WriteBlock(Block: TBitBlock; Position: Integer);
    127 begin
    128   if Block is TBitMemory then begin
    129     if (Position and 7) = 0 then begin
    130       if (Block.Size and 7) = 0 then
    131         Move(TBitMemory(Block).Data^, PByte(FData + Position shr 3)^, Block.Size shr 3)
    132         else inherited;
    133     end else inherited;
    134   end else inherited;
    135 end;
    136 
    137 procedure TBitMemory.Invert;
    138 var
    139   I: Integer;
    140 begin
    141   if (Size and 7) = 0 then begin
    142     for I := 0 to (Size shr 3) - 1 do
    143       PByte(FData + I)^ := PByte(FData + I)^ xor $ff;
    144   end
    145   else inherited;
    146 
    147 end;
    148 
    149 function TBitMemory.GetInteger: Integer;
    150 var
    151   I: Integer;
    152   V: Integer;
    153 begin
    154   Result := 0;
    155   I := 0;
    156   while (I < 32) and (I < Size) do begin
    157     V := FData[I shr 3];
    158     V := V shl I;
    159     Result := Result or V;
    160 //    Result := Result or (FData[I shr 3] shl I);
    161     Inc(I, 8);
    162   end;
    163   if Size < 32 then
    164     Result := Result and ((1 shl Size) - 1);
    165 end;
    166 
    167 procedure TBitMemory.SetInteger(Value: Integer);
    168 var
    169   I: Integer;
    170 begin
    171   I := 0;
    172   while (I < 32) and (I < Size) do begin
    173     FData[I shr 3] := (Value shr I) and $ff;
    174     Inc(I, 8);
    175   end;
    176 end;
    177 
    178 function TBitMemory.GetSize: Integer;
    179 begin
    180   Result := FSize;
    181 end;
    182 
    183 procedure TBitMemory.SetSize(AValue: Integer);
    184 var
    185   ByteSize: Integer;
    186 begin
    187   if AValue = FSize then Exit;
    188   FSize := AValue;
    189   ByteSize := FSize shr 3;
    190   if (FSize and 7) > 0 then Inc(ByteSize);
    191   FData := ReAllocMem(FData, ByteSize);
    192 end;
    193 
    194 function TBitMemory.GetItem(Index: Integer): Byte;
    195 begin
    196   if Index >= Size then raise Exception.Create('Out of range');
    197   Result := (PByte(FData + (Index shr 3))^ shr (Index and 7)) and 1;
    198 end;
    199 
    200 procedure TBitMemory.SetItem(Index: Integer; AValue: Byte);
    201 begin
    202   if Index >= Size then raise Exception.Create('Out of range, Size:' + IntToStr(Size) + ', Index:' + IntToStr(Index));
    203   PByte(FData + (Index shr 3))^ := PByte(FData + (Index shr 3))^ and not (1 shl (Index and 7))
    204     or ((AValue and 1) shl (Index and 7));
    205 end;
    206 
    207 constructor TBitMemory.Create;
    208 begin
    209   FData := nil;
    210 end;
    211 
    212 destructor TBitMemory.Destroy;
    213 begin
    214   FreeMem(FData);
    215   inherited Destroy;
    216 end;
    217 
    218 { TBitBlock }
    219 
    220 function TBitBlock.GetItem(Index: Integer): Byte;
    221 begin
    222   Result := 0;
    223 end;
    224 
    225 function TBitBlock.GetSize: Integer;
    226 begin
    227   Result := 0;
    228 end;
    229 
    230 procedure TBitBlock.SetItem(Index: Integer; AValue: Byte);
    231 begin
    232 
    233 end;
    234 
    235 procedure TBitBlock.SetSize(AValue: Integer);
    236 begin
    237 end;
    238 
    239 procedure TBitBlock.Invert;
    240 var
    241   I: Integer;
    242 begin
    243   for I := 0 to Size - 1 do
    244     Items[I] := not Items[I];
    245 end;
    246 
    247 function TBitBlock.GetInteger: Integer;
    248 begin
    249   Result := 0;
    250 end;
    251 
    252 procedure TBitBlock.SetInteger(Value: Integer);
    253 begin
    254 
    255 end;
    256 
    257 procedure TBitBlock.ReadBlock(Block: TBitBlock; Position: Integer);
    258 var
    259   I: Integer;
    260 begin
    261   for I := 0 to Block.Size - 1 do
    262     Block.Items[I] := Items[Position + I];
    263 end;
    264 
    265 procedure TBitBlock.WriteBlock(Block: TBitBlock; Position: Integer);
    266 var
    267   I: Integer;
    268 begin
    269   for I := 0 to Block.Size - 1 do
    270     Items[Position + I] := Block.Items[I];
    271 end;
    272 
    273 procedure TBitBlock.Clear(Value: Byte);
    274 var
    275   I: Integer;
    276 begin
    277   for I := 0 to Size - 1 do
    278     Items[I] := Value;
    279 end;
    280 
    281 procedure TBitBlock.Assign(Source: TBlock);
    282 var
    283   I: Integer;
    284 begin
    285   Size := Source.Size;
    286   for I := 0 to Size - 1 do
    287     Items[I] := Source.Items[I];
    288 end;
    289 
    290 { TBlock }
    291 
    292 procedure TBlock.ReadBlock(Block: TBlock; Position: Integer);
    293 var
    294   I: Integer;
    295 begin
    296   if Position + Block.Size > Size then raise Exception.Create('');
    297   for I := 0 to Block.Size - 1 do
    298     Items[I] := Items[Position + I];
    299 end;
    300 
    301 procedure TBlock.WriteBlock(Block: TBlock; Position: Integer);
    302 var
    303   I: Integer;
    304 begin
    305   if Position + Block.Size > Size then raise Exception.Create('');
    306   for I := 0 to Block.Size - 1 do
    307     Items[Position + I] := Items[I];
    308 end;
    309 
    310 procedure TBlock.Clear(Value: Byte);
    311 var
    312   I: Integer;
    313 begin
    314   for I := 0 to Size - 1 do
    315     Items[I] := Value;
    316 end;
    317 
    318 procedure TBlock.Assign(Source: TBlock);
    319 var
    320   I: Integer;
    321 begin
    322   Size := Source.Size;
    323   for I := 0 to Size - 1 do
    324     Items[I] := Source.Items[I];
    325 end;
    32645
    32746{ TPositionMemory }
    … …  
    37190end;
    37291
    373 procedure TMemory.Assign(Source: TBlock);
     92procedure TMemory.Assign(Source: TMemory);
    37493begin
    375   if Source is TMemory then begin
    376     Size := Source.Size;
    377     Move(TMemory(Source).Data^, FData^, Size);
    378   end else inherited;
     94  Size := Source.Size;
     95  Move(Source.Data^, FData^, Size);
    37996end;
    38097
Note: See TracChangeset for help on using the changeset viewer.