home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / sound / sbutil / misc.exe / MISC.PAS next >
Encoding:
Pascal/Delphi Source File  |  1991-04-04  |  9.9 KB  |  311 lines
  1. {**************************************************************************
  2.  
  3.                                  MISC
  4.  
  5.                   Copyright (C) 1990,91 Anthony Rumble
  6.  
  7. Author: Anthony Rumble
  8. Date: 15/01/91
  9.  
  10. *************************************************************************}
  11. unit misc;
  12.  
  13. interface
  14.  
  15. uses dos, crt, mtask;
  16.  
  17. function DecToHex (Number: longint; HexChars: byte): string;
  18. function julian:longint;
  19. function mkstring(t:word):string;
  20. procedure wait(t:longint);
  21. function spc(o:integer):string;
  22. function rpt(r:char; tms:word):string;
  23. function pwr(I:integer; power:integer):integer;
  24. procedure display_bits(i:byte);
  25. procedure pause;
  26. function Exist(fs :string) :boolean;
  27. Function Upper(Str:string):string;
  28.  
  29. Function Malloc(Var Ptr; Size : Word) : Word;
  30. { Allocate free memory and return a pointer to it.  The amount of memory      }
  31. { requested from DOS is calculated as (Size/4)+1 paragraphs.  If the          }
  32. { allocation is successful, the untyped VAR parameter Ptr will be populated   }
  33. { with the address of the allocated memory block, and the function will return}
  34. { a zero result.  Should the request to DOS fail, Ptr will be populated with  }
  35. { the value NIL, and the function will return the appropriate DOS error code. }
  36.  
  37. Function Dalloc(Var Ptr) : Word;
  38. { Deallocate the memory pointed to by the untyped VAR parameter Ptr           }
  39.  
  40. Function DosMemAvail : LongInt;
  41. { Return the size of the largest contiguous chuck of memory available for use }
  42.  
  43. implementation
  44. {***************************************************************************
  45.                              DECTOHEX
  46. ***************************************************************************}
  47. { -- Converts any number into a Hex character string -- }
  48. function DecToHex (Number: longint; HexChars: byte): string;
  49. const
  50.   D2H: array[0..$F] of char = '0123456789ABCDEF';
  51. var
  52.   HexStr:       string;
  53.   HexChar,Bits: byte;
  54. begin
  55.   HexStr:='';
  56.   for HexChar:=0 to pred(HexChars) do
  57.     begin
  58.       Bits:=HexChar shl 2;
  59.       HexStr:=D2H[(Number shr Bits) and $F] + HexStr;
  60.     end;
  61.   DecToHex:='$' + HexStr;
  62. end;
  63. {***************************************************************************
  64.                              JULIAN
  65. ***************************************************************************}
  66. function julian:longint;
  67. var
  68.  year, month, day, dayofweek:word;
  69.  hour, minute, second, sec100:word;
  70.  temp:longint;
  71. begin
  72.  temp:=0;
  73.  getdate(year, month, day, dayofweek);
  74.  gettime(hour, minute, second, sec100);
  75.  temp:=month * 2419200;
  76.  temp:=temp + day * 86400;
  77.  temp:=temp + hour * 3600;
  78.  temp:=temp + minute * 60;
  79.  temp:=temp + second;
  80.  julian:=temp;
  81. end;
  82. {***************************************************************************
  83.                                RPT
  84. ***************************************************************************}
  85. function rpt(r:char; tms:word):string;
  86. var
  87.  tmp:string;
  88.  x:integer;
  89. begin
  90.  tmp:='';
  91.  for x:=1 to tms do
  92.   tmp:=tmp+r;
  93.  rpt:=tmp;
  94. end;
  95. {***************************************************************************
  96.                                MKSTRING
  97. ***************************************************************************}
  98. function mkstring(t:word):string;
  99. var
  100.  temp:string;
  101. begin
  102.  str(t, temp);
  103.  mkstring:=temp;
  104. end;
  105.  
  106. {***************************************************************************
  107.                                WAIT
  108. ***************************************************************************}
  109. procedure wait(t:longint);
  110. var
  111.  tmp:longint;
  112. begin
  113.  tmp:=julian+t;
  114.  repeat;
  115.  taskswitch;
  116.  until julian > tmp;
  117. end;
  118. {***************************************************************************
  119.                                   SPC
  120. ***************************************************************************}
  121. function spc(o:integer):string;
  122. var g:integer;
  123.     tmp:string;
  124. begin
  125.  tmp:='';
  126.  for g:=1 to o do
  127.  begin
  128.   tmp:=tmp+' ';
  129.  end;
  130.  spc:=tmp;
  131. end;
  132. {***************************************************************************
  133.                                   PWR
  134. ***************************************************************************}
  135. function pwr(i:integer; power:integer):integer;
  136. var
  137.  a:integer;
  138.  tmp:longint;
  139. begin
  140.  tmp:=1;
  141.  for a:=1 to power do
  142.  begin
  143.   tmp:=tmp*i;
  144.  end;
  145.  pwr:=tmp;
  146. end;
  147. {***************************************************************************
  148.                              DISPLAY_BITS
  149. ***************************************************************************}
  150. procedure display_bits(i:byte);
  151. var
  152.  tmp:byte;
  153. begin
  154.  tmp:=i;
  155.  {Check bit 7}
  156.  if tmp>127 then
  157.  begin
  158.   write('1');
  159.   tmp:=tmp-128;
  160.  end else write('0');
  161.  {Check bit 6}
  162.  if tmp>63 then
  163.  begin
  164.   write('1');
  165.   tmp:=tmp-64;
  166.  end else write('0');
  167.  {Check bit 5}
  168.  if tmp>31 then
  169.  begin
  170.   write('1');
  171.   tmp:=tmp-32;
  172.  end else write('0');
  173.  {Check bit 4}
  174.  if tmp>15 then
  175.  begin
  176.   write('1');
  177.   tmp:=tmp-16;
  178.  end else write('0');
  179.  {Check bit 3}
  180.  if tmp>7 then
  181.  begin
  182.   write('1');
  183.   tmp:=tmp-8;
  184.  end else write('0');
  185.  {Check bit 2}
  186.  if tmp>3 then
  187.  begin
  188.   write('1');
  189.   tmp:=tmp-4;
  190.  end else write('0');
  191.  {Check bit 1}
  192.  if tmp>1 then
  193.  begin
  194.   write('1');
  195.   tmp:=tmp-2;
  196.  end else write('0');
  197.  {Check bit 0}
  198.  if tmp>0 then
  199.  begin
  200.   write('1');
  201.  end else write('0');
  202.  writeln;
  203. end;
  204. {***************************************************************************
  205.                                   PAUSE
  206. ***************************************************************************}
  207. procedure pause;
  208. var
  209.  ch:char;
  210. begin
  211.  write('Press any key to continue:');
  212.  repeat;
  213.  taskswitch;
  214.  until keypressed;
  215.  ch:=readkey;
  216.  writeln;
  217. end;
  218. {***************************************************************************
  219.                                   EXIST
  220. ---------------------------------------------------------------------------
  221. Returns True if file exists; otherwise, it returns False.
  222. Closes the file if it exists.
  223. ***************************************************************************}
  224. function Exist(fs :string) :boolean;
  225. var
  226.  f: file;
  227.  tmp:boolean;
  228. begin
  229. {$I-}
  230.  Assign(f,fs);
  231.  Reset(f);
  232.  Close(f);
  233. {$I+}
  234.  tmp:=(IOResult=0) and (fs<>'');
  235.  exist:=tmp;
  236. end;
  237. {***************************************************************************
  238.                                   MALLOC
  239. ***************************************************************************}
  240. Function Malloc(Var Ptr; Size : Word) : Word;
  241. Begin
  242.    Inline(
  243.      $8B/$46/<SIZE/         {            mov         ax,[bp+<Size]}
  244.      $B9/$04/$00/           {            mov         cx,4}
  245.      $D3/$E8/               {            shr         ax,cl}
  246.      $40/                   {            inc         ax}
  247.      $89/$C3/               {            mov         bx,ax}
  248.      $B4/$48/               {            mov         ah,$48}
  249.      $CD/$21/               {            int         $21             ;Allocate memory}
  250.      $72/$07/               {            jc          AllocErr        ;If any errors ....}
  251.      $C7/$46/$FE/$00/$00/   {NoErrors:   mov word    [bp-2],0        ;Return 0 for successful allocation}
  252.      $EB/$05/               {            jmp short   Exit}
  253.      $89/$46/$FE/           {AllocErr:   mov         [bp-2],ax       ;Return error code}
  254.      $31/$C0/               {            xor         ax,ax           ;Store a NIL value into the ptr}
  255.      $C4/$7E/<PTR/          {Exit:       les         di,[bp+<Ptr]    ;Address of pointer into es:di}
  256.      $50/                   {            push        ax              ;Save the Segment part}
  257.      $31/$C0/               {            xor         ax,ax           ;Offset is always 0}
  258.      $FC/                   {            cld                         ;Make sure direction is upward}
  259.      $AB/                   {            stosw                       ;Store offset of memory block}
  260.      $58/                   {            pop         ax              ;Get back segment part}
  261.      $AB);                  {            stosw                       ;Store segment of memory block}
  262.    
  263. End {Malloc};
  264. {***************************************************************************
  265.                                   DALLOC
  266. ***************************************************************************}
  267. Function Dalloc(Var Ptr) : Word;
  268. Begin
  269.    If Pointer(Ptr) <> NIL then begin
  270.       Inline(
  271.         $B4/$49/               {            mov         ah,$49}
  272.         $C4/$7E/<PTR/          {            les         di,[bp+<Ptr]}
  273.         $26/$C4/$3D/           {        es: les         di,[di]}
  274.         $CD/$21/               {            int         $21}
  275.         $72/$02/               {            jc          Exit}
  276.         $31/$C0/               {NoError:    xor         ax,ax}
  277.         $89/$46/$FE);          {Exit:       mov         [bp-2],ax}
  278.       Pointer(Ptr) := NIL;
  279.    end {if}
  280.    else
  281.       Dalloc := 0;
  282. End {Dealloc};
  283. {***************************************************************************
  284.                              DOSMEMAVAIL
  285. ***************************************************************************}
  286. Function DosMemAvail : LongInt;
  287. Begin
  288.    Inline(
  289.      $BB/$FF/$FF/           {         mov         bx,$FFFF}
  290.      $B4/$48/               {         mov         ah,$48}
  291.      $CD/$21/               {         int         $21}
  292.      $89/$D8/               {         mov         ax,bx}
  293.      $B9/$10/$00/           {         mov         cx,16}
  294.      $F7/$E1/               {         mul         cx}
  295.      $89/$46/$FC/           {         mov         [bp-4],ax}
  296.      $89/$56/$FE);          {         mov         [bp-2],dx}
  297. end {DosMemAvail};
  298. {***************************************************************************
  299.                                 UPPER
  300. ***************************************************************************}
  301. Function Upper(Str:string):string;
  302. var
  303.   I : integer;
  304. begin
  305.     For I := 1 to length(Str) do
  306.         Str[I] := Upcase(Str[I]);
  307.     Upper := Str;
  308. end;  {Func Upper}
  309.  
  310.  
  311. end.