← Back to branch summary

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

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/amunits/units/realtime.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/units/realtime.pas
 
1
{
 
2
    This file is part of the Free Pascal run time library.
 
3
 
 
4
    A file in Amiga system run time library.
 
5
    Copyright (c) 1998-2003 by Nils Sjoholm
 
6
    member of the Amiga RTL development team.
 
7
 
 
8
    See the file COPYING.FPC, included in this distribution,
 
9
    for details about the copyright.
 
10
 
 
11
    This program is distributed in the hope that it will be useful,
 
12
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
14
 
 
15
 **********************************************************************}
 
16
 
 
17
{
 
18
    History:
 
19
 
 
20
    Added functions and procedures with array of const.
 
21
    For use with fpc 1.0.7. They are in systemvartags.
 
22
    11 Nov 2002.
 
23
 
 
24
    Added the defines use_amiga_smartlink and
 
25
    use_auto_openlib. Implemented autoopening of the
 
26
    library.
 
27
    14 Jan 2003.
 
28
 
 
29
    Changed integer > smallint,
 
30
            cardinal > longword.
 
31
    Changed startcode for unit.
 
32
    09 Feb 2003.
 
33
 
 
34
    nils.sjoholm@mailbox.swipnet.se
 
35
}
 
36
 
 
37
{$I useamigasmartlink.inc}
 
38
{$ifdef use_amiga_smartlink}
 
39
   {$smartlink on}
 
40
{$endif use_amiga_smartlink}
 
41
 
 
42
UNIT realtime;
 
43
 
 
44
INTERFACE
 
45
USES exec, utility;
 
46
 
 
47
{***************************************************************************}
 
48
 
 
49
const
 
50
{ realtime.library's idea of time is based on a clock which emits a pulse
 
51
 * 1200 times a second (1.2kHz). All time values maintained by realtime.library
 
52
 * are based on this number. For example, the field RealTimeBase->rtb_Time
 
53
 * expresses an amount of time equivalent to (RealTimeBase->rtb_Time/TICK_FREQ)
 
54
 * seconds.
 
55
 }
 
56
 TICK_FREQ = 1200;
 
57
 
 
58
 
 
59
{***************************************************************************}
 
60
 
 
61
 
 
62
{ Each Conductor represents a group of applications which wish to remain
 
63
 * synchronized together.
 
64
 *
 
65
 * This structure must only be allocated by realtime.library and is
 
66
 * READ-ONLY!
 
67
 }
 
68
Type
 
69
 pConductor = ^tConductor;
 
70
 tConductor = record
 
71
    cdt_Link        : tNode;
 
72
    cdt_Reserved0   : WORD;
 
