[Q]: Отдача таймслайсов. Паскаль с ассемблером.
[A]: Vadim Rumyantsev (2:5030/301)
Более новая версия с пофиксенным зависанием при редком стечении обстоятельств в полночь в ДОСе :) И ещё чуть-чуть список операционных систем расширен.
──────────────────────────────────[Cut Here]──────────────────────────────────
{ Written by Vadim Rumyantsev, 2:5030/301. }
{ Generic DELAY unit – release timeslices }
{ if under OS/2 2.0, Windows 3.0, DesqView, }
{ DoubleDOS and probably DOS 5.0 (?!), else }
{ do nothing. }
{ It is assumed that program receives time }
{ quantums every day… so, don't run this }
{ unit on slow systems! 
}
{ Virtual Pascal compatible now! }
{ Delphi 2.0 compatible now. }
{ You may use this without restrictions }
UNIT USLDelay;
{$I-}
INTERFACE
type
OS_Type = (OS_MSDOS, OS_DOUBLEDOS, OS_TOPVIEW, OS_DESQVIEW,
OS_OS2_1, OS_OS2_2, OS_WINDOWS, OS_WIN32, OS_MACOS);
const
AccessDenied : set of byte = [5 {$IFNDEF DOS} , 32 {$ENDIF} ];
var
Running_OS_Name : string;
{$IFDEF OS2} const
Running_OS = OS_OS2_2;
{$ENDIF} {$IFDEF WIN32} const
Running_OS = OS_WIN32;
{$ENDIF} {$IFDEF MSDOS} var
Running_OS : OS_Type;
{$ENDIF} {$IFDEF DPMI} var
Running_OS : OS_Type;
{$ENDIF}
procedure Delay (n : longint);
IMPLEMENTATION
{$IFDEF OS2}
uses {$IFDEF VIRTUALPASCAL} Os2base {$ELSE} Doscalls {$ENDIF};
var
Buf : packed array [5..12] of longint; Sgn : string; f : file; fp : longint; sp : longint; p1, p2 : integer;
{$ENDIF}
{$IFDEF WIN32}
uses SysUtils, Windows;
const
UnknownPlatform = 'Win32'; UnknownWin95 = 'Win9x';
var
VersionInfo : TOsVersionInfoA; vb : string [10];
{$ENDIF}
{$IFDEF MSDOS}
uses Dos;
{ Define Seg0040 for backward compatibility with TP 4.0 .. TP 6.0 }
const
Seg0040 = $0040;
var
r : Registers; dosvh, dosvl : byte; osvh, osvl : byte; vendor : string [3];
{$DEFINE DOSMODE}
{$ENDIF}
{$IFDEF DPMI}
uses Dos;
{ Define Seg0040 for backward compatibility with TP 4.0 .. TP 6.0 }
var
r : Registers; dosvh, dosvl : byte; osvh, osvl : byte; vendor : string [3];
{$DEFINE DOSMODE}
{$ENDIF}
function Version (vh, vl : longint) : string;
var
vhs, vls : string [2];
begin
str (vh, vhs); str (vl, vls); if length (vls) = 1 then vls := '0' + vls; if vls [length (vls)] = '0' then dec (vls [0]); Version := vhs + '.' + vls
end;
{$IFDEF OS2}
procedure Delay;
begin
if DosSleep (n) <> 0 then;
end;
BEGIN
Running_OS_Name := 'OS/2';
if DosQuerySysInfo (5, 12, Buf, sizeof (Buf)) = 0 then begin
FileMode := open_access_ReadOnly + open_share_DenyNone;
assign (f, chr (64 + Buf [5]) + ':\OS2KRNL');
reset (f, 1);
seek (f, $3C);
blockread (f, fp, 4);
seek (f, fp+$88);
blockread (f, fp, 4);
seek (f, fp);
blockread (f, Sgn [0], 1);
blockread (f, Sgn [1], length (Sgn));
p1 := pos ('@#', Sgn);
p2 := pos ('#@', Sgn);
if (IoResult = 0) and
(p1 <> 0) and (p2 <> 0) and (p2 > (p1+2))
then begin
Sgn := copy (Sgn, p1+2, p2-p1-2);
p1 := pos (':', Sgn);
if p1 <> 0 then
Sgn := copy (Sgn, p1+1, 255);
Running_OS_Name := Running_OS_Name + ' Revision ' + Sgn
end
else begin
Buf [11] := Buf [11] div 10;
if (Buf [11] = 2) and (Buf [12] >= 30) and (Buf [12] < 90) then begin
Buf [11] := Buf [12] div 10;
Buf [12] := Buf [12] mod 10
end;
Running_OS_Name := Running_OS_Name + ' ' + Version (Buf [11], Buf [12])
end;
close (f); if IoResult <> 0 then;
end;
{$ENDIF}
{$IFDEF WIN32}
procedure Delay;
begin
Sleep (n);
end;
BEGIN
with VersionInfo do begin
dwOsVersionInfoSize := sizeof (VersionInfo);
if not GetVersionExA (VersionInfo) then
Running_OS_Name := UnknownPlatform
else begin
str (dwBuildNumber and $FFFF, vb);
case dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS:
if (dwMajorVersion = 4) and (dwMinorVersion = 0) then
Running_OS_Name := 'Windows 95'
else if (dwMajorVersion = 4) and (dwMinorVersion = 10) then
Running_OS_Name := 'Windows 98'
else if (dwMajorVersion = 4) and (dwMinorVersion = 90) then
Running_OS_Name := 'Windows Me'
else
Running_OS_Name := UnknownWin95;
VER_PLATFORM_WIN32_NT:
if (dwMajorVersion = 5) then
Running_OS_Name := 'Windows 2000'
else
Running_OS_Name := 'Windows NT'
else
Running_OS_Name := UnknownPlatform
end;
Running_OS_Name := Running_OS_Name + ' ' +
Version (dwMajorVersion, dwMinorVersion) + '/' + vb;
if szCsdVersion [0] <> #0 then
Running_OS_Name := Running_OS_Name + ' ' + StrPas (@szCsdVersion [0])
end
end;
{$ENDIF}
{$IFDEF DOSMODE}
procedure Delay (n : longint);
const
TicksPerDay = 1572480;
var
DelayQnt : longint; DoneTime : longint; LastTime : longint; ThisTime : longint; DateFlag : boolean; nh, nl : word;
begin
if Running_OS = OS_OS2_2 then begin
{$IFDEF VER70}
nh := n shr 8 shr 8;
{$ELSE}
nh := n shr 16;
{$ENDIF}
nl := n and $FFFF;
asm
mov dx, nh;
mov ax, nl;
hlt;
db $35,$CA
end;
exit
end;
DoneTime := MemW [Seg0040:$006C]; { What time is it? }
DelayQnt := round (n / 1000 * 18.2); { How many ticks wait? }
DateFlag := (DoneTime + DelayQnt) >= TicksPerDay; { Skip midnight? }
DoneTime := (DoneTime + DelayQnt) mod TicksPerDay; { When we'll finish? }
LastTime := MemW [Seg0040:$006C];
while (DateFlag or (LastTime < DoneTime)) do begin
{ probably fixed damned midnight freeze }
ThisTime := MemW [Seg0040:$006C];
if ThisTime < LastTime then { A new day! }
DateFlag := false;
LastTime := ThisTime;
{ Release timeslice }
case Running_OS of
OS_TOPVIEW, OS_DESQVIEW:
begin
r.AX := $1000;
Intr ($15, r)
end;
OS_DOUBLEDOS:
begin
r.AH := $EE;
if DelayQnt > 767 then
r.AL := $FF
else
r.AL := DelayQnt div 3;
dec (DelayQnt, r.AL * 3);
Intr ($21, r)
end
else
begin
r.AX := $1680;
Intr ($2F, r)
end;
end
end
end;
BEGIN
r.AX := $3000; MsDos (r); dosvh := r.AL; dosvl := r.AH; if r.BH = $00 then vendor := 'PC' else if r.BH = $66 then vendor := 'PTS' else if r.BH = $FF then vendor := 'MS' else vendor := 'OEM';
{ Check for Novell NetWare to eliminate conflict with DoubleDOS detection }
r.AX := $DC00; Intr ($21, r);
if r.AL = 0 then begin
{ NetWare is not installed, so we can check for DoubleDOS }
r.AX := $E400;
Intr ($21, r);
if r.AL <> 0 then begin { Yes, DoubleDos }
Running_OS := OS_DOUBLEDOS;
Running_OS_Name := 'DoubleDos';
exit
end;
end;
{ Check for DesqView }
r.AX := $1022; r.BX := $0000; Intr ($15, r);
if r.BX <> 0 then begin { Yes, DesqView or TopView }
if r.BX <> $0A01 then begin
Running_OS := OS_TOPVIEW;
Running_OS_Name := 'TopView ' + Version (r.BL, r.BH)
end
else begin
Running_OS := OS_DESQVIEW;
r.CX := $4445; { 'DE', Serg Projzogin uses it }
r.DX := $5351; { 'SQ', Serg Projzogin uses it }
r.AX := $2B01;
Intr ($21, r);
Running_OS_Name := 'DesqView ' + Version (r.BH, r.BL)
end;
exit
end;
{ Check for OS/2 }
r.AX := $4010; r.BX := $0000; Intr ($2F, r);
if r.BX <> 0 then begin { Yes, OS/2 }
if r.BH >= 20 then
Running_OS := OS_OS2_2
else
Running_OS := OS_OS2_1;
Include (AccessDenied, 162);
if (r.BH <> dosvh) or (r.BL <> dosvl) then begin { DOS VMB under OS/2 }
osvh := r.BH div 10;
osvl := r.BL;
if (osvh = 2) and (osvl >= 30) and (osvl < 90) then begin
osvh := osvl div 10;
osvl := osvl mod 10
end;
Running_OS_Name := vendor + ' DOS ' + Version (dosvh, dosvl) +
' under OS/2 ' + Version (osvh, osvl);
exit
end;
dosvh := dosvh div 10;
if (dosvh = 2) and (dosvl >= 30) and (dosvl < 90) then begin
dosvh := dosvl div 10;
dosvl := dosvl mod 10
end;
Running_OS_Name := 'OS/2 ' + Version (dosvh, dosvl);
exit
end;
r.AX := $1600; Intr ($2F, r);
if r.AL <> 0 then begin { Yes, Windows }
Running_OS := OS_WINDOWS;
if r.AX = $0004 then
Running_OS_Name := 'Windows 95'
else if r.AX = $0A04 then
Running_OS_Name := 'Windows 98'
else if r.AX = $5A04 then
Running_OS_Name := 'Windows Me'
else
Running_OS_Name := 'Windows ' + Version (r.AL, r.AH);
exit
end;
Running_OS := OS_MSDOS; Running_OS_Name := vendor + ' DOS ' + Version (dosvh, dosvl);
{$ENDIF}
END.
──────────────────────────────────[Cut Here]──────────────────────────────────