Posted By: Jovo (Jovo) on 'CZprogram'
Title:     Pascal a velke bloky pameti
Date:      Wed Jan 15 10:45:20 1997

{

Nazdar,
  tohle je unita, ktera pracuje pod Pascalem s velkejma blokama pameti
  (>64KB). Program se musi ladit pod BP.EXE a v menu Compile nastavit
  target na PROTECTED !. BP bezi pod DPMI, proto je treba mit QEMM, nebo
  dpmi16.ovl a ja uz nevim co.
    Chyba je, ze to nejde primo krokovat (F8). Jedinej zpusob je v
  Options/Tools/Turbo Debugger nastavit misto TD -> TDX a pak program
  prelozit (F9) a pak na nej pustit TDX (shift+F4). Zaroven je dobry
  v Options/Debugger nastavit jak Standalone ... tak Integrated ...
  prokrokovani zdrojaku a ne prelozeneho kodu :)

    Pak jen Malloc(pointer, velikost) / Free(pointer) a jede to.
  Hlodla pamet se hned Zamkne. DPMI totiz muze swapovat na disk a proto
  se pamet, kdyz se s ni nic nedela odemkne (GlobalLock, GlobalUnLock)
  a kdyz je treba, pak se zamkne.  Malloc hned zamyka, takze se o to
  nemusite starat.

  ------------------------------------------------------------------------

    Testovaci programek dole naplni pole 640*480 LongIntu a kazdej naplni
  a pak je precte a porovna, jestli to sedi. Fachalo mi to pod BP.EXE 7.0
  a EMM386. Zkusil jsem treba takove forky, jako je zapsat dva Wordy a pak
  to precist jako LongInt a vono to fachalo ! Nooo, na 386/40 to byla hruza,
  ale na Pentaku/100 to byly vteriny.

  Kouknete se na proceduru AdjustPointer, NUTNE ji potrebuju zoptimalizovat !
  Zkusil jsem udelat 32-bit .OBJ v ASM a slinkovat to, ale porad mi to hlasi
  GPF, zrejme, ze to nema povolenej pristup do Cseg a Dseg nebo co. Pak jsem
  to zkusil udelat pres
    db $66 mov es,_index
  a asi nejsem takovej machr, aby mi to chodilo :)
  HEEEEELP ! PLEEEEEAAAASEEEEEE ! Optimalizujte to a postnete to sem.

                                                              Jovo.

{----------------------------------------------------------------------}
{ cut here }
unit memwrite;
{by JOVO 97,
  -  xhovor00@dcse.fee.vutbr.cz
  -  public domain, ale kdyz to budete chtit pouzit, tak skody zpusobene timto
     kodem jdou na vas vrub a poslete mi trochu slivovice :) jako odmenu a
     nebude-li slivka, tak mi dejte kredit.
  -  Jestli to modifikujete, tak mi to poslete, protoze bych rad dostal nejake
     do ruky nejake optimalizace, tohle je jen first-thought code, i kdyz
     facha
  -  co takhle WriteProm ( var p:pointer;var promenna;var count : byte);
                 ktera by psala promennou do pameti na zaklade odkazu a kolik
                 byte zapsat ? Hmm, to stoji za pokus.
}
interface
uses winapi;
  {to je for, co :) }

  type
     short = shortint;
     long  = longint;
     int   = integer;
     {jestli nekdo potrebuje vetsi presnost, tak sorry.
       Type     | Range               | Digits | Bytes  | Pocet/64KB
       --------------------------------------------------------
       short    | -128..127                    |  1   * |  65536
       byte     | 0..255                       |  1   * |  65536
       int      | -32768..32767                |  2   * |  32768
       word     | 0..65535                     |  2   * |  32768
       long     | -2147483648..2147483647      |  4   * |  16384
       --------------------------------------------------------
       real     | 2.9e-39..1.7e38     | 11-12  |  6     | -----
       single   | 1.5e-45..3.4e38     |  7-8   |  4   * |  16384
       double   | 5.0e-324..1.7e308   | 15-16  |  8   * |   8192
       extended | 3.4e-4932..1.1e4932 | 19-20  | 10     | ------
       comp     | -9.2e18..9.2e18     | 19-20  |  8   * |   8192
     Jak vidno, pouze typy oznacene  *  jsou 'sude' - vleze se jich do
     jednoho segmentu cely pocet. Kdybyste pak chteli zapsat napriklad
     real (6B) na adresu 65535-1, tak se prvni 2B vlezou a 4B za nima
     nechutne 'pretecou' -> GPF error jak blazen :)
     }
      real = double;
    function Malloc(size:long):pointer;
    { = getmem
      - alokuje a zamkne blok pameti}
    function  free(var p:pointer):Thandle;
    { = freemem, jenze je bez parametru (udavajici pocet uvolnovanych byte)
      - uvolni a odemkne blok pameti}

  {No, a tyhle procedurky a funkce zapisi Byte,Long,...,Real do pameti
   na urcene misto. Prectete si popis u WRITESHORT}
  procedure WriteShort(p:pointer;index:long;S:short);
  function  ReadShort(p:pointer;index:long):short;
  procedure WriteByte(p:pointer;index:long;R:byte);
  function  ReadByte(p:pointer;index:long):byte;
  procedure WriteInt(p:pointer;index:long;R:int);
  function  ReadInt(p:pointer;index:long):int;
  procedure WriteWord(p:pointer;index:long;R:word);
  function  ReadWord(p:pointer;index:long):word;
  procedure WriteLong(p:pointer;index:long;R:long);
  function  ReadLong(p:pointer;index:long):long;
  procedure WriteReal(p:pointer;index:long;R:real);
  function  ReadReal(p:pointer;index:long):real;