73
    cdt_Players     : tMinList;          { this conductor's players      }
 
74
    cdt_ClockTime,                       { current time of this sequence }
 
75
    cdt_StartTime,                       { start time of this sequence   }
 
76
    cdt_ExternalTime,                    { time from external unit       }
 
77
    cdt_MaxExternalTime,                 { upper limit on sync'd time    }
 
78
    cdt_Metronome   : ULONG;             { MetricTime highest pri node   }
 
79
    cdt_Reserved1   : WORD;
 
80
    cdt_Flags       : WORD;              { conductor flags               }
 
81
    cdt_State       : Byte;              { playing or stopped            }
 
82
 end;
 
83
 
 
84
const
 
85
{ Flag bits for Conductor.cdt_Flags }
 
86
 CONDUCTF_EXTERNAL = 1;   { clock is externally driven }
 
87
 CONDUCTF_GOTTICK  = 2;   { received 1st external tick }
 
88
 CONDUCTF_METROSET = 4;   { cdt_Metronome filled in    }
 
89
 CONDUCTF_PRIVATE  = 8;   { conductor is private       }
 
90
 
 
91
 CONDUCTB_EXTERNAL = 0;
 
92
 CONDUCTB_GOTTICK  = 1;
 
93
 CONDUCTB_METROSET = 2;
 
94
 CONDUCTB_PRIVATE  = 3;
 
95
 
 
96
{ constants for Conductor.cdt_State and SetConductorState() }
 
97
 CONDSTATE_STOPPED    = 0;   { clock is stopped              }
 
98
 CONDSTATE_PAUSED     = 1;   { clock is paused               }
 
99
 CONDSTATE_LOCATE     = 2;   { go to 'running' when ready    }
 
100
 CONDSTATE_RUNNING    = 3;   { run clock NOW                 }
 
101
 
 
102
{ These do not actually exist as Conductor states, but are used as additional
 
103
 * arguments to SetConductorState()
 
104
 }
 
105
 CONDSTATE_METRIC     = -1;   { ask high node to locate       }
 
106
 CONDSTATE_SHUTTLE    = -2;   { time changing but not running }
 
107
 CONDSTATE_LOCATE_SET = -3;   { maestro done locating         }
 
108
 
 
109
 
 
110
{***************************************************************************}
 
111
 
 
112
 
 
113
{ The Player is the connection between a Conductor and an application.
 
114
 *
 
115
 * This structure must only be allocated by realtime.library and is
 
116
 * READ-ONLY!
 
117
 }
 
118
Type
 
119
 pPlayer = ^tPlayer;
 
120
 tPlayer = record
 
121
    pl_Link             : tNode;
 
122
    pl_Reserved0,
 
123
    pl_Reserved1        : Shortint;
 
124
    pl_Hook             : pHook;         { player's hook function       }
 
125
    pl_Source           : pConductor;    { pointer to parent context    }
 
126
    pl_Task             : pTask;         { task to signal for alarm     }
 
127
    pl_MetricTime       : Longint;       { current time in app's metric }
 
128
    pl_AlarmTime        : Longint;       { time to wake up              }
 
129
    pl_UserData         : Pointer;       { for application use  }
 
130
    pl_PlayerID         : WORD;          { for application use  }
 
131
    pl_Flags            : WORD;          { general Player flags         }
 
132
 end;
 
133
 
 
134
const
 
135
{ Flag bits for Player.pl_Flags }
 
136
 PLAYERF_READY     = 1;   { player is ready to go!        }
 
137
 PLAYERF_ALARMSET  = 2;   { alarm is set                  }
 
138
 PLAYERF_QUIET     = 3;   { a dummy player, used for sync }
 
139
 PLAYERF_CONDUCTED = 8;   { give me metered time          }
 
140
 PLAYERF_EXTSYNC   = 16;   { granted external sync         }
 
141
 
 
142
 PLAYERB_READY     = 0;
 
143
 PLAYERB_ALARMSET  = 1;
 
144
 PLAYERB_QUIET     = 2;
 
145
 PLAYERB_CONDUCTED = 3;
 
146
 PLAYERB_EXTSYNC   = 4;
 
147
 
 
148
 
 
149
{***************************************************************************}
 
150
 
 
151
 
 
152
{ Tags for CreatePlayer(), SetPlayerAttrs(), and GetPlayerAttrs() }
 
153
 PLAYER_Base         = (TAG_USER+64)   ;
 
154
 PLAYER_Hook         = (PLAYER_Base+1) ;  { set address of hook function }
 
155
 PLAYER_Name         = (PLAYER_Base+2) ;  { name of player       }
 
156
 PLAYER_Priority     = (PLAYER_Base+3) ;  { priority of player           }
 
157
 PLAYER_Conductor    = (PLAYER_Base+4) ;  { set conductor for player     }
 
158
 PLAYER_Ready        = (PLAYER_Base+5) ;  { the "ready" flag             }
 
159
 PLAYER_AlarmTime    = (PLAYER_Base+12);  { alarm time (sets PLAYERF_ALARMSET) }
 
160
 PLAYER_Alarm        = (PLAYER_Base+13);  { sets/clears PLAYERF_ALARMSET flag  }
 
161
 PLAYER_AlarmSigTask = (PLAYER_Base+6) ;  { task to signal for alarm/notify    }
 
162
 PLAYER_AlarmSigBit  = (PLAYER_Base+8) ;  { signal bit for alarm (or -1) }
 
163
 PLAYER_Conducted    = (PLAYER_Base+7) ;  { sets/clears PLAYERF_CONDUCTED flag   }
 
164
 PLAYER_Quiet        = (PLAYER_Base+9) ;  { don't process time thru this }
 
165
 PLAYER_UserData     = (PLAYER_Base+10);
 
166
 PLAYER_ID           = (PLAYER_Base+11);
 
167
 PLAYER_ExtSync      = (PLAYER_Base+14);  { attempt/release to ext sync  }
 
168
 PLAYER_ErrorCode    = (PLAYER_Base+15);  { error return value           }
 
169
 
 
170
 
 
171
{***************************************************************************}
 
172
 
 
173
 
 
174
{ Method types for messages sent via a Player's hook }
 
175
 PM_TICK     = 0;
 
176
 PM_STATE    = 1;
 
177
 PM_POSITION = 2;
 
178
 PM_SHUTTLE  = 3;
 
179
 
 
180
Type
 
181
{ used for PM_TICK, PM_POSITION and PM_SHUTTLE methods }
 
182
 ppmTime = ^tpmTime;
 
183
 tpmTime = record
 
184
    pmt_Method  : ULONG;        { PM_TICK, PM_POSITION, or PM_SHUTTLE }
 
185
    pmt_Time    : ULONG;
 
186
 end;
 
187
 
 
188
{ used for the PM_STATE method }
 
189
 ppmState = ^tpmState;
 
190
 tpmState = record
 
191
    pms_Method  : ULONG;        { PM_STATE }
 
192
    pms_OldState: ULONG;
 
193
 end;
 
194
 
 
195
 
 
196
{***************************************************************************}
 
197
 
 
198
const
 
199
{ Possible lock types for LockRealTime() }
 
200
 RT_CONDUCTORS = 0;   { conductor list }
 
201
 
 
202
 
 
203
{***************************************************************************}
 
204
 
 
205
 
 
206
{ realtime.library error codes }
 
207
 RTE_NOMEMORY    = 801;   { memory allocation failed      }
 
208
 RTE_NOCONDUCTOR = 802;   { player needs a conductor      }
 
209
 RTE_NOTIMER     = 803;   { timer (CIA) allocation failed }
 
210
 RTE_PLAYING     = 804;   { can't shuttle while playing   }
 
211
 
 
212
 
 
213
{***************************************************************************}
 
214
 
 
215
 
 
216
{ OpenLibrary("realtime.library",0) returns a pointer to this structure.
 
217
 * All fields are READ-ONLY.
 
218
 }
 
219
Type
 
220
 pRealTimeBase = ^tRealTimeBase;
 
221
 tRealTimeBase = record
 
222
    rtb_LibNode     : tLibrary;
 
223
    rtb_Reserved0   : Array[0..1] of Byte;
 
224
 
 
225
    rtb_Time,                      { current time                         }
 
226
    rtb_TimeFrac    : ULONG;       { fixed-point fraction part of time    }
 
227
    rtb_Reserved1   : WORD;
 
228
    rtb_TickErr     : smallint;     { nanosecond error from ideal Tick     }
 
229
 end;                              { length to real tick length           }
 
230
 
 
231
{ Actual tick length is: 1/TICK_FREQ + rtb_TickErr/1e9 }
 
232
 
 
233
const
 
234
 RealTime_TickErr_Min = -705;
 
235
 RealTime_TickErr_Max =  705;
 
236
 
 
237
{*--- functions in V37 or higher (Release 2.04) ---*}
 
238
 
 
239
VAR RealTimeBase : pRealTimeBase;
 
240
 
 
241
const
 
242
    REALTIMENAME : PChar = 'realtime.library';
 
243
 
 
244
FUNCTION CreatePlayerA(const tagList : pTagItem) : pPlayer;
 
245
PROCEDURE DeletePlayer(player : pPlayer);
 
246
FUNCTION ExternalSync(player : pPlayer; minTime : LONGINT; maxTime : LONGINT) : BOOLEAN;
 
247
FUNCTION FindConductor(const name : pCHAR) : pConductor;
 
248
FUNCTION GetPlayerAttrsA(const player : pPlayer;const tagList : pTagItem) : ULONG;
 
249
FUNCTION LockRealTime(lockType : ULONG) : POINTER;
 
250
FUNCTION NextConductor(const previousConductor : pConductor) : pConductor;
 
251
FUNCTION SetConductorState(player : pPlayer; state : ULONG; time : LONGINT) : LONGINT;
 
252
FUNCTION SetPlayerAttrsA(player : pPlayer;const tagList : pTagItem) : BOOLEAN;
 
253
PROCEDURE UnlockRealTime(lock : POINTER);
 
254
 
 
255
{You can remove this include and use a define instead}
 
256
{$I useautoopenlib.inc}
 
257
{$ifdef use_init_openlib}
 
258
procedure InitREALTIMELibrary;
 
259
{$endif use_init_openlib}
 
260
 
 
261
{This is a variable that knows how the unit is compiled}
 
262
var
 
263
    REALTIMEIsCompiledHow : longint;
 
264
 
 
265
IMPLEMENTATION
 
266
 
 
267
{$ifndef dont_use_openlib}
 
268
uses msgbox;
 
269
{$endif dont_use_openlib}
 
270
 
 
271
FUNCTION CreatePlayerA(const tagList : pTagItem) : pPlayer;
 
272
BEGIN
 
273
  ASM
 
274
    MOVE.L  A6,-(A7)
 
275
    MOVEA.L tagList,A0
 
276
    MOVEA.L RealTimeBase,A6
 
277
    JSR -042(A6)
 
278
    MOVEA.L (A7)+,A6
 
279
    MOVE.L  D0,@RESULT
 
280
  END;
 
281
END;
 
282
 
 
283
PROCEDURE DeletePlayer(player : pPlayer);
 
284
BEGIN
 
285
  ASM
 
286
    MOVE.L  A6,-(A7)
 
287
    MOVEA.L player,A0
 
288
    MOVEA.L RealTimeBase,A6
 
289
    JSR -048(A6)
 
290
    MOVEA.L (A7)+,A6
 
291
  END;
 
292
END;
 
293
 
 
294
FUNCTION ExternalSync(player : pPlayer; minTime : LONGINT; maxTime : LONGINT) : BOOLEAN;
 
295
BEGIN
 
296
  ASM
 
297
    MOVE.L  A6,-(A7)
 
298
    MOVEA.L player,A0
 
299
    MOVE.L  minTime,D0
 
300
    MOVE.L  maxTime,D1
 
301
    MOVEA.L RealTimeBase,A6
 
302
    JSR -066(A6)
 
303
    MOVEA.L (A7)+,A6
 
304
    TST.W   D0
 
305
    BEQ.B   @end
 
306
    MOVEQ   #1,D0
 
307
  @end: MOVE.B  D0,@RESULT
 
308
  END;
 
309
END;
 
310
 
 
311
FUNCTION FindConductor(const name : pCHAR) : pConductor;
 
312
BEGIN
 
313
  ASM
 
314
    MOVE.L  A6,-(A7)
 
315
    MOVEA.L name,A0
 
316
    MOVEA.L RealTimeBase,A6
 
317
    JSR -078(A6)
 
318
    MOVEA.L (A7)+,A6
 
319
    MOVE.L  D0,@RESULT
 
320
  END;
 
321
END;
 
322
 
 
323
FUNCTION GetPlayerAttrsA(const player : pPlayer;const tagList : pTagItem) : ULONG;
 
324
BEGIN
 
325
  ASM
 
326
    MOVE.L  A6,-(A7)
 
327
    MOVEA.L player,A0
 
328
    MOVEA.L tagList,A1
 
329
    MOVEA.L RealTimeBase,A6
 
330
    JSR -084(A6)
 
331
    MOVEA.L (A7)+,A6
 
332
    MOVE.L  D0,@RESULT
 
333
  END;
 
334
END;
 
335
 
 
336
FUNCTION LockRealTime(lockType : ULONG) : POINTER;
 
337
BEGIN
 
338
  ASM
 
339
    MOVE.L  A6,-(A7)
 
340
    MOVE.L  lockType,D0
 
341
    MOVEA.L RealTimeBase,A6
 
342
    JSR -030(A6)
 
343
    MOVEA.L (A7)+,A6
 
344
    MOVE.L  D0,@RESULT
 
345
  END;
 
346
END;
 
347
 
 
348
FUNCTION NextConductor(const previousConductor : pConductor) : pConductor;
 
349
BEGIN
 
350
  ASM
 
351
    MOVE.L  A6,-(A7)
 
352
    MOVEA.L previousConductor,A0
 
353
    MOVEA.L RealTimeBase,A6
 
354
    JSR -072(A6)
 
355
    MOVEA.L (A7)+,A6
 
356
    MOVE.L  D0,@RESULT
 
357
  END;
 
358
END;
 
359
 
 
360
FUNCTION SetConductorState(player : pPlayer; state : ULONG; time : LONGINT) : LONGINT;
 
361
BEGIN
 
362
  ASM
 
363
    MOVE.L  A6,-(A7)
 
364
    MOVEA.L player,A0
 
365
    MOVE.L  state,D0
 
366
    MOVE.L  time,D1
 
367
    MOVEA.L RealTimeBase,A6
 
368
    JSR -060(A6)
 
369
    MOVEA.L (A7)+,A6
 
370
    MOVE.L  D0,@RESULT
 
371
  END;
 
372
END;
 
373
 
 
374
FUNCTION SetPlayerAttrsA(player : pPlayer;const tagList : pTagItem) : BOOLEAN;
 
375
BEGIN
 
376
  ASM
 
377
    MOVE.L  A6,-(A7)
 
378
    MOVEA.L player,A0
 
379
    MOVEA.L tagList,A1
 
380
    MOVEA.L RealTimeBase,A6
 
381
    JSR -054(A6)
 
382
    MOVEA.L (A7)+,A6
 
383
    TST.W   D0
 
384
    BEQ.B   @end
 
385
    MOVEQ   #1,D0
 
386
  @end: MOVE.B  D0,@RESULT
 
387
  END;
 
388
END;
 
389
 
 
390
PROCEDURE UnlockRealTime(lock : POINTER);
 
391
BEGIN
 
392
  ASM
 
393
    MOVE.L  A6,-(A7)
 
394
    MOVEA.L lock,A0
 
395
    MOVEA.L RealTimeBase,A6
 
396
    JSR -036(A6)
 
397
    MOVEA.L (A7)+,A6
 
398
  END;
 
399
END;
 
400
 
 
401
const
 
402
    { Change VERSION and LIBVERSION to proper values }
 
403
 
 
404
    VERSION : string[2] = '0';
 
405
    LIBVERSION : longword = 0;
 
406
 
 
407
{$ifdef use_init_openlib}
 
408
  {$Info Compiling initopening of realtime.library}
 
409
  {$Info don't forget to use InitREALTIMELibrary in the beginning of your program}
 
410
 
 
411
var
 
412
    realtime_exit : Pointer;
 
413
 
 
414
procedure CloserealtimeLibrary;
 
415
begin
 
416
    ExitProc := realtime_exit;
 
417
    if RealTimeBase <> nil then begin
 
418
        CloseLibrary(pLibrary(RealTimeBase));
 
419
        RealTimeBase := nil;
 
420
    end;
 
421
end;
 
422
 
 
423
procedure InitREALTIMELibrary;
 
424
begin
 
425
    RealTimeBase := nil;
 
426
    RealTimeBase := pRealTimeBase(OpenLibrary(REALTIMENAME,LIBVERSION));
 
427
    if RealTimeBase <> nil then begin
 
428
        realtime_exit := ExitProc;
 
429
        ExitProc := @CloserealtimeLibrary;
 
430
    end else begin
 
431
        MessageBox('FPC Pascal Error',
 
432
        'Can''t open realtime.library version ' + VERSION + #10 +
 
433
        'Deallocating resources and closing down',
 
434
        'Oops');
 
435
        halt(20);
 
436
    end;
 
437
end;
 
438
 
 
439
begin
 
440
    REALTIMEIsCompiledHow := 2;
 
441
{$endif use_init_openlib}
 
442
 
 
443
{$ifdef use_auto_openlib}
 
444
  {$Info Compiling autoopening of realtime.library}
 
445
 
 
446
var
 
447
    realtime_exit : Pointer;
 
448
 
 
449
procedure CloserealtimeLibrary;
 
450
begin
 
451
    ExitProc := realtime_exit;
 
452
    if RealTimeBase <> nil then begin
 
453
        CloseLibrary(pLibrary(RealTimeBase));
 
454
        RealTimeBase := nil;
 
455
    end;
 
456
end;
 
457
 
 
458
begin
 
459
    RealTimeBase := nil;
 
460
    RealTimeBase := pRealTimeBase(OpenLibrary(REALTIMENAME,LIBVERSION));
 
461
    if RealTimeBase <> nil then begin
 
462
        realtime_exit := ExitProc;
 
463
        ExitProc := @CloserealtimeLibrary;
 
464
        REALTIMEIsCompiledHow := 1;
 
465
    end else begin
 
466
        MessageBox('FPC Pascal Error',
 
467
        'Can''t open realtime.library version ' + VERSION + #10 +
 
468
        'Deallocating resources and closing down',
 
469
        'Oops');
 
470
        halt(20);
 
471
    end;
 
472
 
 
473
{$endif use_auto_openlib}
 
474
 
 
475
{$ifdef dont_use_openlib}
 
476
begin
 
477
    REALTIMEIsCompiledHow := 3;
 
478
   {$Warning No autoopening of realtime.library compiled}
 
479
   {$Warning Make sure you open realtime.library yourself}
 
480
{$endif dont_use_openlib}
 
481
 
 
482
 
 
483
END. (* UNIT REALTIME *)
 
484
 
 
485
 
 
486