← Back to branch summary

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

« back to all changes in this revision

Viewing changes to packages/extra/amunits/units/diskfont.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:
packages/extra/amunits/units/diskfont.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
 
    History:
18
 
    
19
 
    Added the defines use_amiga_smartlink and
20
 
    use_auto_openlib. Implemented autoopening
21
 
    of the library.
22
 
    13 Jan 2003.
23
 
    
24
 
    Update for AmigaOS 3.9.
25
 
       FUNCTION GetDiskFontCtrl
26
 
       PROCEDURE SetDiskFontCtrlA
27
 
    Varargs for SetDiskFontCtrl is in
28
 
    systemvartags.
29
 
    Changed startup for library.
30
 
    01 Feb 2003.
31
 
 
32
 
    Changed cardinal > longword.
33
 
    09 Feb 2003.
34
 
    
35
 
    nils.sjoholm@mailbox.swipnet.se Nils Sjoholm
36
 
}
37
 
 
38
 
{$I useamigasmartlink.inc}
39
 
{$ifdef use_amiga_smartlink}
40
 
   {$smartlink on}
41
 
{$endif use_amiga_smartlink}
42
 
 
43
 
unit diskfont;
44
 
 
45
 
INTERFACE
46
 
 
47
 
uses exec, graphics,utility;
48
 
 
49
 
Const
50
 
 
51
 
    MAXFONTPATH         = 256;
52
 
 
53
 
Type
54
 
 
55
 
    pFontContents = ^tFontContents;
56
 
    tFontContents = record
57
 
        fc_FileName     : Array [0..MAXFONTPATH-1] of Char;
58
 
        fc_YSize        : Word;
59
 
        fc_Style        : Byte;
60
 
        fc_Flags        : Byte;
61
 
    end;
62
 
 
63
 
 
64
 
   pTFontContents = ^tTFontContents;
65
 
   tTFontContents = record
66
 
    tfc_FileName  : Array[0..MAXFONTPATH-3] of Char;
67
 
    tfc_TagCount  : Word;
68
 
 
69
 
    tfc_YSize     : Word;
70
 
    tfc_Style,
71
 
    tfc_Flags     : Byte;
72
 
   END;
73
 
 
74
 
 
75
 
Const
76
 
 
77
 
    FCH_ID              = $0f00;
78
 
    TFCH_ID             = $0f02;
79
 
    OFCH_ID             = $0f03;
80
 
 
81
 
 
82
 
 
83
 
Type
84
 
 
85
 
    pFontContentsHeader = ^tFontContentsHeader;
86
 
    tFontContentsHeader = record
87
 
        fch_FileID      : Word;
88
 
        fch_NumEntries  : Word;
89
 
    end;
90
 
 
91
 
Const
92
 
 
93
 
    DFH_ID              = $0f80;
94
 
    MAXFONTNAME         = 32;
95
 
 
96
 
Type
97
 
 
98
 
    pDiskFontHeader = ^tDiskFontHeader;
99
 
    tDiskFontHeader = record
100
 
        dfh_DF          : tNode;
101
 
        dfh_FileID      : Word;
102
 
        dfh_Revision    : Word;
103
 
        dfh_Segment     : Longint;
104
 
        dfh_Name        : Array [0..MAXFONTNAME-1] of Char;
105
 
        dfh_TF          : tTextFont;
106
 
    end;
107
 
 
108
 
Const
109
 
 
110
 
    AFB_MEMORY          = 0;
111
 
    AFF_MEMORY          = 1;
112
 
    AFB_DISK            = 1;
113
 
    AFF_DISK            = 2;
114
 
    AFB_SCALED          = 2;
115
 
    AFF_SCALED          = $0004;
116
 
    AFB_BITMAP          = 3;
117
 
    AFF_BITMAP          = $0008;
118
 
    AFB_TAGGED          = 16;
119
 
    AFF_TAGGED          = $10000;
120
 
 
121
 
 
122
 
Type
123
 
 
124
 
    pAvailFonts = ^tAvailFonts;
125
 
    tAvailFonts = record
126
 
        af_Type         : Word;
127
 
        af_Attr         : tTextAttr;
128
 
    end;
129
 
 
130
 
    pTAvailFonts = ^tTAvailFonts;
131
 
    tTAvailFonts = record
132
 
        taf_Type        : Word;
133
 
        taf_Attr        : tTTextAttr;
134
 
    END;
135
 
 
136
 
    pAvailFontsHeader = ^tAvailFontsHeader;
137
 
    tAvailFontsHeader = record
138
 
        afh_NumEntries  : Word;
139
 
    end;
140
 
 
141
 
const
142
 
    DISKFONTNAME : PChar = 'diskfont.library';
143
 
 
144
 
