home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / UTILITY / SYSTEM / GETTIME.ZIP / STOPWATC.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-12-01  |  1.7 KB  |  79 lines
  1. unit stopwatch;
  2. interface
  3. uses hexdump;
  4. type clock = longint;
  5. procedure startclock(var c: clock);
  6. function  stopclock(c: clock): real;
  7. procedure wait(secs: real);
  8. procedure milliwait(millisecs: word);
  9.  
  10. implementation
  11.  
  12. var timer_freq: longint;
  13.   x, prevx: byte;
  14.   diff: word;
  15.  
  16. function cyclecnt: byte; {counter in timer chip channel 0);}
  17.    var c: word;
  18.        cr: record
  19.             clo: byte;
  20.             chi: byte
  21.            end absolute c;
  22. begin
  23.    inline ($FA); {CLI  disable interrupt}
  24.    port[$43] := $06; {channel 0, latch present value, mode 3, binary}
  25.    cr.clo := port[$40];
  26.    cr.chi := port[$40];
  27.    inline ($FB); {STI  enable interrupt};
  28.    cyclecnt := hi(c);
  29. end;
  30.  
  31. procedure milliwait(millisecs: word);
  32. const debug=false;
  33. var
  34.     countdown: longint;
  35. begin
  36.     countdown := millisecs * timer_freq div 1000;
  37.     if debug then writeln('countdown: ', countdown);
  38.     x := cyclecnt;
  39.     repeat
  40.       prevx := x;
  41.       x := cyclecnt;
  42.       if x<prevx then diff := prevx - x
  43.  
  44.       else diff := word(prevx) + $100 - x;
  45.  
  46.       if debug then writeln ('prev: ', word_to_hex(prevx),
  47.           '  x: ', word_to_hex(x), '  diff: ', word_to_hex(diff),
  48.           '  countdown: ', countdown);
  49.       dec (countdown, diff)
  50.     until countdown <= 0;
  51. end;
  52.  
  53.  
  54. procedure startclock(var c: clock);
  55. var ticks: longint absolute $0040:$006C;
  56. begin
  57.    c := ticks;
  58. end;
  59.  
  60. function stopclock(c: clock): real;
  61. var ticks: longint absolute $0040:$006C;
  62. begin
  63.   stopclock := (ticks - c) / 18.2;
  64. end;
  65.  
  66.  
  67.  
  68. procedure wait(secs: real);
  69.    var c: clock;
  70. begin
  71.    startclock(c);
  72.    repeat
  73.      begin end
  74.    until stopclock(c) >= secs;
  75. end;
  76. begin
  77.   timer_freq := round (3386360 / (1.418 * $100));
  78. end.
  79.