← 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/amigalib.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/amigalib.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 DoMethodA, DoSuperMethodA, CoerceMethodA and SetSuperAttrsA.
 
21
 
 
22
    I've translated those from amigae. I'm not sure that they are
 
23
    correct but it's a start. Now you can try to make some tests
 
24
    with mui.
 
25
    30 Jul 2000.
 
26
 
 
27
    Added stuff for commodities.
 
28
    FreeIEvents
 
29
    CxCustom
 
30
    CxDebug
 
31
    CxFilter
 
32
    CxSender
 
33
    CxSignal
 
34
    CxTranslate
 
35
    19 Aug 2000.
 
36
 
 
37
    Rewrote Createport and DeletePort.
 
38
    06 Sep 2000.
 
39
 
 
40
    Added two printf, one with pchar and one with string.
 
41
    They use array of const so this unit compiles with
 
42
    mode objfpc.
 
43
    05 Nov 2002.
 
44
 
 
45
    Added the define use_amiga_smartlink
 
46
    13 Jan 2003.
 
47
 
 
48
    nils.sjoholm@mailbox.swipnet.se
 
49
}
 
50
 
 
51
{$mode objfpc}
 
52
{$I useamigasmartlink.inc}
 
53
{$ifdef use_amiga_smartlink}
 
54
    {$smartlink on}
 
55
{$endif use_amiga_smartlink}
 
56
 
 
57
unit amigalib;
 
58
 
 
59
 
 
60
INTERFACE
 
61
 
 
62
uses exec,intuition,utility,commodities,inputevent,amigados;
 
63
 
 
64
{*  Exec support functions from amiga.lib  *}
 
65
 
 
66
procedure BeginIO (ioRequest: pIORequest);
 
67
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
 
68
procedure DeleteExtIO (ioReq: pIORequest);
 
69
function CreateStdIO (port: pMsgPort): pIOStdReq;
 
70
procedure DeleteStdIO (ioReq: pIOStdReq);
 
71
function CreatePort (name: PChar; pri: longint): pMsgPort;
 
72
procedure DeletePort (port: pMsgPort);
 
73
function CreateTask (name: STRPTR; pri: longint;
 
74
                     initPC : Pointer;
 
75
             stackSize : ULONG): pTask;
 
76
procedure DeleteTask (task: pTask);
 
77
procedure NewList (list: pList);
 
78
 
 
79
{* Commodities support functions from amiga.lib *}
 
80
procedure FreeIEvents (events: pInputEvent);
 
81
function CxCustom
 
82
                (action: pointer;
 
83
                id: longint): pCxObj;
 
84
 
 
85
function CxDebug (id: long): pCxObj;
 
86
function CxFilter (d: STRPTR): pCxObj;
 
87
function CxSender
 
88
                (port: pMsgPort;
 
89
                id: longint): pCxObj;
 
90
 
 
91
function CxSignal
 
92
                (task: pTask;
 
93
                sig: byte): pCxObj;
 
94
 
 
95
function CxTranslate (ie: pInputEvent): pCxObj;
 
96
 
 
97
 
 
98
function DoMethodA(obj : pObject_; msg : APTR): ulong;
 
99
function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
 
100
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
 
101
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
 
