#1344. Ссылка. Хитрости с битовыми операциями

https://tproger.ru/digest/awesome-bits/

Я вот совсем не сторонник подобных штучек, но мало ли...

Цитата оттуда:

Целые числа

Установка n-ого бита

1	x | (1<<n)

Обнуление n-ого бита

1	x & ~(1<<n)

Переключение n-ого бита

1	x ^ (1<<n)

Округление до следующей степени двойки

1 2 3 4 5 6 7 8

unsigned int v; //only works if v is 32 bit v--; v |= v >> 1; v |= v >> 2; v |= v >> 4; v |= v >> 8; v |= v >> 16; v++;

Получение максимального целого

....

#1343. Perform, SendMessage, SendDockNotification. Потенциальный Range Check

Perform, SendMessage, SendDockNotification

LParam и THandle

procedure SendDockNotification(Msg: Cardinal; WParam, LParam: THandle);

function Perform(Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): LRESULT;

function SendMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; overload;
function SendMessage(hWnd: HWND; Msg: UINT; wParam: INT_PTR; lParam: LPARAM): LRESULT; stdcall; overload;

LPARAM = INT_PTR;
THandle = NativeUInt;

(!) Range Check потенциальный.

#1342. Bug в Delphi Berlin 10.2

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

Суть следующая.
У нас есть BPL с FMX формами.
Устанавливаем ей BuildConfiguration в Release.
Пытаемся добавить форму ловим Exception:
"False" is not a valid integer value

Если изменить BuildConfiguration на Debug.
Всё ок.

Добаввил баг в qc.
Link

Мелочь но всё таки. 

#1341. Helper routine for stress testing large 64 bit addresses to be correct with integer casts

Helper routine for stress testing large 64 bit addresses to be correct with integer casts.

Useful for porting from 32 to 64 bits.

Original in russian - http://programmingmindstream.blogspot.ru/2017/01/1333-64-integer.html.

Idea from gunsmoker'а and Николай Зверев.

Links:
http://programmingmindstream.blogspot.ru/2016/12/1330-win64.html
http://www.delphinotes.ru/2016/10/win64-2.html

unit l3DebugUtils;

interface

procedure l3ReserveMem;

implementation

uses
 Windows
 ;

procedure l3ReserveMem;
{$IfDef Win64}
var
 l_P : Pointer;
begin
 while true do
 begin
  l_P := VirtualAlloc(nil, 1024 * 1024, MEM_RESERVE, PAGE_NOACCESS);
  // - reserve by one megabyte while low addresses not ended (less 4Gb).
  if (l_P = nil) then
   break;
  if (NativeUInt(l_P) >= High(Cardinal{Integer})) then
   break;
 end;//while true
end;
{$Else  Some64}
begin
end;
{$EndIf Some64}

end.

Put call to l3ReserveMem at first line of dpr and get the fact that all addresses later will be greater than $FFFFFFFF.

Then test our application and wait for AV or Range Check.

Pay attention to PAGE_NOACCESS - thus low adresses is not readable or writeable.

This code can be left in release build for user. It's not reserve real memory but only address space.

---

I have this call in my tests:

begin
 {$IfDef nsTest}
 g_CVSPath := 'w:\common\components\DailyTest';
 {$EndIf nsTest}
 //#UC START# *4B2A48AA03D4CVSPath*
 l3ReserveMem; // !!! HERE !!!
 //#UC END# *4B2A48AA03D4CVSPath*
 TAutoTestsSuite.Register;
 try
  if KTestRunner.NeedKTestRunner([TtoK, TItsLAW, TArchi2, TtoK64, TtoKT]) then
   KTestRunner.RunRegisteredTests
  else
  if System.IsConsole then
   TextTestRunner.RunRegisteredTests
  else
   GUITestRunner.RunRegisteredTests;
 except
  on E: Exception do
  begin
   {$If defined(MTDORB) AND defined(NoKPageTool)}
   if TKBridge.Exists then
    TKBridge.Instance.Logout;
   {$IfEnd}
   l3System.Exception2Log(E);
   TestsExitCode := 2;
  end;//Exception
 end;//try..except
{$IfNDef Some64}
 if (TestsExitCode <> 0) then
  Halt(TestsExitCode);
{$EndIf  Some64}
end.

#1340. Побрюзжу

