← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/amunits/demos/simple_timer.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/amunits/demos/simple_timer.pas
 
1
program simpletimer;
 
2
 
 
3
 
 
4
uses exec, timer, amigados, amigalib;
 
5
 
 
6
 
 
7
 
 
8
{ manifest constants -- 'never will change' }
 
9
const
 
10
     SECSPERMIN   = (60);
 
11
     SECSPERHOUR  = (60*60);
 
12
     SECSPERDAY   = (60*60*24);
 
13
 
 
14
var
 
15
     seconds : longint;
 
16
     tr      : ptimerequest;      { IO block for timer commands }
 
17
     oldtimeval : ttimeval;   { timevals to store times     }
 
18
     mytimeval  : ttimeval;
 
19
     currentval : ttimeval;
 
20
 
 
21
Function Create_Timer(theUnit : longint) : pTimeRequest;
 
22
var
 
23
    Error : longint;
 
24
    TimerPort : pMsgPort;
 
25
    TimeReq : pTimeRequest;
 
26
begin
 
27
    TimerPort := CreatePort(Nil, 0);
 
28
    if TimerPort = Nil then
 
29
        Create_Timer := Nil;
 
30
    TimeReq := pTimeRequest(CreateExtIO(TimerPort,sizeof(tTimeRequest)));
 
31
    if TimeReq = Nil then begin
 
32
        DeletePort(TimerPort);
 
33
        Create_Timer := Nil;
 
34
    end;
 
35
    Error := OpenDevice(TIMERNAME, theUnit, pIORequest(TimeReq), 0);
 
36
    if Error <> 0 then begin
 
37
        DeleteExtIO(pIORequest(TimeReq));
 
38
        DeletePort(TimerPort);
 
39
        Create_Timer := Nil;
 
40
    end;
 
41
    TimerBase := pointer(TimeReq^.tr_Node.io_Device);
 
42
    Create_Timer := pTimeRequest(TimeReq);
 
43
end;
 
44
 
 
45
Procedure Delete_Timer(WhichTimer : pTimeRequest);
 
46
var
 
47
    WhichPort : pMsgPort;
 
48
begin
 
49
 
 
50
    WhichPort := WhichTimer^.tr_Node.io_Message.mn_ReplyPort;
 
51
    if assigned(WhichTimer) then begin
 
52
        CloseDevice(pIORequest(WhichTimer));
 
53
        DeleteExtIO(pIORequest(WhichTimer));
 
54
    end;
 
55
    if assigned(WhichPort) then
 
56
        DeletePort(WhichPort);
 
57
end;
 
58
 
 
59
procedure wait_for_timer(tr : ptimerequest; tv : ptimeval);
 
60
begin
 
61
    tr^.tr_node.io_Command := TR_ADDREQUEST; { add a new timer request }
 
62
 
 
63
    { structure assignment }
 
64
    tr^.tr_time.tv_secs := tv^.tv_secs;
 
65
    tr^.tr_time.tv_micro := tv^.tv_micro;
 
66
 
 
67
    { post request to the timer -- will go to sleep till done }
 
68
    DoIO(pIORequest(tr));
 
69
end;
 
70
 
 
71
{ more precise timer than AmigaDOS Delay() }
 
72
function time_delay(tv : ptimeval; theunit : longint): longint;
 
73
var
 
74
    tr : ptimerequest;
 
75
begin
 
76
    { get a pointer to an initialized timer request block }
 
77
    tr := create_timer(theunit);
 