102
 
 
103
{
 
104
 
 
105
   NAME
 
106
        printf - print a formatted output line to the standard output.
 
107
 
 
108
   SYNOPSIS
 
109
        printf(formatstring [,value [,values] ] );
 
110
 
 
111
   FUNCTION
 
112
        Format the output in accordance with specifications in the format
 
113
        string.
 
114
 
 
115
   INPUTS
 
116
        formatString - a C-language-like NULL-terminated format string,
 
117
                       with the following supported % options:
 
118
 
 
119
          %[flags][width][.limit][length]type
 
120
 
 
121
            $     - must follow the arg_pos value, if specified
 
122
          flags   - only one allowed. '-' specifies left justification.
 
123
          width   - field width. If the first character is a '0', the
 
124
                    field is padded with leading 0s.
 
125
            .     - must precede the field width value, if specified
 
126
          limit   - maximum number of characters to output from a string.
 
127
                    (only valid for %s or %b).
 
128
          length  - size of input data defaults to word (16-bit) for types c,
 
129
                    d, u and x, 'l' changes this to long (32-bit).
 
130
          type    - supported types are:
 
131
                          b - BSTR, data is 32-bit BPTR to byte count followed
 
132
                              by a byte string. A NULL BPTR is treated as an
 
133
                              empty string. (V36)
 
134
                          d - signed decimal
 
135
                          u - unsigned decimal
 
136
                          x - hexadecimal with hex digits in uppercase
 
137
                          X - hexadecimal with hex digits in lowercase
 
138
                          s - string, a 32-bit pointer to a NULL-terminated
 
139
                              byte string. A NULL pointer is treated
 
140
                              as an empty string.
 
141
                          c - character
 
142
 
 
143
        value(s) - numeric variables or addresses of null-terminated strings
 
144
                   to be added to the format information.
 
145
 
 
146
   NOTE
 
147
        The global "_stdout" must be defined, and contain a pointer to
 
148
        a legal AmigaDOS file handle. Using the standard Amiga startup
 
149
        module sets this up. In other cases you will need to define
 
150
        stdout, and assign it to some reasonable value (like what the
 
151
        dos.library/Output() call returns). This code would set it up:
 
152
 
 
153
                ULONG stdout;
 
154
                stdout=Output();
 
155
 
 
156
   BUGS
 
157
        This function will crash if the resulting stream after
 
158
        parameter substitution is longer than 140 bytes.
 
159
 
 
160
}
 
161
 
 
162
procedure printf(Fmtstr : pchar; Args : array of const);
 
163
procedure printf(Fmtstr : string; Args : array of const);
 
164
 
 
165
IMPLEMENTATION
 
166
 
 
167
uses pastoc;
 
168
 
 
169
{*  Exec support functions from amiga.lib  *}
 
170
 
 
171
procedure BeginIO (ioRequest: pIORequest);
 
172
begin
 
173
   asm
 
174
      move.l  a6,-(a7)
 
175
      move.l  ioRequest,a1    ; get IO Request
 
176
      move.l  20(a1),a6      ; extract Device ptr
 
177
      jsr     -30(a6)        ; call BEGINIO directly
 
178
      move.l  (a7)+,a6
 
179
   end;
 
180
end;
 
181
 
 
182
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
 
183
var
 
184
   IOReq: pIORequest;
 
185
begin
 
186
    IOReq := NIL;
 
187
    if port <> NIL then
 
188
    begin
 
189
        IOReq := AllocMem(size, MEMF_CLEAR or MEMF_PUBLIC);
 
190
        if IOReq <> NIL then
 
191
        begin
 
192
            IOReq^.io_Message.mn_Node.ln_Type   := NT_REPLYMSG;
 
193
            IOReq^.io_Message.mn_Length    := size;
 
194
            IOReq^.io_Message.mn_ReplyPort := port;
 
195
        end;
 
196
    end;
 
197
    CreateExtIO := IOReq;
 
198
end;
 
199
 
 
200
 
 
201
procedure DeleteExtIO (ioReq: pIORequest);
 
202
begin
 
203
    if ioReq <> NIL then
 
204
    begin
 
205
        ioReq^.io_Message.mn_Node.ln_Type := $FF;
 
206
        ioReq^.io_Message.mn_ReplyPort    := pMsgPort(-1);
 
207
        ioReq^.io_Device                  := pDevice(-1);
 
208
        ExecFreeMem(ioReq, ioReq^.io_Message.mn_Length);
 
209
    end
 
210
end;
 
211
 
 
212
 
 
213
function CreateStdIO (port: pMsgPort): pIOStdReq;
 
214
begin
 
215
    CreateStdIO := pIOStdReq(CreateExtIO(port, sizeof(tIOStdReq)))
 
216
end;
 
217
 
 
218
 
 
219
procedure DeleteStdIO (ioReq: pIOStdReq);
 
220
begin
 
221
    DeleteExtIO(pIORequest(ioReq))
 
222
end;
 
223
 
 
224
 
 
225
function Createport(name : PChar; pri : longint): pMsgPort;
 
226
var
 