FFreeNotifies: TList<TComponent>;
....

procedure TComponent.RemoveFreeNotifications;
begin
  if FFreeNotifies <> nil then
  begin
    while Assigned(FFreeNotifies) and (FFreeNotifies.Count > 0) do
      TComponent(FFreeNotifies[FFreeNotifies.Count - 1]).Notification(Self, opRemove);
    FreeAndNil(FFreeNotifies);
  end;
end;


Ну нет слов...

#1339. Скрипт для переименования файла по маске

CONST cFrom '.XE64.'
CONST cTo '.XE.'
CONST cFolder 'O:\Compare\x64\'

PROCEDURE DoFile
  STRING IN aFile
 STRING VAR l_NewName
 aFile cFrom cTo string:Replace >>> l_NewName
 l_NewName .
 
 aFile l_NewName RenameFile .
; // DoFile

@ DoFile [ '*' cFrom '*' ] strings:Cat cFolder ProcessFilesWithMask

Ну или с параметрами из командной строки:

STRING VAR cFrom 
STRING VAR cTo 
STRING VAR cFolder 

2 ParamStr >>> cFrom
3 ParamStr >>> cTo
4 ParamStr >>> cFolder

PROCEDURE DoFile
  STRING IN aFile
 STRING VAR l_NewName
 aFile cFrom cTo string:Replace >>> l_NewName
 l_NewName .
 
 aFile l_NewName RenameFile .
; // DoFile

@ DoFile [ '*' cFrom '*' ] strings:Cat cFolder ProcessFilesWithMask

#1338. System.TMonitor как объект синхронизации

Наткнулся тут на чудный кусок в System.pas:

   { TMonitor is an implementation of the concept invented by C.A.R Hoare and Per Brinch Hansen.
    See http://en.wikipedia.org/wiki/Monitor_%28synchronization%29 for more information.

    Every TObject derived instance can be used as a monitor. However, it is recommended that privately
    constructed objects be used rather than the publicly available instance itself. This will allow the
    developer to better control access to the lock and to ensure that the locking rules are adhered to.
    If a publicly available instance were to be used a the lock, such as a TComponent derivative, then
    deadlocks are more likely when external code is locking and unlocking the monitor in addition to
    the code internal to the class. In many cases, a mutex/critical section/condition variable can be
    created by simply constructing a variable of type TObject and calling the TMonitor.XXXX(ObjInstance)
    methods. }

  PPMonitor = ^PMonitor;
  PMonitor = ^TMonitor;
  TMonitor = record

То есть получается, что любой объект Delphi может служить объектом синхронизации. Примерно как у Apple - synchronize(self).

Т.е. любой объект можно использовать как критическую секцию:

 System.TMonitor.Enter(Self);
 try
  // - защищаемый код
 finally
  System.TMonitor.Exit(Self);
 end

Или как Event:

 System.TMonitor.PulseAll(Self);
 ...
 System.TMonitor.Wait(Self);

http://docwiki.embarcadero.com/Libraries/Seattle/en/System.TMonitor