78
 
 
79
    { any nonzero return says timedelay routine didn't work. }
 
80
    if tr = NIL then time_delay := -1;
 
81
 
 
82
    wait_for_timer(tr, tv);
 
83
 
 
84
    { deallocate temporary structures }
 
85
    delete_timer(tr);
 
86
    time_delay := 0;
 
87
end;
 
88
 
 
89
function set_new_time(secs : longint): longint;
 
90
var
 
91
    tr : ptimerequest;
 
92
begin
 
93
    tr := create_timer(UNIT_MICROHZ);
 
94
 
 
95
    { non zero return says error }
 
96
    if tr = nil then set_new_time := -1;
 
97
 
 
98
    tr^.tr_time.tv_secs := secs;
 
99
    tr^.tr_time.tv_micro := 0;
 
100
    tr^.tr_node.io_Command := TR_SETSYSTIME;
 
101
    DoIO(pIORequest(tr));
 
102
 
 
103
    delete_timer(tr);
 
104
    set_new_time := 0;
 
105
end;
 
106
 
 
107
function get_sys_time(tv : ptimeval): longint;
 
108
var
 
109
    tr : ptimerequest;
 
110
begin
 
111
    tr := create_timer( UNIT_MICROHZ );
 
112
 
 
113
    { non zero return says error }
 
114
    if tr = nil then get_sys_time := -1;
 
115
 
 
116
    tr^.tr_node.io_Command := TR_GETSYSTIME;
 
117
    DoIO(pIORequest(tr));
 
118
 
 
119
   { structure assignment }
 
120
   tv^ := tr^.tr_time;
 
121
 
 
122
   delete_timer(tr);
 
123
   get_sys_time := 0;
 
124
end;
 
125
 
 
126
 
 
127
 
 
128
 
 
129
procedure show_time(secs : longint);
 
130
var
 
131
   days,hrs,mins : longint;
 
132
begin
 
133
   { Compute days, hours, etc. }
 
134
   mins := secs div 60;
 
135
   hrs := mins div 60;
 
136
   days := hrs div 24;
 
137
   secs := secs  mod 60;
 
138
   mins := mins mod 60;
 
139
   hrs := hrs mod 24;
 
140
 
 
141
   { Display the time }
 
142
   writeln('*   Hour Minute Second  (Days since Jan.1,1978)');
 
143
   writeln('*   ', hrs, ':   ',mins,':   ', secs,'       (  ',days, ' )');
 
144
   writeln;
 
145
end;
 
146
 
 
147
 
 
148
begin
 
149
   writeln('Timer test');
 
150
 
 
151
   { sleep for two seconds }
 
152
   currentval.tv_secs := 2;
 
153
   currentval.tv_micro := 0;
 
154
   time_delay(@currentval, UNIT_VBLANK);
 
155
   writeln('After 2 seconds delay');
 
156
 
 
157
   { sleep for four seconds }
 
158
   currentval.tv_secs := 4;
 
159
   currentval.tv_micro := 0;
 
160
   time_delay(@currentval, UNIT_VBLANK);
 
161
   writeln('After 4 seconds delay');
 
162
 
 
163
   { sleep for 500,000 micro-seconds = 1/2 second }
 
164
   currentval.tv_secs := 0;
 
165
   currentval.tv_micro := 500000;
 
166
   time_delay(@currentval, UNIT_MICROHZ);
 
167
   writeln('After 1/2 second delay');
 
168
 
 
169
   writeln('DOS Date command shows: ');
 
170
   Execute('date', 0, 0);
 
171
 
 
172
   { save what system thinks is the time....we'll advance it temporarily }
 
173
   get_sys_time(@oldtimeval);
 
174
   writeln('Original system time is:');
 
175
   show_time(oldtimeval.tv_secs );
 
176
 
 
177
   writeln('Setting a new system time');
 
178
 
 
179
   seconds := 1000 * SECSPERDAY + oldtimeval.tv_secs;
 
180
 
 
181
   set_new_time( seconds );
 
182
   { (if user executes the AmigaDOS DATE command now, he will}
 
183
   { see that the time has advanced something over 1000 days }
 
184
 
 
185
   write('DOS Date command now shows: ');
 
186
   Execute('date', 0, 0);
 
187
 
 
188
   get_sys_time(@mytimeval);
 
189
   writeln('Current system time is:');
 
190
   show_time(mytimeval.tv_secs);
 
191
 
 
192
   { Added the microseconds part to show that time keeps }
 
193
   { increasing even though you ask many times in a row  }
 
194
 
 
195
   writeln('Now do three TR_GETSYSTIMEs in a row (notice how the microseconds increase)');
 
196
   writeln;
 
197
   get_sys_time(@mytimeval);
 
198
   writeln('First TR_GETSYSTIME      ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
 
199
   get_sys_time(@mytimeval);
 
200
   writeln('Second TR_GETSYSTIME     ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
 
201
   get_sys_time(@mytimeval);
 
202
   writeln('Third TR_GETSYSTIME      ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
 
203
   writeln;
 
204
   writeln('Resetting to former time');
 
205
   set_new_time(oldtimeval.tv_secs);
 
206
 
 
207
   get_sys_time(@mytimeval);
 
208
   writeln('Current system time is:');
 
209
   show_time(mytimeval.tv_secs);
 
210
 
 
211
end.