227
   sigbit : Byte;
 
228
   port    : pMsgPort;
 
229
begin
 
230
   sigbit := AllocSignal(-1);
 
231
   if sigbit = -1 then CreatePort := nil;
 
232
   port := Allocmem(sizeof(tMsgPort),MEMF_CLEAR or MEMF_PUBLIC);
 
233
   if port = nil then begin
 
234
      FreeSignal(sigbit);
 
235
      CreatePort := nil;
 
236
   end;
 
237
   with port^ do begin
 
238
       if assigned(name) then
 
239
       mp_Node.ln_Name := name
 
240
       else mp_Node.ln_Name := nil;
 
241
       mp_Node.ln_Pri := pri;
 
242
       mp_Node.ln_Type := NT_MsgPort;
 
243
       mp_Flags := PA_Signal;
 
244
       mp_SigBit := sigbit;
 
245
       mp_SigTask := FindTask(nil);
 
246
   end;
 
247
   if assigned(name) then AddPort(port)
 
248
   else NewList(addr(port^.mp_MsgList));
 
249
   CreatePort := port;
 
250
end;
 
251
 
 
252
procedure DeletePort (port: pMsgPort);
 
253
begin
 
254
    if port <> NIL then
 
255
    begin
 
256
        if port^.mp_Node.ln_Name <> NIL then
 
257
            RemPort(port);
 
258
 
 
259
        port^.mp_Node.ln_Type     := $FF;
 
260
        port^.mp_MsgList.lh_Head  := pNode(-1);
 
261
        FreeSignal(port^.mp_SigBit);
 
262
        ExecFreeMem(port, sizeof(tMsgPort));
 
263
    end;
 
264
end;
 
265
 
 
266
 
 
267
function CreateTask (name: STRPTR; pri: longint;
 
268
        initPC: pointer; stackSize: ULONG): pTask;
 
269
var
 
270
   memlist : pMemList;
 
271
   task    : pTask;
 
272
   totalsize : Longint;
 
273
begin
 
274
    task  := NIL;
 
275
    stackSize   := (stackSize + 3) and not 3;
 
276
    totalsize := sizeof(tMemList) + sizeof(tTask) + stackSize;
 
277
 
 
278
    memlist := AllocMem(totalsize, MEMF_PUBLIC + MEMF_CLEAR);
 
279
    if memlist <> NIL then begin
 
280
       memlist^.ml_NumEntries := 1;
 
281
       memlist^.ml_ME[0].me_Un.meu_Addr := Pointer(memlist + 1);
 
282
       memlist^.ml_ME[0].me_Length := totalsize - sizeof(tMemList);
 
283
 
 
284
       task := pTask(memlist + sizeof(tMemList) + stackSize);
 
285
       task^.tc_Node.ln_Pri := pri;
 
286
       task^.tc_Node.ln_Type := NT_TASK;
 
287
       task^.tc_Node.ln_Name := name;
 
288
       task^.tc_SPLower := Pointer(memlist + sizeof(tMemList));
 
289
       task^.tc_SPUpper := Pointer(task^.tc_SPLower + stackSize);
 
290
       task^.tc_SPReg := task^.tc_SPUpper;
 
291
 
 
292
       NewList(@task^.tc_MemEntry);
 
293
       AddTail(@task^.tc_MemEntry,@memlist^.ml_Node);
 
294
 
 
295
       AddTask(task,initPC,NIL)
 
296
    end;
 
297
    CreateTask := task;
 
298
end;
 
299
 
 
300
 
 
301
procedure DeleteTask (task: pTask);
 
302
begin
 
303
    RemTask(task)
 
304
end;
 
305
 
 
306
 
 
307
procedure NewList (list: pList);
 
308
begin
 
309
    with list^ do
 
310
    begin
 
311
        lh_Head     := pNode(@lh_Tail);
 
312
        lh_Tail     := NIL;
 
313
        lh_TailPred := pNode(@lh_Head)
 
314
    end
 
315
end;
 
316
 
 
317
procedure FreeIEvents (events: pInputEvent);
 
318
begin
 
319
        while events <> NIL do
 
320
        begin
 
