Форум: "Прочее";
Текущий архив: 2014.09.21;
Скачать: [xml.tar.bz2];

Вниз

_DynArrayAddRef/_NewUnicodeString/_NewAnsiString/_NewWideString   Найти похожие ветки 

← →
Мистер Хэ   (2014-02-10 17:29) [0]

Нужно узнать объявления и особенности работы на низком уровне с динамическими массивами и строками в Delphi и FPC. Под руками только компиляторы Delphi 6 и XE5 - просьба скопировать данные типы и функции из модуля System своей версии Delphi/FPC если они отличаются!
(комментарии для компактности удалил)

Delphi6:
procedure _DynArrayAddRef;
asm
       TEST    EAX,EAX
       JE      @@exit
  LOCK INC     dword ptr [EAX-8]
@@exit:
end;

function _NewAnsiString(length: Longint): Pointer;
var
 P: PStrRec;
begin
 Result := nil;
 if length <= 0 then Exit;
 GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1));
 Result := Pointer(Integer(P) + sizeof(StrRec));
 P.length := length;
 P.refcnt := 1;
 PWideChar(Result)[length div 2] := #0;  // length guaranteed >= 2
end;

function _NewWideString(CharLength: Longint): Pointer;
{$IFDEF LINUX}
begin
 Result := _NewAnsiString(CharLength*2);
end;
{$ENDIF}
{$IFDEF MSWINDOWS}
asm
       TEST    EAX,EAX
       JE      @@1
       PUSH    EAX
       PUSH    0
       CALL    SysAllocStringLen
       TEST    EAX,EAX
       JE      WStrError
@@1:
end;
{$ENDIF}

Delphi XE5:
 PStrRec = ^StrRec;
 StrRec = packed record
 {$IF defined(CPUX64)}
   _Padding: LongInt; // Make 16 byte align for payload..
 {$ENDIF}
   codePage: Word;
   elemSize: Word;
   refCnt: Longint;
   length: Longint;
 end;

 PDynArrayRec = ^TDynArrayRec;
 TDynArrayRec = packed record
 {$IFDEF CPUX64}
   _Padding: LongInt; // Make 16 byte align for payload..
 {$ENDIF}
   RefCnt: LongInt;
   Length: NativeInt;
 end;

procedure _DynArrayAddRef(P: Pointer);
begin
 if P <> nil then
   AtomicIncrement(PDynArrayRec(PByte(P) - SizeOf(TDynArrayRec))^.RefCnt);
end;

function _NewUnicodeString(CharLength: LongInt): Pointer;
var
 P: PStrRec;
begin
 Result := nil;
 if CharLength > 0 then
 begin
   // Allocate a memory with record and extra wide-null terminator.
   if CharLength >= (MaxInt - SizeOf(StrRec)) div SizeOf(WideChar) then _IntOver;
   GetMem(P, SizeOf(StrRec) + (CharLength + 1) * SizeOf(WideChar));
   Result := Pointer(PByte(P) + SizeOf(StrRec));
   P.length := CharLength;
   P.refCnt := 1;
   P.elemSize := SizeOf(WideChar);
   P.codePage := Word(DefaultUnicodeCodePage);
   PWideChar(Result)[CharLength] := #0;
 end;
end;

function _NewAnsiString(CharLength: LongInt; CodePage: Word): Pointer;
var
 P: PStrRec;
begin
 Result := nil;
 if CharLength > 0 then
 begin
   // Alloc an extra null for strings with even length.  This has no actual
   // cost since the allocator will round up the request to an even size
   // anyway. All _WideStr allocations have even length, and need a double
   // null terminator.
   if CharLength >= MaxInt - SizeOf(StrRec) then _IntOver;
   GetMem(P, CharLength + SizeOf(StrRec) + 1 + ((CharLength + 1) and 1));
   Result := Pointer(PByte(P) + SizeOf(StrRec));
   P.length := CharLength;
   P.refcnt := 1;
   if CodePage = 0 then
     CodePage := Word(DefaultSystemCodePage);
   P.codePage := CodePage;
   P.elemSize := 1;
   PWideChar(Result)[CharLength div 2] := #0;  // length guaranteed >= 2
 end;
end;

function _NewWideString(CharLength: LongInt): Pointer;
{$IFDEF POSIX}
{$IFDEF PUREPASCAL}
begin
  Result := _NewUnicodeString(CharLength);
end;
{$ELSE}
asm
       JMP     _NewUnicodeString
end;
{$ENDIF !PUREPASCAL}
{$ENDIF POSIX}
{$IFDEF MSWINDOWS}
{$IFDEF PUREPASCAL}
begin
 Result := nil;
 if CharLength <> 0 then
 begin
   Result := SysAllocStringLen(nil, CharLength);
   if Result = nil then
     WStrError;
 end;