VAR DiskfontBase : pLibrary;
145
 
 
146
 
FUNCTION AvailFonts(buffer : pCHAR; bufBytes : LONGINT; flags : LONGINT) : LONGINT;
147
 
PROCEDURE DisposeFontContents(fontContentsHeader : pFontContentsHeader);
148
 
FUNCTION NewFontContents(fontsLock : BPTR; fontName : pCHAR) : pFontContentsHeader;
149
 
FUNCTION NewScaledDiskFont(sourceFont : pTextFont; destTextAttr : pTextAttr) : pDiskFontHeader;
150
 
FUNCTION OpenDiskFont(textAttr : pTextAttr) : pTextFont;
151
 
FUNCTION GetDiskFontCtrl(tagid : LONGINT) : LONGINT;
152
 
PROCEDURE SetDiskFontCtrlA(taglist : pTagItem);
153
 
 
154
 
{Here we read how to compile this unit}
155
 
{You can remove this include and use a define instead}
156
 
{$I useautoopenlib.inc}
157
 
{$ifdef use_init_openlib}
158
 
procedure InitDISKFONTLibrary;
159
 
{$endif use_init_openlib}
160
 
 
161
 
{This is a variable that knows how the unit is compiled}
162
 
var
163
 
    DISKFONTIsCompiledHow : longint;
164
 
 
165
 
IMPLEMENTATION
166
 
 
167
 
{
168
 
 If you don't use array of const then just remove tagsarray
169
 
}
170
 
uses
171
 
{$ifndef dont_use_openlib}
172
 
msgbox;
173
 
{$endif dont_use_openlib}
174
 
 
175
 
FUNCTION AvailFonts(buffer : pCHAR; bufBytes : LONGINT; flags : LONGINT) : LONGINT;
176
 
BEGIN
177
 
  ASM
178
 
    MOVE.L  A6,-(A7)
179
 
    MOVEA.L buffer,A0
180
 
    MOVE.L  bufBytes,D0
181
 
    MOVE.L  flags,D1
182
 
    MOVEA.L DiskfontBase,A6
183
 
    JSR -036(A6)
184
 
    MOVEA.L (A7)+,A6
185
 
    MOVE.L  D0,@RESULT
186
 
  END;
187
 
END;
188
 
 
189
 
PROCEDURE DisposeFontContents(fontContentsHeader : pFontContentsHeader);
190
 
BEGIN
191
 
  ASM
192
 
    MOVE.L  A6,-(A7)
193
 
    MOVEA.L fontContentsHeader,A1
194
 
    MOVEA.L DiskfontBase,A6
195
 
    JSR -048(A6)
196
 
    MOVEA.L (A7)+,A6
197
 
  END;
198
 
END;
199
 
 
200
 
FUNCTION NewFontContents(fontsLock : BPTR; fontName : pCHAR) : pFontContentsHeader;
201
 
BEGIN
202
 
  ASM
203
 
    MOVE.L  A6,-(A7)
204
 
    MOVEA.L fontsLock,A0
205
 
    MOVEA.L fontName,A1
206
 
    MOVEA.L DiskfontBase,A6
207
 
    JSR -042(A6)
208
 
    MOVEA.L (A7)+,A6
209
 
    MOVE.L  D0,@RESULT
210
 
  END;
211
 
END;
212
 
 
213
 
FUNCTION NewScaledDiskFont(sourceFont : pTextFont; destTextAttr : pTextAttr) : pDiskFontHeader;
214
 
BEGIN
215
 
  ASM
216
 
    MOVE.L  A6,-(A7)
217
 
    MOVEA.L sourceFont,A0
218
 
    MOVEA.L destTextAttr,A1
219
 
    MOVEA.L DiskfontBase,A6
220
 
    JSR -054(A6)
221
 
    MOVEA.L (A7)+,A6
222
 
    MOVE.L  D0,@RESULT
223
 
  END;
224
 
END;
225
 
 
226
 
FUNCTION OpenDiskFont(textAttr : pTextAttr) : pTextFont;
227
 
BEGIN
228
 
  ASM
229
 
    MOVE.L  A6,-(A7)
230
 
    MOVEA.L textAttr,A0
231
 
    MOVEA.L DiskfontBase,A6
232
 
    JSR -030(A6)
233
 
    MOVEA.L (A7)+,A6
234
 
    MOVE.L  D0,@RESULT
235
 
  END;
236
 
END;
237
 
 
238
 
FUNCTION GetDiskFontCtrl(tagid : LONGINT) : LONGINT;
239
 
BEGIN
240
 
  ASM
241
 
        MOVE.L  A6,-(A7)
242
 
        MOVE.L  tagid,D0
243
 
        MOVEA.L DiskfontBase,A6