321
                FreeMem (events, sizeof (tInputEvent));
 
322
                events := events^.ie_NextEvent
 
323
        end
 
324
end;
 
325
 
 
326
function CxCustom
 
327
                (action: pointer;
 
328
                id: longint): pCxObj;
 
329
begin
 
330
        CxCustom := CreateCxObj(CX_CUSTOM, longint(action), id)
 
331
end;
 
332
 
 
333
function CxDebug (id: long): pCxObj;
 
334
begin
 
335
        CxDebug := CreateCxObj(CX_DEBUG, id, 0)
 
336
end;
 
337
 
 
338
function CxFilter (d: STRPTR): pCxObj;
 
339
begin
 
340
        CxFilter := CreateCxObj(CX_FILTER, longint(d), 0)
 
341
end;
 
342
 
 
343
function CxSender
 
344
                (port: pMsgPort;
 
345
                id: longint): pCxObj;
 
346
begin
 
347
        CxSender := CreateCxObj(CX_SEND, longint(port), id)
 
348
end;
 
349
 
 
350
function CxSignal
 
351
                (task: pTask;
 
352
                sig: byte): pCxObj;
 
353
begin
 
354
        CxSignal:= CreateCxObj(CX_SIGNAL, longint(task), sig)
 
355
end;
 
356
 
 
357
function CxTranslate (ie: pInputEvent): pCxObj;
 
358
begin
 
359
        CxTranslate := CreateCxObj(CX_TRANSLATE, longint(ie), 0)
 
360
end;
 
361
 
 
362
function DoMethodA(obj : pObject_; msg : APTR): ulong;
 
363
var
 
364
    o : p_Object;
 
365
begin
 
366
    if assigned(obj) then begin
 
367
       o := p_Object(obj);
 
368
       DoMethodA := CallHookPkt(@o^.o_Class^.cl_Dispatcher, obj,msg);
 
369
    end else DoMethodA := 0;
 
370
end;
 
371
 
 
372
function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
 
373
begin
 
374
    if assigned(obj) and assigned(cl) then
 
375
       DoSuperMethodA := CallHookPkt(@cl^.cl_Super^.cl_Dispatcher,obj,msg)
 
376
    else DoSuperMethodA := 0;
 
377
end;
 
378
 
 
379
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
 
380
begin
 
381
    if assigned(cl) and assigned(obj) then
 
382
       CoerceMethodA := CallHookPkt(@cl^.cl_Dispatcher,obj,msg)
 
383
    else CoerceMethodA := 0;
 
384
end;
 
385
 
 
386
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
 
387
var
 
388
    arr : array[0..2] of longint;
 
389
begin
 
390
    arr[0] := OM_SET;
 
391
    arr[1] := longint(msg);
 
392
    arr[2] := 0;
 
393
    SetSuperAttrsA := DoSuperMethodA(cl, obj, @arr);
 
394
end;
 
395
 
 
396
var
 
397
  argarray : array [0..20] of longint;
 
398
 
 
399
function gettheconst(args : array of const): pointer;
 
400
var
 
401
   i : longint;
 
402
 
 
403
begin
 
404
 
 
405
    for i := 0 to High(args) do begin
 
406
        case args[i].vtype of
 
407
            vtinteger : argarray[i] := longint(args[i].vinteger);
 
408
            vtpchar   : argarray[i] := longint(args[i].vpchar);
 
409
            vtchar    : argarray[i] := longint(args[i].vchar);
 
410
            vtpointer : argarray[i] := longint(args[i].vpointer);
 
411
            vtstring  : argarray[i] := longint(pas2c(args[i].vstring^));
 
412
        end;
 
413
    end;
 
414
    gettheconst := @argarray;
 
415
end;
 
416
 
 
417
procedure printf(Fmtstr : pchar; Args : array of const);
 
418
begin
 
419
    VPrintf(Fmtstr,gettheconst(Args));
 
420
end;
 
421
 
 
422
procedure printf(Fmtstr : string; Args : array of const);
 
423
begin
 
424
    VPrintf(pas2c(Fmtstr) ,gettheconst(Args));
 
425
end;
 
426
 
 
427
 
 
428
end.