end;

---

← →
Мистер Хэ   (2014-02-10 17:31) [1]

да, для Delphi 6:

 PStrRec = ^StrRec;
 StrRec = packed record
   refCnt: Longint;
   length: Longint;
 end;

---

← →
Rouse_ ©   (2014-02-11 10:40) [2]

2007

type
 PStrRec = ^StrRec;
 StrRec = packed record
   refCnt: Longint;
   length: Longint;
 end;

TDynArrayRec - отсутствует

_DynArrayAddRef - как в 6

_NewUnicodeString - отсутствует

function _NewAnsiString(length: Longint): Pointer;
{$IFDEF PUREPASCAL}
var
 P: PStrRec;
begin
 Result := nil;
 if length <= 0 then Exit;
 // Alloc an extra null for strings with even length.  This has no actual cost
 // since the allocator will round up the request to an even size anyway.
 // All widestring allocations have even length, and need a double null terminator.
 GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1));
 Result := Pointer(Integer(P) + sizeof(StrRec));
 P.length := length;
 P.refcnt := 1;
 PWideChar(Result)[length div 2] := #0;  // length guaranteed >= 2
end;
{$ELSE}
asm
 { ->    EAX     length                  }
 { <-    EAX pointer to new string       }

         TEST    EAX,EAX
         JLE     @@lengthLEZero
         PUSH    EAX
         ADD     EAX,rOff+2                       // one or two nulls (Ansi/Wide)
         AND     EAX, not 1                   // round up to even length
         PUSH    EAX
         CALL    _GetMem
         POP     EDX                              // actual allocated length (>= 2)
         MOV     word ptr [EAX+EDX-2],0           // double null terminator
         ADD     EAX,rOff
         POP     EDX                              // requested string length
         MOV     [EAX-skew].StrRec.length,EDX
         MOV     [EAX-skew].StrRec.refCnt,1
         RET
         
@@lengthLEZero:
         XOR     EAX,EAX
end;
{$ENDIF}

function _NewWideString(CharLength: Longint): Pointer;
{$IFDEF LINUX}
begin
 Result := _NewAnsiString(CharLength*2);
end;
{$ENDIF}
{$IFDEF MSWINDOWS}
asm
       TEST    EAX,EAX
       JE      @@1
       PUSH    EAX
       PUSH    0
       CALL    SysAllocStringLen
       TEST    EAX,EAX
       JE      WStrError
@@1:
end;
{$ENDIF}

---

← →
Мистер Хэ   (2014-02-11 10:43) [3]

> Rouse_ ©   (11.02.14 10:40) [2]

Ага, спасибо!
Получается всё как в Delphi6.

Теперь хочется посмотреть изменения для Delphi 2009 и FPC
Ребят, не поленитесь посмотреть, у кого есть, пожалуйста

---

← →
NoUser ©   (2014-02-11 17:48) [4]

FPC 2.6.2
Type
  pdynarray = ^tdynarray;
  tdynarray = packed record
     refcount : ptrint;
     high : tdynarrayindex;
  end;

procedure fpc_dynarray_incr_ref(p : pointer);
 var
    realp : pdynarray;
 begin
    if p=nil then
      exit;

    realp:=pdynarray(p-sizeof(tdynarray));
    if realp^.refcount=0 then
      HandleErrorFrame(204,get_frame);

    inclocked(realp^.refcount);
 end;

Type
 PAnsiRec = ^TAnsiRec;
 TAnsiRec = Packed Record
   Ref,
   Len   : SizeInt;
   First : Char;
 end;

Const
 AnsiRecLen = SizeOf(TAnsiRec);
 FirstOff   = SizeOf(TAnsiRec)-1;

Function NewAnsiString(Len : SizeInt) : Pointer;
{  Allocate a new AnsiString on the heap.
 initialize it to zero length and reference count 1.}
Var
 P : Pointer;
begin
 { request a multiple of 16 because the heap manager alloctes anyways chunks of 16 bytes }
 GetMem(P,Len+AnsiRecLen);
 If P<>Nil then
  begin
    PAnsiRec(P)^.Ref:=1;         { Set reference count }
    PAnsiRec(P)^.Len:=0;         { Initial length }
    PAnsiRec(P)^.First:=#0;      { Terminating #0 }
    inc(p,firstoff);             { Points to string now }
  end;
 NewAnsiString:=P;
end;

Type
 PWideRec = ^TWideRec;
 TWideRec = Packed Record
   Len   : DWord;
   First : WideChar;
 end;

Const
 WideRecLen = SizeOf(TWideRec);
 WideFirstOff = SizeOf(TWideRec)-sizeof(WideChar);

Function NewWideString(Len : SizeInt) : Pointer;
{  Allocate a new WideString on the heap.
 initialize it to zero length and reference count 1.}