244
 
        JSR     -060(A6)
245
 
        MOVEA.L (A7)+,A6
246
 
        MOVE.L  D0,@RESULT
247
 
  END;
248
 
END;
249
 
 
250
 
PROCEDURE SetDiskFontCtrlA(taglist : pTagItem);
251
 
BEGIN
252
 
  ASM
253
 
        MOVE.L  A6,-(A7)
254
 
        MOVEA.L taglist,A0
255
 
        MOVEA.L DiskfontBase,A6
256
 
        JSR     -066(A6)
257
 
        MOVEA.L (A7)+,A6
258
 
  END;
259
 
END;
260
 
 
261
 
const
262
 
    { Change VERSION and LIBVERSION to proper values }
263
 
 
264
 
    VERSION : string[2] = '0';
265
 
    LIBVERSION : longword = 0;
266
 
 
267
 
{$ifdef use_init_openlib}
268
 
  {$Info Compiling initopening of diskfont.library}
269
 
  {$Info don't forget to use InitDISKFONTLibrary in the beginning of your program}
270
 
 
271
 
var
272
 
    diskfont_exit : Pointer;
273
 
 
274
 
procedure ClosediskfontLibrary;
275
 
begin
276
 
    ExitProc := diskfont_exit;
277
 
    if DiskfontBase <> nil then begin
278
 
        CloseLibrary(DiskfontBase);
279
 
        DiskfontBase := nil;
280
 
    end;
281
 
end;
282
 
 
283
 
procedure InitDISKFONTLibrary;
284
 
begin
285
 
    DiskfontBase := nil;
286
 
    DiskfontBase := OpenLibrary(DISKFONTNAME,LIBVERSION);
287
 
    if DiskfontBase <> nil then begin
288
 
        diskfont_exit := ExitProc;
289
 
        ExitProc := @ClosediskfontLibrary;
290
 
    end else begin
291
 
        MessageBox('FPC Pascal Error',
292
 
        'Can''t open diskfont.library version ' + VERSION + #10 +
293
 
        'Deallocating resources and closing down',
294
 
        'Oops');
295
 
        halt(20);
296
 
    end;
297
 
end;
298
 
 
299
 
begin
300
 
    DISKFONTIsCompiledHow := 2;
301
 
{$endif use_init_openlib}
302
 
 
303
 
{$ifdef use_auto_openlib}
304
 
  {$Info Compiling autoopening of diskfont.library}
305
 
 
306
 
var
307
 
    diskfont_exit : Pointer;
308
 
 
309
 
procedure ClosediskfontLibrary;
310
 
begin
311
 
    ExitProc := diskfont_exit;
312
 
    if DiskfontBase <> nil then begin
313
 
        CloseLibrary(DiskfontBase);
314
 
        DiskfontBase := nil;
315
 
    end;
316
 
end;
317
 
 
318
 
begin
319
 
    DiskfontBase := nil;
320
 
    DiskfontBase := OpenLibrary(DISKFONTNAME,LIBVERSION);
321
 
    if DiskfontBase <> nil then begin
322
 
        diskfont_exit := ExitProc;
323
 
        ExitProc := @ClosediskfontLibrary;
324
 
        DISKFONTIsCompiledHow := 1;
325
 
    end else begin
326
 
        MessageBox('FPC Pascal Error',
327
 
        'Can''t open diskfont.library version ' + VERSION + #10 +
328
 
        'Deallocating resources and closing down',
329
 
        'Oops');
330
 
        halt(20);
331
 
    end;
332
 
 
333
 
{$endif use_auto_openlib}
334
 
 
335
 
{$ifdef dont_use_openlib}
336
 
begin
337
 
    DISKFONTIsCompiledHow := 3;
338
 
   {$Warning No autoopening of diskfont.library compiled}
339
 
   {$Warning Make sure you open diskfont.library yourself}
340
 
{$endif dont_use_openlib}
341
 
 
342
 
 
343
 
END. (* UNIT DISKFONT *)
344
 
 
345
 
{
346
 
  $Log: diskfont.pas,v $
347
 
  Revision 1.5  2003/02/10 17:59:46  nils
348
 
  *  fixes for delphi mode
349
 
 
350
 
  Revision 1.4  2003/02/07 20:48:36  nils
351
 
  * update for amigaos 3.9
352
 
 
353
 
  * changed startcode for library
354
 
 
355
 
  Revision 1.3  2003/01/14 18:46:04  nils
356
 
  * added defines use_amia_smartlink and use_auto_openlib
357
 
 
358
 
  * implemented autoopening of library
359
 
 
360
 
  Revision 1.2  2002/11/18 20:52:58  nils
361
 
    * added diskfontname
362
 
 
363
 
}
364
 
 
365
 
 
366