Правда из-за этого теперь ВСЕ объекты стали на SizeOf(Pointer) БОЛЬШЕ :-(

  hfFieldSize          = SizeOf(Pointer);
  hfMonitorOffset      = 0;

class function TMonitor.GetFieldAddress(const AObject: TObject): PPMonitor;

begin

  Result := PPMonitor(PByte(AObject) + AObject.InstanceSize - hfFieldSize + hfMonitorOffset);

end;

(+) Важно.
https://www.delphitools.info/2013/06/06/tmonitor-vs-trtlcriticalsection/

https://www.delphitools.info/2013/05/30/performance-issue-in-nextgen-arc-model/#more-2486

#1337. Invalid obj file. Berlin. 64 бита

Делаем с-файл с функцией в которой есть static переменная.

Делаем obj файл в cpp builder 64 бита.

Делаем pas файл. Подключаем к нему получившийся obj.

Компилируем Delphi 64 бита.

Получаем ошибку линковки bad obj file format.

БЕЗ static - всё хорошо. Но нужен static...

Однако сами Embarcadero как-то же собирают crtl в котором есть static. И оно даже как-то линкуется.

Если переменную сделать глобальной, но не static, то получаем ошибку bad symbol.

Рафинированый пример выделять пока некогда.

Если переменную сделать глобальной и extern и инстанцировать её на стороне pas кода, то всё хорошо. Только pas коду совершенно не нужно такое знание кишков c кода.

А если в функции сделать переменную на стеке типа char [16000] то на стороне Delphi требуется определение функции __chkstk. В msdn можно найти её куцее описание.

#1336. Berlin. Баг

При запущеной IDE Berlin не работает функция OleGetClipboard. В любом приложении на Delphi. Даже не под отладчиком. Выгружаешь IDE всё хорошо. Загружаешь. Опять плохо.

#1335. Ошибка в ImageEn _DIBDrawTo. 64 бита

Было:

procedure _DIBDrawTo(DestCanvas: TCanvas; fhdib: THANDLE; orgx, orgy, orgdx, orgdy, destx, desty, destdx, destdy: integer);
var
  bminfo: ^TBITMAPINFO;
begin
  bminfo := GlobalLock(fhdib);
  SetStretchBltMode(destcanvas.handle, COLORONCOLOR);
  if bminfo^.bmiHeader.biBitCount <= 8 then
    // <=256 colors
    StretchDIBits(destcanvas.Handle, destx, desty, destdx, destdy, orgx, orgy, orgdx, orgdy,
      pointer(Cardinal(bminfo) + sizeof(TBITMAPINFOHEADER) + (1 shl bminfo^.bmiHeader.biBitCount) * 4),
      bminfo^, DIB_RGB_COLORS, SRCCOPY)
  else
    // >256 colors
    StretchDIBits(destcanvas.Handle, destx, desty, destdx, destdy, orgx, orgy, orgdx, orgdy,
      pointer(Cardinal(bminfo) + sizeof(TBITMAPINFOHEADER)),
      bminfo^, DIB_RGB_COLORS, SRCCOPY);
  GlobalUnLock(fhdib);
end; 

Надо:

procedure _DIBDrawTo(DestCanvas: TCanvas; fhdib: THANDLE; orgx, orgy, orgdx, orgdy, destx, desty, destdx, destdy: integer);
var
  bminfo: ^TBITMAPINFO;
begin
  bminfo := GlobalLock(fhdib);
  SetStretchBltMode(destcanvas.handle, COLORONCOLOR);
  if bminfo^.bmiHeader.biBitCount <= 8 then
    // <=256 colors
    StretchDIBits(destcanvas.Handle, destx, desty, destdx, destdy, orgx, orgy, orgdx, orgdy,
      pointer(PAnsiChar(bminfo) + sizeof(TBITMAPINFOHEADER) + (1 shl bminfo^.bmiHeader.biBitCount) * 4),
      bminfo^, DIB_RGB_COLORS, SRCCOPY)
  else
    // >256 colors
    StretchDIBits(destcanvas.Handle, destx, desty, destdx, destdy, orgx, orgy, orgdx, orgdy,
      pointer(PAnsiChar(bminfo) + sizeof(TBITMAPINFOHEADER)),
      bminfo^, DIB_RGB_COLORS, SRCCOPY);
  GlobalUnLock(fhdib);
end; 

Cardinal => PAnsiChar.

Вообще полезно просмотреть все исходники на предмет наличия масок:

Pointer(Cardinal
Pointer(Integer
Pointer(Longint

PChar(Cardinal
PChar(Integer
PChar(Longint

PAnsiChar(Cardinal
PAnsiChar(Integer
PAnsiChar(Longint

#1334. Ярослав Бровин про FreeAndNil и компанию

http://yaroslavbrovin.ru/object_life_cycle_in_delphi_part_1_windows_osx-ru/

"

Использование FreeAndNil

Этот способ является решением проблемы повторного удаления объекта с мусорным указателем. Забегая вперед, сразу хочу сказать, что я настоятельно рекомендую использовать только этот способ удаления объектов, поскольку он поможет вам обнаружить ошибку сразу же на месте."


Ну НАКОНЕЦ-то ЭТО было СКАЗАНО. После стольких лет перемывания из пустого в порожнее.

Коротко. "Нелюбителям" FreeAndNil
У меня проблема в ДНК? Может быть кто-нибудь объяснит мне "что хотел сказать автор"?
Почему всегда нужно использовать FreeAndNil вместо Free

#1333. Функция-помощник для стрессового тестирования длинных 64-битных адресов на предмет совместимости с Integer

Функция-помощник для тестирования длинных 64-битных адресов на предмет совместимости с Integer. Творческая переработка идей gunsmoker'а и Николая Зверева.

По мотивам:
http://programmingmindstream.blogspot.ru/2016/12/1330-win64.html
http://www.delphinotes.ru/2016/10/win64-2.html

unit l3DebugUtils;

interface

procedure l3ReserveMem;

implementation

uses
 Windows
 ;

procedure l3ReserveMem;
{$IfDef Win64}
var
 l_P : Pointer;
begin
 while true do
 begin
  l_P := VirtualAlloc(nil, 1024 * 1024, MEM_RESERVE, PAGE_NOACCESS);
  // - распределяем по мегабайту, пока не выберем "младшее" адресное пространство (меньше 4Гб).
  if (l_P = nil) then
   break;
  if (NativeUInt(l_P) >= High(Cardinal{Integer})) then
   break;
 end;//while true
end;
{$Else  Some64}
begin
end;
{$EndIf Some64}

end.

Втыкаем вызов l3ReserveMem первой строчкой в dpr и получаем, что все далее распределённые адреса будут больше $FFFFFFFF.

Далее протыкиваем наше приложение или запускаем автоматические тесты. И ловим Range Check'и и AV. Там где Pointer приводится к Integer и Cardinal и наоборот. В прямую сторону Range Check в обратную - скорее всего AV.

Я много чего наловил. И в чужом коде - тоже. В частности в ImageEn. Например в функции _DIBDrawTo. Но об этом в другой раз.

Этот код можно и в релизе оставить. И тренироваться "на пользователях".

---

У меня вызов функции в тестах вот так вставлен:

begin
 {$IfDef nsTest}
 g_CVSPath := 'w:\common\components\DailyTest';
 {$EndIf nsTest}
 //#UC START# *4B2A48AA03D4CVSPath*
 l3ReserveMem;
 //#UC END# *4B2A48AA03D4CVSPath*
 TAutoTestsSuite.Register;
 try
  if KTestRunner.NeedKTestRunner([TtoK, TItsLAW, TArchi2, TtoK64, TtoKT]) then
   KTestRunner.RunRegisteredTests
  else
  if System.IsConsole then
   TextTestRunner.RunRegisteredTests
  else
   GUITestRunner.RunRegisteredTests;
 except
  on E: Exception do
  begin
   {$If defined(MTDORB) AND defined(NoKPageTool)}
   if TKBridge.Exists then
    TKBridge.Instance.Logout;
   {$IfEnd}
   l3System.Exception2Log(E);
   TestsExitCode := 2;
  end;//Exception
 end;//try..except
{$IfNDef Some64}
 if (TestsExitCode <> 0) then
  Halt(TestsExitCode);
{$EndIf  Some64}
end.

#1332. Старый баг. Ещё Delphi 7

http://www.delphikingdom.com/asp/talktopic.asp?ID=302

Попробуйте скомпилировать данный код со включенной опцией Include TD32 debug info.

program buildL3;

const
  w_WildSet = [WideChar('?')];

begin
end.

- получаем Internal Error DBG1477.

Просто только сегодня с коллегой вспоминали.

Ну и он в тему к предыдущему - http://programmingmindstream.blogspot.ru/2017/01/1331-64.html.

#1331. Забавный баг 64-битного компилятора

const
 csRusSmallI = AnsiChar('и');
 csRusBigI = AnsiChar('И');
 csSetRusI = [csRusSmallI, csRusBigI];
begin
 Assert(#0 in csSetRusI);
 //- проверка проходит, что НЕ правильно
end.

const
 csRusSmallI = AnsiChar('и');
 csRusBigI = AnsiChar('И');
 csSetRusI : set of AnsiChar = [csRusSmallI, csRusBigI];
begin
 Assert(#0 in csSetRusI);
 //- проверка НЕ проходит, что ПРАВИЛЬНО
end.

Delphi XE4

"Понятное дело", что есть CharInSet и CharInArray, но при портировании старого кода - малость раздражает.

Да. В 32-х битах - это не повторяется. На всякий случай повторил.

И "на самом деле" в первом примере значение csSetRusI равно ['и', 'И', #0, #2, #3]. Т.е. там какой-то "мусор". Завтра погляжу как это выглядит в ассемблере.