Var
 P : Pointer;
begin
{$ifdef MSWINDOWS}
 if winwidestringalloc then
   begin
     P:=SysAllocStringLen(nil,Len);
     if P=nil then
       WideStringError;
   end
 else
{$endif MSWINDOWS}
   begin
     GetMem(P,Len*sizeof(WideChar)+WideRecLen);
     If P<>Nil then
       begin
        PWideRec(P)^.Len:=Len*2;     { Initial length }
        PWideRec(P)^.First:=#0;      { Terminating #0 }
        inc(p,WideFirstOff);         { Points to string now }
       end
     else
       WideStringError;
   end;
 NewWideString:=P;
end;

Type
 PUnicodeRec = ^TUnicodeRec;
 TUnicodeRec = Packed Record
   Ref : SizeInt;
   Len : SizeInt;
   First : UnicodeChar;
 end;

Const
 UnicodeRecLen = SizeOf(TUnicodeRec);
 UnicodeFirstOff = SizeOf(TUnicodeRec)-sizeof(UnicodeChar);

Function NewUnicodeString(Len : SizeInt) : Pointer;
{
 Allocate a new UnicodeString on the heap.
 initialize it to zero length and reference count 1.
}
Var
 P : Pointer;
begin
 GetMem(P,Len*sizeof(UnicodeChar)+UnicodeRecLen);
 If P<>Nil then
   begin
    PUnicodeRec(P)^.Len:=Len*2;     { Initial length }
    PUnicodeRec(P)^.Ref:=1;         { Initial Refcount }
    PUnicodeRec(P)^.First:=#0;      { Terminating #0 }
    inc(p,UnicodeFirstOff);         { Points to string now }
   end
 else
   UnicodeStringError;
 NewUnicodeString:=P;
end;


---

← →
Мистер Хэ   (2014-02-11 18:02) [5]

> NoUser ©   (11.02.14 17:48) [4]

ого
спасибо большое!

размер Char в FPC равен 1?

и это... разве в FPC нет строк типа...
type
 CyrillicString = type AnsiString(1251);

---

← →
Мистер Хэ   (2014-02-11 18:02) [6]

All,

осталось посмотреть Delphi 2009 :)
ребят, у кого он есть - посмотрите пожалуйста

---

← →
Чайник ©   (2014-02-11 18:11) [7]

Д2010

type
 PStrRec = ^StrRec;
 StrRec = packed record
   codePage: Word;
   elemSize: Word;
   refCnt: Longint;
   length: Longint;
 end;

TDynArrayRec – отсутствует

rocedure _DynArrayAddRef;
asm
{     ->EAX     Pointer to heap object }
       TEST    EAX,EAX
       JE      @@exit
  LOCK INC     dword ptr [EAX-8]
@@exit:
end;

function _NewUnicodeString(CharLength: Longint): Pointer;
{$IFDEF PUREPASCAL}
var
 P: PStrRec;
begin
 Result := nil;
 if CharLength <= 0 then Exit;
 // Allocate a memory with record and extra wide-null terminator.
 GetMem(P, SizeOf(StrRec) + (CharLength + 1) * SizeOf(WideChar));
 Result := Pointer(Integer(P) + sizeof(StrRec));
 P.length := CharLength;
 P.refCnt := 1;
 P.elemSize := SizeOf(WideChar);
 P.codePage := Word(DefaultUnicodeCodePage);
 PWideChar(Result)[CharLength] := #0;
end;
{$ELSE}
asm
       { ->    EAX     length                  }
       { <-    EAX pointer to new string       }
       TEST    EAX,EAX
       JLE     @@lengthLEZero  // length <= 0?
       PUSH    EAX             // save length
       ADD     EAX,EAX         // convert to bytes
       JO      @@overflow
       ADD     EAX,rOff+2      // + record + terminator
       JO      @@overflow
       CALL    _GetMem
       ADD     EAX,rOff
       POP     EDX                              // requested string length
       MOV     [EAX-skew].StrRec.refCnt,1
       MOV     [EAX-skew].StrRec.length,EDX
       MOV     word ptr [EAX+EDX*2],0           // wide null terminator
       MOV     word ptr [EAX-skew].StrRec.elemSize,2
       MOVZX   EDX,Word Ptr DefaultUnicodeCodePage
       MOV     word ptr [EAX-skew].StrRec.codePage,DX
       RET
@@overflow:
       JMP     _IntOver  
@@lengthLEZero:
       XOR     EAX,EAX
end;
{$ENDIF}

function _NewAnsiString(length: Longint; CodePage: Word): Pointer;
{$IFDEF PUREPASCAL}
var
 P: PStrRec;