implementation
{tak tohle jsou vnitrni konstanty a promenne}
const flags=GMEM_zeroinit;{cerstve hlodla pamet se vymaze nulama}
const Q = 65535; {viz adjust Pointer}
const __SB = sizeof(byte);{   uff  }
      __SS = sizeof(short);
      __SI = sizeof(int);
      __SW = sizeof(word);
      __SL = sizeof(long);
      __SR = sizeof(real);
      safe = 56   ; {Kolik byte se alokuje navic na kazdy pointer, aby moh
                     clovek po alokaci 150ti Longu moh zapsat i ten 150tej a
                     nedockal se GPF error (216).
   Experimentalne ziskane vysledky hodnoty SAFE:
     byte    :5         5*1 +0
     word    :11        5*2 +1
     long    :22        5*4 +2
     real    :34        5*6 +4
     extended:56        5*10+6
   Coz je zrejme Sizeof(typ)*5 + SizeOf(predchazejici Typ);
   }

VAR
     _PB:^Byte; {ukazatele, pres ktere se zapisuje a cte}
     _PS:^Short;
     _PI:^Int;
     _PW:^Word;
     _PL:^Long;
     _PR:^Real;
     _index:Long;   {prepocitavaci index}
     _p    :pointer;{pointer, obema se ulehci zasobniku}
     s,o:word;


    function Malloc(size:long):pointer;
      begin;
        Malloc:=GlobalAllocPtr(flags,size+safe);
      end;

    function  free(var p:pointer):Thandle;
      begin;
        free:=GlobalFreePtr(p);
      end;


  Function AdjustPointer:pointer;
  {prepocte segment a offset pointru vzhledem k _indexu}
  {const Q = 65535 }
    begin;
      asm
        les di,_p
        mov s,es
        mov o,di
      end;{ ziskani kam ukazuje p}

      while _index>Q do       {dokud preleza hranici 64KB...}
        begin;
          s:=s+SelectorInc;   { ...zvedni segment o 8... }
          _index:=_index-Q-1; {a zmensi ho o hranice-1, proc o -1 to nevim
                               ale facha to :) }
        end;
      AdjustPointer:=ptr(s,o+_index);{pak z seg a ofs vyrob pointer
                                      a ten vrat}
    end;




  procedure WriteShort(p:pointer;index:long;S:short);
    begin;
        _index:=index*__SS;{index je v bytech, proto se musi vynasobit
                           velikosti toho ktereho typu. Tady to zrovna
                           neni treba, ale uz takovy typ word...}
        _p := p;           {pomocne prirazeni}
        _PS:=AdjustPointer;{Prepocita pointer. Funkce GlobalAllocPtr alokuje
                               pamet jako po sobe jdouci segmenty. Jenze v sele
                               ktorech je neco navic (prava), takze kdyz 
prelezeme
                               64KB hranici, neinkrementuje se segment, ale 
musi se
                               k nemu pripocitat 8. To znamena, ze jestlize je
                               index 5x pres hranici 64KB, pak se SSSS:OOOO 
prepocita
                               jako SSSS+8*5:OOOO a mame spravny index.}
        _PS^:=S;{Zapise short.}
    end;

  function  ReadShort(p:pointer;index:long):short;
    begin;
        _index:=index*__SS;_p := p;
        _PS:=AdjustPointer;
        ReadShort:=_PS^;
    end;

  procedure WriteByte(p:pointer;index:long;R:byte);
    begin;
        _index:=index*__SB;_p := p;
        _PB:=AdjustPointer;
        _PB^:=R;
    end;

  function  ReadByte(p:pointer;index:long):byte;
    begin;
        _index:=index*__SB;_p := p;
        _PB:=AdjustPointer;
        ReadByte:=_PB^;
    end;

  procedure WriteInt(p:pointer;index:long;R:int);
    begin;
        _index:=index*__SI;_p := p;
        _PI:=AdjustPointer;
        _PI^:=R;
    end;

  function  ReadInt(p:pointer;index:long):int;
    begin;
        _index:=index*__SI;_p := p;
        _PI:=AdjustPointer;
        ReadInt:=_PI^;
    end;

  procedure WriteWord(p:pointer;index:long;R:word);
    begin;
        _index:=index*__SW;_p := p;
        _PW:=AdjustPointer;
        _PW^:=R;
    end;

  function  ReadWord(p:pointer;index:long):word;
    begin;
        _index:=index*__SW;_p := p;
        _PW:=AdjustPointer;
        ReadWord:=_PW^;
    end;

  procedure WriteLong(p:pointer;index:long;R:long);
    begin;
        _index:=index*__SL;_p := p;
        _PL:=AdjustPointer;
        _PL^:=R;
    end;

  function  ReadLong(p:pointer;index:long):long;
    begin;
        _index:=index*__SL;_p := p;
        _PL:=AdjustPointer;
        ReadLong:=_PL^;
    end;

  procedure WriteReal(p:pointer;index:long;R:real);
    begin;
        _index:=index*__SR;_p := p;
        _PR:=AdjustPointer;
        _PR^:=R;
    end;

  function  ReadReal(p:pointer;index:long):real;
    begin;
        _index:=index*__SR;_p := p;
        _PR:=AdjustPointer;
        ReadReal:=_PR^;
    end;
{/////////////////////////////////////////////////////////////////////////////}

begin;
  writeln('Pripocitavat se bude : ',SelectorInc);
  if SelectorInc=$1000 then
    begin;
      writeln('...tato hodnota odpovida realnemu modu, ja chci DPMI !....');
      halt(1);
    end;
end.


{----------------------------------------------------------------------}
{ cut here }

program memwrite_test;
uses crt,memwrite;

   procedure pam;
     begin;
       writeln(' volna pamet : ',maxavail,' Byte.');
     end;



var p,p2:pointer;
    pocet:long;
    r:real;
    L,base:long;
    W:word;
begin;
  clrscr;
  pam;
  w:=SizeOf(long);
  pocet:=640*480;

  writeln('Pocet = ',pocet,'  velikost jednotky = ',w,'  clekem = ',pocet*w,' 
Byte');

  P:=Malloc(pocet*w);{alokace}
  pam;
  if P=Nil then
    begin;
      writeln('malo pameti....');
      halt;
    end;

  writeln('test start');
  for l:=0 to pocet do  writeLong(p,l,l);
    {zapiseme longinty}
  writeln('konec zapisu');

  for l:=0 to pocet do
    {a pak je cteme, jestli souhlasi}
    if ReadLong(p,l)<>l then
      begin;
        writeln('L = ',L,' ziskana hodnota = ',ReadLong(p,l));
        {a jestli neco nesouhlasi}
      end;
  writeln('test end');
  Free(p);{uvolneni}
  pam;
end.
{----------------------------------------------------------}
{No a to je vse, pratele.} 

Search the boards