home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 December / simtel1292_SIMTEL_1292_Walnut_Creek.iso / msdos / info / mem3.arc / MEM.PAS < prev    next >
Pascal/Delphi Source File  |  1988-03-23  |  12KB  |  381 lines
  1. Uses Crt, Dos;
  2. {$M 10000,0,0}  {$I-}
  3.  
  4. Type DumArr=Array[0..6] of Byte;
  5.  
  6. Const
  7.   HiInt  :Word=$8000;
  8.   Clock  :DumArr=($FC,$91,$74,$29,$2E,$FF,$2E);
  9.   ClkLoc :Word=$0120;
  10.   Pascal :DumArr=($32,$CE,$F6,$D1,$80,$E1,$80);
  11.   PasLoc :Word=$FFF0;
  12.   SupKey :DumArr=($E9,$57,$94,$34,$12,$43,$6F);
  13.   KeyLoc :Word=$0110;
  14.   Lightng:DumArr=($E9,$55,$83,$34,$12,$43,$6F);
  15.   LitLoc :Word=$0110;
  16.   PcTools:DumArr=($50,$43,$20,$54,$6F,$6F,$6C);
  17.   PCTLoc :Word=$15E9;
  18.   SideKik:DumArr=($E9,$E9,$03,$CD,$AB,$43,$6F);
  19.   SKLoc  :Word=$0110;
  20.   Qega   :DumArr=($E9,$05,$0E,$FE,$CA,$ED,$FE);
  21.   QEGLoc :Word=$0110;
  22.   Com3_3 :DumArr=($E9,$2D,$0D,$BA,$DA,$0A,$3D);
  23.   Com3_3L:Word=$0110;
  24.   DVUser :DumArr=($00,$55,$8B,$EC,$83,$C5,$06);
  25.   DVULoc :Word=$0110;
  26.   Cache  :DumArr=($50,$43,$54,$4F,$4F,$4C,$53);
  27.   CacLoc :Word=$0113;
  28.   Hercul :DumArr=($00,$F0,$02,$35,$2D,$2E,$07);
  29.   HercLoc:Word=$0118;
  30.   DVAnsi :DumArr=($BE,$0A,$3B,$38,$13,$3B,$41);
  31.   AnsiLoc:Word=$0200;
  32.   PushD  :DumArr=($50,$55,$53,$48,$44,$49,$52);
  33.   PushLoc:Word=$013C;
  34.  
  35. Var
  36.   Regs  :Registers;
  37.   ForeGrn,BckGrn,OccCnt,FreCnt,SysMemX,SysMemY:Byte;
  38.   EnvSz,MCseg,Reported,HiY:Word;
  39.   FreSize,CurArena:Word;
  40.   CR    :String[2];
  41.   PstEnv:Boolean;
  42.  
  43. Procedure Colors;
  44.  Var Z,X,Y,PrevVal,Fore,Back:Word; ReDir:Boolean;
  45.  Const MrkX=1; MrkY=25; MrkW=80; ModeSeg=$40; ModeOff=$49;
  46.  Begin
  47.    If Mem[ModeSeg:ModeOff]=7 then Z:=$B000  Else Z:=$B800;
  48.    PrevVal:=Mem[Z:(MrkY-1)*MrkW*2+(MrkX-1)]; X:=WhereX; Y:=WhereY;
  49.    GotoXY(MrkX,MrkY); Regs.AH:=2; Regs.DL:=$FF; MSDOS(Regs);
  50.    If (WhereX=MrkX) and (WhereY=MrkY) then Begin
  51.      DirectVideo:=False;
  52.     End Else Begin
  53.       If Mem[Z:(MrkY-1)*MrkW*2+(MrkX-1)]=$FF then
  54.        DirectVideo:=True
  55.       Else
  56.        DirectVideo:=False;
  57.      End;
  58.    GotoXY(X,Y); Mem[Z:(MrkY-1)*MrkW*2+(MrkX-1)]:=PrevVal;
  59.    Assign(Input,''); Reset(Input);
  60.  End;
  61.  
  62. Function RR(N:LongInt):Real;
  63.  Begin
  64.    RR:=N/1;
  65.   End;
  66.  
  67. Function HexW(N:Word):String; Forward;
  68.  
  69. Procedure SendAt(X,Y:Byte; S:String);
  70.  Begin
  71.    GotoXY(X,Y); Write(S);
  72.   End;
  73.  
  74. Procedure Frames;
  75.  Var T:Byte;
  76.  Begin
  77.    Window(1,1,80,25);
  78.    GotoXY(1,1); Write('╔══════════════════════════════════════╦═══════════════════════════════════════╗');
  79.    For T:=2 to 24 do Begin
  80.      GotoXY(1,T); Write('║'); GotoXY(40,T); Write('║');
  81.      GotoXY(80,T); Write('║');
  82.     End;
  83.    GotoXY(1,4); Write('╠══════════════════════════════════════╣');
  84.    GotoXY(40,3); Write('╠═══════════════════════════════════════╣');
  85.   End;
  86.  
  87. Procedure FindEnviron(S:String;var PSPS,PSPO:Word);
  88.  Var Count:Integer; Found:Boolean;
  89.  Begin
  90.    For Count:=1 to Length(S) do S[Count]:=UpCase(S[Count]);
  91.    S:=S+'=';
  92.    PSPO:=0; PSPS:=MemW[CSeg-$10:$2C];
  93.    Count:=1; Found:=False;
  94.    While (Count<=Length(S)) and (PSPO<32768) do Begin
  95.      If S[Count]<>Chr(Mem[PSPS:PSPO]) then Begin
  96.        Count:=1; While (PSPO<32768) and (Mem[PSPS:PSPO]<>0) do Inc(PSPO);
  97.        If (PSPO>=32768) then Found:=False  Else Begin
  98.          Inc(PSPO); If Mem[PSPS:PSPO]=0 then Begin
  99.            PSPO:=$FFFF; Found:=False;
  100.           End;
  101.         End;
  102.       End Else Begin
  103.         Inc(Count); Inc(PSPO);
  104.        End;
  105.     End;
  106.    If Count>Length(S) then Found:=True  Else Found:=False;
  107.    If Not Found then Begin
  108.      PSPS:=0; PSPO:=0;
  109.     End Else Begin
  110.       While (PSPO>0) and (Mem[PSPS:PSPO]<>0) do Dec(PSPO);
  111.       If Mem[PSPS:PSPO]=0 then Inc(PSPO);
  112.      End;
  113.   End;
  114.  
  115. Function GetEnviron(S:String):String;
  116.  Var Se,OOf:Word; St:String; T:Integer;
  117.  Begin
  118.    FindEnviron(S,Se,OOf);
  119.    If Se<>0 then Begin
  120.      St:=''; While (Mem[Se:OOf]<>Ord('=')) and (OOf<32768) do Inc(OOf);
  121.      Inc(OOf);
  122.      While (Mem[Se:OOf]<>0) and (OOf<32768) do Begin
  123.        St:=St+Chr(Mem[Se:OOf]); Inc(OOf);
  124.       End;
  125.     End Else St:='';
  126.    GetEnviron:=St;
  127.   End;
  128.  
  129. Function LstDrive:Char;
  130.  Var A:Char; S:String;
  131.  Begin
  132.    S:=GetEnviron('LastDrive'); If S='' then Begin
  133.      S:=ParamStr(1); If S='' then S:='Z' Else S:=S[1];
  134.     End;
  135.    LstDrive:=UpCase(S[1]);
  136.   End;
  137.  
  138. Function DoStr1(Num:LongInt;Y:Word):String;
  139.  Var S:String; X:Word;
  140.  Begin
  141.    Str(Num:0,S); X:=Length(S);
  142.    If X>9 then S:=Copy(S,1,X-9)+','+Copy(S,X-8,3)+','+Copy(S,X-6,3)+','+Copy(S,X-5,3)+','+Copy(S,X-2,30)
  143.    Else If X>6 then S:=Copy(S,1,X-6)+','+Copy(S,X-5,3)+','+Copy(S,X-2,30)
  144.     Else If X>3 then S:=Copy(S,1,X-3)+','+Copy(S,X-2,30);
  145.    While Length(S)<Y do S:=' '+S;
  146.    DoStr1:=S
  147.   End;
  148.  
  149. Function DoStr(Num:LongInt;Y:Word):String;
  150.  Var S:String; Start:Boolean; Fctr:Char; X:Byte;
  151.  Begin
  152.    Start:=True; Fctr:=#0; X:=Y;
  153.    While Start or (Length(S)>X) do Begin
  154.      If Start then Begin
  155.        Start:=False;
  156.       End Else Begin
  157.         Num:=Trunc(Num/1024+0.599999);
  158.         If Fctr='m' then Fctr:='g';
  159.         If Fctr='k' then Fctr:='m';
  160.         If Fctr=#0  then Fctr:='k';
  161.         X:=Y-1;
  162.        End;
  163.      S:=DoStr1(Num,X);
  164.     End;
  165.    If Fctr>#0 then S:=S+Fctr;
  166.    DoStr:=S;
  167.   End;
  168.  
  169. Function Hex(N:Byte):String;
  170.  Var X,T:Word; S,Numbers:String;
  171.  Begin
  172.    S:=''; Numbers:='0123456789ABCDEF';
  173.    X:=Trunc(N/16); N:=N Mod 16;
  174.    S:=S+Numbers[X+1]; X:=N;
  175.    S:=S+Numbers[X+1];
  176.    Hex:=S;
  177.   End;
  178.  
  179. Function HexW(N:Word):String;
  180.  Begin
  181.    HexW:=Hex(Hi(N))+Hex(Lo(N));
  182.   End;
  183.  
  184. Function CompArr(X:Word;Y:DumArr):Boolean;
  185.  Var W:Boolean; T:Byte;
  186.  Begin
  187.    W:=True;
  188.    For T:=0 to 6 do Begin
  189.      If Y[T]<>Mem[CurArena:T+X] then Begin W:=False; T:=6; End;
  190.     End;
  191.    CompArr:=W;
  192.   End;
  193.  
  194. Procedure GetOwner(S:Word);
  195.  Var T:Word; P:String;
  196.  Begin
  197.    P:=': resident';
  198.    If CompArr(ClkLoc,Clock)    then P:=': CLOCK display';
  199.    If CompArr(PasLoc,Pascal)   then P:=': PASCAL compiler';
  200.    If CompArr(KeyLoc,SupKey)   then P:=': SUPERKEY';
  201.    If CompArr(LitLoc,Lightng)  then P:=': LIGHTNING';
  202.    If CompArr(PcTLoc,PcTools)  then P:=': PCTOOLS';
  203.    If CompArr(SKLoc ,SideKik)  then P:=': SIDEKICK';
  204.    If CompArr(Com3_3L,Com3_3)  then P:=': DOS command v 3.3';
  205.    If CompArr(QegLoc,Qega)     then P:=': QEGA processor';
  206.    If CompArr(DVULoc,DVUser)   then P:=': DesqView Users';
  207.    If CompArr(CacLoc,Cache)    then P:=': PC disk Cache';
  208.    If CompArr(HercLoc,Hercul)  then P:=': Hercules graphics';
  209.    If CompArr(PushLoc,PushD)   then P:=': PUSHDIR';
  210.    If CompArr(AnsiLoc,DvAnsi)  then P:=': DVAnsi driver';
  211.    If MemW[S:3]+S+2=MemW[S:1]  then Begin
  212.      Write(': DOS environments'); GotoXY(1+4+3,WhereY);
  213.      EnvSz:=MemW[CurArena:3]+1;   PstEnv:=True;
  214.     End Else Begin
  215.       If P=': resident' then If MemW[CurArena:1]<>CurArena+$1 then
  216.         P:=': allocated to '+HexW(MemW[CurArena:1]);
  217.       PstEnv:=False; EnvSz:=0; Write(P);
  218.      End;
  219.   End;
  220.  
  221. Procedure MemoryArena;
  222.  Var
  223.     T,NxtArena,LstArena,LrgCont,Contig,ArenaH:Word;
  224.     LstCont,Got,MeFound:Boolean; A:Char;
  225.  Begin
  226.    Window(2,5,39,24);
  227.    T:=$50; Got:=False; PstEnv:=False; MeFound:=False;
  228.    While (Not Got) and (T<Reported) do Begin
  229.      If MemW[T:$10]=$20CD then Begin
  230.        If MemW[T:1]+MemW[T:3]=MemW[T:$12] then Begin
  231.          Got:=True; CurArena:=T;
  232.         End;
  233.       End;
  234.      T:=T+1;
  235.     End;
  236.    If WhereY>1 then Write(CR);
  237.    Write('0000 - '+HexW(CurArena)+' '+DoStr(Trunc(RR(CurArena)*16),4)+' ');
  238.    Write(': BIOS/DOS');
  239.    FreSize:=0; LstArena:=0; LrgCont:=0; Contig:=0; LstCont:=False; ArenaH:=0;
  240.    While (CurArena>ArenaH) and
  241.          (CurArena<Reported)    do    Begin
  242.      If Keypressed then Begin
  243.        A:=ReadKey; If A=#3 then Halt; If A=#0 then A:=ReadKey;
  244.        A:=ReadKey;
  245.       End;
  246.      If WhereY>17 then Delay(300);
  247.      NxtArena:=CurArena+MemW[CurArena:3]+1;
  248.      If CurArena>ArenaH then ArenaH:=CurArena;
  249.      If MemW[CurArena:1]=0 then Begin PstEnv:=False; EnvSz:=0; End;
  250.      If Not PstEnv then Begin Write(CR+HexW(CurArena)+' - '); EnvSz:=0;
  251.       End Else Begin
  252.         ClrEol;
  253.        End;
  254.      Write(HexW(NxtArena)+' '+DoStr(Trunc(RR(MemW[CurArena:3]+1+EnvSz)*16),4)+' ');
  255.      If (MemW[CurArena:1]=0) or    {NOT OWNED}
  256.         (MCSeg=CurArena)     then Begin
  257.        If (MCSeg=CurArena)   then Begin Write(': Me'); MeFound:=True; End
  258.         Else Write(':  -- FREE! -- ');
  259.        Contig:=Contig+MemW[CurArena:3]+1;
  260.        LstCont:=True; PstEnv:=False; EnvSz:=0;
  261.        FreSize:=FreSize+MemW[CurArena:3]+1;
  262.       End Else Begin                {OWNED}
  263.         GetOwner(CurArena);
  264.         If CompArr(PasLoc,Pascal) then Begin
  265.           FreSize:=FreSize+MemW[CurArena:3]+1;
  266.           Contig:=Contig+MemW[CurArena:3]+1;
  267.           LstCont:=True;
  268.          End Else If LstCont then Begin
  269.            If Contig>LrgCont then LrgCont:=Contig;
  270.            LstCont:=False; Contig:=0;
  271.           End;
  272.        End;
  273.      LstArena:=CurArena;
  274.      CurArena:=NxtArena;
  275.      If (CurArena<=LstArena) or
  276.         (CurArena>=Reported)    and
  277.         (MeFound=False)      then Begin
  278.        CurArena:=MCSeg; LstArena:=0; NxtArena:=CurArena+MemW[CurArena:3]+1;
  279.       End;
  280.     End;
  281.    If LstCont then Begin
  282.      If Contig>LrgCont then LrgCont:=Contig;
  283.     End;
  284. {   Write(Cr+' My block = ',DoStr(Trunc(RR(MemW[CSeg-$10:02]-MCSeg)*16),9));  }
  285.    If FreSize=0 then Begin
  286.      FreSize:=1;
  287.      If LrgCont=0 then LrgCont:=1;
  288.     End;
  289.    If LrgCont<FreSize then
  290.     Write(CR+' LARGEST BLOCK   : '+DoStr(Trunc(RR(LrgCont-1)*16),9));
  291.    If WhereY+5>=HiY then HiY:=WhereY+5;
  292.    Window(41,4,79,24); SendAt(SysMemX,SysMemY,DoStr(Trunc(RR(FreSize-1)*16),9)+' bytes');
  293.   End;
  294.  
  295. Procedure GetSpeed;
  296.  Var
  297.    NewTime:LongInt;
  298.    X,Fctr:Word;
  299.  Const NDirectFctr=63;
  300.         DirectFctr=165;
  301.  Begin
  302.    If DirectVideo then Fctr:=DirectFctr  Else Fctr:=NDirectFctr;
  303.    SendAt(12,2,' Dos Speed:');
  304.    Regs.AX:=$2C00; MsDos(Regs);
  305.    Inc(Regs.DH); If Regs.DH>59 then Begin
  306.      Regs.DH:=0; Inc(Regs.CL); If Regs.CL>59 then Begin
  307.        Regs.CL:=0; Inc(Regs.CH); If Regs.CH>23 then Regs.CH:=0;
  308.       End;
  309.     End;
  310.    NewTime:=((Regs.CX shl 16) + Regs.DX); Regs.CX:=0; Regs.DX:=0;
  311.    X:=0; While ((Regs.CX shl 16) + Regs.DX<NewTime) and (X<(Fctr*10)) do
  312.      Begin X:=X+1; Regs.AX:=$2C00; MsDos(Regs);
  313.      GotoXY(13,3); Write((X/Fctr)*100:7:2,'%');
  314.     End;
  315.    If X>=Fctr*10 then Begin
  316.      SendAt(13,3,' MISSED ');
  317.     End;
  318.    Write(CR+CR);
  319.   End;
  320.  
  321. Function ValidDr(X:Byte):Boolean;
  322.  Begin
  323.    X:=X-1; If X<2 then Begin
  324.      Regs.AH:=0; Intr($13,Regs);
  325.      Regs.AH:=4; Regs.AL:=1; Regs.CH:=0; Regs.CL:=1;
  326.      Regs.DH:=0; Regs.DL:=X; Intr($13,Regs);
  327.      ValidDr:=((Regs.Flags and Fcarry)=0)
  328.     End Else Begin
  329.       ValidDr:=(DiskSize(X+1)>1024);
  330.      End;
  331.   End;
  332.  
  333. Procedure GetDrives;
  334.   Var Dr:Array[0..5] of Word; T,X,Fails:Byte; R:LongInt;
  335.  Begin
  336.    GotoXY(41,2); WriteLn('              Size   /     Available');
  337.    Window(41,4,79,24); Fails:=0;
  338.    T:=1; While T<=Ord(LstDrive)-64 do Begin
  339.      Regs.AH:=$0D; MsDos(Regs);
  340.      If ValidDr(T) then Begin
  341.        Write('       '+Chr(64+T)+': '+DoStr(DiskSize(T),10)+' / '+
  342.                                       DoStr(DiskFree(T),10)+' bytes');
  343.       End;
  344.      Inc(T);
  345.     End;
  346.   End;
  347.  
  348. Procedure GetExtended;
  349.  Var X:Word;
  350.  Begin
  351.    X:=MemW[0:$19C];
  352.    If X>0 then Begin
  353.      Regs.AX:=$4200; Intr($67,Regs);
  354.      If Regs.AX=0 then Begin
  355.         SendAt(40,WhereY,'AboveBoard: '+DoStr(Trunc(Regs.DX * (HiInt/2)),8)+' /   '+
  356.                                         DoStr(Trunc(Regs.BX * (HiInt/2)),8)+' bytes')
  357.        End;
  358.     End;
  359.   End;
  360.  
  361. Procedure SystemMem;
  362.  Var  Amount,Start,Ends:Word; Work:LongInt;
  363.  Begin
  364.    Intr($12,Regs); Reported:=Regs.AX; GotoXY(40,WhereY);
  365.    Write('System Mem: '+DoStr(Trunc(RR(Regs.AX)) Shl 10,8)+' /  ');
  366.    SysMemX:=WhereX; SysMemY:=WhereY; HiY:=WhereY+4;
  367.    Reported:=Trunc(Reported/16*1024);
  368.    MemoryArena; WriteLn;
  369.   End;
  370.  
  371. Begin
  372.   Colors;
  373.   CR:=#13+#10;
  374.   ClrScr; MCseg:=CSeg-$11; Frames;
  375.   GetSpeed; GetDrives;
  376.   GetExtended;
  377.   SystemMem;
  378.   Window(1,HiY,80,25); ClrScr;
  379.   Write('╚══════════════════════════════════════╩═══════════════════════════════════════╝');
  380.  End.
  381.