begin
 Result := nil;
 if length <= 0 then Exit;
 // Alloc an extra null for strings with even length.  This has no actual cost
 // since the allocator will round up the request to an even size anyway.
 // All widestring allocations have even length, and need a double null terminator.
 GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1));
 Result := Pointer(Integer(P) + sizeof(StrRec));
 P.length := length;
 P.refcnt := 1;
 P.codePage := Word(DefaultSystemCodePage);
 P.elemSize := 1;
 PWideChar(Result)[length div 2] := #0;  // length guaranteed >= 2
end;
{$ELSE}
asm
 { ->    EAX     length                  }
 { <-    EAX pointer to new string       }

         TEST    EAX,EAX
         JLE     @@lengthLEZero
         PUSH    EAX
         ADD     EAX,rOff+2                       // one or two nulls (Ansi/Wide)
         JO      @@overflow
         AND     EAX, not 1                   // round up to even length
         PUSH    EDX
         PUSH    EAX
         CALL    _GetMem
         POP     EDX                              // actual allocated length (>= 2)
         POP     ECX
         MOV     word ptr [EAX+EDX-2],0           // double null terminator
         ADD     EAX,rOff
         POP     EDX                              // requested string length
         MOV     [EAX-skew].StrRec.length,EDX
         MOV     [EAX-skew].StrRec.refCnt,1
         TEST    ECX,ECX
         JNE     @@NotDefault
         MOV     ECX,DefaultSystemCodePage
@@NotDefault:
         MOV     EDX,ECX
         MOV     word ptr [EAX-skew].StrRec.codePage,DX
         MOV     word ptr [EAX-skew].StrRec.elemSize,1
         RET

@@overflow:
         JMP     _IntOver          
         
@@lengthLEZero:
         XOR     EAX,EAX
end;
{$ENDIF}
function _NewWideString(CharLength: Longint): Pointer;
{$IF defined(LINUX) or defined(MACOSX)}
begin
  { MACOSXTODO: check code page on this }
  Result := _NewAnsiString(CharLength*2, 0);
//  Result := _NewAnsiString(CharLength*2);
end;
{$IFEND}
{$IFDEF MSWINDOWS}
asm
       TEST    EAX,EAX
       JE      @@1
       PUSH    EAX
       PUSH    0
       CALL    SysAllocStringLen
       TEST    EAX,EAX
       JE      WStrError
@@1:
end;
{$ENDIF}

---

← →
Мистер Хэ   (2014-02-11 21:51) [8]

> Чайник ©   (11.02.14 18:11) [7]

Спасибо!
Ну чтож, осталось понять, такой же ли код в Delphi 2009
Таки это переходный период, возможно там что-то не так как сейчас :)

---

← →
ХэХеХэ   (2014-02-11 22:55) [9]

Просим не публиковать серийные номера, коды, а также алгоритмы взлома того или иного программного обеспечения.

Выкладывание таких огромных кусков исходников RTL онлайн нарушает все мыслимые лицензии. Неспроста в триальной версии Delphi исходников нет.

---

← →
NoUser ©   (2014-02-11 23:58) [10]

> размер Char в FPC равен 1?
> и это... разве в FPC нет строк типа...

Да, и это
type
   UTF8String = type ansistring;
+
http://www.freepascal.ru/article/freepascal/20051026001249/

---

← →
Мистер Хэ   (2014-02-12 01:00) [11]

> NoUser ©   (11.02.14 23:58) [10]

Интересно
Спасибо

Ребят,у кого Delphi 2009, признавайтесь?

---

← →
Inovet ©   (2014-02-12 01:14) [12]

> [11] Мистер Хэ   (12.02.14 01:00)
> Delphi 2009

Он же глючный был, кажись.

---

← →
Мистер Хэ   (2014-02-12 09:31) [13]

> Inovet ©   (12.02.14 01:14) [12]

Да они все глючные по своему :)
Просто это "недостающее звено", которое надо "восстановить" :)

---

← →
Мистер Хэ   (2014-02-13 09:50) [14]

Меня пока больше всего смущает реализация WideString вне Windows

По Delphi 2010 включительно она
 _NewAnsiString(CharLength*2)

В FreePascal примерно так же

А вот в XE2 и позже уже такая реализация:
 _NewUnicodeString(CharLength);

Между 2010 и XE2 есть только одна версия - XE1
Ни у кого нет?

---

← →
Мистер Хэ   (2014-02-13 10:56) [15]

Всё, теперь ясно
В XE тоже  _NewUnicodeString(CharLength);

Всем спасибо

---

← →
Мистер Хэ   (2014-02-13 10:56) [16]

Всё, теперь ясно
В XE тоже  _NewUnicodeString(CharLength);

Всем спасибо

---

Страницы: 1 вся ветка

Форум: "Прочее";
Текущий архив: 2014.09.21;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.52 MB
Время: 0.004 c